Sudoku Solver in Haskell

sudoku.hs

import Data.List
import Data.Maybe

full :: [[[Int]]]
full = replicate 9 $ replicate 9 [1..9]

solve :: Int -> [[Int]] -> Maybe [[Int]]
solve n s
    | invalid s = Nothing
    | complete s' = Just s'
    | n <= 0 = Nothing
    | otherwise = listToMaybe $ mapMaybe (solve (n - 1)) tests
  where
    (s', p) = simple s
    tests =
        [ repl x (repl y $ const o) s'
        | x <- [0..8], y <- [0..8], o <- p !! x !! y
        ]

invalid :: [[Int]] -> Bool
invalid s = not $ length s == 9 && all ((== 9) . length) s && t s && t c && t q
  where
    t = all $ \xs ->
        length (filter (/= 0) xs) == length (nub $ filter (/= 0) xs)
    c = map (\i -> map (!! i) s) [0..8]
    q = [ square (x, y) s | x <- [0, 3, 6], y <- [0, 3, 6] ]

complete :: [[Int]] -> Bool
complete s = t s && t c && t q where
    t = all ((== [1..9]) . sort)
    c = map (\i -> map (!! i) s) [0..8]
    q = [ square (x, y) s | x <- [0, 3, 6], y <- [0, 3, 6] ]

simple :: [[Int]] -> ([[Int]], [[[Int]]])
simple sudoku = go (sudoku, full) where
    go (s, p) | invalid s = (s, p)
              | clean (s, p) == (s, p) = (s, p)
              | otherwise = go $ clean (s, p)

clean :: ([[Int]], [[[Int]]]) -> ([[Int]], [[[Int]]])
clean = go (0, 0) where
    go (x, y) (s, p)
        | x > 8 = (s, p)
        | y > 8 = go (x + 1, 0) (s, p)
        | null (p !! x !! y) = go (x, y + 1) (s, p)
        | s !! x !! y > 0 =
            go (x, y) (s, repl x (repl y (const [])) p)
        | length (p !! x !! y) == 1 =
            go (x, y) (repl x (repl y (const (head (p !! x !! y)))) s, p)
        | otherwise =
            go (x, y + 1) (s, sieve (x, y) (s, p))

sieve :: (Int, Int) -> ([[Int]], [[[Int]]]) -> [[[Int]]]
sieve (x, y) (s, p) = repl x (repl y rm) p where
    is = s !! x ++ map (!! y) s ++ square (x, y) s
    rm xs = foldr delete xs is

square :: (Int, Int) -> [[Int]] -> [Int]
square (x, y) s = concat rs where
    xi = x `div` 3 * 3
    yi = y `div` 3 * 3
    cs = take 3 $ drop xi s
    rs = map (take 3 . drop yi) cs

repl :: Int -> (a -> a) -> [a] -> [a]
repl i f xs = let (ls, r : rs) = splitAt i xs in ls ++ f r : rs

hard :: [[Int]]
hard = [ [0, 0, 8, 7, 0, 0, 0, 0, 0]
       , [7, 0, 0, 0, 0, 9, 0, 1, 5]
       , [0, 3, 0, 8, 0, 0, 0, 7, 0]
       , [0, 7, 0, 1, 3, 0, 0, 0, 6]
       , [0, 0, 0, 0, 0, 0, 0, 0, 0]
       , [8, 0, 0, 0, 2, 7, 0, 3, 0]
       , [0, 5, 0, 0, 0, 3, 0, 4, 0]
       , [9, 2, 0, 6, 0, 0, 0, 0, 7]
       , [0, 0, 0, 0, 0, 4, 9, 0, 0]
       ]

easy :: [[Int]]
easy = [ [1, 0, 3, 0, 0, 9, 8, 0, 4]
       , [0, 6, 0, 0, 7, 0, 5, 2, 0]
       , [2, 9, 0, 0, 0, 0, 0, 0, 7]
       , [9, 0, 0, 2, 0, 1, 0, 0, 0]
       , [0, 8, 0, 0, 0, 0, 0, 3, 0]
       , [0, 0, 0, 7, 0, 6, 0, 0, 1]
       , [8, 0, 0, 0, 0, 0, 0, 9, 3]
       , [0, 1, 9, 0, 4, 0, 0, 7, 0]
       , [3, 0, 4, 9, 0, 0, 1, 0, 6]
       ]

main :: IO ()
main = do
    -- ls <- replicateM 9 getLine
    -- let sudoku = map (map (\x -> read [x])) ls
    let sudoku = hard
    let solution = solve 3 sudoku
    case solution of
        Nothing -> putStrLn "No solution found."
        Just x -> mapM_ (putStrLn . concatMap show) x