aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorMatthias Andreas Benkard <code@mail.matthias.benkard.de>2016-01-20 20:49:36 +0100
committerMatthias Andreas Benkard <code@mail.matthias.benkard.de>2016-01-20 20:49:36 +0100
commit26d908e252b21ae66e1496bb35ca31c69b53ba25 (patch)
tree08f1751591446924cb00382dbeabd0907a6a8ceb /src
Initial checkin.
Diffstat (limited to 'src')
-rw-r--r--src/Lib.hs185
-rw-r--r--src/Model.hs28
2 files changed, 213 insertions, 0 deletions
diff --git a/src/Lib.hs b/src/Lib.hs
new file mode 100644
index 0000000..38ca843
--- /dev/null
+++ b/src/Lib.hs
@@ -0,0 +1,185 @@
+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
+module Lib
+ ( main
+ ) where
+
+import ClassyPrelude
+import GHCJS.DOM.Types (toJSString, fromJSString)
+import GHCJS.Types (JSString)
+import GHCJS.Foreign ()
+import Data.JSString ()
+import Reflex
+import Reflex.Dom
+import Reflex.Host.Class (HostFrame)
+import Prelude.Unicode ((≡), (≥))
+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.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 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
+ input ← textInput $ def & textInputConfig_inputType .~ "number"
+ & textInputConfig_attributes .~ (constDyn (Data.Map.fromList [("placeholder", "amount"), ("pattern", "[0-9]*")]))
+ elAttr "div" (Data.Map.fromList [("class", "ui label")]) $ do
+ text "ml"
+ elAttr "i" (Data.Map.fromList [("class", "coffee icon")]) $ do
+ return ()
+ return input
+ n ← mapDyn readMay $ _textInput_value input
+ 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
+ elAttr "i" (Data.Map.fromList [("class", "add icon")]) $ return ()
+ 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
+
+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
+ -- 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")])))
+ elAttr "i" (Data.Map.fromList [("class", "book icon")]) $ return ()
+ return input
+ let descEv = textInputGetEnter descInput
+ let desc = _textInput_value descInput
+ (amountEv, amount) ← numberInput
+ -- output
+ drinkComponents ← combineDyn3
+ (\desc' amount' currentTime' →
+ case amount' of
+ Just amount'' → Just (pack desc', amount'', currentTime')
+ Nothing → Nothing)
+ desc amount currentTime
+ let ev = descEv `appendEvents` amountEv `appendEvents` acceptBtn
+ return (ev, drinkComponents)
+
+css ∷ String
+css = [here|
+@import url(https://fonts.googleapis.com/css?family=Lato:400,400italic,300italic,300,700italic,700,100,100italic,900italic,900&subset=latin,latin-ext);
+@viewport {
+ width: device-width;
+}
+@-ms-viewport {
+ width: device-width;
+}
+@-o-viewport {
+ width: device-width;
+}
+html {
+ font-family: 'Lato', sans-serif;
+}
+.fullwidth {
+ width: 100%;
+}
+|]
+
+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 ()
+ return ()
+ where
+ elMeta name content = do
+ void $ elAttr "meta" (Data.Map.fromList [("name", name),
+ ("content", content)]) $ return ()
+
+main ∷ IO ()
+main = mainWidgetWithHead buildHead $ do
+ Just window ← liftIO $ DOM.currentWindow
+ Just storage ← liftIO $ DOMWindow.getLocalStorage window
+ rawStoredDB ← liftIO $ DOMStorage.getItem storage ("drinks" ∷ JSString)
+ let loadedDB = rawStoredDB >>= \jsstr → Aeson.decode (encodeUtf8 (pack (fromJSString jsstr)))
+ let initialDrinkDB = maybe (DrinkDB []) id loadedDB
+ today ← Clock.utctDay <$> (liftIO $ Clock.getCurrentTime)
+ 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
+ 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")])
+ elDynAttr "div" progressMessageAttrs $
+ el "em" $ el "strong" $
+ dynText =<< mapDyn (\totalLitersToday' → "Progress today: " ++ show totalLitersToday' ++ " of 2.5 liters") totalLitersToday
+ -- drink log
+ rowKeysAndValues ← mapDyn
+ (\drinkDB' → Data.Map.fromList $
+ [((-drink^.drinkId, drink^.drinkTimestamp), drink) | drink ← (unDrinkDB drinkDB')])
+ drinkDB
+ _ ← tableDynAttr "ui celled inverted purple table"
+ [ ("Date", \_ drinkDyn → dynText =<< mapDyn (\x → TimeFormat.formatTime TimeFormat.defaultTimeLocale "%F %R" (x^.drinkTimestamp)) drinkDyn)
+ , ("Type", \_ drinkDyn → dynText =<< mapDyn (\x → unpack $ x^.drinkDescription) drinkDyn)
+ , ("Amount", \_ drinkDyn → dynText =<< mapDyn (\x → show (x^.drinkLiters) <> " liters") drinkDyn)
+ ]
+ rowKeysAndValues
+ (\(_, timestamp) → return $ constDyn $ case () of
+ () | Clock.utctDay timestamp ≡ today →
+ mempty
+ () →
+ Data.Map.fromList [("class", "disabled")])
+ return ()
diff --git a/src/Model.hs b/src/Model.hs
new file mode 100644
index 0000000..bb3d1fe
--- /dev/null
+++ b/src/Model.hs
@@ -0,0 +1,28 @@
+{-# LANGUAGE OverloadedStrings, NoImplicitPrelude #-}
+module Model
+ ( Drink(..)
+ , drinkId
+ , drinkDescription
+ , drinkTimestamp
+ , drinkLiters
+ , DrinkDB(..)
+ ) where
+
+import ClassyPrelude
+import Control.Category.Unicode ((∘))
+import Control.Lens
+import qualified Data.Aeson.TH as AesonTH
+import qualified Data.Scientific as Scientific
+import qualified Data.Time.Clock as Clock
+
+data Drink = Drink
+ { _drinkId ∷ Int32
+ , _drinkDescription ∷ Text
+ , _drinkTimestamp ∷ Clock.UTCTime
+ , _drinkLiters ∷ Scientific.Scientific
+ }
+$(makeLenses ''Drink)
+$(AesonTH.deriveJSON (AesonTH.defaultOptions{AesonTH.fieldLabelModifier = toLower ∘ (drop 6)}) ''Drink)
+
+data DrinkDB = DrinkDB { unDrinkDB ∷ [Drink] }
+$(AesonTH.deriveJSON AesonTH.defaultOptions ''DrinkDB)