raiseUnder and multiple effect interpretation - Polysemy

interp1 :: Member e3 r => Sem (e1 : e2 : r) a -> Sem r a

interp2 :: Sem (e1 : e2 : r) a -> Sem r a
interp2 = interp_e3 . interp1 . raiseUnder???

lift :: forall effs1 effs2 a. Lift effs1 effs2 => Sem effs1 a -> Sem effs2 a

-- inspired by
-- https://github.com/hasura/eff/blob/bf0520d0fb0644fef2bb78d0cfa289efdc9fc851/eff/src/Control/Effect/Internal.hs#L688

class Raise (r :: [Effect]) (r' :: [Effect]) where
  raiseUnion :: Union r m a -> Union r' m a

instance {-# overlapping #-} Raise r r where
  raiseUnion = id

instance (r' ~ (_0:r''), Raise r r'') => Raise r r' where
  raiseUnion = (\(Union n w) -> Union (There n) w) . raiseUnion

class Subsume (r :: [Effect]) (r' :: [Effect]) where
  subsumeUnion :: Union r m a -> Union r' m a

instance {-# incoherent #-} Raise r r' => Subsume r r' where
  subsumeUnion = raiseUnion

instance (Member e r', Subsume r r') => Subsume (e:r) r' where
  subsumeUnion = either subsumeUnion injWeaving . decomp

instance Subsume '[] r where
  subsumeUnion = absurdU

raise' :: Subsume r r' => Sem r a -> Sem r' a
raise' = hoistSem $ hoist raise' . subsumeUnion

raise :: Sem r a -> Sem (e ': r) a
raise = raise'

raiseUnder :: Sem (e1 ': r) a -> Sem (e1 ': (e2 ': r)) a
raiseUnder = raise'

raiseUnder2 :: Sem (e1 ': r) a -> Sem (e1 ': (e2 ': (e3 ': r))) a
raiseUnder2 = raise'

raiseUnder3 :: Sem (e1 ': r) a -> Sem (e1 ': (e2 ': (e3 ': (e4 ': r)))) a
raiseUnder3 = raise'

subsume :: Member e r => Sem (e ': r) a -> Sem r a
subsume = raise'

-------------------------------------------------------------------------------
-- | Raises effect stack by arbitrary number of effects.
raise' :: Raise r r' => Sem r a -> Sem r' a
raise' = hoistSem $ hoist raise' . raiseUnion

raise :: Sem r a -> Sem (e ': r) a
raise = raise'

raiseUnder :: Sem (e1 ': r) a -> Sem (e1 ': (e2 ': r)) a
raiseUnder = subsume'

raiseUnder2 :: Sem (e1 ': r) a -> Sem (e1 ': (e2 ': (e3 ': r))) a
raiseUnder2 = subsume'

raiseUnder3 :: Sem (e1 ': r) a -> Sem (e1 ': (e2 ': (e3 ': (e4 ': r)))) a
raiseUnder3 = subsume'

class Raise (r :: [Effect]) (r' :: [Effect]) where
  raiseUnion :: Union r m a -> Union r' m a

instance {-# overlapping #-} Raise r r where
  raiseUnion = id

instance (r' ~ (_0:r''), Raise r r'') => Raise r r' where
  raiseUnion = (\(Union n w) -> Union (There n) w) . raiseUnion

-------------------------------------------------------------------------------
-- | Allows reordering and adding known effects on top of effect stack, as long
-- as polymorphic tail of new stack is 'raise'-d version of the original one.
subsume' :: Subsume r r' => Sem r a -> Sem r' a
subsume' = hoistSem $ hoist subsume' . subsumeUnion

subsume :: Member e r => Sem (e ': r) a -> Sem r a
subsume = subsume'

class Subsume (r :: [Effect]) (r' :: [Effect]) where
  subsumeUnion :: Union r m a -> Union r' m a

instance {-# incoherent #-} Raise r r' => Subsume r r' where
  subsumeUnion = raiseUnion

instance (Member e r', Subsume r r') => Subsume (e:r) r' where
  subsumeUnion = either subsumeUnion injWeaving . decomp

instance Subsume '[] r where
  subsumeUnion = absurdU