inter :: a -> [[a]] -> [[[a]]]
inter x = go
 where
   go [] = []
   go (y:ys) = ((x:y):ys) : map (y:) (go ys)

part :: Int -> [a] ->[[[a]]]
part _ [] = []
part 1 xs = [[xs]]
part k (x:xs) = map ([x]:) prev_ks ++ concatMap (inter x) ks
 where
   prev_ks = part (k-1) xs
   ks = part k xs

main = print $ part 3 [1..4]