More complicated date handling

3 files changed, 96 insertions, 26 deletions

diff --git a/Handler/Common.hs b/Handler/Common.hs
index a1ae34b..990732d 100644
--- a/Handler/Common.hs
+++ b/Handler/Common.hs
@@ -28,9 +28,19 @@ import Handler.Common.Types
 
 import Text.Julius (RawJS(..))
 
+import Data.List.NonEmpty (NonEmpty)
+import Data.Semigroup hiding (First(..))
+import Data.Monoid (First(..))
+
 dayFormat :: Day -> String
 dayFormat = formatTime defaultTimeLocale "%e. %b %y"
 
+data DayFormConfig = DayFormConfig
+                     { dfNever :: Bool
+                     , dfUnknown :: Bool
+                     , dfKnown :: Bool
+                     }
+
 itemForm :: Maybe Item -- ^ Update existing item or insert new?
          -> Html -> MForm Handler (FormResult (WithType Item), Widget)
 itemForm proto identView = do
@@ -41,12 +51,12 @@ itemForm proto identView = do
   let kt kWidget tWidget =
         [whamlet|
                 <div .td>^{kWidget}
-                <div .td>^{tWidget}
+               <div .td>^{tWidget}
                 |]
   ((kindRes, typeRes), typedKindWidget) <- typedKindField kt ((itemKind <$> proto), t)
-  (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"
+  (boughtRes, boughtWidget) <- dayForm (Just . fromMaybe (DateKnown today) $ itemBought <$> proto) $ DayFormConfig False True True
+  (expiresRes, expiresWidget) <- dayForm (itemExpires <$> proto) $ DayFormConfig True False True
+  (openedRes, openedWidget) <- dayForm (itemOpened <$> proto) $ DayFormConfig True True True
 
   let itemRes = do
         itemKind <- kindRes
@@ -66,33 +76,79 @@ itemForm proto identView = do
             <div .td>^{openedWidget}
             |]
   where
-    dayForm :: Maybe (Maybe Day) -> String -> MForm Handler (FormResult (Maybe Day), Widget)
-    dayForm proto label = do
+    dayForm :: Maybe ItemDate -> DayFormConfig -> MForm Handler (FormResult ItemDate, Widget)
+    dayForm proto DayFormConfig{..} = do
       today <- utctDay <$> liftIO getCurrentTime
 
-      checkboxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique
+      let mWhen = bool (Nothing <$) (fmap Just)
+
+      neverBoxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique
+      unknownBoxId <- ("check" <>) . show . hashUnique <$> liftIO newUnique
+      groupId <- ("dateGroup" <>) . 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
+      dNever <- mWhen dfNever $
+        mopt checkBoxField ("" { fsId = Just $ Text.pack neverBoxId }) . Just . Just . fromMaybe True $ fmap isNever proto
+      dUnknown <- mWhen dfUnknown $
+        mopt checkBoxField ("" { fsId = Just $ Text.pack unknownBoxId }) . Just . Just . fromMaybe False $ fmap isUnknown proto
+      dDay <- mWhen dfKnown $
+        mopt dayField "" . Just . Just $ case proto of
+                             Just (DateKnown d) -> d
+                             _                  -> today
 
-      let res = (bool Just (const Nothing) <$> isNothingRes) <*> dayRes
+      let res = resFromMaybe . fromMaybe FormMissing . fmap (fmap getFirst) $ mconcat
+            [ fmap (fmap (First . bool Nothing (Just DateNever) . fromMaybe False) . fst) dNever
+            , fmap (fmap (First . bool Nothing (Just DateUnknown) . fromMaybe False) . fst) dUnknown
+            , fmap (fmap (First . fmap DateKnown) . fst) dDay
+            ]
+          resFromMaybe (FormSuccess Nothing) = FormFailure ["Missing required information"]
+          resFromMaybe (FormSuccess (Just x)) = FormSuccess x
+          resFromMaybe FormMissing = FormMissing
+          resFromMaybe (FormFailure es) = FormFailure es
       return . (res, ) $ do
+        toWidget $
+          [julius|
+                 $(function () {
+                   var updateInput = function() {
+                     $('##{rawJS groupId} :input').filter(':not(:checkbox)').prop("disabled", $('##{rawJS groupId} :checkbox').filter(':checked').length > 0);
+                   };
+                 
+                   $('##{rawJS groupId} :checkbox').change(function() {
+                     if (this.checked) {
+                       $('##{rawJS groupId} :checkbox').not(this).prop('checked', false);
+                     }
+                     updateInput();
+                   });
+
+                   updateInput();
+                 });
+                 |]
+        let width = length $ (filter id [ isJust dNever, isJust dUnknown ] :: [Bool])
         [whamlet|
                 $newline never
-                <div .table>
-                  <div .tr>
-                    <label for=#{checkboxId} .checkbox .td>
-                      ^{fvInput isNothingView}
-                      <span>
-                        #{label}
-                  <div .tr>
-                    <div .td .dayInput>^{fvInput dayView}
+                <table ##{groupId} .dayField>
+                  <tr>
+                    $maybe (_, isNeverView) <- dNever
+                      <td>
+                        <label for=#{neverBoxId} .checkbox>
+                          ^{fvInput isNeverView}
+                          <span>
+                            Never
+                    $maybe (_, isUnknownView) <- dUnknown
+                      <td>
+                        <label for=#{unknownBoxId} .checkbox>
+                          ^{fvInput isUnknownView}
+                          <span>
+                            Unknown
+                  $maybe (_, dayView) <- dDay
+                    <tr>
+                      <td .dayInput :width > 0:colspan=#{width}>
+                        ^{fvInput dayView}
                 |]
 
 inventoryListing :: InventoryState -> Widget
-inventoryListing InventoryState{ invFormState = formState, ..} = $(widgetFile "inventoryListing")
+inventoryListing InventoryState{ invFormState = formState, ..} = do
+  today <- liftIO $ utctDay <$> getCurrentTime
+  $(widgetFile "inventoryListing")
 
 referenceForm :: Maybe Reference -- ^ Update existing item or insert new?
               -> Html -> MForm Handler (FormResult (WithType Reference), Widget)
@@ -188,7 +244,7 @@ kinds = do
   stock <- runDB $ selectList [] []
   reference <- runDB $ selectList [] []
 
-  return . Set.fromList $ concat
+  return . Set.fromList $ (concat :: [[a]] -> [a])
     [ [ itemKind | Entity _ Item{..} <- stock ]
     , [ referenceKind | Entity _ Reference{..} <- reference ]
     ]
diff --git a/Handler/List.hs b/Handler/List.hs
index 70f323a..4209651 100644
--- a/Handler/List.hs
+++ b/Handler/List.hs
@@ -19,9 +19,23 @@ import Database.Persist.Sql (Single(..), rawSql)
 import Thermoprint.Client
 
 list :: Handler (Set (WithType Text))
-list = do
-  (map (uncurry WithType . bimap unSingle unSingle) -> kinds) <- runDB $ rawSql "select reference.kind, kind.type from reference,kind where (not exists (select * from item where COALESCE(item.expires >= CURRENT_DATE, TRUE) and (item.norm_kind = reference.norm_kind))) and (reference.norm_kind = kind.norm_kind)" []
-  return $ Set.fromList kinds
+list = runDB $ do
+  today <- liftIO $ utctDay <$> getCurrentTime
+  
+  items <- map entityVal <$> selectList [] []
+  references <- Set.fromList <$> (withTypes . fmap entityVal =<< selectList [] [])
+
+  let
+    references' = Set.filter (isNothing . flip find items . matches) references
+    matches (Reference{..} `WithType` _) Item{..}
+      | today `isBefore` itemExpires = itemNormKind == referenceNormKind
+      | otherwise = False
+      
+    isBefore _ DateNever = True
+    isBefore _ DateUnknown = False
+    isBefore d1 (DateKnown d2) = d1 < d2
+
+  return $ Set.map (fmap referenceKind) references'
 
 mkPrintout :: Set (WithType Text) -> Printout
 mkPrintout list = Printout ps
diff --git a/Handler/OpenItem.hs b/Handler/OpenItem.hs
index 468c6ec..3b1dfeb 100644
--- a/Handler/OpenItem.hs
+++ b/Handler/OpenItem.hs
@@ -5,7 +5,7 @@ import Import
 postOpenItemR :: ItemId -> Handler TypedContent
 postOpenItemR itemId = do
   today <- utctDay <$> liftIO getCurrentTime
-  result <- fmap (Entity itemId) . runDB $ updateGet itemId [ ItemOpened =. Just today
+  result <- fmap (Entity itemId) . runDB $ updateGet itemId [ ItemOpened =. DateKnown today
                                                             ]
   selectRep $ do
     provideJson result