My interpretation of Twan van Laarhoven's great Nonograms write-up.

nonograms.hs

{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}

import           Control.Monad
import           Data.Foldable
import           Data.Function
import           Data.Functor
import qualified Data.List          as L
import           Data.List.NonEmpty (NonEmpty(..),(<|))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict    as M
import qualified Data.Set           as S
import           Data.Set (Set)

newtype Id = Id Int deriving (Eq,Ord)

blank,filled :: Id -> Bool
blank (Id n) = n < 0
filled = not . blank

genIds :: [Int] -> [Id]
genIds = L.map Id . go 1 where
  go n [] = [-n,-n]
  go n (w:ws) = [-n,-n] ++ [n+1..n+w] ++ go (n+w+1) ws

newtype C a = Cell (Set a) deriving (Eq,Foldable,Semigroup,Monoid)
type Cell = C Id

certainCell :: Id -> Cell
certainCell = Cell . S.singleton

cellFromIds :: [Id] -> Cell
cellFromIds = Cell . S.fromList

cellScore :: Cell -> Int
cellScore (Cell s) = S.size s

cellIntersection :: Cell -> Cell -> Cell
cellIntersection (Cell a) (Cell b) = Cell (S.intersection a b)

genSuccessor :: [Id] -> Id -> Cell
genSuccessor is =
  let after = M.fromListWith S.union (L.zip is (L.map S.singleton (L.tail is)))
  in \i -> Cell (M.findWithDefault S.empty i after)

data CellState = Blank | Filled | Unknown | Absurd deriving Eq

cellState :: Cell -> CellState
cellState (Cell s) | S.null s     = Absurd
                   | all blank s  = Blank
                   | all filled s = Filled
                   | otherwise    = Unknown

data Line = Line { cells       :: NonEmpty Cell
                 , prd, scs    :: Id -> Cell
                 , start, end  :: Cell }
instance Eq Line where (==) = (==) `on` cells

lineStates :: Line -> NonEmpty CellState
lineStates = NE.map cellState . cells

lineDone,lineFailed :: Line -> Bool
lineDone   = notElem Unknown . lineStates
lineFailed =    elem Absurd  . lineStates

genLine :: Pos -> [Int] -> Line
genLine lg ws = Line (replicateNE lg (cellFromIds ids))
                     (genSuccessor (L.reverse ids))
                     (genSuccessor ids)
                     (certainCell (L.head ids))
                     (certainCell (L.last ids))
  where ids = genIds ws

reverseLine :: Line -> Line
reverseLine Line{..} = Line (NE.reverse cells) scs prd end start

propagF,propagB :: Line -> Line
propagB = reverseLine . propagF . reverseLine
propagF l = l { cells = scanlTailNE f (start l) (cells l) }
  where f (Cell from) to = cellIntersection to (foldMap (scs l) from)

solveLine :: Line -> Line
solveLine = propagB . propagF

data Nonogram = Nonogram { rows, columns :: NonEmpty Line } deriving Eq

done,failed :: Nonogram -> Bool
done   Nonogram{..} = all lineDone   (rows <> columns)
failed Nonogram{..} = any lineFailed (rows <> columns)

nonogram :: NonEmpty [Int] -> NonEmpty [Int] -> Nonogram
nonogram cs rs = Nonogram (NE.map (genLine (lengthNE cs)) rs)
                          (NE.map (genLine (lengthNE rs)) cs)

transposeNonogram :: Nonogram -> Nonogram
transposeNonogram Nonogram{..} = Nonogram columns rows

constrainRows,constrainCols :: Nonogram -> Nonogram
constrainRows n = n { rows = NE.map solveLine (rows n) }

constrainCols n =
  n { columns = NE.zipWith filterLine
                           (NE.transpose (NE.map lineStates (rows n)))
                           (columns n) }

filterLine :: NonEmpty CellState -> Line -> Line
filterLine states l = l { cells = NE.zipWith filterCell states (cells l) }

filterCell :: CellState -> Cell -> Cell
filterCell Blank  = \(Cell s) -> Cell (S.filter blank s)
filterCell Filled = \(Cell s) -> Cell (S.filter filled s)
filterCell _      = id

stabilize :: Eq a => (a -> a) -> a -> a
stabilize f = go where go x = case f x of fx | fx == x -> x
                                             | otherwise -> go fx

constrain :: Nonogram -> Nonogram
constrain = stabilize (step . step) where
  step = transposeNonogram . constrainCols . constrainRows

data Scored f a = Scored { best :: f a, score :: Int } deriving Functor
instance Semigroup (Scored f a) where
  a <> b | score a >= score b = a
         | otherwise          = b

mapBest :: (Functor f,Semigroup (f (NonEmpty a)))
        => (a -> f a) -> NonEmpty a -> f (NonEmpty a)
-- mapBest :: (a -> Scored [] a) -> NonEmpty a -> Scored [] (NonEmpty a)
mapBest f (NE.uncons -> (x,mxs)) = case mxs of
  Nothing -> fmap pure (f x)
  Just xs -> (f x <&> (<| xs)) <> ((x <|) <$> mapBest f xs)

mapBestLine :: (Functor f,Semigroup (f (NonEmpty Cell)))
            => (Cell -> f Cell) -> Line -> f Line
-- mapBestLine :: (Cell -> Scored [] Cell) -> Line -> Scored [] Line
mapBestLine f l = fmap setCells (mapBest f (cells l))
  where setCells cs = l { cells = cs }

mapBestNonogram :: ( Functor f,Semigroup (f (NonEmpty Line))
                   , Semigroup (f (NonEmpty Cell)) )
                => (Cell -> f Cell) -> Nonogram -> f Nonogram
-- mapBestNonogram :: (Cell -> Scored [] Cell) -> Nonogram -> Scored [] Nonogram
mapBestNonogram f n = fmap setRows (mapBest (mapBestLine f) (rows n))
  where setRows rs = n { rows = rs }

guessCell :: Cell -> Scored [] Cell
guessCell cell = Scored (L.map certainCell (toList cell)) (cellScore cell)

guess :: Nonogram -> [Nonogram]
guess = best . mapBestNonogram guessCell

solve :: Nonogram -> [Nonogram]
solve n = do let n' = constrain n
             guard $ not (failed n')
             if done n' then pure n' else guess n' >>= solve

-- The Data.List.NonEmpty missing utilities:

newtype Pos = UnsafePos { getPos :: Int }
-- converting Int to Pos needs checking its >0
-- converting Pos to Int is always safe

lengthNE :: NonEmpty a -> Pos
lengthNE = UnsafePos . (1 +) . length . NE.tail
-- safe by construction: length is ≥0

scanlTailNE :: (b -> a -> b) -> b -> NonEmpty a -> NonEmpty b
scanlTailNE f z = NE.fromList . L.tail . L.scanl f z . toList
-- safe by construction: scanl returns one more element that its input

replicateNE :: Pos -> a -> NonEmpty a
replicateNE n = takeNE (getPos n) . NE.repeat where
  takeNE n' (x :| xs) = x :| L.take (n'-1) xs