My Haskell solution to the "Alphametics" challenge at https://exercism.org/tracks/haskell/exercises/alphametics

Alphametics.hs

module Alphametics (solve) where

import Data.Char (isSpace)
import Data.List (nub, intersect, transpose, elemIndex)
import Data.Maybe (fromJust)

solve :: String -> Maybe [(Char, Int)]
solve input = if length solutions == 1 then Just $ zip charMap (head solutions) else Nothing
  where
    toRowsOfChars       = wordsBy "+="                                -- create list of words from input (["SEND","MORE","MONEY"])
    toNonZeros          = map toNonZerosMap . nub . map head          -- create list of chars that can't be zero from rowsOfChars ("SM")
    toNonZerosMap x     = fromJust $ elemIndex x charMap              -- helper for above
    toColsOfChars       = transpose . map reverse                     -- create list of columns (right to left) from rowsOfChars (["DEY","NRE","EON","SMO","M"])
    toCharMap           = nub . concat                                -- create list of each char from colsOfChars ("DEYNROSM")
    toEncPuzzle :: [Int] -> [Char] -> [Int]                           -- encode columns into lists of coefficents from colsOfChars ([[1,1,-1],[0,-1,0,1,1],[0,1,0,-1,0,1],[0,0,0,0,0,-1,1,1],[0,0,0,0,0,0,0,-1]])
    toEncPuzzle acc x   = map encodeChar $ oldChars ++ newChars
      where
        oldChars      = take (length acc) charMap
        newChars      = intersect (nub x) $ drop (length acc) charMap
        encodeChar c  = let (lx:ix) = reverse x in -- create (last x) and (init x)
                        length (filter (==c) ix) + if c == lx then -1 else 0
    toCandidates :: [([Int], Int)] -> [Int] -> [([Int], Int)]         -- create all solutions without final column constaints (non-zeros and no carry out)
    -- p : current puzzle column, prev : result from previous column
    -- a : all, o : old, n : new, co : carry out, ci : carry in
    toCandidates prev p  = [(a,co) | (o,ci)<-prev, n<-digitCombs numNew,
                                     let a = o++n, nub a == a,
                                     co<-[0..length rowsOfChars - 2], ci + dot a p == 10*co]
      where numNew = length p - (length . fst . head $ prev)
    toSolutionsPrelim   = map fst . filter (\x -> snd x == 0)         -- apply no carry out constraint
    toSolsFold acc x    = filter (\sol -> (sol !! x)  /= 0) acc       -- apply non-zeros constraint
    -- Below are all the intermediate results for each of the `to` functions above.
    rowsOfChars         = toRowsOfChars input
    nonZeros            = toNonZeros rowsOfChars
    colsOfChars         = toColsOfChars rowsOfChars
    charMap             = toCharMap colsOfChars
    encodedPuzzle       = tail $ scanl toEncPuzzle [] colsOfChars
    candidates          = foldl toCandidates [([],0)] encodedPuzzle
    solutionsPrelim     = toSolutionsPrelim candidates
    solutions           = foldl toSolsFold solutionsPrelim nonZeros

wordsBy :: [Char] -> String -> [String]
wordsBy chars = words . map (\c -> if c `elem` chars then ' ' else c)

dot :: Num a => [a] -> [a] -> a
dot = (sum.) . zipWith (*)

-- Produce all combinations of n digits
digitCombs :: (Num a, Enum a) => Int -> [[a]]
digitCombs 0 = [[]]
digitCombs n = [x:xs | x<-[0..9], xs<-digitCombs(n-1)]