src/Pure/Tools/codegen_serializer.ML

substantial improvements in code generator

(*  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 *)