feat: graph multiple names

onomastics-ng/web/Main.hs

@@ -13,8 +13,7 @@ module Main where
 import Control.Monad (liftM2)
 import Control.Monad.IO.Class (liftIO)
 import Data.Aeson (ToJSON (..))
-import Data.List (find)
-import qualified Data.Map as Map (fromList, mapWithKey)
+import qualified Data.Map as Map (fromList, lookup)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
 import GHC.Generics (Generic)
@@ -28,13 +27,14 @@ import Servant
 import Servant.HTML.Blaze (HTML)
 import Text.Blaze (ToMarkup (..))
 
-data Response = Response {color :: Text, areas :: [Area], statistics :: ByArea Double}
+data Response = Response {color :: [Text], areas :: [Area], statistics :: [(Text, ByArea Double)]}
     deriving (Generic)
 
 instance ToMarkup Response where
     toMarkup response =
         preEscapedToMarkup $
             renderMap
+                (SvgSettings{scaleToMaximum = Global})
                 (color response)
                 (areas response)
                 (statistics response)
@@ -42,29 +42,35 @@ instance ToMarkup Response where
 instance ToJSON Response where
     toJSON response =
         toJSON $
-            Map.mapWithKey
-                ( \k double ->
-                    let maybeArea = find ((== k) . key) (areas response)
-                     in Map.fromList
-                            [ ("value" :: Text, toJSON double)
-                            , ("population", toJSON $ fmap population maybeArea)
-                            , ("name", toJSON $ fmap name maybeArea)
-                            ]
-                )
-                (getByArea $ statistics response)
+            Map.fromList $
+                map
+                    ( \area ->
+                        ( name area
+                        , Map.fromList $
+                            ("population", toJSON $ population area) :
+                            map
+                                ( \(surname, stats) ->
+                                    ( surname
+                                    , toJSON $ Map.lookup (key area) (getByArea stats)
+                                    )
+                                )
+                                (statistics response)
+                        )
+                    )
+                    (areas response)
 
 type OnomapApi =
     Capture "mode" Mode
-        :> Capture "name" Text
+        :> QueryParams "name" Text
         :> QueryParam "by" AreaKind
-        :> QueryParam "color" Text
-        :> Get '[JSON, HTML] Response
+        :> QueryParams "color" Text
+        :> Get '[HTML] Response
 
 app :: Manager -> ([Area], [Area]) -> Application
 app manager' (theDistricts, theStates) = serve onomapApi server
   where
     server :: Server OnomapApi
-    server = \mode surname maybeAreaKind maybeColor ->
+    server = \mode (surnames :: [Text]) maybeAreaKind colors ->
         liftIO $
             runStoepel manager' $ do
                 let areaMode = fromMaybe District maybeAreaKind
@@ -75,11 +81,19 @@ app manager' (theDistricts, theStates) = serve onomapApi server
                     theAreas = case areaMode of
                         State -> theStates
                         District -> theDistricts
-                theStatistics <-
-                    computeAreaStatistics computeFunction theAreas <$> case areaMode of
-                        State -> stateStatistics (Just surname)
-                        District -> districtStatistics (Just surname)
-                return Response{color = fromMaybe "black" maybeColor, areas = theAreas, statistics = theStatistics}
+                    theNames = map Just surnames
+                theStats <- case areaMode of
+                    State -> mapM stateStatistics theNames
+                    District -> mapM districtStatistics theNames
+                let stats = map (computeAreaStatistics computeFunction theAreas) theStats
+                return
+                    Response
+                        { color = case colors of
+                            [] -> defaultColorPalette
+                            x -> x
+                        , areas = theAreas
+                        , statistics = zip surnames stats
+                        }
     onomapApi :: Proxy OnomapApi
     onomapApi = Proxy