Kershaw prime sieve

{-# LANGUAGE BangPatterns #-}

import Control.Concurrent.Async (mapConcurrently_)
import Control.Concurrent.STM
import Control.Monad (forM_, when)
import qualified Data.IntMap.Strict as IntMap
import Math.NumberTheory.Primes.Testing (isPrime)
import System.Environment (getArgs)

kershawPrime :: Int -> Maybe Integer
kershawPrime y = let p = gcd (2 ^ y - 2) (3 ^ y - 2)
                 in if isPrime p then Just p else Nothing

processNumber :: TVar (IntMap.IntMap [Int]) -> TVar Int -> Int -> Int -> Int -> IO ()
processNumber primesVar progressVar total start y = do
    maybePrime <- atomically $ do
        modifyTVar' progressVar (+1)
        progress <- readTVar progressVar
        let percentProgress = ((progress * 100) `div` total)
        return (kershawPrime y, percentProgress)

    case maybePrime of
        (Just p, percentProgress) -> do
            isNewPrime <- atomically $ do
                primes <- readTVar primesVar
                if IntMap.member (fromIntegral p) primes
                then return False
                else do
                    modifyTVar' primesVar (IntMap.insertWith (++) (fromIntegral p) [y])
                    return True
            when isNewPrime $ putStrLn $ "First found Kershaw prime " ++ show p ++ " at y=" ++ show y
            when (y == start + ((percentProgress * total) `div` 100)) $ putStrLn $ "Now at y=" ++ show y
        (_, percentProgress) ->
            when (y == start + ((percentProgress * total) `div` 100)) $ putStrLn $ "Now at y=" ++ show y

findKershawPrimesConcurrently :: Int -> Int -> IO ()
findKershawPrimesConcurrently start end = do
  progressVar <- newTVarIO 0
  primesVar <- newTVarIO IntMap.empty
  let total = end - start + 1

  mapConcurrently_ (processNumber primesVar progressVar total start) [start..end]

  uniquePrimes <- atomically $ readTVar primesVar

  putStrLn "Unique Kershaw primes found:"
  forM_ (IntMap.toList uniquePrimes) $ \(p, ys) ->
    putStrLn $ "Found Kershaw prime " ++ show p ++ " at ys=" ++ show (map (\y -> "y=" ++ show y) ys)

main :: IO ()
main = do
  [startStr, endStr] <- getArgs
  let start = read startStr
      end = read endStr
  putStrLn $ "Finding Kershaw primes from " ++ show start ++ " to " ++ show end
  findKershawPrimesConcurrently start end