228 lines
5.4 KiB
OCaml
228 lines
5.4 KiB
OCaml
(* A pretty-printer for the generic language P. *)
|
|
|
|
open PPrint
|
|
open P
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
(* Types. *)
|
|
|
|
let print_tyvar x =
|
|
string x
|
|
|
|
let rec print_type ty =
|
|
print_type_quant ty
|
|
|
|
and print_type_quant ty =
|
|
group @@ match ty with
|
|
| TyMu (x, ty) ->
|
|
group (
|
|
string "mu " ^^
|
|
space ^^
|
|
print_tyvar x ^^
|
|
dot
|
|
) ^//^ print_type_quant ty
|
|
| TyForall (x, ty) ->
|
|
group (
|
|
lbracket ^^
|
|
print_tyvar x ^^
|
|
rbracket
|
|
) ^//^ print_type_quant ty
|
|
| ty ->
|
|
print_type_arrow ty
|
|
|
|
|
|
and print_type_arrow ty =
|
|
group @@ match ty with
|
|
| TyArrow (ty1, ty2) ->
|
|
print_type_tyconstr ty1
|
|
^^ space ^^ string "->"
|
|
^//^ print_type_arrow ty2
|
|
| ty ->
|
|
print_type_tyconstr ty
|
|
|
|
and print_type_tyconstr ty =
|
|
group @@ match ty with
|
|
| TyConstr datatype ->
|
|
print_datatype datatype
|
|
| ty ->
|
|
print_type_atom ty
|
|
|
|
and print_type_atom ty =
|
|
group @@ match ty with
|
|
| TyVar x ->
|
|
print_tyvar x
|
|
| TyProduct tys ->
|
|
surround_separate_map 2 0 (lbrace ^^ rbrace)
|
|
lbrace star rbrace print_type tys
|
|
| TyEq (ty1, ty2) ->
|
|
string "eq " ^^ lparen ^^
|
|
print_type ty1 ^^ comma ^^
|
|
print_type ty2 ^^
|
|
rparen
|
|
| TyMu _ | TyForall _ | TyArrow _ | TyConstr _ as ty ->
|
|
parens (print_type ty)
|
|
|
|
and print_datatype (Datatype.Type tyconstr, tyargs) =
|
|
string tyconstr
|
|
^//^ separate_map space print_type_atom tyargs
|
|
|
|
let print_angle elem =
|
|
surround 2 0 langle elem rangle
|
|
|
|
let print_angle_type ty =
|
|
print_angle @@ print_type ty
|
|
|
|
let print_angle_datatype dty =
|
|
print_angle @@ print_datatype dty
|
|
|
|
(* -------------------------------------------------------------------------- *)
|
|
|
|
(* Terms. *)
|
|
|
|
let print_tevar x =
|
|
string x
|
|
|
|
let print_variant (Datatype.Label lbl) dty print_arg arg =
|
|
group (
|
|
string lbl
|
|
^^ optional print_angle_datatype dty
|
|
^^ (match arg with
|
|
| None ->
|
|
empty
|
|
| Some arg -> space ^^ print_arg arg)
|
|
)
|
|
|
|
let print_tuple print_elem elems =
|
|
match elems with
|
|
| [] -> lparen ^^ rparen
|
|
| _ ->
|
|
let contents =
|
|
match elems with
|
|
| [elem] ->
|
|
(* For arity-1 tuples we print (foo,)
|
|
instead of (foo) which would be ambiguous. *)
|
|
print_elem elem ^^ comma
|
|
| _ ->
|
|
separate_map (comma ^^ break 1) print_elem elems in
|
|
surround 2 0 lparen contents rparen
|
|
|
|
let print_let_in lhs rhs body =
|
|
string "let"
|
|
^^ surround 2 1 empty lhs empty
|
|
^^ string "="
|
|
^^ surround 2 1 empty rhs empty
|
|
^^ string "in"
|
|
^^ prefix 0 1 empty body
|
|
|
|
let print_annot print_elem (tyvars, typ) =
|
|
surround 2 0 lparen (
|
|
print_elem ^^ space ^^ string ":"
|
|
^//^ string "some" ^^ space ^^ separate_map space print_tyvar tyvars
|
|
^^ dot ^//^ print_type typ
|
|
) rparen
|
|
|
|
let rec print_term t =
|
|
print_term_abs t
|
|
|
|
and print_term_abs t =
|
|
group @@ match t with
|
|
| TyAbs (x, t1) ->
|
|
string "FUN" ^^ space
|
|
^^ print_tyvar x ^^ space
|
|
^^ string "->"
|
|
^//^ print_term_abs t1
|
|
| Let (p, t1, t2) ->
|
|
print_let_in
|
|
(print_pattern p)
|
|
(print_term t1)
|
|
(print_term_abs t2)
|
|
| Abs (p, t) ->
|
|
string "fun" ^^ space
|
|
^^ print_pattern p ^^ space
|
|
^^ string "->"
|
|
^//^ print_term_abs t
|
|
| t ->
|
|
print_term_app t
|
|
|
|
and print_term_app t =
|
|
group @@ match t with
|
|
| TyApp (t1, ty2) ->
|
|
print_term_app t1
|
|
^//^ lbracket ^^ print_type ty2 ^^ rbracket
|
|
| App (t1, t2) ->
|
|
print_term_app t1
|
|
^//^ print_term_atom t2
|
|
| Proj (i, t) ->
|
|
string "proj" ^^ print_angle (OCaml.int i)
|
|
^^ space ^^ print_term_atom t
|
|
| Variant (lbl, dty, t) ->
|
|
print_variant lbl dty print_term_atom t
|
|
| t ->
|
|
print_term_atom t
|
|
|
|
and print_term_atom t =
|
|
group @@ match t with
|
|
| Var x ->
|
|
print_tevar x
|
|
| Hole (ty, ts) ->
|
|
optional print_angle_type ty
|
|
^^ string "..."
|
|
^^ surround_separate_map 2 0 (lbracket ^^ rbracket) lbracket (comma ^^ break 1) rbracket print_term ts
|
|
| Tuple (ts) ->
|
|
print_tuple print_term ts
|
|
| Match (ty, t, brs) ->
|
|
print_match ty t brs
|
|
| Eq ->
|
|
string "Eq"
|
|
| Use (t1, ty1, t2) ->
|
|
string "use " ^^
|
|
print_term t1 ^^ colon ^^ print_type ty1 ^^ string "in" ^^
|
|
print_term t2
|
|
| Annot (t, tyannot) ->
|
|
print_annot (print_term t) tyannot
|
|
| TyAbs _ | Let _ | Abs _
|
|
| TyApp _ | App _ | Proj _ | Inj _ | Variant _ as t ->
|
|
parens (print_term t)
|
|
|
|
and print_match ty scrutinee brs =
|
|
string "match" ^^ optional print_angle_type ty
|
|
^^ surround 2 1 empty (print_term scrutinee) empty
|
|
^^ string "with" ^^ hardline
|
|
^^ print_branches brs ^^ hardline
|
|
^^ string "end"
|
|
|
|
and print_branches brs =
|
|
separate_map hardline print_branch brs
|
|
|
|
and print_branch (pat,t) =
|
|
group (
|
|
bar ^^ space ^^ nest 2 (print_pattern pat)
|
|
^^ space ^^ string "->"
|
|
^//^ print_term t
|
|
)
|
|
|
|
and print_pattern pat =
|
|
print_pattern_inj pat
|
|
|
|
and print_pattern_inj pat =
|
|
group @@ match pat with
|
|
| PVariant (lbl, dty, pat) ->
|
|
print_variant lbl dty
|
|
print_pattern_atom pat
|
|
| pat ->
|
|
print_pattern_atom pat
|
|
|
|
and print_pattern_atom pat =
|
|
group @@ match pat with
|
|
| PVar x ->
|
|
print_tevar x
|
|
| PWildcard ->
|
|
underscore
|
|
| PTuple ps ->
|
|
print_tuple print_pattern ps
|
|
| PAnnot (pat, typ_annot) ->
|
|
print_annot (print_pattern pat) typ_annot
|
|
| PInj _ | PVariant _ as pat ->
|
|
group (parens (print_pattern pat))
|