diff --git a/CHANGELOG b/CHANGELOG --- a/CHANGELOG +++ b/CHANGELOG @@ -1,3 +1,6 @@ +2015-10-28 Ivan Perez + * keera-posture.cabal: Relaxes dependencies, version bump (0.2.1). + 2015-06-20 Ivan Perez * keera-posture.cabal, src/Controller.hs: Version bump (0.1.4.4). diff --git a/README b/README --- a/README +++ b/README @@ -10,7 +10,63 @@ cat, or make your back pain problems worse. Use it with care and under medical supervision only. Report any issues with the program to Keera Studios by email, facebook, linkedin or google plus. It is best used in combination with programs -that force you to take regular breaks, stretch, etc. If you use it, you agree not to sue us. +that force you to take regular breaks, stretch, etc. By continuing to use +keera-posture, you are agreeing not to sue us or Keera Studios Ltd. + +INSTALLATION (default) +===================================== + +Keera Posture is available on hackage. Unless you need the latest development +version, the recommended way is to install the version there. + +I often use cabal sandboxes (```cabal sandbox init```). I recommend the following: + +1) Install C/C++ development headers. That includes gtk, sdl, opengl, opencv. + +2) Update your hackage DB using ```cabal update```. + +3) Install gtk2hs-buildtools (```cabal install gtk2hs-buildtools```). +Adjust your PATH to find the path where the binaries have been placed. + +4) Install keera-posture (```cabal install keera-posture```). + +INSTALLATION ON DEBIAN (the not-so-easy way; but still quite easy) +================================================================== + +You need to have git, cabal, cabal-dev and ghc installed. Everything else will +be installed for you. You also need to run sudo (at least once) so that the script +can sudo without a password whenever it needs to. + +If you do not know how to install cabal-dev, run: + + $ cabal install cabal-dev + $ export PATH=$PATH:$HOME/.cabal/bin + +After that, all you need is: + + $ mkdir -p keera-posture && cd keera-posture && (wget -O- https://raw.githubusercontent.com/keera-studios/keera-posture/master/debian/package-from-scratch.sh | bash) + +This will create all the necessary directories, check out all sources, prompt +to install dependencies, compile the whole program, and create a DEB file for your +architecture and version of debian/ubuntu. If it works, install that. + +COMPILATION ON OTHER LINUX/UNIX SYSTEMS (not so easy, not so hard) +================================================================== + +Again, you need to have ghc, cabal, cabal-dev and git. You also need some +libraries installed (GL, SDL, SDL-mixer, FTGL, OpenCV, Gtk2, Glade2). The list +for debian systems is: + +- libopencv-dev libglade2-dev libgl-dev libglu1-mesa-dev libftgl-dev libsdl1.2-dev libsdl-mixer1.2-dev + +I don't use Fedora, so you have to find which ones are yours. Then, run the following: + + $ mkdir -p keera-posture && cd keera-posture && (wget -O- https://raw.githubusercontent.com/keera-studios/keera-posture/master/installation.sh | bash) + +This will check out, compile and install everything you need. + +DOING EVERYTHING BY HAND (only for developers) +============================================== Dependencies (tools): - alex (gtk2hs-buildtools), happy (gtk2hs-buildtools), gtk2hs-buildtools. diff --git a/data/keera-posture.png b/data/keera-posture.png new file mode 100644 Binary files /dev/null and b/data/keera-posture.png differ diff --git a/keera-posture.cabal b/keera-posture.cabal --- a/keera-posture.cabal +++ b/keera-posture.cabal @@ -6,7 +6,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.1.4.4 +Version: 0.2.1 -- A short (one-line) description of the package. Synopsis: Get notifications when your sitting posture is inappropriate. @@ -31,7 +31,7 @@ Maintainer: support@keera.co.uk -- A copyright notice. --- Copyright: +-- Copyright: -- Stability of the package (experimental, provisional, stable...) -- Stability: Experimental @@ -54,24 +54,24 @@ -- .hs or .lhs file containing the Main module. Main-is: Main.hs hs-source-dirs: src/ - + if os(windows) ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O2 -- ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O2 -optl-mwindows -- ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O2 -rtsopts=all extra-libraries: SDL_mixer - else + else ghc-options: -threaded -Wall -fno-warn-unused-do-bind -- ghc-options: -threaded -Wall -fno-warn-unused-do-bind -O2 obj/OpenCVGtkPixbuf.o -- Packages needed in order to build this package. - -- Build-depends: + -- Build-depends: if os(windows) Build-depends: base >= 4.0 && < 5, containers, cv-combinators, cmdargs, - HOpenCV <= 0.1.2.4, + HOpenCV, mtl, IfElse, filepath, @@ -110,7 +110,7 @@ containers, cv-combinators, cmdargs, - HOpenCV <= 0.1.2.4, + HOpenCV, mtl, IfElse, filepath, @@ -143,7 +143,7 @@ keera-hails-mvc-controller, keera-hails-mvc-solutions-config, keera-hails-reactivevalues - + -- Modules not exported by this package. Other-modules: Audio, AI.CV.PostureProcessors, @@ -203,10 +203,10 @@ View, View.InitLanguagesCombo, View.Objects - + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source. -- Build-tools: hails - + source-repository head type: git location: https://github.com/keera-studios/keera-posture.git diff --git a/src/Controller/Conditions/Calibrate.hs b/src/Controller/Conditions/Calibrate.hs --- a/src/Controller/Conditions/Calibrate.hs +++ b/src/Controller/Conditions/Calibrate.hs @@ -2,7 +2,9 @@ module Controller.Conditions.Calibrate where import Control.Monad +import Data.ReactiveValue import Graphics.UI.Gtk +import Graphics.UI.Gtk.Reactive import CombinedEnvironment @@ -11,11 +13,19 @@ installHandlers cenv = void $ do let ui = mainWindowBuilder $ view cenv + let precalibrateRV = wrapDo_ (precalibrate cenv) + -- Full RV-based implementation. + -- precalibrationWindowVisibleRV <- + -- windowVisibilityPassive <$> + -- precalibrationWindow (mainWindowBuilder $ view cenv) + -- precalibrateRV = (\() -> True) `liftW` precalibrationWindowVisibleRV + menu <- mainMenuCalibrateItem ui - menu `on` menuItemActivate $ precalibrate cenv + menuItemActivateField menu =:> precalibrateRV btn <- preferencesNotebookCalibrateBtn ui - btn `on` buttonActivated $ precalibrate cenv + buttonActivateField btn =:> precalibrateRV + -- btn `on` buttonActivated $ precalibrate cenv -- | Shows the precalibration window precalibrate :: CEnv -> IO() diff --git a/src/Controller/Conditions/Help.hs b/src/Controller/Conditions/Help.hs --- a/src/Controller/Conditions/Help.hs +++ b/src/Controller/Conditions/Help.hs @@ -3,13 +3,15 @@ module Controller.Conditions.Help where import Control.Monad -import Graphics.UI.Gtk +import Data.ReactiveValue +import Graphics.UI.Gtk.Reactive import CombinedEnvironment import System.Application installHandlers :: CEnv -> IO() -installHandlers cenv = void $ do +installHandlers cenv = do menu <- mainMenuHelp $ mainWindowBuilder $ view cenv - menu `on` menuItemActivate $ onViewAsync $ void $ - openUrlBySystemTool "http://www.keera.co.uk/projects/keera-posture/documentation/" + menuItemActivateField menu =:> wrapDo_ + (onViewAsync $ void $ + openUrlBySystemTool "http://www.keera.co.uk/projects/keera-posture/documentation/") diff --git a/src/Controller/Conditions/MenuEnabled.hs b/src/Controller/Conditions/MenuEnabled.hs --- a/src/Controller/Conditions/MenuEnabled.hs +++ b/src/Controller/Conditions/MenuEnabled.hs @@ -21,6 +21,9 @@ -- TODO: Update to reactive interface using =:= and liftRW condition :: CEnv -> IO() condition cenv = onViewAsync $ do + -- notificationEnabledField + -- =:> modRW vShould mainMenuItemLabel + menu <- mainMenuEnableItem $ mainWindowBuilder $ view cenv awhenM (menuItemGetLabel menu) $ \lbl -> do -- Current view value diff --git a/src/Controller/Conditions/MenuEnabledClick.hs b/src/Controller/Conditions/MenuEnabledClick.hs --- a/src/Controller/Conditions/MenuEnabledClick.hs +++ b/src/Controller/Conditions/MenuEnabledClick.hs @@ -2,35 +2,70 @@ module Controller.Conditions.MenuEnabledClick where import Control.Monad +import Data.ReactiveValue import Graphics.UI.Gtk +import Graphics.UI.Gtk.Reactive import CombinedEnvironment -import Model.Model (Status(..)) +import Model.Model (Status(..), isDisabled, isCalibrating) import Hails.MVC.Model.ProtectedModel.Reactive -- Detects interaction with the main window and the tray icon installHandlers :: CEnv -> IO() installHandlers cenv = void $ do + -- View points menu <- mainMenuEnableItem $ mainWindowBuilder $ view cenv - menu `on` menuItemActivate $ condition cenv icon <- trayIcon $ mainWindowBuilder $ view cenv - icon `on` statusIconActivate $ condition cenv + let anyInteraction = lMerge (menuItemActivateField menu) + (statusIconActivateField icon) --- | Closes the menu and toggles notification status -condition :: CEnv -> IO() -condition cenv = onViewAsync $ do + -- Model points + let stField = mkFieldAccessor statusField (model cenv) + + -- Reactive Rules + + -- Hide menu (whatever happens) + anyInteraction =:> wrapDo_ (popDownMenu cenv) + + -- Advance state if it was calibrating + + let statusIfMustCalibrate = anyInteraction `governingR` statusIfNotCalibrating + -- statusIfMustCalibrate = liftR2 (\_ s -> s) anyInteraction statusIfNotCalibrating + statusIfNotCalibrating = stField `guardRO'` (not.isCalibrating) + + statusIfMustCalibrate =:> (nextState `liftW` stField) + + -- let updateStatusRV = modRW (\x _ -> if not (isCalibrating x) then nextState x else x) stField + -- anyInteraction =:> updateStatusRV + + -- Disable notification if it was calibrating + let notifEnabled = mkFieldAccessor notificationEnabledField (model cenv) + + statusIfMustCalibrate =:> (isDisabled `liftW` notifEnabled) + +nextState :: Status -> Status +nextState StatusDisabled = StatusIdle +nextState _ = StatusDisabled + +popDownMenu cenv = onViewAsync $ do -- Close the menu if the option is selected menu <- mainMenu $ mainWindowBuilder $ view cenv menuPopdown menu - let pm = model cenv - - status <- getStatus pm - -- notifyEnabled <- getter notificationEnabledField pm +-- -- | Closes the menu and toggles notification status +-- condition :: CEnv -> IO() +-- condition cenv = onViewAsync $ do +-- -- Close the menu if the option is selected +-- menu <- mainMenu $ mainWindowBuilder $ view cenv +-- menuPopdown menu +-- +-- -- status <- getStatus pm +-- -- notifyEnabled <- getter notificationEnabledField pm +-- + -- case status of + -- StatusDisabled -> do setStatus pm StatusIdle + -- setter notificationEnabledField pm True + -- StatusCallibrating -> return () + -- _ -> do setStatus pm StatusDisabled + -- setter notificationEnabledField pm False - case status of - StatusDisabled -> do setStatus pm StatusIdle - setter notificationEnabledField pm True - StatusCallibrating -> return () - _ -> do setStatus pm StatusDisabled - setter notificationEnabledField pm False diff --git a/src/Controller/Conditions/NotifyWindow.hs b/src/Controller/Conditions/NotifyWindow.hs --- a/src/Controller/Conditions/NotifyWindow.hs +++ b/src/Controller/Conditions/NotifyWindow.hs @@ -2,9 +2,9 @@ -- of notification is enabled module Controller.Conditions.NotifyWindow where -import Control.Arrow -import Control.Monad +import Data.ReactiveValue import Graphics.UI.Gtk +import Graphics.UI.Gtk.Reactive import CombinedEnvironment import Model.Model (Status(..)) @@ -13,26 +13,40 @@ -- | Notifies/stops notifying when the system is started, or when notification, -- status or overlay are changed. installHandlers :: CEnv -> IO() -installHandlers cenv = void $ do - let (vw, pm) = (view &&& model) cenv - onEvent pm Initialised $ condition cenv - onEvent pm NotificationEnabledChanged $ condition cenv - onEvent pm NotificationOverlayEnabledChanged $ condition cenv - onEvent pm StatusChanged $ condition cenv +installHandlers cenv = do + -- Model RVs + let stField = mkFieldAccessor statusField (model cenv) + notifEnabled = mkFieldAccessor notificationEnabledField (model cenv) + notifOverl = mkFieldAccessor notificationOverlayEnabledField (model cenv) + + let shouldNotify = liftR3 (\x y z -> x && y && z) + ((StatusNotifying ==) `liftR` stField) + notifEnabled + notifOverl + + -- View elements + win <- notificationWindow $ mainWindowBuilder $ view cenv -- FIXME: This should be on the view only - win <- notificationWindow $ mainWindowBuilder vw widgetModifyBg win StateNormal $ Color 65256 32256 32256 --- | Resets the visibility of the notification window -condition :: CEnv -> IO() -condition cenv = onViewAsync $ do - let (vw, pm) = (view &&& model) cenv - status <- getStatus pm - notifyEnabled <- getter notificationEnabledField pm - overlayEnabled <- getter notificationOverlayEnabledField pm - win <- notificationWindow $ mainWindowBuilder vw - - if status == StatusNotifying && notifyEnabled && overlayEnabled - then widgetShowAll win - else widgetHideAll win + -- Reactive Rules + widgetVisibleReactive win <:= shouldNotify + +-- import Control.Monad + -- onEvent pm Initialised $ condition cenv + -- onEvent pm NotificationEnabledChanged $ condition cenv + -- onEvent pm NotificationOverlayEnabledChanged $ condition cenv + -- onEvent pm StatusChanged $ condition cenv +-- -- | Resets the visibility of the notification window +-- condition :: CEnv -> IO() +-- condition cenv = onViewAsync $ do +-- let (vw, pm) = (view &&& model) cenv +-- status <- getStatus pm +-- notifyEnabled <- getter notificationEnabledField pm +-- overlayEnabled <- getter notificationOverlayEnabledField pm +-- win <- notificationWindow $ mainWindowBuilder vw +-- +-- if status == StatusNotifying && notifyEnabled && overlayEnabled +-- then widgetShowAll win +-- else widgetHideAll win diff --git a/src/Controller/Conditions/Postcalibration.hs b/src/Controller/Conditions/Postcalibration.hs --- a/src/Controller/Conditions/Postcalibration.hs +++ b/src/Controller/Conditions/Postcalibration.hs @@ -2,45 +2,65 @@ -- results). module Controller.Conditions.Postcalibration where -import Control.Monad -import Control.Monad.Trans -import Graphics.UI.Gtk +import Data.ReactiveValue +import Graphics.UI.Gtk.Reactive import CombinedEnvironment import Controller.Conditions.Calibration -- | Detects when the dialog is closed, or when its buttons are pressed. installHandlers :: CEnv -> IO() -installHandlers cenv = void $ do +installHandlers cenv = do let ui = mainWindowBuilder $ view cenv calWin <- calibrationWindow ui - calWin `on` deleteEvent $ liftIO (handleClose cenv) - btnCls <- calibrationCloseBtn ui - btnCls `on` buttonActivated $ onViewAsync (void (handleClose cenv)) - btnCal <- calibrationRecalibrateBtn ui - btnCal `on` buttonActivated $ handleRecalibrate cenv --- Close the calibration window when appropriate -handleClose :: CEnv -> IO Bool -handleClose cenv = do - let ui = mainWindowBuilder $ view cenv - btn <- calibrationCloseBtn ui - isEnabled <- get btn widgetSensitive - calWin <- calibrationWindow ui - if isEnabled then widgetHide calWin else widgetShowAll calWin - return isEnabled + let mustClose = lMerge (windowCloseReactive calWin) + (buttonActivateField btnCls) --- Request a recalibration when instructed by the user -handleRecalibrate :: CEnv -> IO () -handleRecalibrate cenv = onViewAsync $ do - let ui = mainWindowBuilder $ view cenv - btn1 <- calibrationCloseBtn ui - btn2 <- calibrationRecalibrateBtn ui + mustReallyClose = mustClose `governingR` btnClsSensitive - widgetSetSensitive btn1 False - widgetSetSensitive btn2 False + btnClsSensitive = widgetSensitiveReactive btnCls + btnCalSensitive = widgetSensitiveReactive btnCal - calibrate cenv + mustReallyClose =:> widgetVisibleReactive calWin + buttonActivateField btnCal =:> (constW False btnClsSensitive) + buttonActivateField btnCal =:> (constW False btnCalSensitive) + buttonActivateField btnCal =:> wrapDo_ (calibrate cenv) + + + -- import Control.Monad + -- import Control.Monad.Trans + -- import Graphics.UI.Gtk + -- calWin `on` deleteEvent $ liftIO (handleClose cenv) + + -- btnCls <- calibrationCloseBtn ui + -- btnCls `on` buttonActivated $ onViewAsync (void (handleClose cenv)) + -- btnCal `on` buttonActivated $ handleRecalibrate cenv + + +-- -- Close the calibration window when appropriate +-- handleClose :: CEnv -> IO Bool +-- handleClose cenv = do +-- -- calCloseSensitive = widgetSensitive btnCls +-- +-- let ui = mainWindowBuilder $ view cenv +-- btn <- calibrationCloseBtn ui +-- isEnabled <- get btn widgetSensitive +-- calWin <- calibrationWindow ui +-- if isEnabled then widgetHide calWin else widgetShowAll calWin +-- return isEnabled + +-- Request a recalibration when instructed by the user +-- handleRecalibrate :: CEnv -> IO () +-- handleRecalibrate cenv = onViewAsync $ do +-- let ui = mainWindowBuilder $ view cenv +-- btn1 <- calibrationCloseBtn ui +-- btn2 <- calibrationRecalibrateBtn ui +-- +-- widgetSetSensitive btn1 False +-- widgetSetSensitive btn2 False +-- +-- calibrate cenv diff --git a/src/Controller/Conditions/Precalibration.hs b/src/Controller/Conditions/Precalibration.hs --- a/src/Controller/Conditions/Precalibration.hs +++ b/src/Controller/Conditions/Precalibration.hs @@ -3,8 +3,8 @@ module Controller.Conditions.Precalibration where import Control.Monad -import Control.Monad.Trans -import Graphics.UI.Gtk +import Data.ReactiveValue +import Graphics.UI.Gtk.Reactive import CombinedEnvironment import Controller.Conditions.Calibration @@ -15,43 +15,75 @@ installHandlers :: CEnv -> IO() installHandlers cenv = void $ do let ui = mainWindowBuilder $ view cenv - - preWin <- precalibrationWindow ui - preWin `on` deleteEvent $ liftIO (condition cenv) >> return True - - btn <- precalibrationOkBtn ui - btn `on` buttonActivated $ condition cenv --- | Hides the dialog when necessary, and shows the next step -condition :: CEnv -> IO() -condition cenv = onViewAsync $ do - let ui = mainWindowBuilder $ view cenv - - -- Hide precalibration window + -- Precalibration widgets preWin <- precalibrationWindow ui - widgetHide preWin + btn <- precalibrationOkBtn ui - -- Show calibration window + -- Calibration widgets calWin <- calibrationWindow ui - widgetShowAll calWin - -- Disable buttons - btn1 <- calibrationCloseBtn ui - btn2 <- calibrationRecalibrateBtn ui + -- Signal that triggers changes + let precalibrationNext = lMerge (windowCloseReactive preWin) + (buttonActivateField btn) - widgetSetSensitive btn1 False - widgetSetSensitive btn2 False + -- Hide the precalibration window + precalibrationNext =:> constW False (widgetVisibleReactive preWin) - -- Readjust title, explanation and image - lblT <- calibrationTitleLbl ui - labelSetMarkup lblT title1 + -- Show the calibration window + precalibrationNext =:> constW True (widgetVisibleReactive calWin) + btnCls <- calibrationCloseBtn ui + btnCal <- calibrationRecalibrateBtn ui + let btnClsSensitive = widgetSensitiveReactive btnCls + btnCalSensitive = widgetSensitiveReactive btnCal + + lblT <- calibrationTitleLbl ui lblE <- calibrationExplanationLbl ui - labelSetText lblE explanation1 - + calImg <- calibrationImage ui fn <- getDataFileName "calibration-preview.png" - imageSetFromFile calImg fn - -- Run calibration - calibrate cenv + precalibrationNext =:> + ( (constW False (btnClsSensitive &&& btnCalSensitive)) + &&& (constW title1 (labelTextReactive lblT)) + &&& (constW explanation1 (labelTextReactive lblE)) + &&& (constW fn (imageFileReactive calImg)) + &&& (wrapDo_ (calibrate cenv)) + ) + +-- import Graphics.UI.Gtk +---- | Hides the dialog when necessary, and shows the next step +--condition :: CEnv -> IO() +--condition cenv = onViewAsync $ do +-- let ui = mainWindowBuilder $ view cenv +-- +-- -- -- Hide precalibration window +-- -- preWin <- precalibrationWindow ui +-- -- widgetHide preWin +-- +-- -- -- Show calibration window +-- -- calWin <- calibrationWindow ui +-- -- widgetShowAll calWin +-- +-- -- -- Disable buttons +-- -- btn1 <- calibrationCloseBtn ui +-- -- btn2 <- calibrationRecalibrateBtn ui +-- +-- -- widgetSetSensitive btn1 False +-- -- widgetSetSensitive btn2 False +-- +-- -- Readjust title, explanation and image +-- lblT <- calibrationTitleLbl ui +-- reactiveValueWrite (labelTextReactive lblT) title1 +-- +-- lblE <- calibrationExplanationLbl ui +-- reactiveValueWrite (labelTextReactive lblE) title1 +-- +-- calImg <- calibrationImage ui +-- fn <- getDataFileName "calibration-preview.png" +-- reactiveValueWrite (imageFileReactive calImg) fn +-- +-- -- Run calibration +-- calibrate cenv +-- diff --git a/src/Controller/Conditions/PreferencesDialog.hs b/src/Controller/Conditions/PreferencesDialog.hs --- a/src/Controller/Conditions/PreferencesDialog.hs +++ b/src/Controller/Conditions/PreferencesDialog.hs @@ -2,15 +2,16 @@ -- closed. module Controller.Conditions.PreferencesDialog where -import Control.Monad +import Data.ReactiveValue import Graphics.UI.Gtk +import Graphics.UI.Gtk.Reactive import CombinedEnvironment installHandlers :: CEnv -> IO() -installHandlers cenv = void $ do +installHandlers cenv = do menu <- mainMenuPreferences $ mainWindowBuilder $ view cenv - menu `on` menuItemActivate $ condition cenv + menuItemActivateField menu =:> wrapDo_ (condition cenv) condition :: CEnv -> IO() condition cenv = onViewAsync $ do diff --git a/src/Controller/Conditions/PreferencesDialogDestroy.hs b/src/Controller/Conditions/PreferencesDialogDestroy.hs --- a/src/Controller/Conditions/PreferencesDialogDestroy.hs +++ b/src/Controller/Conditions/PreferencesDialogDestroy.hs @@ -1,13 +1,17 @@ -- | Hides the preferences dialog when the user closes it module Controller.Conditions.PreferencesDialogDestroy where -import Control.Monad -import Control.Monad.Reader (liftIO) -import Graphics.UI.Gtk +import Data.ReactiveValue +import Graphics.UI.Gtk.Reactive import CombinedEnvironment installHandlers :: CEnv -> IO() -installHandlers cenv = void $ do +installHandlers cenv = do dg <- preferencesDialog $ mainWindowBuilder $ view cenv - dg `on` deleteEvent $ liftIO (onViewAsync (widgetHide dg)) >> return True + windowCloseReactive dg =:> constW False (widgetVisibleReactive dg) + +-- import Control.Monad +-- import Control.Monad.Reader (liftIO) +-- import Graphics.UI.Gtk + -- dg `on` deleteEvent $ liftIO (onViewAsync (widgetHide dg)) >> return True diff --git a/src/Controller/Conditions/Quit.hs b/src/Controller/Conditions/Quit.hs --- a/src/Controller/Conditions/Quit.hs +++ b/src/Controller/Conditions/Quit.hs @@ -2,20 +2,28 @@ module Controller.Conditions.Quit where import Control.Monad +import Data.ReactiveValue import Graphics.UI.Gtk +import Graphics.UI.Gtk.Reactive import CombinedEnvironment -- | Detect when the user activates the menu item 'Quit' installHandlers :: CEnv -> IO() -installHandlers cenv = void $ do +installHandlers cenv = do menu <- mainMenuQuit $ mainWindowBuilder $ view cenv - menu `on` menuItemActivate $ condition cenv - --- | Deinstalls the status icon and stops the view, effectively stopping the --- whole program. -condition :: CEnv -> IO() -condition cenv = do icon <- trayIcon $ mainWindowBuilder $ view cenv - statusIconSetVisible icon False - mainQuit + + menuItemActivateField menu =:> + ( (constW False (statusIconVisibleReactive icon)) + &&& (wrapDo_ mainQuit) + ) + + +-- -- | Deinstalls the status icon and stops the view, effectively stopping the +-- -- whole program. +-- condition :: CEnv -> IO() +-- condition cenv = do +-- icon <- trayIcon $ mainWindowBuilder $ view cenv +-- statusIconSetVisible icon False +-- mainQuit diff --git a/src/Controller/Conditions/Website.hs b/src/Controller/Conditions/Website.hs --- a/src/Controller/Conditions/Website.hs +++ b/src/Controller/Conditions/Website.hs @@ -2,14 +2,15 @@ module Controller.Conditions.Website where import Control.Monad -import Graphics.UI.Gtk +import Data.ReactiveValue +import Graphics.UI.Gtk.Reactive import CombinedEnvironment import System.Application -- | Opens the project's url when the user requests it installHandlers :: CEnv -> IO() -installHandlers cenv = void $ do +installHandlers cenv = do menu <- mainMenuWebsite $ mainWindowBuilder $ view cenv - menu `on` menuItemActivate $ - onViewAsync $ void $ openUrlBySystemTool "http://www.keera.es/projects/keera-posture/" + menuItemActivateField menu =:> + wrapDo_ (onViewAsync $ void $ openUrlBySystemTool "http://www.keera.es/projects/keera-posture/") diff --git a/src/Controller/Conditions/Welcome.hs b/src/Controller/Conditions/Welcome.hs --- a/src/Controller/Conditions/Welcome.hs +++ b/src/Controller/Conditions/Welcome.hs @@ -2,38 +2,42 @@ -- only be shown if the user executes the program for the first time. module Controller.Conditions.Welcome where -import Control.Arrow import Control.Monad -import Control.Monad.Trans -import Graphics.UI.Gtk +import Data.ReactiveValue +import Graphics.UI.Gtk.Reactive import CombinedEnvironment import Hails.MVC.Model.ProtectedModel.Reactive installHandlers :: CEnv -> IO() installHandlers cenv = void $ do - let (ui, pm) = ((mainWindowBuilder . view) &&& model) cenv + -- View elements + let ui = mainWindowBuilder $ view cenv + win <- welcomeWindow ui + btn <- welcomeOkBtn ui + -- Model RVs + let firstRun = mkFieldAccessor firstRunField (model cenv) + -- Show the welcome window only when necessary (if this is not the first time -- that the program is executed) - onEvent pm FirstRunChanged $ condition cenv - - -- guardRO (firstRunField (model cenv) `liftR` (== Just True)) =:> - -- windowVisiblePassive welcomeWindow - - -- buttonActivatedReactive btn =:> (windowVisiblePassive welcomeWindow `liftW` False) - -- windowCloseReactive btn =:> (windowVisiblePassive welcomeWindow `liftW` False) + guardRO ((Just True ==) `liftR` firstRun) =:> widgetVisibleReactive win - -- Hide the window when requested - win <- welcomeWindow ui - win `on` deleteEvent $ liftIO (onViewAsync (widgetHide win)) >> return True - btn <- welcomeOkBtn ui - btn `on` buttonActivated $ onViewAsync (widgetHide win) + windowCloseReactive win =:> constW False (widgetVisibleReactive win) + buttonActivateField btn =:> constW False (widgetVisibleReactive win) --- Shows the window if this is the first time the program is run -condition :: CEnv -> IO() -condition cenv = onViewAsync $ do - fr <- getter firstRunField $ model cenv - when (fr == Just True) $ - widgetShowAll =<< welcomeWindow (mainWindowBuilder $ view cenv) +-- import Control.Arrow +-- import Control.Monad.Trans +-- import Graphics.UI.Gtk +-- +-- let (ui, pm) = ((mainWindowBuilder . view) &&& model) cenv +-- onEvent pm FirstRunChanged $ condition cenv +-- win `on` deleteEvent $ liftIO (onViewAsync (widgetHide win)) >> return True +-- btn `on` buttonActivated $ onViewAsync (widgetHide win) +-- -- Shows the window if this is the first time the program is run +-- condition :: CEnv -> IO() +-- condition cenv = onViewAsync $ do +-- fr <- getter firstRunField $ model cenv +-- when (fr == Just True) $ +-- widgetShowAll =<< welcomeWindow (mainWindowBuilder $ view cenv) diff --git a/src/Model/Model.hs b/src/Model/Model.hs --- a/src/Model/Model.hs +++ b/src/Model/Model.hs @@ -104,6 +104,14 @@ | StatusDisabled deriving (Eq, Ord) +isCalibrating :: Status -> Bool +isCalibrating StatusCallibrating = True +isCalibrating _ = False + +isDisabled :: Status -> Bool +isDisabled StatusDisabled = True +isDisabled _ = False + -- | Languages supported by this program data Language = English | Galician diff --git a/src/Model/ProtectedModel.hs b/src/Model/ProtectedModel.hs --- a/src/Model/ProtectedModel.hs +++ b/src/Model/ProtectedModel.hs @@ -16,3 +16,10 @@ import Model.ProtectedModel.Detector as Exported onEvents pm es x = mapM_ (\e -> onEvent pm e x) es + +-- , initialisedField +-- import Hails.MVC.Model.ProtectedModel.Reactive +-- initialisedField = ReactiveElement +-- [ Initialised ] +-- (\_ _ -> return ()) +-- (\_ -> return ())