More complicated date handling

11 files changed, 175 insertions, 61 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
diff --git a/Import/NoFoundation.hs b/Import/NoFoundation.hs
index 6872d0a..1a5b107 100644
--- a/Import/NoFoundation.hs
+++ b/Import/NoFoundation.hs
@@ -5,6 +5,7 @@ module Import.NoFoundation
 
 import ClassyPrelude.Yesod     as Import
 import Model                   as Import
+import Model.Types             as Import
 import Settings                as Import
 import Settings.StaticFiles    as Import
 import Yesod.Auth              as Import
diff --git a/Model.hs b/Model.hs
index 90f5904..8778111 100644
--- a/Model.hs
+++ b/Model.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveFunctor #-}
 
 module Model where
 
@@ -18,6 +19,8 @@ import qualified Data.HashMap.Lazy as HashMap
 import Data.Aeson
 import Data.Aeson.Types (Parser, Value(..))
 
+import Model.Types
+
 -- You can define all of your database entities in the entities file.
 -- You can find more information on persistent and how to declare entities
 -- at:
@@ -68,32 +71,28 @@ withTypes vals = do
 instance Ord Item where
   x `compare` y = mconcat cmprs
     where
-      cmprs = [ itemOpened x `compareM` itemOpened y
-              , itemExpires x `compareM` itemExpires y
+      cmprs = [ itemOpened x `compare` itemOpened y
+              , itemExpires x `compare` itemExpires y
               , itemKind x `compare` itemKind y
               , itemBought x `compare` itemBought y
               ]
 
-      compareM (Just _) Nothing = LT
-      compareM Nothing (Just _) = GT
-      compareM (Just a) (Just b) = compare a b
-      compareM _ _ = EQ
-
 instance ToJSON Item where
   toJSON Item{..} = object $
     [ "kind" .= itemKind
-    ] ++ maybe [] (\x -> ["bought" .= x]) itemBought
-    ++ maybe [] (\x -> ["expires" .= x]) itemExpires
-    ++ maybe [] (\x -> ["opened" .= x]) itemOpened
+    , "bought" .= itemBought
+    , "expires" .= itemExpires
+    , "opened" .= itemOpened
+    ]
 
 instance FromJSON Item where
   parseJSON = withObject "Item" $ \obj -> do
     itemKind <- obj .: "kind"
     let
       itemNormKind = normalizeKind itemKind
-    itemBought <- obj .:? "bought"
-    itemExpires <- obj .:? "expires"
-    itemOpened <- obj .:? "opened"
+    itemBought <- maybe DateUnknown DateKnown <$> obj .:? "bought"
+    itemExpires <- maybe DateNever DateKnown <$> obj .:? "expires"
+    itemOpened <- obj .: "opened"
     return Item{..}
   
 instance ToJSON (Entity Item) where
@@ -122,9 +121,9 @@ normalizeKind = Text.strip . Text.toCaseFold
 
 data ItemDiff = DiffKind Text
               | DiffType Text
-              | DiffBought (Maybe Day)
-              | DiffExpires (Maybe Day)
-              | DiffOpened (Maybe Day)
+              | DiffBought ItemDate
+              | DiffExpires ItemDate
+              | DiffOpened ItemDate
 
 newtype ItemDiffs = ItemDiffs [ItemDiff]
 
@@ -149,7 +148,7 @@ toUpdate (ItemDiffs ds) = mconcat $ do
     DiffOpened d  -> (, []) [ ItemOpened =. d ]
 
 data WithType a = WithType { typedVal :: a, valType :: Text }
-  deriving (Eq, Ord, Show)
+  deriving (Eq, Ord, Show, Functor)
 
 typeToJSON :: ToJSON a
            => Text -- ^ Key for value, if needed
diff --git a/Model/Types.hs b/Model/Types.hs
new file mode 100644
index 0000000..61bebfd
--- /dev/null
+++ b/Model/Types.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE DeriveGeneric #-}
+
+module Model.Types
+  ( ItemDate(..)
+  , isNever, isUnknown, isKnown
+  ) where
+
+import ClassyPrelude.Yesod
+
+data ItemDate = DateUnknown | DateKnown Day | DateNever
+  deriving (Eq, Ord, Show, Read, Generic)
+
+isNever, isUnknown, isKnown :: ItemDate -> Bool
+isNever DateNever = True
+isNever _ = False
+isUnknown DateUnknown = True
+isUnknown _ = False
+isKnown (DateKnown _) = True
+isKnown _ = False
+
+unknownVerb :: IsString a => a
+unknownVerb = "unknown"
+
+instance ToJSON ItemDate where
+  toJSON DateNever = Null
+  toJSON DateUnknown = String unknownVerb
+  toJSON (DateKnown d) = toJSON d
+instance FromJSON ItemDate where
+  parseJSON Null = pure DateNever
+  parseJSON v@(String inp)
+    | unknownVerb == inp = pure DateUnknown
+    | otherwise = DateKnown <$> parseJSON v
+  parseJSON v = DateKnown <$> parseJSON v
+
+derivePersistFieldJSON "ItemDate"
diff --git a/bar.cabal b/bar.cabal
index 5003000..5605d97 100644
--- a/bar.cabal
+++ b/bar.cabal
@@ -18,6 +18,7 @@ library
                      Import
                      Import.NoFoundation
                      Model
+                     Model.Types
                      Settings
                      Settings.StaticFiles
                      Handler.Common
diff --git a/config/models b/config/models
index 16b4ce0..8aebc5b 100644
--- a/config/models
+++ b/config/models
@@ -1,9 +1,9 @@
 Item
     kind Text
     normKind Text
-    bought Day Maybe
-    expires Day Maybe
-    opened Day Maybe
+    bought ItemDate
+    expires ItemDate
+    opened ItemDate
     Foreign Kind fkType normKind
     deriving Show Eq
 Reference
diff --git a/templates/default-layout.cassius b/templates/default-layout.cassius
index bd76a01..50aab3f 100644
--- a/templates/default-layout.cassius
+++ b/templates/default-layout.cassius
@@ -33,7 +33,7 @@
   color: #aaa
 .table .table .td, .table .table .tc, .table .table .th, .table .table .kind
   padding: 0
-table table td, table table th
+table table td, table table th, .table table td, .table table th
   padding: 0
 #messages
   list-style-type: none
diff --git a/templates/inventoryListing.cassius b/templates/inventoryListing.cassius
new file mode 100644
index 0000000..9a7459e
--- /dev/null
+++ b/templates/inventoryListing.cassius
@@ -0,0 +1,3 @@
+.expired
+  color: #800
+  font-weight: bold
\ No newline at end of file
diff --git a/templates/inventoryListing.hamlet b/templates/inventoryListing.hamlet
index 3be43db..39758bb 100644
--- a/templates/inventoryListing.hamlet
+++ b/templates/inventoryListing.hamlet
@@ -26,22 +26,27 @@
         <div .kind>#{itemKind}
         <div .type>#{itemType}
         <div .td .day>
-          $maybe bought <- itemBought
-            #{dayFormat bought}
-          $nothing
-            <hr>
+          $case itemBought
+            $of DateUnknown
+              <hr>
+            $of DateKnown d
+              #{dayFormat d}
         <div .td .day>
-          $maybe expires <- itemExpires
-            #{dayFormat expires}
-          $nothing
-            <hr>
+          $case itemExpires
+            $of DateNever
+              <hr>
+            $of DateKnown d
+              <span :d < today:.expired>#{dayFormat d}
         <div .td .day>
-          $maybe opened <- itemOpened
-            #{dayFormat opened}
-          $nothing
-            <form method=post action=@{OpenItemR itemId}>
-              <button type=submit>
-                Open
+          $case itemOpened
+            $of DateKnown d
+              #{dayFormat d}
+            $of DateUnknown
+              Yes
+            $of DateNever
+              <form method=post action=@{OpenItemR itemId}>
+                <button type=submit>
+                  Open
         <div .td>
           <form method=get action=@{UpdateItemR itemId}##{toPathPiece itemId}>
             <button type=submit>