Cracking codes using backtracking

Coded.hs

import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Monad.Logic
import Data.List
import qualified Data.Map as M

type BindingT k v = StateT (M.Map k v)

bind :: (MonadPlus m, Ord k, Eq v) => k -> v -> BindingT k v m ()
bind k v = do
  m <- get
  case M.lookup k m of
    Just v' | v' /= v -> mzero
    _ -> put $ M.insert k v m

-- gives [('f','2'),('k','1'),('n','8'),('s','6'),('t','3'),('u','4')]
main :: IO ()
main = print $ solve ["funk", "nuts", "stun"] ["6348", "8342", "8436", "2481"]

type Solver a = BindingT Char Char Logic a

solve :: [String] -> [String] -> [(Char, Char)]
solve ws cs = M.toList . snd $ observe (runStateT (solveWords ws cs) M.empty)
      
-- | Solves for all supplied words and codes. Assumes one incorrect dummy code.
solveWords :: [String] -> [String] -> Solver ()
solveWords ws cs = foldr1 mplus $ map (go ws) (selections cs)
    where
      go ws cs = sequence_ $ map (flip solveWord cs) ws
      selections [] = []
      selections (x:xs) = xs : [ x:ys | ys <- selections xs]

solveWord :: String -> [String] -> Solver ()
solveWord w cs = foldr1 mplus $ map (sequence_ . zipWith bind w) cs