https://stackoverflow.com/questions/49545045/defining-incremental-environments-without-running-into-overlapping-instances

fruit.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

import Data.Type.Bool
import GHC.TypeLits

(...) = undefined

type Name = String
data Fruit = Orange | Pear | Apple
data Vegetable = Cucumber | Carrot | Spinach
data Legume = Lentils | Chickpeas | BlackEyedPeas

data Tree a = Leaf a | Node (Tree a) (Tree a)

type family Contents basket :: Tree *

type instance Contents [Fruit] = 'Leaf Fruit
type instance Contents [Vegetable] = 'Leaf Vegetable
type instance Contents [Legume] = 'Leaf Legume

data a :& b = a :& b

type instance Contents (a :& b) = Node (Contents a) (Contents b)

type family y == x :: Bool where
  x == x = 'True
  x == y = 'False

type family In (x :: *) (ys :: Tree *) :: Bool where
  In x (Leaf y) = x == y
  In x (Node l r) = In x l || In x r

class (In item (Contents basket) ~ 'True) => Has item basket where
  get :: basket -> Name -> Maybe item

instance Has Fruit [Fruit] where
  get = (...)

instance Has Vegetable [Vegetable] where
  get = (...)

instance Has Legume [Legume] where
  get = (...)

instance PairHas item a b (In item (Contents a)) (In item (Contents b))
         => Has item (a :& b) where
  get = getPair

class ( In item (Contents a) ~ inA
      , In item (Contents b) ~ inB
      , (inA || inB) ~ 'True)
      => PairHas item a b inA inB where
  getPair :: (a :& b) -> Name -> Maybe item

instance (Has item a, In item (Contents b) ~ 'False)
         => PairHas item a b 'True 'False where
  getPair (a :& _) = get a

instance (In item (Contents a) ~ 'False, Has item b)
         => PairHas item a b 'False 'True where
  getPair (_ :& b) = get b

instance ( TypeError (Text "Duplicate contents")
         , In item (Contents a) ~ 'True
         , In item (Contents b) ~ 'True)
         => PairHas item a b 'True 'True where
  getPair = undefined

instance ( TypeError (Text "Not found")
         , In item (Contents a) ~ 'False
         , In item (Contents b) ~ 'False
         , 'False ~ 'True)
         => PairHas item a b 'False 'False where
  getPair = undefined

data Smootie

mkSmootie :: (Has Fruit e, Has Vegetable e) => e -> Smootie
mkSmootie = (...)

data Salad

mkSalad :: (Has Vegetable e, Has Legume e) => e -> Salad
mkSalad = (...)

cook :: (Smootie, Salad)
cook = let ingredients = [Orange] :& [Cucumber] :& [BlackEyedPeas] in
  (mkSmootie ingredients, mkSalad ingredients)