diff options
Diffstat (limited to 'Handler/Common.hs')
-rw-r--r-- | Handler/Common.hs | 64 |
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 @@ | |||
3 | module Handler.Common | 3 | module 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 | ||
10 | import Import | 15 | import Import |
@@ -25,7 +30,7 @@ itemForm :: Maybe Item -- ^ Update existing item or insert new? | |||
25 | itemForm proto identView = do | 30 | itemForm 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 | ||
75 | inventoryListing :: InventoryState -> Widget | 80 | inventoryListing :: InventoryState -> Widget |
76 | inventoryListing InventoryState{..} = do | 81 | inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing") |
77 | setTitle "Bar Inventory" | 82 | |
78 | $(widgetFile "inventoryListing") | 83 | referenceForm :: Maybe Reference -- ^ Update existing item or insert new? |
84 | -> Html -> MForm Handler (FormResult Reference, Widget) | ||
85 | referenceForm 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 | |||
99 | referenceListing :: ReferenceState -> Widget | ||
100 | referenceListing ReferenceState{ refFormState = formState, ..} = $(widgetFile "referenceListing") | ||
101 | |||
102 | kindField :: Maybe Text -> MForm Handler (FormResult Text, Widget) | ||
103 | kindField 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 | |||
124 | kinds :: Handler [Text] | ||
125 | kinds = do | ||
126 | stock <- runDB $ selectList [] [] | ||
127 | reference <- runDB $ selectList [] [] | ||
128 | |||
129 | return $ concat | ||
130 | [ [ itemKind | Entity _ Item{..} <- stock ] | ||
131 | , [ referenceKind | Entity _ Reference{..} <- reference ] | ||
132 | ] | ||