-
-
Save srid/2dc18afadea2cb09e8fedf202c6aba2e to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
diff --git a/src/Self/Calendar/Tracking.hs b/src/Self/Calendar/Tracking.hs | |
index dcd3b0e..22d2130 100644 | |
--- a/src/Self/Calendar/Tracking.hs | |
+++ b/src/Self/Calendar/Tracking.hs | |
@@ -1,15 +1,15 @@ | |
{-# LANGUAGE DataKinds #-} | |
{-# LANGUAGE GADTs #-} | |
+{-# LANGUAGE NoImplicitPrelude #-} | |
{-# LANGUAGE PolyKinds #-} | |
{-# LANGUAGE TemplateHaskell #-} | |
{-# LANGUAGE TypeFamilies #-} | |
-{-# LANGUAGE NoImplicitPrelude #-} | |
{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} | |
module Self.Calendar.Tracking where | |
-import qualified Data.Dependent.Map as DMap | |
import Data.Dependent.Map (DMap) | |
+import qualified Data.Dependent.Map as DMap | |
import Data.Dependent.Sum | |
import Data.GADT.Compare.TH | |
import Polysemy | |
@@ -22,7 +22,7 @@ import qualified Self.Feeling as Feeling | |
-- | What we are tracking on daily basis. | |
-- | |
-- When adding a new tracker, we only need to modify this module. | |
-data Tracking :: Type -> Type where | |
+data Tracking a where | |
Tracking_Activity :: Tracking Activity.Entry | |
Tracking_Feeling :: Tracking [Feeling.Entry] | |
Tracking_Calisthenics :: Tracking Calisthenics.Entry | |
diff --git a/src/Self/Calisthenics.hs b/src/Self/Calisthenics.hs | |
index 44c5dbf..45a41e1 100644 | |
--- a/src/Self/Calisthenics.hs | |
+++ b/src/Self/Calisthenics.hs | |
@@ -6,6 +6,8 @@ | |
{-# LANGUAGE FlexibleInstances #-} | |
{-# LANGUAGE GADTs #-} | |
{-# LANGUAGE LambdaCase #-} | |
+{-# LANGUAGE MultiParamTypeClasses #-} | |
+{-# LANGUAGE NoImplicitPrelude #-} | |
{-# LANGUAGE OverloadedStrings #-} | |
{-# LANGUAGE PolyKinds #-} | |
{-# LANGUAGE QuasiQuotes #-} | |
@@ -15,8 +17,6 @@ | |
{-# LANGUAGE TypeApplications #-} | |
{-# LANGUAGE TypeFamilies #-} | |
{-# LANGUAGE TypeOperators #-} | |
-{-# LANGUAGE ViewPatterns #-} | |
-{-# LANGUAGE NoImplicitPrelude #-} | |
{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} | |
module Self.Calisthenics where | |
@@ -24,24 +24,35 @@ module Self.Calisthenics where | |
import Data.Barbie | |
import Data.Barbie.Bare | |
import Data.Barbie.TH | |
-import Data.Map.Strict (Map) | |
-import qualified Data.Map.Strict as Map | |
+import Data.Constraint.Extras.TH | |
+import Data.Dependent.Map (DMap) | |
+import qualified Data.Dependent.Map as DMap | |
+import Data.GADT.Compare.TH | |
+import Data.GADT.Show.TH | |
import GHC.Generics | |
import Lucid | |
import Polysemy | |
import Polysemy.State | |
import Relude hiding (State, get, modify, runState) | |
+import Self.X | |
+ | |
+newtype Sets = Sets { unSets :: Int } | |
+ deriving (Eq, Generic, Show, Ord) | |
+ | |
+data Movement a where | |
+ PushUp :: Movement Sets | |
+ Squat :: Movement Sets | |
-data Movement | |
- = PushUp | |
- | Squat | |
- deriving (Eq, Show, Ord, Generic) | |
+deriveArgDict ''Movement | |
+deriveGEq ''Movement | |
+deriveGCompare ''Movement | |
+deriveGShow ''Movement | |
declareBareB | |
[d| | |
data Entry' | |
= Entry' | |
- { sets :: Map Movement Int | |
+ { sets :: DMap Movement Identity | |
} | |
|] | |
@@ -51,12 +62,12 @@ deriving instance Show Entry | |
deriving instance Show (Entry' Covered Maybe) | |
-instance ToHtml Movement where | |
+instance ToHtml (X Movement) where | |
toHtmlRaw = toHtml | |
toHtml = toHtml . show @Text | |
data CalisthenicsLang m a where | |
- DidSet :: Movement -> Int -> CalisthenicsLang m () | |
+ DidSet :: X Movement -> CalisthenicsLang m () | |
makeSem ''CalisthenicsLang | |
@@ -68,10 +79,22 @@ runCalisthenicsLang' = | |
fmap (first extractEntity) . runState initialEntry | |
. reinterpret | |
( \case | |
- DidSet move n -> do | |
- modify $ \e -> e {sets = Just $ maybe (Map.singleton move n) (Map.insertWith (+) move n) $ sets e} | |
+ DidSet m -> | |
+ case m of | |
+ PushUp :/ n -> | |
+ modify $ \e -> e | |
+ { sets = Just $ maybe (DMap.singleton PushUp (Identity n)) (addSets PushUp n) $ sets e | |
+ } | |
+ Squat :/ n -> | |
+ modify $ \e -> e | |
+ { sets = Just $ maybe (DMap.singleton Squat (Identity n)) (addSets Squat n) $ sets e | |
+ } | |
) | |
where | |
+ addSets :: Movement Sets -> Sets -> DMap Movement Identity -> DMap Movement Identity | |
+ addSets move (Sets n) = | |
+ flip DMap.update move $ Just . fmap (\case | |
+ Sets m -> Sets $ m + n) | |
initialEntry :: Entry' Covered Maybe | |
initialEntry = | |
Entry' $ Just mempty |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment