Implement old bar.hs

1 files changed, 78 insertions, 0 deletions

diff --git a/Handler/Common.hs b/Handler/Common.hs
new file mode 100644
index 0000000..38fb1ce
--- /dev/null
+++ b/Handler/Common.hs
@@ -0,0 +1,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")