summaryrefslogtreecommitdiff
path: root/Handler/Common.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Handler/Common.hs')
-rw-r--r--Handler/Common.hs64
1 files changed, 59 insertions, 5 deletions
diff --git a/Handler/Common.hs b/Handler/Common.hs
index 38fb1ce..2416d15 100644
--- a/Handler/Common.hs
+++ b/Handler/Common.hs
@@ -3,8 +3,13 @@
3module Handler.Common 3module Handler.Common
4 ( inventoryListing 4 ( inventoryListing
5 , itemForm 5 , itemForm
6 , referenceListing
7 , referenceForm
8 , kinds
6 , InventoryState(..) 9 , InventoryState(..)
10 , ReferenceState(..)
7 , FormState(..) 11 , FormState(..)
12 , HasFormState(..)
8 ) where 13 ) where
9 14
10import Import 15import Import
@@ -25,7 +30,7 @@ itemForm :: Maybe Item -- ^ Update existing item or insert new?
25itemForm proto identView = do 30itemForm proto identView = do
26 today <- utctDay <$> liftIO getCurrentTime 31 today <- utctDay <$> liftIO getCurrentTime
27 32
28 (kindRes, kindView) <- mreq textField "" $ itemKind <$> proto 33 (kindRes, kindWidget) <- kindField $ itemKind <$> proto
29 (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown" 34 (boughtRes, boughtWidget) <- dayForm (maybe (Just $ Just today) Just $ fmap itemBought proto) "Unknown"
30 (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never" 35 (expiresRes, expiresWidget) <- dayForm (fmap itemExpires proto) "Never"
31 (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never" 36 (openedRes, openedWidget) <- dayForm (fmap itemOpened proto) "Never"
@@ -41,7 +46,7 @@ itemForm proto identView = do
41 [whamlet| 46 [whamlet|
42 $newline never 47 $newline never
43 #{identView} 48 #{identView}
44 <div .td>^{fvInput kindView} 49 <div .td>^{kindWidget}
45 <div .td>^{boughtWidget} 50 <div .td>^{boughtWidget}
46 <div .td>^{expiresWidget} 51 <div .td>^{expiresWidget}
47 <div .td>^{openedWidget} 52 <div .td>^{openedWidget}
@@ -73,6 +78,55 @@ itemForm proto identView = do
73 |] 78 |]
74 79
75inventoryListing :: InventoryState -> Widget 80inventoryListing :: InventoryState -> Widget
76inventoryListing InventoryState{..} = do 81inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing")
77 setTitle "Bar Inventory" 82
78 $(widgetFile "inventoryListing") 83referenceForm :: Maybe Reference -- ^ Update existing item or insert new?
84 -> Html -> MForm Handler (FormResult Reference, Widget)
85referenceForm proto identView = do
86 (kindRes, kindWidget) <- kindField $ referenceKind <$> proto
87
88 let referenceRes = do
89 referenceKind <- kindRes
90 return Reference{ referenceNormKind = normalizeKind referenceKind, .. }
91
92 return . (referenceRes, ) $
93 [whamlet|
94 $newline never
95 #{identView}
96 <div .td>^{kindWidget}
97 |]
98
99referenceListing :: ReferenceState -> Widget
100referenceListing ReferenceState{ refFormState = formState, ..} = $(widgetFile "referenceListing")
101
102kindField :: Maybe Text -> MForm Handler (FormResult Text, Widget)
103kindField proto = do
104 optionId <- ("options" <>) . tshow . hashUnique <$> liftIO newUnique
105
106 let
107 attrs = [ ("list", optionId)
108 , ("autocomplete", "off")
109 ]
110
111 (kindRes, kindView) <- mreq textField ("" { fsAttrs = attrs }) proto
112
113 options <- lift kinds
114
115 return . (kindRes, ) $
116 [whamlet|
117 $newline never
118 ^{fvInput kindView}
119 <datalist ##{optionId}>
120 $forall opt <- options
121 <option value=#{opt}>
122 |]
123
124kinds :: Handler [Text]
125kinds = do
126 stock <- runDB $ selectList [] []
127 reference <- runDB $ selectList [] []
128
129 return $ concat
130 [ [ itemKind | Entity _ Item{..} <- stock ]
131 , [ referenceKind | Entity _ Reference{..} <- reference ]
132 ]