Works kinda

src/Sudoku.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings, LambdaCase, MultiWayIf #-}
+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}
 module Sudoku ( isValid
               , Cell(..)
               , Grid(..)
@@ -18,6 +19,9 @@ import Control.Parallel
 import Control.Parallel.Strategies
 import Text.Printf
 import Data.List
+import Control.Monad
+import Control.DeepSeq
+import GHC.Generics (Generic)
 
 data Cell where
   One :: Cell
@@ -30,7 +34,7 @@ data Cell where
   Eight :: Cell
   Nine :: Cell
   Unknown :: Cell
-  deriving (Eq)
+  deriving (Eq, Generic, NFData)
 
 instance Show Cell where
   show One = "1"
@@ -69,11 +73,11 @@ instance Show Square where
 
 -- Grid is 9x9
 newtype Grid = Grid (Matrix Cell)
-  deriving Eq
+  deriving (Eq, Generic, NFData)
 
 instance Show Grid where
   show (Grid m) = prettyMatrix m
-
+  
 emptyGrid :: Grid
 emptyGrid = coerce $ matrix 9 9 (const Unknown)
 
@@ -124,7 +128,7 @@ isValid g = and $ flip (parMap rpar) [1..9]
                       let row = isValidRow (getRow i g)
                           col = isValidColumn (getColumn i g)
                           square = isValidSquare (getSquare i g)
-                      in col `par` square `par` row && col && square
+                      in row && col && square
                    )
 
 updateCell :: Int -> Int -> Cell -> Grid -> Grid
@@ -151,17 +155,13 @@ place c pos g = coerce $ setElem c pos (coerce g)
   
 solve :: Grid -> Grid
 solve g = let left = leftToPlace g in
-          case nub $ go g left of
+          case nub $ runEval (go [g] left) of
             []  -> error "No solution D:"
             [x] -> x
             xs   -> error (printf "%d solutions" $ length xs)
-  where go :: Grid -> [Cell] -> [Grid]
-        go g []     = if isValid g then pure g else mempty
-        go g (x:xs) = if not $ isValid g then mempty else
-          let empties = findEmpty g in
-            go' xs $ flip (x `place`) g <$> empties
-
-        go' :: [Cell] -> [Grid] -> [Grid]
-        go' _ [] = []
-        go' xs (g:gs) = let sol = go g xs in
-                          sol `par` go' xs gs <> sol
+  where go :: [Grid] -> [Cell] -> Eval [Grid]
+        go gs []     = filterM (pure . isValid) gs
+        go gs (x:xs) = filterM (pure . isValid) gs >>=
+            pure . (>>= \g' -> findEmpty g' >>= pure . (g',)) >>= 
+            parList rdeepseq . ((uncurry $ flip (place x)) <$>) >>=
+            flip go xs