diff --git a/2023/haskell/app/Main.hs b/2023/haskell/app/Main.hs
index 6f31173..08b0590 100644
--- a/2023/haskell/app/Main.hs
+++ b/2023/haskell/app/Main.hs
@@ -3,7 +3,6 @@ module Main where
 import Utils (readInput)
 import qualified Day01
 import qualified Day02
-import Debug.Trace (traceShowId)
 
 
 day01 :: IO ()
@@ -17,7 +16,9 @@ day02 = do
   text <- readInput 2
   case Day02.parse text of
     Left err -> putStrLn err
-    Right xd -> print . Day02.solveA . traceShowId $ xd
+    Right xd -> do
+      print . Day02.solveA $ xd
+      print . Day02.solveB $ xd
 
 main :: IO ()
 main = do
diff --git a/2023/haskell/solutions/Day02.hs b/2023/haskell/solutions/Day02.hs
index fdebdef..1487ebd 100644
--- a/2023/haskell/solutions/Day02.hs
+++ b/2023/haskell/solutions/Day02.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
-module Day02 (Cube(..), Game(..), parse, solveA) where
+module Day02 (Cube(..), Game(..), parse, solveA, solveB) where
 
 import Data.Void (Void)
 import Data.Text (Text)
@@ -13,8 +13,8 @@ import Text.Megaparsec.Char.Lexer (decimal)
 data Cube = R Int | G Int | B Int deriving Show
 
 data Game = Game
-  { gameId   :: Int
-  , gameSets :: [[Cube]]
+  { gId   :: Int
+  , gSets :: [[Cube]]
   } deriving Show
 
 type Parser = Parsec Void Text
@@ -25,34 +25,34 @@ parse = first errorBundlePretty . runParser games ""
   where
     cube :: Parser Cube
     cube = do
-      _ <- optional space
-      number <- decimal
+      _     <- optional space
+      count <- decimal
       space
       color <- choice
         [ R <$ string "red"
         , G <$ string "green"
         , B <$ string "blue"
         ]
-      return . color $ number
+      return $ color count
     set :: Parser [Cube]
     set = space *> cube `sepBy` char ','
     sets :: Parser [[Cube]]
     sets = set `sepBy` char ';'
     game :: Parser Game
     game = do
-      _ <- string "Game"
+      _     <- string "Game"
       space
-      gameId <- decimal
-      _ <- char ':'
-      gameSets <- sets
-      _ <- optional newline
+      gId   <- decimal
+      _     <- char ':'
+      gSets <- sets
+      _     <- optional newline
       return $ Game {..}
     games :: Parser [Game]
     games = many game <* eof
 
 
 solveA :: [Game] -> Int
-solveA = sum . map gameId . filter isValid
+solveA = sum . map gId . filter isValid
   where
     isSetValid :: Cube -> Bool
     isSetValid count = case count of
@@ -60,4 +60,15 @@ solveA = sum . map gameId . filter isValid
       G g -> g <= 13
       B b -> b <= 14
     isValid :: Game -> Bool
-    isValid Game {..} = all (all isSetValid) gameSets
+    isValid Game {..} = all (all isSetValid) gSets
+
+solveB :: [Game] -> Int
+solveB = sum . map toPower
+  where
+    update :: (Int, Int, Int) -> Cube -> (Int, Int, Int)
+    update (r, g, b) cube = case cube of
+      R r' -> (max r r', g, b)
+      G g' -> (r, max g g', b)
+      B b' -> (r, g, max b b')
+    toPower :: Game -> Int
+    toPower Game {..} = (\(r, g, b) -> r * g * b) . foldl update (0, 0, 0) . concat $ gSets
diff --git a/2023/haskell/tests/Main.hs b/2023/haskell/tests/Main.hs
index 70a390d..ac17517 100644
--- a/2023/haskell/tests/Main.hs
+++ b/2023/haskell/tests/Main.hs
@@ -18,10 +18,11 @@ day01 = TestList
 
 day02 :: Test
 day02 = TestList
-  [ TestCase $ assertEqual "should return 8" 8 (Day02.solveA inputA)
+  [ TestCase $ assertEqual "should return 8" 8 (Day02.solveA input)
+  , TestCase $ assertEqual "should return 2286" 2286 (Day02.solveB input)
   ]
   where
-    inputA =
+    input =
       [ Day02.Game 1 [[Day02.B 3, Day02.R 4], [Day02.R 1, Day02.G 2, Day02.B 6], [Day02.G 2]]
       , Day02.Game 2 [[Day02.B 1, Day02.G 2], [Day02.G 3, Day02.B 4, Day02.R 1], [Day02.G 1, Day02.B 1]]
       , Day02.Game 3 [[Day02.G 8, Day02.B 6, Day02.R 20], [Day02.B 5, Day02.R 4, Day02.G 13], [Day02.G 5, Day02.R 1]]