 Solution

Prune until a fixed point before enumerating the surviving domains:

stable :: Eq a => (a -> a) -> a -> a
stable f x = let y = f x
             in if y == x then x else stable f y

solve :: Grid -> [Grid]
solve = filter complete . expand . stable prune . choices

New singleton cells can make a later pruning pass effective even if one pass has already run. Under the supplied deletion-only, solution-preserving contract, fixed-point pruning of finite constraint domains terminates: every changed pass strictly decreases the total number of candidates, initially at most $81\cdot 9=729$. No valid solution is removed. An empty domain causes expand to return no candidates; a fixed point with unresolved alternatives still needs enumeration and the final complete test.