(* Title: Pure/Tools/codegen_serializer.ML
ID: $Id$
Author: Florian Haftmann, TU Muenchen
Serializer from intermediate language ("Thin-gol") to
target languages (like ML or Haskell).
*)
signature CODEGEN_SERIALIZER =
sig
type 'a pretty_syntax;
type serializer =
string list list
-> (string -> CodegenThingol.itype pretty_syntax option)
* (string -> CodegenThingol.iexpr pretty_syntax option)
-> string
-> string list option
-> CodegenThingol.module
-> unit -> Pretty.T * unit;
val parse_syntax: (string -> 'b -> 'a * 'b) -> OuterParse.token list ->
('b -> 'a pretty_syntax * 'b) * OuterParse.token list;
val parse_targetdef: (string -> string) -> string -> string;
val serializers: {
ml: string * (string * string * string -> serializer),
haskell: string * (string -> serializer)
}
end;
structure CodegenSerializer: CODEGEN_SERIALIZER =
struct
open CodegenThingolOp;
infix 8 `%%;
infixr 6 `->;
infixr 6 `-->;
infix 4 `$;
infix 4 `$$;
infixr 5 `|->;
infixr 5 `|-->;
(** generic serialization **)
(* precedences *)
datatype lrx = L | R | X;
datatype fixity =
BR
| NOBR
| INFX of (int * lrx);
datatype 'a mixfix =
Arg of fixity
| Ignore
| Pretty of Pretty.T
| Quote of 'a;
type 'a pretty_syntax = (int * int) * (fixity -> (fixity -> 'a -> Pretty.T) -> 'a list -> Pretty.T);
fun eval_lrx L L = false
| eval_lrx R R = false
| eval_lrx _ _ = true;
fun eval_fxy BR _ = true
| eval_fxy NOBR _ = false
| eval_fxy (INFX (pr1, lr1)) (INFX (pr2, lr2)) =
pr1 > pr2
orelse pr1 = pr2
andalso eval_lrx lr1 lr2
| eval_fxy (INFX _) _ = false;
val str = setmp print_mode [] Pretty.str;
fun brackify _ [p] = p
| brackify true (ps as _::_) = Pretty.enclose "(" ")" (Pretty.breaks ps)
| brackify false (ps as _::_) = Pretty.block (Pretty.breaks ps);
fun from_app mk_app from_expr const_syntax fxy (f, es) =
let
fun mk NONE es =
brackify (eval_fxy fxy BR) (mk_app f es)
| mk (SOME ((i, k), pr)) es =
let
val (es1, es2) = splitAt (i, es);
in
brackify (eval_fxy fxy BR) (pr fxy from_expr es1 :: map (from_expr BR) es2)
end;
in mk (const_syntax f) es end;
fun fillin_mixfix fxy_this ms fxy pr args =
let
fun brackify true = Pretty.enclose "(" ")"
| brackify false = Pretty.block;
fun fillin [] [] =
[]
| fillin (Arg fxy :: ms) (a :: args) =
pr fxy a :: fillin ms args
| fillin (Ignore :: ms) args =
fillin ms args
| fillin (Pretty p :: ms) args =
p :: fillin ms args
| fillin (Quote q :: ms) args =
pr BR q :: fillin ms args;
in brackify true (fillin ms args) (* (eval_fxy fxy_this fxy) *) end;
(* user-defined syntax *)
val (atomK, infixK, infixlK, infixrK) =
("atom", "infix", "infixl", "infixr");
val _ = OuterSyntax.add_keywords ["atom", "infix", "infixl", "infixr"];
fun parse_infix (fixity as INFX (i, x)) s =
let
val l = case x of L => fixity
| _ => INFX (i, X);
val r = case x of R => fixity
| _ => INFX (i, X);
in
pair [Arg l, (Pretty o Pretty.brk) 1, (Pretty o str) s, (Pretty o Pretty.brk) 1, Arg r]
end;
fun parse_mixfix reader s ctxt =
let
fun sym s = Scan.lift ($$ s);
fun lift_reader ctxt s =
ctxt
|> reader s
|-> (fn x => pair (Quote x));
val sym_any = Scan.lift (Scan.one Symbol.not_eof);
val parse = Scan.repeat (
(sym "_" -- sym "_" >> K (Arg NOBR))
|| (sym "_" >> K (Arg BR))
|| (sym "?" >> K Ignore)
|| (sym "/" |-- Scan.repeat (sym " ") >> (Pretty o Pretty.brk o length))
|| Scan.depend (fn ctxt => $$ "{" |-- $$ "*" |-- Scan.repeat1
( $$ "'" |-- Scan.one Symbol.not_eof
|| Scan.unless ($$ "*" -- $$ "}") (Scan.one Symbol.not_eof)) --|
$$ "*" --| $$ "}" >> (implode #> lift_reader ctxt #> swap))
|| (Scan.repeat1
( sym "'" |-- sym_any
|| Scan.unless (sym "_" || sym "?" || sym "/" || sym "{" |-- sym "*")
sym_any) >> (Pretty o str o implode)));
in case Scan.finite' Symbol.stopper parse (ctxt, Symbol.explode s)
of (p, (ctxt, [])) => (p, ctxt)
| _ => error ("Malformed mixfix annotation: " ^ quote s)
end;
fun parse_syntax_proto reader = OuterParse.$$$ "(" |-- (
OuterParse.$$$ infixK |-- OuterParse.nat >> (fn i => (parse_infix (INFX (i, X)), INFX (i, X)))
|| OuterParse.$$$ infixlK |-- OuterParse.nat >> (fn i => (parse_infix (INFX (i, L)), INFX (i, L)))
|| OuterParse.$$$ infixrK |-- OuterParse.nat >> (fn i => (parse_infix (INFX (i, R)), INFX (i, R)))
|| OuterParse.$$$ atomK |-- pair (parse_mixfix reader, NOBR)
|| pair (parse_mixfix reader, BR)
) -- OuterParse.string --| OuterParse.$$$ ")" >> (fn ((p, fxy), s) => (p s, fxy));
fun parse_syntax reader =
let
fun is_arg (Arg _) = true
| is_arg Ignore = true
| is_arg _ = false;
fun mk fixity mfx =
let
val i = length (List.filter is_arg mfx)
in ((i, i), fillin_mixfix fixity mfx) end;
in
parse_syntax_proto reader
#-> (fn (mfx_reader, fixity) : ('Z -> 'Y mixfix list * 'Z) * fixity =>
pair (mfx_reader #-> (fn mfx => pair (mk fixity mfx)))
)
end;
fun newline_correct s =
s
|> Symbol.strip_blanks
|> space_explode "\n"
|> map (implode o (fn [] => []
| (" "::xs) => xs
| xs => xs) o explode)
|> space_implode "\n";
fun parse_named_quote resolv s =
case Scan.finite Symbol.stopper (Scan.repeat (
($$ "`" |-- $$ "`")
|| ($$ "`" |-- Scan.repeat1 (Scan.unless ($$ "`") (Scan.one Symbol.not_eof))
--| $$ "`" >> (resolv o implode))
|| Scan.repeat1
(Scan.unless ($$ "`") (Scan.one Symbol.not_eof)) >> implode
) >> implode) (Symbol.explode s)
of (p, []) => p
| (p, ss) => error ("Malformed definition: " ^ quote p ^ " - " ^ commas ss);
fun parse_targetdef resolv = parse_named_quote resolv o newline_correct;
(* abstract serializer *)
type serializer =
string list list
-> (string -> CodegenThingol.itype pretty_syntax option)
* (string -> CodegenThingol.iexpr pretty_syntax option)
-> string
-> string list option
-> CodegenThingol.module
-> unit -> Pretty.T * unit;
fun abstract_serializer preprocess (from_defs, from_module, validator)
(target, (tyco_syntax, const_syntax)) (name_root, nspgrp) postprocess select module =
let
fun from_prim (name, prim) =
case AList.lookup (op =) prim target
of NONE => error ("no primitive definition for " ^ quote name)
| SOME p => p;
in
module
|> debug 3 (fn _ => "selecting submodule...")
|> (if is_some select then (partof o the) select else I)
|> tap (Pretty.writeln o pretty_deps)
|> debug 3 (fn _ => "preprocessing...")
|> preprocess
|> debug 3 (fn _ => "serializing...")
|> serialize (from_defs (from_prim, (tyco_syntax, const_syntax)))
from_module validator nspgrp name_root
|> postprocess
end;
fun abstract_validator keywords name =
let
fun replace_invalid c =
if (Char.isAlphaNum o the o Char.fromString) c orelse c = "'"
andalso not (NameSpace.separator = c)
then c
else "_"
fun suffix_it name =
name
|> member (op =) keywords ? suffix "'"
|> (fn name' => if name = name' then name else suffix_it name')
in
name
|> translate_string replace_invalid
|> suffix_it
|> (fn name' => if name = name' then NONE else SOME name')
end;
fun postprocess_single_file path p =
File.write (Path.unpack path) (Pretty.output p ^ "\n");
fun parse_single_file serializer =
OuterParse.name >> (fn path => serializer (postprocess_single_file path));
(** ML serializer **)
local
fun ml_from_defs (is_cons, needs_type)
(from_prim, (tyco_syntax, const_syntax)) resolv defs =
let
fun chunk_defs ps =
let
val (p_init, p_last) = split_last ps
in
Pretty.chunks (p_init @ [Pretty.block ([p_last, str ";"])])
end;
fun ml_from_label s =
let
val s' = NameSpace.unpack s;
in
NameSpace.pack (Library.drop (length s' - 2, s'))
|> translate_string (fn "_" => "__" | "." => "_" | c => c)
end;
fun postify [] f = f
| postify [p] f = Pretty.block [p, Pretty.brk 1, f]
| postify (ps as _::_) f = Pretty.block [Pretty.list "(" ")" ps, Pretty.brk 1, f];
fun ml_from_type fxy (IType (tyco, tys)) =
(case tyco_syntax tyco
of NONE =>
postify (map (ml_from_type BR) tys) ((str o resolv) tyco)
| SOME ((i, k), pr) =>
if not (i <= length tys andalso length tys <= k)
then error ("number of argument mismatch in customary serialization: "
^ (string_of_int o length) tys ^ " given, " ^ string_of_int i ^ " to " ^ string_of_int k
^ " expected")
else pr fxy ml_from_type tys)
| ml_from_type fxy (IFun (t1, t2)) =
let
fun eval_fxy_postfix BR _ = false
| eval_fxy_postfix NOBR _ = false
| eval_fxy_postfix (INFX (pr1, lr1)) (INFX (pr2, lr2)) =
pr1 > pr2
orelse pr1 = pr2
andalso eval_lrx lr1 lr2
| eval_fxy_postfix (INFX _) _ = false;
in
brackify (eval_fxy_postfix fxy (INFX (1, R))) [
ml_from_type (INFX (1, X)) t1,
str "->",
ml_from_type (INFX (1, R)) t2
]
end
| ml_from_type _ (IVarT (v, [])) =
str ("'" ^ v)
| ml_from_type _ (IVarT (_, sort)) =
"cannot serialize sort constrained type variable to ML: " ^ commas sort |> error
| ml_from_type _ (IDictT fs) =
Pretty.gen_list "," "{" "}" (
map (fn (f, ty) =>
Pretty.block [str (ml_from_label f ^ ": "), ml_from_type NOBR ty]) fs
);
fun ml_from_pat fxy (ICons ((f, ps), ty)) =
(case const_syntax f
of NONE => if length ps <= 1
then
ps
|> map (ml_from_pat BR)
|> cons ((str o resolv) f)
|> brackify (eval_fxy fxy BR)
else
ps
|> map (ml_from_pat BR)
|> Pretty.gen_list "," "(" ")"
|> single
|> cons ((str o resolv) f)
|> brackify (eval_fxy fxy BR)
| SOME ((i, k), pr) =>
if not (i <= length ps andalso length ps <= k)
then error ("number of argument mismatch in customary serialization: "
^ (string_of_int o length) ps ^ " given, " ^ string_of_int i ^ " to " ^ string_of_int k
^ " expected")
else pr fxy ml_from_expr (map iexpr_of_ipat ps))
| ml_from_pat fxy (IVarP (v, ty)) =
if needs_type ty
then
brackify (eval_fxy fxy BR) [
str v,
str ":",
ml_from_type NOBR ty
]
else
str v
and ml_from_expr fxy (e as IApp (e1, e2)) =
(case (unfold_app e)
of (e as (IConst (f, _)), es) =>
ml_from_app fxy (f, es)
| _ =>
brackify (eval_fxy fxy BR) [
ml_from_expr NOBR e1,
ml_from_expr BR e2
])
| ml_from_expr fxy (e as IConst (f, _)) =
ml_from_app fxy (f, [])
| ml_from_expr fxy (IVarE (v, _)) =
str v
| ml_from_expr fxy (IAbs ((v, _), e)) =
brackify (eval_fxy fxy BR) [
str ("fn " ^ v ^ " =>"),
ml_from_expr NOBR e
]
| ml_from_expr fxy (e as ICase (_, [_])) =
let
val (ps, e) = unfold_let e;
fun mk_val (p, e) = Pretty.block [
str "val ",
ml_from_pat fxy p,
str " =",
Pretty.brk 1,
ml_from_expr NOBR e,
str ";"
]
in Pretty.chunks [
[str ("let"), Pretty.fbrk, map mk_val ps |> Pretty.chunks] |> Pretty.block,
[str ("in"), Pretty.fbrk, ml_from_expr NOBR e] |> Pretty.block,
str ("end")
] end
| ml_from_expr fxy (ICase (e, c::cs)) =
let
fun mk_clause definer (p, e) =
Pretty.block [
str definer,
ml_from_pat NOBR p,
str " =>",
Pretty.brk 1,
ml_from_expr NOBR e
]
in brackify (eval_fxy fxy BR) (
str "case"
:: ml_from_expr NOBR e
:: mk_clause "of " c
:: map (mk_clause "| ") cs
) end
| ml_from_expr fxy (IInst _) =
error "cannot serialize poly instant to ML"
| ml_from_expr fxy (IDictE fs) =
Pretty.gen_list "," "{" "}" (
map (fn (f, e) =>
Pretty.block [str (ml_from_label f ^ " = "), ml_from_expr NOBR e]) fs
)
| ml_from_expr fxy (ILookup ([], v)) =
str v
| ml_from_expr fxy (ILookup ([l], v)) =
brackify (eval_fxy fxy BR) [
str ("#" ^ (ml_from_label l)),
str v
]
| ml_from_expr fxy (ILookup (ls, v)) =
brackify (eval_fxy fxy BR) [
str ("("
^ (ls |> map ((fn s => "#" ^ s) o ml_from_label) |> foldr1 (fn (l, e) => l ^ " o " ^ e))
^ ")"),
str v
]
| ml_from_expr _ e =
error ("dubious expression: " ^ (Pretty.output o pretty_iexpr) e)
and ml_mk_app f es =
if is_cons f andalso length es > 1
then
[(str o resolv) f, Pretty.gen_list " *" "(" ")" (map (ml_from_expr BR) es)]
else
(str o resolv) f :: map (ml_from_expr BR) es
and ml_from_app fxy =
from_app ml_mk_app ml_from_expr const_syntax fxy;
fun ml_from_funs (ds as d::ds_tl) =
let
fun mk_definer [] = "val"
| mk_definer _ = "fun";
fun check_args (_, Fun ((pats, _)::_, _)) NONE =
SOME (mk_definer pats)
| check_args (_, Fun ((pats, _)::_, _)) (SOME definer) =
if mk_definer pats = definer
then SOME definer
else error ("mixing simultaneous vals and funs not implemented")
| check_args _ _ =
error ("function definition block containing other definitions than functions")
val definer = the (fold check_args ds NONE);
fun mk_eq definer f ty (pats, expr) =
let
val lhs = [str (definer ^ " " ^ f)]
@ (if null pats
then [str ":", ml_from_type NOBR ty]
else map (ml_from_pat BR) pats)
val rhs = [str "=", ml_from_expr NOBR expr]
in
Pretty.block (separate (Pretty.brk 1) (lhs @ rhs))
end
fun mk_fun definer (f, Fun (eqs as eq::eq_tl, (_, ty))) =
let
val (pats_hd::pats_tl) = (fst o split_list) eqs;
val shift = if null eq_tl then I else map (Pretty.block o single);
in (Pretty.block o Pretty.fbreaks o shift) (
mk_eq definer f ty eq
:: map (mk_eq "|" f ty) eq_tl
)
end;
in
chunk_defs (
mk_fun definer d
:: map (mk_fun "and") ds_tl
) |> SOME
end;
fun ml_from_datatypes defs =
let
val defs' = List.mapPartial
(fn (name, Datatype info) => SOME (name, info)
| (name, Datatypecons _) => NONE
| (name, def) => error ("datatype block containing illegal def: " ^ (Pretty.output o pretty_def) def)
) defs
fun mk_cons (co, []) =
str (resolv co)
| mk_cons (co, tys) =
Pretty.block (
str (resolv co)
:: str " of"
:: Pretty.brk 1
:: separate (Pretty.block [str " *", Pretty.brk 1]) (map (ml_from_type NOBR) tys)
)
fun mk_datatype definer (t, ((vs, cs), _)) =
Pretty.block (
str definer
:: ml_from_type NOBR (t `%% map IVarT vs)
:: str " ="
:: Pretty.brk 1
:: separate (Pretty.block [Pretty.brk 1, str "| "]) (map mk_cons cs)
)
in
case defs'
of d::ds_tl =>
chunk_defs (
mk_datatype "datatype " d
:: map (mk_datatype "and ") ds_tl
) |> SOME
| _ => NONE
end
fun ml_from_def (name, Undef) =
error ("empty definition during serialization: " ^ quote name)
| ml_from_def (name, Prim prim) =
from_prim (name, prim)
| ml_from_def (name, Typesyn (vs, ty)) =
(map (fn (vname, []) => () | _ => error "can't serialize sort constrained type declaration to ML") vs;
Pretty.block [
str "type ",
ml_from_type NOBR (name `%% map IVarT vs),
str " =",
Pretty.brk 1,
ml_from_type NOBR ty,
str ";"
]
) |> SOME
| ml_from_def (name, Class _) =
error ("can't serialize class declaration " ^ quote name ^ " to ML")
| ml_from_def (_, Classmember _) =
NONE
| ml_from_def (name, Classinst _) =
error ("can't serialize instance declaration " ^ quote name ^ " to ML")
in (writeln ("ML defs " ^ (commas o map fst) defs); case defs
of (_, Fun _)::_ => ml_from_funs defs
| (_, Datatypecons _)::_ => ml_from_datatypes defs
| (_, Datatype _)::_ => ml_from_datatypes defs
| [def] => ml_from_def def)
end;
in
fun ml_from_thingol target (nsp_dtcon, nsp_class, int_tyco)
nspgrp (tyco_syntax, const_syntax) name_root select module =
let
val reserved_ml = ThmDatabase.ml_reserved @ [
"bool", "int", "list", "true", "false"
];
fun ml_from_module _ (name, ps) () =
(Pretty.chunks ([
str ("structure " ^ name ^ " = "),
str "struct",
str ""
] @ separate (str "") ps @ [
str "",
str ("end; (* struct " ^ name ^ " *)")
]), ());
fun needs_type (IType (tyco, _)) =
has_nsp tyco nsp_class
orelse tyco = int_tyco
| needs_type (IDictT _) =
true
| needs_type _ =
false;
fun is_cons c = has_nsp c nsp_dtcon;
fun eta_expander s =
case const_syntax s
of SOME ((i, _), _) => i
| _ => if has_nsp s nsp_dtcon
then case get_def module s
of Datatypecons dtname => case get_def module dtname
of Datatype ((_, cs), _) =>
let val l = AList.lookup (op =) cs s |> the |> length
in if l >= 2 then l else 0 end
else 0;
fun preprocess module =
module
|> tap (Pretty.writeln o pretty_deps)
|> debug 3 (fn _ => "eta-expanding...")
|> eta_expand eta_expander
|> debug 3 (fn _ => "eta-expanding polydefs...")
|> eta_expand_poly
|> debug 3 (fn _ => "eliminating classes...")
|> eliminate_classes
in
abstract_serializer preprocess (ml_from_defs (is_cons, needs_type), ml_from_module, abstract_validator reserved_ml)
(target, (tyco_syntax, const_syntax)) (name_root, nspgrp) I select module
end;
end; (* local *)
local
fun haskell_from_defs is_cons (from_prim, (tyco_syntax, const_syntax)) resolv defs =
let
fun upper_first s =
let
val (pr, b) = split_last (NameSpace.unpack s);
val (c::cs) = String.explode b;
in NameSpace.pack (pr @ [String.implode (Char.toUpper c :: cs)]) end;
fun lower_first s =
let
val (pr, b) = split_last (NameSpace.unpack s);
val (c::cs) = String.explode b;
in NameSpace.pack (pr @ [String.implode (Char.toLower c :: cs)]) end;
val resolv = fn s =>
let
val (prfix, base) = (split_last o NameSpace.unpack o resolv) s
in
NameSpace.pack (map upper_first prfix @ [base])
end;
fun resolv_const f =
if NameSpace.is_qualified f
then
if is_cons f
then (upper_first o resolv) f
else (lower_first o resolv) f
else
f;
fun haskell_from_sctxt vs =
let
fun from_sctxt [] = str ""
| from_sctxt vs =
vs
|> map (fn (v, cls) => str ((upper_first o resolv) cls ^ " " ^ lower_first v))
|> Pretty.gen_list "," "(" ")"
|> (fn p => Pretty.block [p, str " => "])
in
vs
|> map (fn (v, sort) => map (pair v) sort)
|> Library.flat
|> from_sctxt
end;
fun haskell_from_type fxy ty =
let
fun from_itype fxy (IType (tyco, tys)) sctxt =
(case tyco_syntax tyco
of NONE =>
sctxt
|> fold_map (from_itype BR) tys
|-> (fn tyargs => pair (brackify (eval_fxy fxy BR) ((str o upper_first o resolv) tyco :: tyargs)))
| SOME ((i, k), pr) =>
if not (i <= length tys andalso length tys <= k)
then error ("number of argument mismatch in customary serialization: "
^ (string_of_int o length) tys ^ " given, " ^ string_of_int i ^ " to " ^ string_of_int k
^ " expected")
else (pr fxy haskell_from_type tys, sctxt))
| from_itype fxy (IFun (t1, t2)) sctxt =
sctxt
|> from_itype (INFX (1, X)) t1
||>> from_itype (INFX (1, R)) t2
|-> (fn (p1, p2) => pair (
brackify (eval_fxy fxy (INFX (1, R))) [
p1,
str "->",
p2
]
))
| from_itype fxy (IVarT (v, [])) sctxt =
sctxt
|> pair ((str o lower_first) v)
| from_itype fxy (IVarT (v, sort)) sctxt =
sctxt
|> AList.default (op =) (v, [])
|> AList.map_entry (op =) v (fold (insert (op =)) sort)
|> pair ((str o lower_first) v)
| from_itype fxy (IDictT _) _ =
error "cannot serialize dictionary type to haskell"
in
[]
|> from_itype fxy ty
||> haskell_from_sctxt
|> (fn (pty, pctxt) => Pretty.block [pctxt, pty])
end;
fun haskell_from_pat fxy (ICons ((f, ps), _)) =
(case const_syntax f
of NONE =>
ps
|> map (haskell_from_pat BR)
|> cons ((str o resolv_const) f)
|> brackify (eval_fxy fxy BR)
| SOME ((i, k), pr) =>
if not (i <= length ps andalso length ps <= k)
then error ("number of argument mismatch in customary serialization: "
^ (string_of_int o length) ps ^ " given, " ^ string_of_int i ^ " to " ^ string_of_int k
^ " expected")
else pr fxy haskell_from_expr (map iexpr_of_ipat ps))
| haskell_from_pat fxy (IVarP (v, _)) =
(str o lower_first) v
and haskell_from_expr fxy (e as IApp (e1, e2)) =
(case (unfold_app e)
of (e as (IConst (f, _)), es) =>
haskell_from_app fxy (f, es)
| _ =>
brackify (eval_fxy fxy BR) [
haskell_from_expr NOBR e1,
haskell_from_expr BR e2
])
| haskell_from_expr fxy (e as IConst (f, _)) =
haskell_from_app fxy (f, [])
| haskell_from_expr fxy (IVarE (v, _)) =
(str o lower_first) v
| haskell_from_expr fxy (e as IAbs _) =
let
val (vs, body) = unfold_abs e
in
brackify (eval_fxy fxy BR) (
str "\\"
:: map (str o lower_first o fst) vs @ [
str "->",
haskell_from_expr NOBR body
])
end
| haskell_from_expr fxy (e as ICase (_, [_])) =
let
val (ps, body) = unfold_let e;
fun mk_bind (p, e) = Pretty.block [
haskell_from_pat BR p,
str " =",
Pretty.brk 1,
haskell_from_expr NOBR e
];
in Pretty.chunks [
[str ("let"), Pretty.fbrk, map mk_bind ps |> Pretty.chunks] |> Pretty.block,
[str ("in "), haskell_from_expr NOBR body] |> Pretty.block
] end
| haskell_from_expr fxy (ICase (e, c::cs)) =
let
fun mk_clause definer (p, e) =
Pretty.block [
str definer,
haskell_from_pat NOBR p,
str " ->",
Pretty.brk 1,
haskell_from_expr NOBR e
]
in brackify (eval_fxy fxy BR) (
str "case"
:: haskell_from_expr NOBR e
:: mk_clause "of " c
:: map (mk_clause "| ") cs
) end
| haskell_from_expr fxy (IInst (e, _)) =
haskell_from_expr fxy e
| haskell_from_expr fxy (IDictE _) =
error "cannot serialize dictionary expression to haskell"
| haskell_from_expr fxy (ILookup _) =
error "cannot serialize lookup expression to haskell"
and haskell_mk_app f es =
(str o resolv_const) f :: map (haskell_from_expr BR) es
and haskell_from_app fxy =
from_app haskell_mk_app haskell_from_expr const_syntax fxy;
fun haskell_from_def (name, Undef) =
error ("empty statement during serialization: " ^ quote name)
| haskell_from_def (name, Prim prim) =
from_prim (name, prim)
| haskell_from_def (name, Fun (eqs, (_, ty))) =
let
fun from_eq name (args, rhs) =
Pretty.block [
str (lower_first name),
Pretty.block (map (fn p => Pretty.block [Pretty.brk 1, haskell_from_pat BR p]) args),
Pretty.brk 1,
str ("="),
Pretty.brk 1,
haskell_from_expr NOBR rhs
]
in
Pretty.chunks [
Pretty.block [
str (lower_first name ^ " ::"),
Pretty.brk 1,
haskell_from_type NOBR ty
],
Pretty.chunks (map (from_eq name) eqs)
] |> SOME
end
| haskell_from_def (name, Typesyn (vs, ty)) =
Pretty.block [
str "type ",
haskell_from_sctxt vs,
str (upper_first name),
Pretty.block (map (fn (v, _) => str (" " ^ (lower_first) v)) vs),
str " =",
Pretty.brk 1,
haskell_from_type NOBR ty
] |> SOME
| haskell_from_def (name, Datatype ((vars, constrs), _)) =
let
fun mk_cons (co, tys) =
(Pretty.block o Pretty.breaks) (
str ((upper_first o resolv) co)
:: map (haskell_from_type NOBR) tys
)
in
Pretty.block (
str "data "
:: haskell_from_sctxt vars
:: str (upper_first name)
:: Pretty.block (map (fn (v, _) => str (" " ^ (lower_first) v)) vars)
:: str " ="
:: Pretty.brk 1
:: separate (Pretty.block [Pretty.brk 1, str "| "]) (map mk_cons constrs)
)
end |> SOME
| haskell_from_def (_, Datatypecons _) =
NONE
| haskell_from_def (name, Class ((supclasss, (v, membrs)), _)) =
let
fun mk_member (m, (_, ty)) =
Pretty.block [
str (resolv m ^ " ::"),
Pretty.brk 1,
haskell_from_type NOBR ty
]
in
Pretty.block [
str "class ",
haskell_from_sctxt (map (fn class => (v, [class])) supclasss),
str ((upper_first name) ^ " " ^ v),
str " where",
Pretty.fbrk,
Pretty.chunks (map mk_member membrs)
] |> SOME
end
| haskell_from_def (name, Classmember _) =
NONE
| haskell_from_def (_, Classinst ((clsname, (tyco, arity)), memdefs)) =
Pretty.block [
str "instance ",
haskell_from_sctxt arity,
str ((upper_first o resolv) clsname),
str " ",
haskell_from_type NOBR (IType (tyco, (map (IVarT o rpair [] o fst)) arity)),
str " where",
Pretty.fbrk,
Pretty.chunks (map (fn (m, funn) => haskell_from_def (m, Fun funn) |> the) memdefs)
] |> SOME
in
case List.mapPartial (fn (name, def) => haskell_from_def (name, def)) defs
of [] => NONE
| l => (SOME o Pretty.chunks o separate (str "")) l
end;
in
fun haskell_from_thingol target nsp_dtcon
nspgrp (tyco_syntax, const_syntax) name_root select module =
let
val reserved_haskell = [
"hiding", "deriving", "where", "case", "of", "infix", "infixl", "infixr",
"import", "default", "forall", "let", "in", "class", "qualified", "data",
"newtype", "instance", "if", "then", "else", "type", "as", "do", "module"
] @ [
"Bool", "fst", "snd", "Integer", "True", "False", "negate"
];
fun upper_first s =
let
val (pr, b) = split_last (NameSpace.unpack s);
val (c::cs) = String.explode b;
in NameSpace.pack (pr @ [String.implode (Char.toUpper c :: cs)]) end;
fun haskell_from_module _ (name, ps) () =
(Pretty.block [
str ("module " ^ (upper_first name) ^ " where"),
Pretty.fbrk,
Pretty.fbrk,
Pretty.chunks (separate (str "") ps)
], ());
fun is_cons c = has_nsp c nsp_dtcon;
fun eta_expander c =
const_syntax c
|> Option.map (fst o fst)
|> the_default 0;
fun preprocess module =
module
|> tap (Pretty.writeln o pretty_deps)
|> debug 3 (fn _ => "eta-expanding...")
|> eta_expand eta_expander
in
abstract_serializer preprocess (haskell_from_defs is_cons, haskell_from_module, abstract_validator reserved_haskell)
(target, (tyco_syntax, const_syntax)) (name_root, nspgrp) I select module
end;
end; (* local *)
(** lookup record **)
val serializers =
let
fun seri s f = (s, f s);
in {
ml = seri "ml" ml_from_thingol,
haskell = seri "haskell" haskell_from_thingol
} end;
end; (* struct *)