stuff.diff

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