let rec patt =
function
| Ast.PaId (loc, (Ast.IdLid (_, s))) -> mkpat loc (Ppat_var s)
| Ast.PaId (loc, i) ->
let p =
Ppat_construct ((long_uident ~conv_con i), None,
(constructors_arity ()))
in mkpat loc p
| PaAli (loc, p1, p2) ->
let (p, i) =
(match (p1, p2) with
| (p, Ast.PaId (_, (Ast.IdLid (_, s)))) -> (p, s)
| (Ast.PaId (_, (Ast.IdLid (_, s))), p) -> (p, s)
| _ -> error loc "invalid alias pattern")
in mkpat loc (Ppat_alias ((patt p), i))
| PaAnt (loc, _) -> error loc "antiquotation not allowed here"
| PaAny loc -> mkpat loc Ppat_any
| Ast.PaApp (loc, (Ast.PaId (_, (Ast.IdUid (_, s)))),
(Ast.PaTup (_, (Ast.PaAny loc_any)))) ->
mkpat loc
(Ppat_construct ((lident (conv_con s)),
(Some (mkpat loc_any Ppat_any)), false))
| (PaApp (loc, _, _) as f) ->
let (f, al) = patt_fa [] f in
let al = List.map patt al
in
(match (patt f).ppat_desc with
| Ppat_construct (li, None, _) ->
if constructors_arity ()
then
mkpat loc
(Ppat_construct (li,
(Some (mkpat loc (Ppat_tuple al))), true))
else
(let a =
match al with
| [ a ] -> a
| _ -> mkpat loc (Ppat_tuple al)
in
mkpat loc
(Ppat_construct (li, (Some a), false)))
| Ppat_variant (s, None) ->
let a =
if constructors_arity ()
then mkpat loc (Ppat_tuple al)
else
(match al with
| [ a ] -> a
| _ -> mkpat loc (Ppat_tuple al))
in mkpat loc (Ppat_variant (s, (Some a)))
| _ ->
error (loc_of_patt f)
"this is not a constructor, it cannot be applied in a pattern")
| PaArr (loc, p) ->
mkpat loc (Ppat_array (List.map patt (list_of_patt p [])))
| PaChr (loc, s) ->
mkpat loc
(Ppat_constant (Const_char (char_of_char_token loc s)))
| PaInt (loc, s) ->
let i =
(try int_of_string s
with
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type int")
in mkpat loc (Ppat_constant (Const_int i))
| PaInt32 (loc, s) ->
let i32 =
(try Int32.of_string s
with
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type int32")
in mkpat loc (Ppat_constant (Const_int32 i32))
| PaInt64 (loc, s) ->
let i64 =
(try Int64.of_string s
with
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type int64")
in mkpat loc (Ppat_constant (Const_int64 i64))
| PaNativeInt (loc, s) ->
let nati =
(try Nativeint.of_string s
with
| Failure _ ->
error loc
"Integer literal exceeds the range of representable integers of type nativeint")
in mkpat loc (Ppat_constant (Const_nativeint nati))
| PaFlo (loc, s) ->
mkpat loc
(Ppat_constant (Const_float (remove_underscores s)))
| PaLab (loc, _, _) ->
error loc "labeled pattern not allowed here"
| PaOlb (loc, _, _) | PaOlbi (loc, _, _, _) ->
error loc "labeled pattern not allowed here"
| PaOrp (loc, p1, p2) ->
mkpat loc (Ppat_or ((patt p1), (patt p2)))
| PaRng (loc, p1, p2) ->
(match (p1, p2) with
| (PaChr (loc1, c1), PaChr (loc2, c2)) ->
let c1 = char_of_char_token loc1 c1 in
let c2 = char_of_char_token loc2 c2
in mkrangepat loc c1 c2
| _ ->
error loc "range pattern allowed only for characters")
| PaRec (loc, p) ->
let ps = list_of_patt p [] in
let is_wildcard =
(function | Ast.PaAny _ -> true | _ -> false) in
let (wildcards, ps) = List.partition is_wildcard ps in
let is_closed = if wildcards = [] then Closed else Open
in
mkpat loc
(Ppat_record (((List.map mklabpat ps), is_closed)))
| PaStr (loc, s) ->
mkpat loc
(Ppat_constant
(Const_string (string_of_string_token loc s)))
| Ast.PaTup (loc, (Ast.PaCom (_, p1, p2))) ->
mkpat loc
(Ppat_tuple
(List.map patt (list_of_patt p1 (list_of_patt p2 []))))
| Ast.PaTup (loc, _) -> error loc "singleton tuple pattern"
| PaTyc (loc, p, t) ->
mkpat loc (Ppat_constraint ((patt p), (ctyp t)))
| PaTyp (loc, i) -> mkpat loc (Ppat_type (long_type_ident i))
| PaVrn (loc, s) -> mkpat loc (Ppat_variant (s, None))
| PaLaz (loc, p) -> mkpat loc (Ppat_lazy (patt p))
| (PaEq (_, _, _) | PaSem (_, _, _) | PaCom (_, _, _) | PaNil _
as p) -> error (loc_of_patt p) "invalid pattern"
and mklabpat =
function
| Ast.PaEq (_, i, p) ->
((ident ~conv_lid: conv_lab i), (patt p))
| p -> error (loc_of_patt p) "invalid pattern"