I needed some way of working with arbitrarily deep stacks of arbitrary types for my current project. This is what I came up with. I thought it was pretty neat so I figured I'd share it.

Label.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE TypeOperators #-}

-- An example of how to have an arbitrary stack of types, while still allowing
-- for easy querying and modifying the value at arbitrary depths of the stack.
--
-- While having multiple of the same type in the stack still type checks, the
-- value that is closer to the bottom of the stack is essentially hidden by the
-- type that is higher up.

-- Types l and i being an instance of Label, means that the type i is contained
-- in the type l.
class Label l i where
    get :: l -> i
    modify :: (i -> i) -> l -> l
    put :: i -> l -> l
    put value = modify (const value)

-- Our actual data type that glues together two different types. This is
-- basically a list of Types, the outer type is the one that is readily
-- available, while the inner type is itself some wrapped up type.
data outer :*: inner = outer :*: inner
infixr 7 :*:

-- Base case; handles operations where the outer type is the same as the type
-- that the Label is to query/modify.
instance Label (a :*: b) a where
    get (a :*: _) = a
    modify f (a :*: b) = f a :*: b

-- Recursive case; conceptually strips off layers of the (:*:) type until the
-- desired type is the same as the outer type.
instance (Label b c) => Label (a :*: b) c where
    get (_ :*: inner) = get inner
    modify f (a :*: b) = a :*: modify f b


-- Examples
labelOne :: Int :*: Bool :*: [Int] :*: ()
labelOne = 1 :*: True :*: [1,2,3] :*: ()

labelTwo :: Bool :*: Maybe Int :*: Int :*: ()
labelTwo = True :*: Nothing :*: 2 :*: ()

--getLabel labelOne :: Int -- returns 1
--getLabel labelOne :: Bool -- returns True
--getLabel labelOne :: Double -- Type error

sumLabels :: (Label a Int, Label b Int) => a -> b -> Int
sumLabels a b = get a + get b

--sumLabels labelOne labelTwo -- returns 3