How to get the intersection of lists while handling duplicates without bias?

I suggest you sort the lists first and then traverse them side by side:

shared xs ys = go xs' ys' where
  go [] _ = []
  go _ [] = []
  go aas@(a:as) bbs@(b:bs) = case compare a b of
    GT -> go aas bs
    EQ -> a : go as bs
    LT -> go as bbs
  xs' = sort xs
  ys' = sort ys

As @WillNess pointed out in the comments, Data.List.Ordered has just the function you want:

isect :: Ord a => [a] -> [a] -> [a]
-- |  The 'isect' function computes the intersection of two ordered lists.
-- An element occurs in the output as many times as the minimum number of
-- occurrences in either input.  If either input is a set,  then the output
-- is a set.
--
-- > isect [ 1,2, 3,4 ] [ 3,4, 5,6 ]   == [ 3,4 ]
-- > isect [ 1, 2,2,2 ] [ 1,1,1, 2,2 ] == [ 1, 2,2 ]

Since functions from Data.List.Ordered assume that input lists are sorted, you have to sort them first:

import Data.Function (on)
import Data.List     (sort)

bettershared = Data.List.Ordered.isect `on` sort

We can use Map a Int to represent a bag (AKA multiset) of values of type a. Elements of the multiset are keys in the map, and they're paired with their counts.

import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M

-- Add a value to a bag.
addElem :: Ord a => a -> Map a Int -> Map a Int
addElem = M.alter $ \mc ->
  case mc of
    -- The item is not in the bag. Add it with count 1
    Nothing -> Just 1
    -- The item is in the bag. Increment its count.
    Just count -> Just (count + 1)

-- Build a bag from a list.
buildBag :: Ord a => [a] -> Map a Int
buildBag = foldl' (flip addElem) M.empty

-- Remove one copy of a value from a bag if it's there. Otherwise, return Nothing.
removeElem :: Ord a => a -> Map a Int -> Maybe (Map a Int)
removeElem = M.alterF $ \mc ->
  case mc of
    -- The item is not in the bag. Return Nothing.
    Nothing -> Nothing
    -- The item is in the bag with count 1. Delete it.
    Just 1 -> Just Nothing
    -- At least two of the item are in the bag. Decrement the count.
    Just count -> Just (Just (count - 1))

-- Intersect a list with a bag.
isectWithBag :: Ord a => [a] -> Map a Int -> [a]
isectWithBag [] _b = []
isectWithBag (x:xs) b = case removeElem x b of
      Nothing -> isectWithBag xs b
      Just b' -> x : isectWithBag xs b'

-- Intersect a list with a list.
isect :: Ord a => [a] -> [a] -> [a]
isect xs ys = isectWithBag xs (buildBag ys)

isect xs ys takes time

O((|xs|+|ys|) log |nub ys|)

So when you have information about what the lists are likely to look like, it's best to choose ys to be the one with the fewest distinct elements.

The above solution is disappointing in two ways:

1. It's completely strict in the contents of the second list.

2. To get optimal performance requires that we guess correctly which list has more distinct elements.

It turns out that we can solve both problems at once. We'll work through both lists "in parallel", producing values whenever possible along the way. We use the same bag representation as before, with the same addElem, removeElem, and isectWithBag. In this case, we use two bags, with the elements still available for matching from xs, and from ys, as we move along the two lists. We maintain the invariant that the Map representing the first bag is no larger than the Map representing the second bag, and in particular that it has 0 or 1 fewer keys. We do this by swapping the bags and lists as necessary.

isect2 :: Ord a => [a] -> [a] -> [a]
isect2 = go M.empty M.empty
  where
    go xb _yb [] ys = isectWithBag ys xb
    go xb yb (x:xs) ys =
      case removeElem x yb of
        Nothing -> go' (insertElem x xb) yb xs ys
        Just yb' -> x : go' xb yb' xs ys

    go' xb yb xs ys
      | M.size xb <= M.size yb
      = go xb yb xs ys
      | otherwise
      = go yb xb ys xs

The worst case performance occurs when the intersection is empty. In this case, we get

O((|xs|+|ys|) (log (min (|nub xs|, |nub ys|))))

Unfortunately, the "improved" solution has a problem: when removal from the bag fails, we have to insert into a similarly-sized bag. This means a failure costs twice as much as a success, so this solution will be slower than the monolithic one unless the numbers of distinct elements in the two lists are extremely different from each other. Can we fix this? Yes! We currently maintain two bags with the invariant that their intersection is empty. We can take advantage of this by using a different representation that uses one Map for both. This will make "success" a constant term slower, but "failure" almost twice as fast! We can indicate the number of copies in the xs bag by a positive count, and the number of ys by a negative count. We'll keep track of the number of Map entries with positive values and/or negative values separately. Unfortunately, I have yet to find a non-horrible way to express this version of the algorithm.

When sorting seems to be a reasonable approach in the first place, most of the time it turns out that it is infact not. Sorting has always been my very last resort.

So in this very particular case, which can also be extended to unlimited number of lists, my approach would be folding the shared list [[2,6,10,10],[10,5,10,10,7,10]] on to a Map data structure.

I will give only the algorithm at the moment and later, once i have more time the code will follow.

1. First pass of foldr the Map becomes;

   { 5 : [1], 7 : [1], 10: [4]}

2. Second pass of foldr the Map becomes;

   { 2 :[1], 5 :[1], 6 :[1], 7 :[1], 10:[2,4]}

3. Once folding phase is over, just analyze the Map. Filter out the Map keys with values those have the same length with shared list, which in this case happens to be only key 10.

4. Take the minimum of the value [2,4] which is 2 and do like replicate 2 10 to compose the result.

So as promised here is my take with the Map;

import qualified Data.Map as M

isect :: Ord a => [[a]] -> [a]
isect xss = solve $ mapper xss 1 M.empty
            where
            mapper :: Ord a => [[a]] -> Int -> M.Map a ([Int], Int) -> M.Map a ([Int], Int)
            mapper [] _ m       = m
            mapper (xs:xss) i m = mapper xss (i+1) currentMap
                                  where
                                  currentMap = foldr renew m xs
                                  renew x m' = M.alter f x m'
                                               where
                                               f (Just ((n:ns),j)) = case i - j of
                                                                     0 -> Just ((n+1):ns,j)
                                                                     1 -> Just (1:n:ns,i)
                                                                     _ -> Nothing
                                               f Nothing           = case i of
                                                                     1 -> Just ([1],i)
                                                                     _ -> Nothing
            len = length xss

            solve :: M.Map a ([Int], Int) -> [a]
            solve = M.foldMapWithKey toList
                    where
                    toList k (ns,i) | i == len  = replicate (minimum ns) k
                                    | otherwise = mempty

where it does it's job pretty well and perhaps slightly faster than sorting but honestly as suggested by @WillNess, it seems to me that i would/should rather simply do it like

import qualified Data.List.Ordered as DLO

isect1 :: Ord a => [[a]] -> [a]
isect1 = foldr1 shared
         where
         shared xs ys = DLO.isect (sort xs) (sort ys)

which seems to use half as much the memory footprint of the Map method without any significant performance penalty.