Move drink input into a modal dialog.

1 files changed, 126 insertions, 62 deletions

diff --git a/src/Lib.hs b/src/Lib.hs
index 38ca843..e70c06d 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude, RecursiveDo, ScopedTypeVariables, ConstraintKinds, MultiWayIf, LambdaCase #-}
 module Lib
     ( main
     ) where
@@ -16,22 +16,25 @@ import Control.Lens
 import qualified Data.Aeson as Aeson
 import qualified Data.Scientific as Scientific
 import qualified Data.Time.Clock as Clock
+import qualified Data.Time.Calendar as Calendar
 import qualified Data.Time.Format as TimeFormat
 import qualified Data.Map
 import qualified GHCJS.DOM.Storage as DOMStorage
 import qualified GHCJS.DOM as DOM
 import qualified GHCJS.DOM.Window as DOMWindow
+import qualified GHCJS.DOM.Element as DOMElement
 import Data.String.Here.Uninterpolated (here)
 
 import Model (Drink(..), drinkId, drinkDescription, drinkTimestamp, drinkLiters, DrinkDB(..))
 
 foreign import javascript unsafe "console.log($1)" js_log :: JSString -> IO ()
 
-numberInput ∷ MonadWidget t m ⇒ m (Event t (), Dynamic t (Maybe Scientific.Scientific))
-numberInput = do
-    input ← elAttr "span" (Data.Map.fromList [("class", "ui right labeled left icon input")]) $ do
+numberInput ∷ MonadWidget t m ⇒ Event t () → m (Event t (), Dynamic t (Maybe Scientific.Scientific))
+numberInput clearEvent = do
+    input ← elAttr "span" (Data.Map.fromList [("class", "ui large fluid right labeled left icon input")]) $ do
       input ← textInput $ def & textInputConfig_inputType    .~ "number"
                               & textInputConfig_attributes   .~ (constDyn (Data.Map.fromList [("placeholder", "amount"), ("pattern", "[0-9]*")]))
+                              & setValue                     .~ fmap (const "") clearEvent
       elAttr "div" (Data.Map.fromList [("class", "ui label")]) $ do
         text "ml"
       elAttr "i" (Data.Map.fromList [("class", "coffee icon")]) $ do
@@ -41,40 +44,44 @@ numberInput = do
     let ev = textInputGetEnter input
     return (ev, n)
 
-plusButton ∷ MonadWidget t m ⇒ m (Event t ())
-plusButton = do
-  (e, _) ← elAttr "span" (Data.Map.fromList [("class", "ui input")]) $ do
-    elAttr' "button" (Data.Map.fromList [("class", "ui green icon button")]) $ do
+bigPlusButton ∷ MonadWidget t m ⇒ m (Event t ())
+bigPlusButton = do
+  (e, _) ← elAttr "span" (Data.Map.fromList [("class", "ui fluid input")]) $ do
+    elAttr' "button" (Data.Map.fromList [("class", "ui large fluid huge green labeled icon button")]) $ do
       elAttr "i" (Data.Map.fromList [("class", "add icon")]) $ return ()
+      text "add drink"
   return $ domEvent Click e
 
-combineDyn4 ∷ (Reflex t, MonadHold t m) ⇒ (a → b → c → d → e) → Dynamic t a → Dynamic t b → Dynamic t c → Dynamic t d → m (Dynamic t e)
-combineDyn4 f d1 d2 d3 d4 = do
-    d1d2 ← combineDyn ((,)) d1 d2
-    d3d4 ← combineDyn ((,)) d3 d4
-    combineDyn (\(d1',d2') (d3',d4') → f d1' d2' d3' d4') d1d2 d3d4
+uiButton ∷ MonadWidget t m ⇒ String → m a → m (Event t ())
+uiButton extraClasses inner = do
+  (e, _) ← elAttr' "button" (Data.Map.fromList [("class", "ui " ++ extraClasses ++ " button")]) $
+    inner
+  return $ domEvent Click e
 
 combineDyn3 ∷ (Reflex t, MonadHold t m) ⇒ (a → b → c → d) → Dynamic t a → Dynamic t b → Dynamic t c → m (Dynamic t d)
 combineDyn3 f d1 d2 d3 = do
     d1d2 ← combineDyn ((,)) d1 d2
     combineDyn (\(d1',d2') d3' → f d1' d2' d3') d1d2 d3
 
-drinkInput ∷ MonadWidget t m ⇒ m (Event t (), Dynamic t (Maybe (Text, Scientific.Scientific, UTCTime)))
-drinkInput = elAttr "div" (Data.Map.fromList [("class", "ui green segment")]) $ do
+drinkInput ∷ MonadWidget t m ⇒ Event t () → Event t () → m (Event t (), Dynamic t (Maybe (Text, Scientific.Scientific, UTCTime)))
+drinkInput focusEvent clearEvent = elAttr "div" (Data.Map.fromList [("class", "ui green segment")]) $ do
     -- time
     startTime ← liftIO $ Clock.getCurrentTime
     tick ← tickLossy 1.0 startTime
     currentTime ← holdDyn startTime (map _tickInfo_lastUTC tick)
-    -- accept button
-    acceptBtn ← plusButton
-    -- input
-    descInput ← elAttr "span" (Data.Map.fromList [("class", "ui left icon input")]) $ do
-      input ← textInput (def & textInputConfig_attributes .~ (constDyn (Data.Map.fromList [("placeholder", "drink")])))
+    -- description input
+    descInput ← elAttr "span" (Data.Map.fromList [("class", "ui large fluid left icon input")]) $ do
+      input ← textInput $ def & textInputConfig_attributes .~ (constDyn (Data.Map.fromList [("placeholder", "drink")]))
+                              & setValue                   .~ fmap (const "") clearEvent
       elAttr "i" (Data.Map.fromList [("class", "book icon")]) $ return ()
       return input
     let descEv = textInputGetEnter descInput
     let desc = _textInput_value descInput
-    (amountEv, amount) ← numberInput
+    performEvent_ $ fmap (const $ liftIO $ DOMElement.focus $ _textInput_element descInput) focusEvent
+    --
+    el "br" $ return ()
+    -- amount input
+    (amountEv, amount) ← numberInput clearEvent
     -- output
     drinkComponents ← combineDyn3
       (\desc' amount' currentTime' →
@@ -82,7 +89,7 @@ drinkInput = elAttr "div" (Data.Map.fromList [("class", "ui green segment")]) $
            Just amount'' → Just (pack desc', amount'', currentTime')
            Nothing       → Nothing)
       desc amount currentTime
-    let ev = descEv `appendEvents` amountEv `appendEvents` acceptBtn
+    let ev = descEv `appendEvents` amountEv
     return (ev, drinkComponents)
 
 css ∷ String
@@ -105,16 +112,36 @@ html {
 }
 |]
 
+js ∷ String
+js = [here|
+document.addEventListener("DOMContentLoaded", function (event) {
+  jQuery(function($) {
+    $('.ui.modal')
+      .modal('setting', 'closable', false);
+  });
+});
+|]
+
 buildHead ∷ Widget Spider (Gui Spider (WithWebView SpiderHost) (HostFrame Spider)) ()
 buildHead = do
-    _ ← elDynHtml' "style" (constDyn css)
     elMeta "viewport" "width=device-width, initial-scale=1.0, maximum-scale=1.0, user-scalable=no"
     elMeta "apple-mobile-web-app-capable"          "yes"
     elMeta "apple-mobile-web-app-status-bar-style" "black"
     elMeta "mobile-web-app-capable"                "yes"
     elMeta "msapplication-tap-highlight"           "no"
-    _ ← elAttr "script" (Data.Map.fromList [("type", "text/javascript"), ("src",  "https://cdnjs.cloudflare.com/ajax/libs/semantic-ui/2.1.8/semantic.min.js"),  ("defer", "defer")])    $ return ()
-    _ ← elAttr "link"   (Data.Map.fromList [("type", "text/css"),        ("href", "https://cdnjs.cloudflare.com/ajax/libs/semantic-ui/2.1.8/semantic.min.css"), ("rel", "stylesheet")]) $ return ()
+    elAttr "script" (Data.Map.fromList [("type", "text/javascript"),
+                                        ("src",  "https://code.jquery.com/jquery-2.2.0.min.js")]) $ return ()
+    elAttr "script" (Data.Map.fromList [("type", "text/javascript"),
+                                        ("src",  "https://cdnjs.cloudflare.com/ajax/libs/semantic-ui/2.1.8/semantic.min.js")]) $ return ()
+    --elAttr "script" (Data.Map.fromList [("type", "text/javascript"),
+    --                                    ("src",  "https://cdnjs.cloudflare.com/ajax/libs/webcomponentsjs/0.7.20/webcomponents.min.js")]) $ return ()
+    elAttr "script" (Data.Map.fromList [("type", "text/javascript"),
+                                        ("src",  "https://cdnjs.cloudflare.com/ajax/libs/webcomponentsjs/0.7.20/MutationObserver.min.js")]) $ return ()
+    elAttr "link"   (Data.Map.fromList [("type", "text/css"),
+                                        ("href", "https://cdnjs.cloudflare.com/ajax/libs/semantic-ui/2.1.8/semantic.min.css"),
+                                        ("rel",  "stylesheet")]) $ return ()
+    _ ← elDynHtml' "style" (constDyn css)
+    _ ← elDynHtml' "script" (constDyn js)
     return ()
   where
     elMeta name content = do
@@ -129,44 +156,81 @@ main = mainWidgetWithHead buildHead $ do
     let loadedDB = rawStoredDB >>= \jsstr → Aeson.decode (encodeUtf8 (pack (fromJSString jsstr)))
     let initialDrinkDB = maybe (DrinkDB []) id loadedDB
     today ← Clock.utctDay <$> (liftIO $ Clock.getCurrentTime)
+    let yesterday = Calendar.addDays (-1) today
+
+    -- view part 1: drink input
+    inputDrinkComponentsInputEv ← mdo
+      inputModalAttrs ← forDyn modalActive $ \modalActive' →
+        Data.Map.fromList [("class", if modalActive' then "ui basic modal transition visible active" else "ui basic modal transition hidden")]
+      pageDimmerAttrs ← forDyn modalActive $ \modalActive' →
+        Data.Map.fromList [("class", if modalActive' then "ui dimmer modals page transition visible active" else "ui dimmer modals page transition hidden")]
+      modalActive ← foldDyn ($) False $ mergeWith (.)
+                      [ fmap (\_ → not) toggleButtonClick
+                      , fmap (\_ _ → False) cancelClick
+                      , fmap (\_ _ → False) approveClick
+                      , fmap (\_ _ → False) inputSubmit
+                      ]
+      toggleButtonClick ← elAttr "div" ("class" =: "ui fixed bottom right sticky fluid fullwidth") $ do
+        bigPlusButton
+      (cancelClick, approveClick, inputSubmit, inputDrinkComponents) ← elDynAttr "div" pageDimmerAttrs $ do
+        elDynAttr "div" inputModalAttrs $ do
+          elAttr "div" ("class" =: "header") $ do
+            text "Add drink"
+          (inputSubmit', inputDrinkComponents') ← elAttr "div" ("class" =: "content") $ do
+            drinkInput toggleButtonClick inputDrinkSubmitEv
+          (cancelClick'', approveClick'') ← elAttr "div" ("class" =: "actions ui grid") $ do
+            cancelClick' ← uiButton "large four wide column cancel" $ do
+              text "Cancel"
+            approveClick' ← uiButton "large ten wide column positive approve" $ do
+              text "Add"
+            return (cancelClick', approveClick')
+          return (cancelClick'', approveClick'', inputSubmit', inputDrinkComponents')
+      let inputDrinkSubmitEv = approveClick `appendEvents` inputSubmit
+      let inputDrinkComponentsInputEv = tag (current inputDrinkComponents) inputDrinkSubmitEv 
+      return inputDrinkComponentsInputEv
+
+    -- model
+    drinkDB ← foldDyn (\maybeInput drinkDB →
+                         maybe
+                           drinkDB
+                           (\(inputDesc, inputMilliliters, inputTime) →
+                              let minimalUnusedID =
+                                    foldr (\drink acc → max acc (1 + (drink^.drinkId))) 0 (unDrinkDB drinkDB)
+                                  newDrink =
+                                    Drink { _drinkId          = minimalUnusedID
+                                          , _drinkDescription = inputDesc
+                                          , _drinkTimestamp   = inputTime
+                                          , _drinkLiters      = inputMilliliters/1000
+                                          }
+                              in DrinkDB $ newDrink:(unDrinkDB drinkDB))
+                           maybeInput)
+                      initialDrinkDB
+                      inputDrinkComponentsInputEv
+    -- model: save on change
+    let saveDB = map (\updatedDB → do
+                        liftIO $ js_log "DB has been updated."
+                        liftIO $ DOMStorage.setItem storage ("drinks" ∷ JSString) (toJSString (unpack (decodeUtf8 (Aeson.encode updatedDB)))))
+                     (updated drinkDB)
+    performEvent_ saveDB
+
+    -- view part 2
     el "div" $ do
-      -- drink input
-      (inputDrinkSubmitEv, inputDrinkComponents) ← drinkInput
-      let inputDrinkComponentsInputEv = tagDyn inputDrinkComponents inputDrinkSubmitEv 
-      -- model
-      drinkDB ← foldDyn (\maybeInput drinkDB →
-                           maybe
-                             drinkDB
-                             (\(inputDesc, inputMilliliters, inputTime) →
-                                let minimalUnusedID =
-                                      foldr (\drink acc → max acc (1 + (drink^.drinkId))) 0 (unDrinkDB drinkDB)
-                                    newDrink =
-                                      Drink { _drinkId          = minimalUnusedID
-                                            , _drinkDescription = inputDesc
-                                            , _drinkTimestamp   = inputTime
-                                            , _drinkLiters      = inputMilliliters/1000
-                                            }
-                                in DrinkDB $ newDrink:(unDrinkDB drinkDB))
-                             maybeInput)
-                        initialDrinkDB
-                        inputDrinkComponentsInputEv
-      -- model: save on change
-      let saveDB = map (\updatedDB → do
-                          liftIO $ js_log "DB has been updated."
-                          liftIO $ DOMStorage.setItem storage ("drinks" ∷ JSString) (toJSString (unpack (decodeUtf8 (Aeson.encode updatedDB)))))
-                       (updated drinkDB)
-      performEvent_ saveDB
-      -- progress message
+      -- the progress message that tells you how you're doing today
       totalLitersToday ← forDyn drinkDB $ \drinkDB' →
         sum $ map _drinkLiters $ filter (\drink → Clock.utctDay (drink^.drinkTimestamp) ≡ today) (unDrinkDB drinkDB')
-      progressMessageAttrs ← forDyn totalLitersToday $ \x → case () of
-        _ | x ≥ 2.5 → (Data.Map.fromList [("class", "ui green message")])
-        _ | x ≥ 1.5 → (Data.Map.fromList [("class", "ui yellow message")])
-        _           → (Data.Map.fromList [("class", "ui red message")])
+      totalLitersYesterday ← forDyn drinkDB $ \drinkDB' →
+        sum $ map _drinkLiters $ filter (\drink → Clock.utctDay (drink^.drinkTimestamp) ≡ yesterday) (unDrinkDB drinkDB')
+      progressMessageAttrs ← forDyn totalLitersToday $ \x → if
+        | x ≥ 2.5   → (Data.Map.fromList [("class", "ui green message")])
+        | x ≥ 1.5   → (Data.Map.fromList [("class", "ui yellow message")])
+        | otherwise → (Data.Map.fromList [("class", "ui red message")])
       elDynAttr "div" progressMessageAttrs $
-        el "em" $ el "strong" $
-          dynText =<< mapDyn (\totalLitersToday' → "Progress today: " ++ show totalLitersToday' ++ " of 2.5 liters") totalLitersToday
-      -- drink log
+        el "em" $ do
+          dynText =<< mapDyn (\totalLitersYesterday' → "Yesterday: " ++ show totalLitersYesterday' ++ " of 2.5 liters") totalLitersYesterday
+          el "br" $ return ()
+          el "strong" $ do
+            dynText =<< mapDyn (\totalLitersToday' → "Progress today: " ++ show totalLitersToday' ++ " of 2.5 liters") totalLitersToday
+      -- the drink log
       rowKeysAndValues ← mapDyn
         (\drinkDB' → Data.Map.fromList $
            [((-drink^.drinkId, drink^.drinkTimestamp), drink) | drink ← (unDrinkDB drinkDB')])
@@ -177,9 +241,9 @@ main = mainWidgetWithHead buildHead $ do
                        , ("Amount", \_ drinkDyn → dynText =<< mapDyn (\x → show (x^.drinkLiters) <> " liters") drinkDyn)
                        ]
                        rowKeysAndValues
-                       (\(_, timestamp) → return $ constDyn $ case () of
-                         () | Clock.utctDay timestamp ≡ today →
+                       (\(_, timestamp) → return $ constDyn $ if
+                         | Clock.utctDay timestamp ≡ today →
                            mempty
-                         () →
+                         | otherwise →
                            Data.Map.fromList [("class", "disabled")])
       return ()