Fixpoint Concat (l : Tlist_setoid) : Tlist_setoid -> Tlist_setoid :=
fun m : Tlist_setoid =>
match l with
| Empty => m
| Concat1 a l1 => Concat1 a (Concat l1 m)
end.

Lemma Midr_FreeMonoid : Monoid_idr Concat_map2 Empty.
Canonical Structure FreeMonoid :=
Build_Monoid Mass_FreeMonoid Midl_FreeMonoid Midr_FreeMonoid.