Day 22: Remove unsafePerformIO

hs/app/Main.hs

@@ -79,7 +79,7 @@ main = do
   run 19 (uncurry (>>) . bimap print print) [Day19.solve]
   run 20 print [Day20.solve 2 100, Day20.solve 20 100]
   run 21 print [Day21.solve 2, Day21.solve 25]
-  run 22 (either fail print) [Day22.part1, Day22.part2]
+  run 22 (>>= print) [either fail pure . Day22.part1, Day22.part2]
   run 23 putStrLn [show . Day23.part1, T.unpack . Day23.part2]
   run 24 (either (fail . errorBundlePretty) (maybe (fail "error") putStrLn)) [fmap2 show . Day24.part1, fmap2 T.unpack . Day24.part2]
   run 25 print [Day25.part1]

hs/bench/Main.hs

@@ -1,7 +1,7 @@
 module Main (main) where
 
 import Control.Arrow ((>>>))
-import Criterion.Main (bench, bgroup, defaultMain, env, envWithCleanup, nf)
+import Criterion.Main (bench, bgroup, defaultMain, env, envWithCleanup, nf, nfAppIO)
 import Data.Foldable (find)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text)
@@ -177,7 +177,7 @@ main =
         bgroup
           "Day 22"
           [ bench "part 1" $ nf Day22.part1 input,
-            bench "part 2" $ nf Day22.part2 input
+            bench "part 2" $ nfAppIO Day22.part2 input
           ],
       env (getDayInput 23) $ \input ->
         bgroup

hs/src/Day22.hs

@@ -4,7 +4,7 @@
 module Day22 (part1, part2) where
 
 import Common (readMany, readSome)
-import Control.Concurrent.Async (forConcurrently)
+import Control.Concurrent.Async (mapConcurrently)
 import Control.Concurrent.STM (TArray, atomically)
 import Data.Array.IO (IOUArray)
 import Data.Array.MArray (newArray, readArray, writeArray)
@@ -16,7 +16,6 @@ import Data.Semigroup (Max (Max, getMax), sconcat)
 import Data.Text (Text)
 import Data.Text.Read qualified as T (decimal)
 import Data.Vector.Unboxed qualified as V (generate, (!))
-import System.IO.Unsafe (unsafePerformIO)
 
 step :: (Bits a, Num a) => a -> a
 step num = num3
@@ -32,23 +31,24 @@ part1 input = do
   where
     constants = V.generate 24 $ (!! 2000) . iterate step . bit
 
-part2 :: Text -> Either String Int
-part2 input = do
-  (nums, _) <- readSome T.decimal input
-  maybe (Left "error") (Right . getMax) $ sconcat $ unsafePerformIO $ do
+part2 :: Text -> IO Int
+part2 input = case readSome T.decimal input of
+  Right (nums, _) -> do
     acc <- newArray @TArray bounds 0
-    forConcurrently nums $ \num -> do
-      seen <- newArray @IOUArray bounds False
-      let f (a : b : c : d : e : _) =
-            let key = (a - b, b - c, c - d, d - e)
-             in readArray seen key >>= \case
-                  True -> pure Nothing
-                  False -> do
-                    writeArray seen key True
-                    atomically $ do
-                      total <- (+) e <$> readArray acc key
-                      writeArray acc key total $> Just (Max total)
-          f _ = pure Nothing
-      foldMap' f (tails $ take 2001 $ map (`mod` 10) $ iterate step num)
+    let go num = do
+          seen <- newArray @IOUArray bounds False
+          let f (a : b : c : d : e : _) =
+                let key = (a - b, b - c, c - d, d - e)
+                 in readArray seen key >>= \case
+                      True -> pure Nothing
+                      False -> do
+                        writeArray seen key True
+                        atomically $ do
+                          total <- (+) e <$> readArray acc key
+                          writeArray acc key total $> Just (Max total)
+              f _ = pure Nothing
+          foldMap' f (tails $ take 2001 $ map (`mod` 10) $ iterate step num)
+    mapConcurrently go nums >>= maybe (fail "error") (pure . getMax) . sconcat
+  Left err -> fail err
   where
     bounds = ((-9, -9, -9, -9), (9, 9, 9, 9))

hs/test/Day22Spec.hs

@@ -5,7 +5,7 @@ module Day22Spec (spec) where
 import Data.Text (Text)
 import Data.Text qualified as T (unlines)
 import Day22 (part1, part2)
-import Test.Hspec (Spec, describe, it, shouldBe)
+import Test.Hspec (Spec, describe, it, shouldBe, shouldReturn)
 
 example1, example2 :: Text
 example1 =
@@ -30,4 +30,4 @@ spec = do
       part1 example1 `shouldBe` Right 37327623
   describe "part 2" $ do
     it "examples" $ do
-      part2 example2 `shouldBe` Right 23
+      part2 example2 `shouldReturn` 23