I ran into a problem recently where I had to decide whether a set of sum types was homogeneous (all the same). In itself, this is a pretty simple problem. However, there were a few complicating factors:

1. There exists a type within the types (call it Id) that is ignored in the comparisons.
2. There exists a type (call it Mix) that immediately makes the set non-homogeneous, even if all the types are Mix.

The extension of this problem was, given a list of types, is there a single type that can be removed that will make the rest of the types homogeneous (excepting, of course, the Mix type).

For example, if we define our type as:

data Foo = Bar | Baz | Quux | Id | Mix deriving (Eq, Ord, Show)

then [Bar, Bar, Bar] is homogeneous, [Bar, Bar, Baz] would be homogeneous if Baz were removed. Further, [Bar, Bar, Id] is homogeneous, and [Mix, Mix, Mix] is not. Finally, [Bar, Bar, Mix] contains a Mix type, and hence would not be homogeneous even if this type were removed.

import Data.List as List
import Data.Map as Map

data Foo = Bar | Baz | Quux | Id | Mix deriving (Eq, Ord, Show)

-- Is a list of the above sum types homogeneous? 
-- Note that Id is ignored in the comparisons, and Mix immediately
-- makes this False.
homogeneous :: [Foo] -> Bool
homogeneous [] = True
homogeneous [x] = if x == Mix then False else True
homogeneous (x:xs) = all isEqNotMix xs
    where isEqNotMix y = ((y == x || y == Id) && y /= Mix)

-- Find a type that would make the set homogeneous if it were removed.
-- Note that if we have an already homogeneous set, then removing the
-- single homoogeneous type from the list will leave it being homogenoeous.
-- The final part of the tuple returns whether it was a homogeneous list or not.
-- Note that in the case of no such type existing, the result is
-- (Mixed, Mixed, False).
homogeneousButOne :: [Foo] -> (Foo, Foo, Bool)
homogeneousButOne xs = case xs of
    [] -> (Id, Id, True)
    [x] -> (x, x, homogeneous [x])
    xs@(x:_) -> if homogeneous xs then (x, x, True)
                else (fst mixed, snd mixed, False)
        where mixed = mixedCase $ List.filter (/= Id) xs

-- Deal with the case where the list is not homogeneous in homogeneousButOne.
mixedCase :: [Foo] -> (Foo, Foo)
mixedCase xs 
    | Mix `elem` keys        = (Mix, Mix)
    | Map.size fooMap == 2   = decideTwo fooMap
    | otherwise              = (Mix, Mix)
        where fooMap = List.foldl (acc x -> Map.insertWith (+) x 1 acc) Map.empty xs
              keys = Map.keys fooMap
              single = Map.filter (== 1) fooMap
              multiple = Map.filter (> 1) fooMap
              firstKey = head . Map.keys 
              secondKey = head . tail . Map.keys
               -- Only case where we may not have (Mix, Mix) is if there were
               -- only two types found, and neither of them was `Mix`.
              decideTwo mp = case Map.size single of
                               -- Both types exist > 1 times
                               0 -> (Mix, Mix)
                               -- One type exists once, it is the type that can be removed
                               1 -> (firstKey multiple , firstKey single)
                               -- Both types only exist once (e.g. [Bar, Baz])
                               2 -> (firstKey single, secondKey single)

Any improvements to this code are welcome (excepting the names of the sum types: I realise Foo, Bar, Baz and Quux aren’t great, but in the original problem, the names were no more descriptive).

homogeneous

In this line

homogeneous [x] = if x == Mix then False else True

you have something like if expr then False else True which is the same as not expr. That is:

homogeneous [x] = x /= Mix

In the fact the whole line could be just:

homogeneous [Mix] = False

because the line homogeneous (x:xs) = ... would do the right thing for the cases that are not covered by homogeneous [Mix].

homogeneousButOne

A Map is an overkill in this case, since the problem can be solved in linear time looping through the list of Foos. Here’s one possible implementation:

homogeneousButOne :: [Foo] -> (Foo, Foo, Bool)
homogeneousButOne foos
  | sansId == [] = (Id, Id, True)
  | homogeneous sansId = (ref, ref, True)
  | elem Mix sansId = (Mix, Mix, False)
  | all (== other) others = (ref, other, False)
  | otherwise = (Mix, Mix, False)
  where
    sansId = filter (/= Id) foos
    (ref : remaining) = sansId
    (other : others) = filter (/= ref) remaining

Note however that in this implementation I valued clarity over efficiency.

homogeneous could also be defined using pattern matching, though that would not necessarily be an improvement.

However, homogeneousButOne can definitely be simplified using pattern matching, with no need for Data.Map or Data.List.

data Foo = Bar | Baz | Quux | Id | Mix deriving (Eq, Ord, Show)

homogeneous :: [Foo] -> Bool
homogeneous []           = True
homogeneous (Mix : _)    = False
homogeneous (Id  : xs)   = homogeneous xs
homogeneous (x   : [])   = True
homogeneous (a:Id:rest)  = homogeneous (a:rest)
homogeneous (a:b:rest)   = (a == b) && homogeneous (b:rest)

homogeneousButOne :: [Foo] -> (Foo, Foo, Bool)
homogeneousButOne xs
  | null nonId           = (Id, Id, True)
  | x' == Mix            = (Mix, Mix, False)
  | length nonId == 3    = majority2of3 nonId
  | homogeneous nonId    = (x', x', True)
  | homogeneous xs'      = (head xs', x', False)
  | x' == predominant    = (predominant, alt, False)
  | otherwise            = (Mix, Mix, False)
  where nonId = filter (/= Id) xs
        (x':xs') = nonId
        majority2of3 (a:b:c:[]) =
          if      a == b then (a, c, a == c)
          else if a == c then (a, b, a == b)
          else if b == c then (b, a, b == a)
          else                (Mix, Mix, False)
        (predominant, alt, _) = homogeneousButOne xs'