Working prototype

.envrc

@@ -0,0 +1 @@
+use flake --inputs-from . .

CHANGELOG.md

@@ -0,0 +1,5 @@
+# Revision history for rsi-break
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.

LICENSE

@@ -0,0 +1,26 @@
+Copyright (c) 2023, Ruben Astudillo
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are
+met:
+
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the
+   distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import  (haskellSay)
+
+main :: IO ()
+main = haskellSay "Hello Haskell Nixers!"

app/Main.hs

@@ -0,0 +1,6 @@
+module Main where
+
+import RsiBreak.RealMain (realMain)
+
+main :: IO ()
+main = realMain

default.nix

@@ -0,0 +1,17 @@
+{ mkDerivation, async, base, lens, lib, monomer, SDL, SDL-mixer
+, text, text-show, time
+}:
+mkDerivation {
+  pname = "rsi-break";
+  version = "0.1.0.0";
+  src = ./.;
+  isLibrary = true;
+  isExecutable = true;
+  libraryHaskellDepends = [
+    async base lens monomer SDL SDL-mixer text text-show time
+  ];
+  executableHaskellDepends = [ base ];
+  testHaskellDepends = [ base ];
+  license = lib.licenses.bsd2;
+  mainProgram = "rsi-break";
+}

flake.nix

@@ -0,0 +1,35 @@
+{
+  # inspired by: https://serokell.io/blog/practical-nix-flakes#packaging-existing-applications
+  description = "A Hello World in Haskell with a dependency and a devShell";
+  inputs.nixpkgs.url = "nixpkgs";
+  outputs = { self, nixpkgs }:
+    let
+      supportedSystems = [ "x86_64-linux" "x86_64-darwin" ];
+      forAllSystems = f: nixpkgs.lib.genAttrs supportedSystems (system: f system);
+      nixpkgsFor = forAllSystems (system: import nixpkgs {
+        inherit system;
+        overlays = [ self.overlay ];
+      });
+    in
+    {
+      overlay = (final: prev: {
+        rsi-break = final.haskellPackages.callPackage (import ./default.nix) {};
+      });
+      packages = forAllSystems (system: {
+         rsi-break = nixpkgsFor.${system}.rsi-break;
+      });
+      defaultPackage = forAllSystems (system: self.packages.${system}.rsi-break);
+      checks = self.packages;
+      devShell = forAllSystems (system: let haskellPackages = nixpkgsFor.${system}.haskellPackages;
+        in haskellPackages.shellFor {
+          packages = p: [self.packages.${system}.rsi-break];
+          withHoogle = true;
+          buildInputs = with haskellPackages; [
+            haskell-language-server
+            cabal-install
+          ];
+        # Change the prompt to show that you are in a devShell
+        shellHook = "export PS1='\\e[1;34mdev > \\e[0m'";
+        });
+  };
+}

rsi-break.cabal

@@ -0,0 +1,59 @@
+cabal-version:      3.0
+name:               rsi-break
+version:            0.1.0.0
+-- synopsis:
+-- description:
+license:            BSD-2-Clause
+license-file:       LICENSE
+author:             Ruben Astudillo
+maintainer:         [email protected]
+-- copyright:
+category:           Graphics
+build-type:         Simple
+extra-doc-files:    CHANGELOG.md
+-- extra-source-files:
+
+common warnings
+    ghc-options: -Wall
+
+library
+    import:           warnings
+    exposed-modules:  RsiBreak.Controller
+                      RsiBreak.Model
+                      RsiBreak.View
+                      RsiBreak.RealMain
+    -- other-modules:
+    -- other-extensions:
+    build-depends:    base ^>=4.16.4.0,
+                      monomer,
+                      lens,
+                      text,
+                      text-show,
+                      async,
+                      time
+    hs-source-dirs:   src
+    default-language: Haskell2010
+
+executable rsi-break
+    import:           warnings
+    main-is:          Main.hs
+    ghc-options:      -threaded -rtsopts=all -with-rtsopts=-N2
+    -- other-modules:
+    -- other-extensions:
+    build-depends:
+        base ^>=4.16.4.0,
+        rsi-break
+    hs-source-dirs:   app
+    default-language: Haskell2010
+
+test-suite rsi-break-test
+    import:           warnings
+    default-language: Haskell2010
+    -- other-modules:
+    -- other-extensions:
+    type:             exitcode-stdio-1.0
+    hs-source-dirs:   test
+    main-is:          Main.hs
+    build-depends:
+        base ^>=4.16.4.0,
+        rsi-break

src/RsiBreak/Controller.hs

@@ -0,0 +1,93 @@
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module RsiBreak.Controller where
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.Async
+import Control.Lens
+import Control.Monad (when)
+import Data.Either (isRight)
+import Data.Function (fix)
+import Data.Maybe (maybeToList)
+import Data.String (IsString (..))
+import Data.Text (Text)
+import Data.Time (defaultTimeLocale, formatTime)
+import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
+import Monomer
+import RsiBreak.Model
+
+data AppEvent
+    = AppNewWorkTime Minutes
+    | AppNewRestTime Minutes
+    | AppStartWorkTime
+    | AppUpdateCountDown NominalDiffTime
+    | AppStartRestTimer
+    | AppUpdateWaitState WaitState
+    | AppStopTimer
+
+handleEvent ::
+    WidgetEnv AppModel AppEvent ->
+    WidgetNode AppModel AppEvent ->
+    AppModel ->
+    AppEvent ->
+    [AppEventResponse AppModel AppEvent]
+handleEvent wenv _node model evt =
+    case evt of
+        AppNewWorkTime newS -> [Model (set workInterval newS model)]
+        AppNewRestTime newS -> [Model (set restInterval newS model)]
+        AppUpdateWaitState wstate ->
+            [Model (set currentState wstate model)]
+        AppUpdateCountDown td ->
+            let tdText = fromString (formatTime defaultTimeLocale "%m:%02S" td)
+             in [Model (set currentCountdown tdText model)]
+        AppStartWorkTime ->
+            let ws = view workInterval model
+                curWaitState = view currentState model
+             in if curWaitState == NoWait
+                    then Producer (waitSetup ws WorkWait AppStartRestTimer) : updateCounterReq wenv
+                    else []
+        AppStartRestTimer ->
+            let ws = view restInterval model
+             in Producer (waitSetup ws RestWait AppStartWorkTime) : stopCounterReq wenv
+        AppStopTimer -> stopTimerSetup model
+
+mainCounter :: Text
+mainCounter = "MainCounter"
+
+mainCounterUpdateRef :: WidgetEnv model event -> [WidgetId]
+mainCounterUpdateRef wenv = maybeToList . widgetIdFromKey wenv $ WidgetKey mainCounter
+
+updateCounterReq :: WidgetEnv model event -> [EventResponse s e sp ep]
+updateCounterReq wenv = (\i -> Request (RenderEvery i 500 Nothing)) <$> mainCounterUpdateRef wenv
+
+stopCounterReq :: WidgetEnv model event -> [EventResponse s e sp ep]
+stopCounterReq wenv = Request . RenderStop <$> mainCounterUpdateRef wenv
+
+waitSetup :: Minutes -> (Async () -> WaitState) -> AppEvent -> (AppEvent -> IO ()) -> IO ()
+waitSetup totalTimeMin waitStateWrap thenEv handler = do
+    let
+        totalTimeDiff :: NominalDiffTime
+        totalTimeDiff = fromIntegral (totalTimeMin * 60)
+    startTime <- getCurrentTime
+    waitThr <- async . fix $ \again -> do
+        curTime <- getCurrentTime
+        let timeDiff = diffUTCTime curTime startTime
+        if timeDiff <= totalTimeDiff
+            then do
+                handler (AppUpdateCountDown (totalTimeDiff - timeDiff))
+                threadDelay 500_000
+                again
+            else handler (AppUpdateCountDown 0)
+    handler (AppUpdateWaitState (waitStateWrap waitThr))
+    res <- waitCatch waitThr
+    when (isRight res) (handler thenEv)
+
+stopTimerSetup :: AppModel -> [AppEventResponse AppModel AppEvent]
+stopTimerSetup model =
+    let mthr = case view currentState model of
+            WorkWait t -> [t]
+            RestWait t -> [t]
+            _otherwise -> []
+        delTimer = map (\t -> Task (AppUpdateWaitState NoWait <$ cancel t)) mthr
+     in delTimer ++ [Event (AppUpdateCountDown 0)]

src/RsiBreak/Model.hs

@@ -0,0 +1,25 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module RsiBreak.Model where
+
+import Control.Concurrent.Async
+import Control.Lens
+import Data.Text (Text)
+
+type Minutes = Int
+
+data WaitState
+  = WorkWait (Async ())
+  | RestWait (Async ())
+  | NoWait
+  deriving (Eq)
+
+data AppModel = AppModel
+    { _workInterval :: Minutes
+    , _restInterval :: Minutes
+    , _currentCountdown :: Text
+    , _currentState :: WaitState
+    }
+  deriving (Eq)
+
+$(makeLenses 'AppModel)

src/RsiBreak/RealMain.hs

@@ -0,0 +1,20 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module RsiBreak.RealMain where
+
+import Monomer
+import RsiBreak.Controller
+import RsiBreak.Model
+import RsiBreak.View
+
+realMain :: IO ()
+realMain =
+    startApp model handleEvent buildUI config
+  where
+    config =
+        [ appWindowTitle "Tutorial 01 - Basics"
+        , appWindowIcon "./assets/images/icon.png"
+        , appTheme darkTheme
+        , appFontDef "Regular" "./assets/fonts/Roboto-Regular.ttf"
+        ]
+    model = AppModel 5 1 "0:00" NoWait

src/RsiBreak/View.hs

@@ -0,0 +1,41 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module RsiBreak.View where
+
+import Control.Lens (view)
+import Monomer
+import RsiBreak.Controller
+import RsiBreak.Model
+
+greenBgStyle, blueBgStyle :: StyleState
+greenBgStyle = mempty{_sstBgColor = Just (Color 0 128 0 1)}
+blueBgStyle = mempty{_sstBgColor = Just (Color 0 0 128 1)}
+
+buildUI ::
+    WidgetEnv AppModel AppEvent ->
+    AppModel ->
+    WidgetNode AppModel AppEvent
+buildUI _wenv model =
+    vstack
+        [ label "Rsi Break!"
+        , textField_ currentCountdown [readOnly] `nodeKey` mainCounter `styleBasic` currentCountdownColor
+        , spacer
+        , hstack
+            [ label "Work time: "
+            , numericField_ workInterval [minValue 0, maxValue 300, onChange AppNewWorkTime]
+            ]
+        , hstack
+            [ label "Rest time: "
+            , numericField_ restInterval [minValue 0, maxValue 300, onChange AppNewRestTime]
+            ]
+        , spacer
+        , button "Start" AppStartWorkTime
+        , button "Stop" AppStopTimer
+        ]
+        `styleBasic` [padding 10]
+  where
+    currentCountdownColor =
+        case view currentState model of
+            RestWait _ -> [blueBgStyle]
+            WorkWait _ -> [greenBgStyle]
+            NoWait -> []

test/Main.hs

@@ -0,0 +1,4 @@
+module Main (main) where
+
+main :: IO ()
+main = putStrLn "Test suite not yet implemented."