let rec ctyp =
function
| TyId (loc, i) ->
let li = long_type_ident i
in mktyp loc (Ptyp_constr (li, []))
| TyAli (loc, t1, t2) ->
let (t, i) =
(match (t1, t2) with
| (t, TyQuo (_, s)) -> (t, s)
| (TyQuo (_, s), t) -> (t, s)
| _ -> error loc "invalid alias type")
in mktyp loc (Ptyp_alias ((ctyp t), i))
| TyAny loc -> mktyp loc Ptyp_any
| (TyApp (loc, _, _) as f) ->
let (f, al) = ctyp_fa [] f in
let (is_cls, li) = ctyp_long_id f
in
if is_cls
then mktyp loc (Ptyp_class (li, (List.map ctyp al), []))
else mktyp loc (Ptyp_constr (li, (List.map ctyp al)))
| TyArr (loc, (TyLab (_, lab, t1)), t2) ->
mktyp loc (Ptyp_arrow (lab, (ctyp t1), (ctyp t2)))
| TyArr (loc, (TyOlb (loc1, lab, t1)), t2) ->
let t1 =
TyApp (loc1,
(Ast.TyId (loc1, (Ast.IdLid (loc1, "option")))), t1)
in
mktyp loc
(Ptyp_arrow (("?" ^ lab), (ctyp t1), (ctyp t2)))
| TyArr (loc, t1, t2) ->
mktyp loc (Ptyp_arrow ("", (ctyp t1), (ctyp t2)))
| Ast.TyObj (loc, fl, Ast.RvNil) ->
mktyp loc (Ptyp_object (meth_list fl []))
| Ast.TyObj (loc, fl, Ast.RvRowVar) ->
mktyp loc
(Ptyp_object (meth_list fl [ mkfield loc Pfield_var ]))
| TyCls (loc, id) ->
mktyp loc (Ptyp_class ((ident id), [], []))
| Ast.TyPkg (loc, pt) ->
let (i, cs) = package_type pt
in mktyp loc (Ptyp_package (i, cs))
| TyLab (loc, _, _) ->
error loc "labelled type not allowed here"
| TyMan (loc, _, _) ->
error loc "manifest type not allowed here"
| TyOlb (loc, _, _) ->
error loc "labelled type not allowed here"
| TyPol (loc, t1, t2) ->
mktyp loc (Ptyp_poly ((ty_var_list_of_ctyp t1), (ctyp t2)))
| TyQuo (loc, s) -> mktyp loc (Ptyp_var s)
| TyRec (loc, _) -> error loc "record type not allowed here"
| TySum (loc, _) -> error loc "sum type not allowed here"
| TyPrv (loc, _) -> error loc "private type not allowed here"
| TyMut (loc, _) -> error loc "mutable type not allowed here"
| TyOr (loc, _, _) ->
error loc "type1 | type2 not allowed here"
| TyAnd (loc, _, _) ->
error loc "type1 and type2 not allowed here"
| TyOf (loc, _, _) ->
error loc "type1 of type2 not allowed here"
| TyCol (loc, _, _) ->
error loc "type1 : type2 not allowed here"
| TySem (loc, _, _) ->
error loc "type1 ; type2 not allowed here"
| Ast.TyTup (loc, (Ast.TySta (_, t1, t2))) ->
mktyp loc
(Ptyp_tuple
(List.map ctyp (list_of_ctyp t1 (list_of_ctyp t2 []))))
| Ast.TyVrnEq (loc, t) ->
mktyp loc (Ptyp_variant ((row_field t), true, None))
| Ast.TyVrnSup (loc, t) ->
mktyp loc (Ptyp_variant ((row_field t), false, None))
| Ast.TyVrnInf (loc, t) ->
mktyp loc (Ptyp_variant ((row_field t), true, (Some [])))
| Ast.TyVrnInfSup (loc, t, t') ->
mktyp loc
(Ptyp_variant ((row_field t), true,
(Some (name_tags t'))))
| TyAnt (loc, _) -> error loc "antiquotation not allowed here"
| TyOfAmp (_, _, _) | TyAmp (_, _, _) | TySta (_, _, _) |
TyCom (_, _, _) | TyVrn (_, _) | TyQuM (_, _) |
TyQuP (_, _) | TyDcl (_, _, _, _, _) |
TyObj (_, _, (RvAnt _)) | TyNil _ | TyTup (_, _) ->
assert false
and row_field =
function
| Ast.TyNil _ -> []
| Ast.TyVrn (_, i) -> [ Rtag (i, true, []) ]
| Ast.TyOfAmp (_, (Ast.TyVrn (_, i)), t) ->
[ Rtag (i, true, (List.map ctyp (list_of_ctyp t []))) ]
| Ast.TyOf (_, (Ast.TyVrn (_, i)), t) ->
[ Rtag (i, false, (List.map ctyp (list_of_ctyp t []))) ]
| Ast.TyOr (_, t1, t2) -> (row_field t1) @ (row_field t2)
| t -> [ Rinherit (ctyp t) ]
and name_tags =
function
| Ast.TyApp (_, t1, t2) -> (name_tags t1) @ (name_tags t2)
| Ast.TyVrn (_, s) -> [ s ]
| _ -> assert false
and meth_list fl acc =
match fl with
| Ast.TyNil _ -> acc
| Ast.TySem (_, t1, t2) -> meth_list t1 (meth_list t2 acc)
| Ast.TyCol (loc, (Ast.TyId (_, (Ast.IdLid (_, lab)))), t) ->
(mkfield loc (Pfield (lab, (mkpolytype (ctyp t))))) :: acc
| _ -> assert false
and package_type_constraints wc acc =
match wc with
| Ast.WcNil _ -> acc
| Ast.WcTyp (_, (Ast.TyId (_, (Ast.IdLid (_, id)))), ct) ->
(id, (ctyp ct)) :: acc
| Ast.WcAnd (_, wc1, wc2) ->
package_type_constraints wc1
(package_type_constraints wc2 acc)
| _ ->
error (loc_of_with_constr wc)
"unexpected `with constraint' for a package type"
and package_type : module_type -> package_type =
function
| Ast.MtWit (_, (Ast.MtId (_, i)), wc) ->
((long_uident i), (package_type_constraints wc []))
| Ast.MtId (_, i) -> ((long_uident i), [])
| mt -> error (loc_of_module_type mt) "unexpected package type"