diff --git a/onomastics-ng/cli/Main.hs b/onomastics-ng/cli/Main.hs index 5f36d12..c28e9a7 100644 --- a/onomastics-ng/cli/Main.hs +++ b/onomastics-ng/cli/Main.hs @@ -16,6 +16,7 @@ data Options = Options , surnames :: [Text] , colorPalette :: [Text] , areaMode :: AreaKind + , scaleTo :: ScaleToMaximum } parseOptions :: Parser Options @@ -25,6 +26,7 @@ parseOptions = <*> some (strArgument (metavar "SURNAME" <> help "Surname")) <*> many (strOption (long "color" <> metavar "COLOR" <> help "Color palette for the SVG")) <*> flag District State (long "states" <> help "Analyze by state (instead of district)") + <*> flag Global Local (long "scale-to" <> help "Scale the colors down according to the local/global maximum") opts :: ParserInfo Options opts = info (parseOptions <**> helper) (fullDesc <> progDesc "Map your German surname") @@ -38,7 +40,7 @@ main = do Relative -> relativeCount Absolute -> absoluteCount colors = colorPalette options ++ defaultColorPalette - svgSettings = SvgSettings{scaleToMaximum = Global} + svgSettings = SvgSettings{scaleToMaximum = scaleTo options} res <- runStoepel manager' $ do let theNames = map Just (surnames options) ds <- case areaMode options of diff --git a/onomastics-ng/lib/Onomap/Types.hs b/onomastics-ng/lib/Onomap/Types.hs index 70b7741..93cc69a 100644 --- a/onomastics-ng/lib/Onomap/Types.hs +++ b/onomastics-ng/lib/Onomap/Types.hs @@ -28,6 +28,12 @@ defaultSvgSettings = SvgSettings { scaleToMaximum = Global } data ScaleToMaximum = Global | Local +instance FromHttpApiData ScaleToMaximum where + parseUrlPiece = \case + "global" -> Right Global + "local" -> Right Local + x -> Left x + data Mode = Relative | Absolute instance FromHttpApiData Mode where diff --git a/onomastics-ng/web/Main.hs b/onomastics-ng/web/Main.hs index 97d3ca6..5295fba 100644 --- a/onomastics-ng/web/Main.hs +++ b/onomastics-ng/web/Main.hs @@ -27,14 +27,14 @@ import Servant import Servant.HTML.Blaze (HTML) import Text.Blaze (ToMarkup (..)) -data Response = Response {color :: [Text], areas :: [Area], statistics :: [(Text, ByArea Double)]} +data Response = Response {color :: [Text], areas :: [Area], statistics :: [(Text, ByArea Double)], svgSettings :: SvgSettings} deriving (Generic) instance ToMarkup Response where toMarkup response = preEscapedToMarkup $ renderMap - (SvgSettings{scaleToMaximum = Global}) + (svgSettings response) (color response) (areas response) (statistics response) @@ -64,13 +64,14 @@ type OnomapApi = :> QueryParams "name" Text :> QueryParam "by" AreaKind :> QueryParams "color" Text + :> QueryParam "scale" ScaleToMaximum :> Get '[HTML] Response app :: Manager -> ([Area], [Area]) -> Application app manager' (theDistricts, theStates) = serve onomapApi server where server :: Server OnomapApi - server = \mode (surnames :: [Text]) maybeAreaKind colors -> + server = \mode (surnames :: [Text]) maybeAreaKind colors scaleTo -> liftIO $ runStoepel manager' $ do let areaMode = fromMaybe District maybeAreaKind @@ -90,6 +91,7 @@ app manager' (theDistricts, theStates) = serve onomapApi server Response { color = colors ++ defaultColorPalette , areas = theAreas + , svgSettings = SvgSettings{scaleToMaximum = fromMaybe Global scaleTo} , statistics = zip surnames stats } onomapApi :: Proxy OnomapApi