More complicated date handling

1 files changed, 78 insertions, 22 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 ]
     ]