type _ tree =
  | Node  : 'a tree * 'a tree -> 'a tree
  | Leaf  : [ `good ] tree
  | Taint : [< `good | `bad ] tree -> [ `bad ] tree

let rec untaint : 'a. 'a tree -> [ `good ] tree =
  fun tr -> match tr with
    | Taint _ -> failwith "Cannot untaint this tree"
    | Leaf -> Leaf
(*    ^^^^
Error: This pattern matches values of type [ `good ] tree
       but a pattern was expected which matches values of type [ `bad ] tree
*)
    | Node (l, r) -> Node (untaint l, untaint r)