diff --git a/Handler/Common.hs b/Handler/Common.hs index 2a0de04..f3f76cd 100644 --- a/Handler/Common.hs +++ b/Handler/Common.hs @@ -58,6 +58,21 @@ currencyField = Field showVal = either id (pack . showA) showA x = show ((fromIntegral x :: Double) / 100) +volumeField :: (RenderMessage (HandlerSite m) FormMessage, Show a, Monad m, Integral a) => Field m a +volumeField = Field + { fieldParse = parseHelper $ \rawVals -> + case R.double (prependZero rawVals) of + Right (a, "") -> Right $ floor $ 1000 * a + _ -> Left $ MsgInvalidNumber rawVals + , fieldView = \theId name attr val req -> toWidget [hamlet|$newline never + + |] + , fieldEnctype = UrlEncoded + } + where + showVal = either id (pack . showA) + showA x = show ((fromIntegral x :: Double) / 1000) + amountField :: (RenderMessage (HandlerSite m) FormMessage, Show a, Monad m, Integral a) => Field m a amountField = Field { fieldParse = parseHelper $ \s -> diff --git a/Handler/Modify.hs b/Handler/Modify.hs index f42723b..52bb97c 100644 --- a/Handler/Modify.hs +++ b/Handler/Modify.hs @@ -46,7 +46,7 @@ modifyForm bev = renderDivs $ Beverage <*> areq currencyField (fieldSettingsLabel MsgPrice) (Just $ beveragePrice bev) <*> areq amountField (fieldSettingsLabel MsgCurrentStock) (Just $ beverageAmount bev) <*> areq amountField (fieldSettingsLabel MsgAnnouncedStock) (Just $ beverageAlertAmount bev) - <*> areq currencyField (fieldSettingsLabel MsgVolume) (Just $ beverageMl bev) + <*> areq volumeField (fieldSettingsLabel MsgVolume) (Just $ beverageMl bev) <*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) (Just $ beverageAvatar bev) where avatars = do diff --git a/Handler/Restock.hs b/Handler/Restock.hs index c751f5b..6bd3b55 100644 --- a/Handler/Restock.hs +++ b/Handler/Restock.hs @@ -72,7 +72,7 @@ newArticleForm = renderDivs $ Beverage <*> areq currencyField (fieldSettingsLabel MsgPrice) (Just 100) <*> areq amountField (fieldSettingsLabel MsgAmount) (Just 0) <*> areq amountField (fieldSettingsLabel MsgAmountWarning) (Just 0) - <*> areq currencyField (fieldSettingsLabel MsgVolume) (Just 500) + <*> areq volumeField (fieldSettingsLabel MsgVolume) (Just 500) <*> aopt (selectField avatars) (fieldSettingsLabel MsgSelectAvatar) Nothing where avatars = do