diff --git a/2023/haskell/aoc2023.cabal b/2023/haskell/aoc2023.cabal
index d1a8c9a..6146e9d 100644
--- a/2023/haskell/aoc2023.cabal
+++ b/2023/haskell/aoc2023.cabal
@@ -38,7 +38,8 @@ library
   build-depends:
     base       ^>=4.17.2.0,
     text       ^>=2.1,
-    megaparsec ^>=9.6
+    megaparsec ^>=9.6,
+    microlens  ^>=0.4.13
 
   default-language: Haskell2010
 
diff --git a/2023/haskell/app/Main.hs b/2023/haskell/app/Main.hs
index bd2e3ed..93ec46b 100644
--- a/2023/haskell/app/Main.hs
+++ b/2023/haskell/app/Main.hs
@@ -42,4 +42,4 @@ main = do
   --run 08 Day08.parse Day08.solveA Day08.solveB
   --run 09 Day09.parse Day09.solveA Day09.solveB
   --run 10 Day10.parse Day10.solveA Day10.solveB
-  run 15 Day15.parse Day15.solveA Day15.solveA
+  run 15 Day15.parse Day15.solveA Day15.solveB
diff --git a/2023/haskell/solutions/Day15.hs b/2023/haskell/solutions/Day15.hs
index c4c1eb5..e7cfb64 100644
--- a/2023/haskell/solutions/Day15.hs
+++ b/2023/haskell/solutions/Day15.hs
@@ -1,29 +1,70 @@
 {-# LANGUAGE OverloadedStrings #-}
-module Day15 (parse, solveA) where
+module Day15 (parse, solveA, solveB) where
 
+import Data.Void (Void)
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Char (ord, isSpace)
+import Data.Bifunctor (bimap)
+import Text.Megaparsec (Parsec, errorBundlePretty, runParser, sepBy, optional, eof, many, choice)
+import Text.Megaparsec.Char (newline, alphaNumChar, char)
+import Text.Megaparsec.Char.Lexer (decimal)
+import Lens.Micro (ix, (%~))
 
 
-input :: Text
-input = "rn=1,cm-,qp=3,cm=2,qp-,pc=4,ot=9,ab=5,pc-,pc=6,ot=7"
+data Op
+  = Set Text Int
+  | Del Text
+  deriving Show
+
+type Entry = (Text, Int)
+
+type Parser = Parsec Void Text
 
 
-parse :: Text -> Either String [Text]
-parse = Right . T.splitOn "," . T.filter (not . isSpace)
+parse :: Text -> Either String [(Text, Op)]
+parse text = bimap errorBundlePretty (zip . simple $ text) . runParser complex "" $ text
+  where
+    simple :: Text -> [Text]
+    simple = T.splitOn "," . T.filter (not . isSpace)
+    single :: Parser Op
+    single = do
+      label  <- T.pack <$> many alphaNumChar
+      choice
+        [ Set label <$> (char '=' *> decimal)
+        , Del label <$  char '-'
+        ]
+    complex :: Parser [Op]
+    complex = single `sepBy` "," <* optional newline <* eof
 
 hash :: Text -> Int
-hash = foldl step 0 . T.unpack
+hash = T.foldl step 0
   where
     step :: Int -> Char -> Int
     step curr = (`rem` 256) . (17 *) . (curr +) . ord
 
-solveA :: [Text] -> Int
-solveA = sum . map hash
+solveA :: [(Text, Op)] -> Int
+solveA = sum . map (hash . fst)
 
+del :: Text -> [[Entry]] -> [[Entry]]
+del k = ix (hash k) %~ filter ((k /=) . fst)
 
+set :: Text -> Int -> [[Entry]] -> [[Entry]]
+set k v = ix (hash k) %~ update
+  where
+    update :: [Entry] -> [Entry]
+    update es
+      | any ((k ==) . fst) es = map (\(k', v') -> if k == k' then (k, v) else (k', v')) es
+      | otherwise = es <> [(k, v)]
 
--- >>> solveA <$> parse input
--- Right 1320
-
+solveB :: [(Text, Op)] -> Int
+solveB = sum . zipWith row [1..] . foldl (flip run) (replicate 256 []) . map snd
+  where
+    run :: Op -> [[Entry]] -> [[Entry]]
+    run op = case op of
+      Set k v -> set k v
+      Del k   -> del k
+    box :: Int -> Entry -> Int
+    box i = (i *) . snd
+    row :: Int -> [Entry] -> Int
+    row i = (i *) . sum . zipWith box [1..]
diff --git a/2023/haskell/tests/Main.hs b/2023/haskell/tests/Main.hs
index 695f253..f580301 100644
--- a/2023/haskell/tests/Main.hs
+++ b/2023/haskell/tests/Main.hs
@@ -278,15 +278,13 @@ day10 =
 
 day15 :: Test
 day15 =
-  let parsedA1 = Day15.parse inputA1
-      parsedA2 = Day15.parse inputA2
+  let parsed = Day15.parse input
   in TestList
-    [ TestCase $ assertEqual "A" (Right 52)    (Day15.solveA <$> parsedA1)
-    , TestCase $ assertEqual "A" (Right 1320)  (Day15.solveA <$> parsedA2)
+    [ TestCase $ assertEqual "A" (Right 1320) (Day15.solveA <$> parsed)
+    , TestCase $ assertEqual "A" (Right 145)  (Day15.solveB <$> parsed)
     ]
   where
-    inputA1 = "HASH"
-    inputA2 = "rn=1,cm-,qp=3,cm=2,qp-,pc=4,ot=9,ab=5,pc-,pc=6,ot=7"
+    input = "rn=1,cm-,qp=3,cm=2,qp-,pc=4,ot=9,ab=5,pc-,pc=6,ot=7"
 
 tests :: Test
 tests = TestList