aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--.gitignore2
-rw-r--r--src/Lib.hs188
2 files changed, 128 insertions, 62 deletions
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..4d207b7
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+.stack-work
+
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 ()