1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
|
{-# LANGUAGE ApplicativeDo #-}
module Handler.Common
( inventoryListing
, itemForm
, InventoryState(..)
, FormState(..)
) where
import Import
import Data.Unique
import qualified Data.Text as Text (pack)
import Control.Lens
import Handler.Common.Types
dayFormat :: Day -> String
dayFormat = formatTime defaultTimeLocale "%e. %b %y"
itemForm :: Maybe Item -- ^ Update existing item or insert new?
-> Html -> MForm Handler (FormResult Item, Widget)
itemForm proto identView = do
today <- utctDay <$> liftIO getCurrentTime
(kindRes, kindView) <- mreq textField "" $ itemKind <$> proto
(boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown"
(expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never"
(openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never"
let itemRes = do
itemKind <- kindRes
itemBought <- boughtRes
itemExpires <- expiresRes
itemOpened <- openedRes
return Item{ itemNormKind = normalizeKind itemKind, ..}
return . (itemRes, ) $
[whamlet|
$newline never
#{identView}
<div .td>^{fvInput kindView}
<div .td>^{boughtWidget}
<div .td>^{expiresWidget}
<div .td>^{openedWidget}
|]
where
dayForm :: Maybe (Maybe Day) -> String -> MForm Handler (FormResult (Maybe Day), Widget)
dayForm proto label = do
today <- utctDay <$> liftIO getCurrentTime
checkboxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique
(fmap (fromMaybe False) -> isNothingRes, isNothingView) <-
mopt checkBoxField ("" { fsId = Just $ Text.pack checkboxId }) . Just . Just . fromMaybe True $ fmap isNothing proto
(dayRes, dayView) <-
mreq dayField "" . Just . fromMaybe today $ join proto
let res = (bool Just (const Nothing) <$> isNothingRes) <*> dayRes
return . (res, ) $ do
[whamlet|
$newline never
<div .table>
<div .tr>
<label for=#{checkboxId} .checkbox .td>
^{fvInput isNothingView}
<span>
#{label}
<div .tr>
<div .td .dayInput>^{fvInput dayView}
|]
inventoryListing :: InventoryState -> Widget
inventoryListing InventoryState{..} = do
setTitle "Bar Inventory"
$(widgetFile "inventoryListing")
|
