Compile and Execute Haskell Online

import Control.Monad
import Data.Array.Unboxed
import Data.Array.ST
import Data.List

main = print $ result

lim = 1000000

result = sum $
         map multiple $
         takeWhile (\(p,q) -> p <= lim) $
         pairs

multiple :: (Integer,Integer) -> Integer
multiple (p,q) = q * ((p * modpow m q t) `mod` m)
    where e = truncate $ 1 + logBase 10 (fromIntegral p) 
          m = 10^e
          t = ((4*m) `div` 10) - 1

pairs = drop 2 $ zip primes (tail primes) 

-- Power for integers modulo m
modpow :: Integral a => a -> a -> a -> a
modpow m a b = foldl' step 1 (binary b)
    where step acc x = if x==0 then acc^2 `mod` m
                               else (a * acc^2) `mod` m

-- Binary representation
binary :: Integral a => a -> [a]
binary = reverse . binary'
    where binary' n | n<0 = error "binary: negative number"
                    | n <= 1 = [n]  
                    | otherwise = if n `rem` 2 == 0
                                    then 0 : binary' (n `div` 2)
                                    else 1 : binary' (n `div` 2)

primes = [p | (p,True) <- assocs $ primeWheelSieve 1100000]

primeWheelSieve :: Integer -> UArray Integer Bool
primeWheelSieve limit = runSTUArray $ do
  arr <- newArray (1, limit) False
  writeArray arr 2 True
  writeArray arr 3 True
  writeArray arr 5 True
  forM_ [6 .. limit] (\n -> when (n `rem` 6 == 1 || n `rem` 6 == 5) $
                                writeArray arr n True)
  forM_ [5 .. isqrt limit] $ \p -> do 
      isPrime <- readArray arr p
      when isPrime $ do
          let pp = (p+1) - (p+1) `rem` 6
          (forM_ [p*(pp-1), p*(pp+5) .. limit]
                 (\n -> writeArray arr n False))
          (forM_ [p*(pp+1), p*(pp+7) .. limit]
                 (\n -> writeArray arr n False))
  return arr

isqrt :: Integral a => a -> a
isqrt n = truncate . sqrt . fromIntegral $ n