Updating: keeping atscc2py up-to-date

Updating: keeping atscc2py up-to-date

(* ****** ****** *)
//
// ATS-parse-emit-python
//
(* ****** ****** *)
//
// HX-2014-08-04: start
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload "./atsparemit.sats"
staload "./atsparemit_syntax.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_emit.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_typedef.dats"
//
(* ****** ****** *)

local

staload
TM = "libc/SATS/time.sats"
stadef time_t = $TM.time_t

in (* in-of-local *)

implement
emit_time_stamp (out) = let
//
var tm: time_t
val () = tm := $TM.time_get ()
val (pfopt | p_tm) = $TM.localtime (tm)
//
val () = emit_text (out, "######\n");
val () = emit_text (out, "## The Python3 code is generated by atscc2py\n")
val () = emit_text (out, "## The starting compilation time is: ")
//
val () =
if
p_tm > 0
then let
  prval Some_v @(pf1, fpf1) = pfopt
  val tm_min = $TM.tm_get_min (!p_tm)
  val tm_hour = $TM.tm_get_hour (!p_tm)
  val tm_mday = $TM.tm_get_mday (!p_tm)
  val tm_mon = 1 + $TM.tm_get_mon (!p_tm)
  val tm_year = 1900 + $TM.tm_get_year (!p_tm)
  prval () = fpf1 (pf1)
in
  $extfcall
  (
    void
  , "fprintf"
  , out, "%i-%i-%i: %2ih:%2im\n", tm_year, tm_mon, tm_mday, tm_hour, tm_min
  )
end // end of [then]
else let
  prval None_v () = pfopt
in
  emit_text (out, "**TIME-ERROR**\n")
end // end of [else]
//
val () = emit_text (out, "######\n")
//
in
  // emit_newline (out)
end // end of [emit_time_stamp]

end // end of [local]

(* ****** ****** *)
//
implement
emit_PMVint
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVint]
//
implement
emit_PMVintrep
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVintrep]
//
(* ****** ****** *)
//
implement
emit_PMVbool
  (out, tfv) =
(
  emit_text (out, if tfv then "True" else "False")
) (* end of [emit_PMVbool] *)
//
(* ****** ****** *)

implement
emit_PMVfloat
  (out, tok) = let
//
val-T_FLOAT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVfloat]

(* ****** ****** *)

implement
emit_PMVstring
  (out, tok) = let
//
val-T_STRING(rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVstring]

(* ****** ****** *)

implement
emit_PMVi0nt
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVi0nt]

(* ****** ****** *)

implement
emit_PMVf0loat
  (out, tok) = let
//
val-T_FLOAT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVf0loat]

(* ****** ****** *)

implement
emit_PMVfunlab
  (out, flab) = let
in
  emit_label (out, flab)
end // end of [emit_PMVfunlab]

(* ****** ****** *)

implement
emit_PMVcfunlab
  (out, fl, d0es) =
{
//
val () =
  emit_label (out, fl)
val () =
  emit_text (out, "__closurerize")
//
val () = emit_LPAREN (out)
val () = emit_d0explst (out, d0es)
val () = emit_RPAREN (out)
//
} (* end of [emit_PMVcfunlab] *)

(* ****** ****** *)

implement
emit_CSTSPmyloc
  (out, tok) = let
//
val-T_STRING(rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_CSTSPmyloc]

(* ****** ****** *)

implement
emit_ATSCKpat_con0
  (out, d0e, tag) =
{
  val () =
  emit_text (out, "ATSCKpat_con0(")
  val () = (
    emit_d0exp (out, d0e); emit_text (out, ", "); emit_int (out, tag); emit_RPAREN (out)
  ) (* end of [val] *)
} (* end of [emit_ATSCKpat_con0] *)

implement
emit_ATSCKpat_con1
  (out, d0e, tag) =
{
  val () =
  emit_text (out, "ATSCKpat_con1(")
  val () = (
    emit_d0exp (out, d0e); emit_text (out, ", "); emit_int (out, tag); emit_RPAREN (out)
  ) (* end of [val] *)
} (* end of [emit_ATSCKpat_con1] *)

(* ****** ****** *)
//
implement
emit_tmpvar
  (out, tmp) = emit_i0de (out, tmp)
//
(* ****** ****** *)

implement
emit_d0exp
  (out, d0e0) = let
in
//
case+
d0e0.d0exp_node of
//
| D0Eide (tmp) =>
  {
    val () = emit_tmpvar (out, tmp)
  }
//
| D0Eappid (fid, d0es) =>
  {
    val () = emit_i0de (out, fid)
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
| D0Eappexp (d0e, d0es) =>
  {
    val () = emit_d0exp (out, d0e)
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
//
| D0Elist (d0es) =>
  {
    val () = emit_text (out, "D0Elist")
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
//
| ATSempty (dummy) => emit_text (out, "None")
| ATSextval (toklst) => emit_extval (out, toklst)
//
| ATSPMVint (tok) => emit_PMVint (out, tok)
| ATSPMVintrep (tok) => emit_PMVintrep (out, tok)
//
| ATSPMVbool (tfv) => emit_PMVbool (out, tfv)
//
| ATSPMVfloat (tok) => emit_PMVfloat (out, tok)
//
| ATSPMVstring (tok) => emit_PMVstring (out, tok)
//
| ATSPMVi0nt (tok) => emit_PMVi0nt (out, tok)
| ATSPMVf0loat (tok) => emit_PMVfloat (out, tok)
//
| ATSPMVfunlab (fl) => emit_PMVfunlab (out, fl)
| ATSPMVcfunlab
    (knd, fl, d0es) => emit_PMVcfunlab (out, fl, d0es)
//
| ATSPMVcastfn
    (_(*fid*), _(*s0e*), arg) => emit_d0exp (out, arg)
//
| ATSCSTSPmyloc (tok) => emit_CSTSPmyloc (out, tok)
//
| ATSCKpat_con0
    (d0e, tag) => emit_ATSCKpat_con0 (out, d0e, tag)
| ATSCKpat_con1
    (d0e, tag) => emit_ATSCKpat_con1 (out, d0e, tag)
//
| ATSSELcon _ => emit_SELcon (out, d0e0)
//
| ATSSELrecsin _ => emit_text (out, "ATSSELrecsin(...)")
//
| ATSSELboxrec _ => emit_SELboxrec (out, d0e0)
//
| ATSSELfltrec _ => emit_text (out, "ATSSELfltrec(...)")
//
| ATSfunclo_fun
    (d2e, _(*arg*), _(*res*)) => emit_d0exp (out, d2e)
| ATSfunclo_clo
    (d2e, _(*arg*), _(*res*)) =>
  (
    emit_d0exp (out, d2e);
    emit_LBRACKET (out); emit_int (out, 0); emit_RBRACKET (out)
  ) (* end of [ATSfunclo_clo] *)
//
end // end of [emit_d0exp]

(* ****** ****** *)

local

fun
loop
(
  out: FILEref, d0es: d0explst, i: int
) : void =
(
case+ d0es of
| list_nil () => ()
| list_cons (d0e, d0es) => let
    val () =
      if i > 0 then emit_text (out, ", ")
    // end of [val]
  in
    emit_d0exp (out, d0e); loop (out, d0es, i+1)
  end // end of [list_cons]
)

in (* in-of-local *)

implement
emit_d0explst (out, d0es) = loop (out, d0es, 0)
implement
emit_d0explst_1 (out, d0es) = loop (out, d0es, 1)

end // end of [local]

(* ****** ****** *)
//
extern
fun
tyrec_labsel
  (tyrec: tyrec, lab: symbol): int
//
implement
tyrec_labsel
  (tyrec, lab) = let
//
fun loop
(
  xs: tyfldlst, i: int
) : int =
(
case+ xs of
| list_cons (x, xs) => let
    val TYFLD (id, s0e) = x.tyfld_node
  in
    if lab = id.i0de_sym then i else loop (xs, i+1)
  end // end of [list_cons
| list_nil ((*void*)) => ~1(*error*)
)
//
in
  loop (tyrec.tyrec_node, 0)
end // end of [tyrec_labsel]
//
(* ****** ****** *)

implement
emit_SELcon
  (out, d0e) = let
//
val-ATSSELcon
  (d0rec, s0e, id) = d0e.d0exp_node
val-S0Eide (name) = s0e.s0exp_node
val-~Some_vt (s0rec) = typedef_search_opt (name)
//
val index = tyrec_labsel (s0rec, id.i0de_sym)
//
val () =
  emit_d0exp (out, d0rec)
//
val () = emit_LBRACKET (out)
val () = emit_int (out, index)
val () = emit_RBRACKET (out)
//
in
  // nothing
end // end of [emit_SELcon]

(* ****** ****** *)

implement
emit_SELboxrec
  (out, d0e) = let
//
val-ATSSELboxrec
  (d0rec, s0e, id) = d0e.d0exp_node
val-S0Eide (name) = s0e.s0exp_node
val-~Some_vt (s0rec) = typedef_search_opt (name)
//
val index = tyrec_labsel (s0rec, id.i0de_sym)
//
val () =
  emit_d0exp (out, d0rec)
//
val () = emit_LBRACKET (out)
val () = emit_int (out, index)
val () = emit_RBRACKET (out)
//
in
  // nothing
end // end of [emit_SELboxrec]

(* ****** ****** *)
//
implement
emit_COMMENT_line (out) =
  emit_text (out, "#COMMENT_line\n")
//
implement
emit_COMMENT_block (out) = ((*ignored*))
//
(* ****** ****** *)

local

fun
aux0_arglst
(
  out: FILEref
, s0es: s0explst
, n0: int, i: int
) : void =
(
case+ s0es of
| list_nil () => ()
| list_cons
    (s0e, s0es) => let
    val () =
    if n0+i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "arg"); emit_int (out, i)
    ) (* end of [val] *)
  in
    aux0_arglst (out, s0es, n0, i+1)
  end // end of [list_cons]
) (* end of [aux0_arglst] *)

fun
aux0_envlst
(
  out: FILEref
, s0es: s0explst
, n0: int, i: int
) : void =
(
case+ s0es of
| list_nil () => ()
| list_cons
    (s0e, s0es) => let
    val () =
    if n0+i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "env"); emit_int (out, i)
    ) (* end of [val] *)
  in
    aux0_envlst (out, s0es, n0, i+1)
  end // end of [list_cons]
) (* end of [aux0_envlst] *)

fun
aux1_envlst
(
  out: FILEref
, s0es: s0explst, i: int
) : int =
(
case+ s0es of
| list_nil () => (i)
| list_cons
    (s0e, s0es) => let
    val () =
    if i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "cenv");
      emit_LBRACKET (out); emit_int (out, i+1); emit_RBRACKET (out)
    ) (* end of [val] *)
  in
    aux1_envlst (out, s0es, i+1)
  end // end of [list_cons]
) (* end of [aux1_envlst] *)

in (* in-of-local *)

implement
emit_closurerize
(
  out, fl, env, arg, res
) = let
//
val-S0Elist(s0es_env) = env.s0exp_node
val-S0Elist(s0es_arg) = arg.s0exp_node
//
val () = emit_ENDL (out)
val () = emit_text (out, "def ")
val () = emit_label (out, fl)
val () =
emit_text (out, "__closurerize(")
val () = aux0_envlst (out, s0es_env, 0, 0)
val ((*closing*)) = emit_text (out, "):\n")
//
val () = emit_nspc (out, 2)
val () = emit_text (out, "def ")
val () = emit_label (out, fl)
val () = emit_text (out, "__cfun(")
val () = emit_text (out, "cenv")
val () = aux0_arglst (out, s0es_arg, 1, 0)
val () = emit_text (out, "): return ")
val () =
(
  emit_label (out, fl); emit_LPAREN (out)
)
val n0 = aux1_envlst (out, s0es_env, 0)
val () = aux0_arglst (out, s0es_arg, n0, 0)
val ((*closing*)) = emit_text (out, ")\n")
//
val () = emit_nspc (out, 2)
val () = emit_text (out, "return (")
val () = emit_label (out, fl)
val () = emit_text (out, "__cfun, ")
val () = aux0_envlst (out, s0es_env, 0, 0)
val ((*closing*)) = emit_text (out, ")")
//
val () = emit_newline (out)
//
in
  // nothing
end // end of [emit_closurerize]

end // end of [local]

(* ****** ****** *)

(* end of [atsparemit_emit_py.dats] *)

(* ****** ****** *)
//
// ATS-parse-emit-python
//
(* ****** ****** *)
//
// HX-2014-08-04: start
//
(* ****** ****** *)
//
#include
"share/atspre_staload.hats"
//
(* ****** ****** *)
//
staload
UN = "prelude/SATS/unsafe.sats"
//
(* ****** ****** *)
//
staload "./atsparemit.sats"
staload "./atsparemit_syntax.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_emit.sats"
//
(* ****** ****** *)
//
staload "./atsparemit_typedef.dats"
//
(* ****** ****** *)

local

staload
TM = "libc/SATS/time.sats"
stadef time_t = $TM.time_t

in (* in-of-local *)

implement
emit_time_stamp (out) = let
//
var tm: time_t
val () = tm := $TM.time_get ()
val (pfopt | p_tm) = $TM.localtime (tm)
//
val () = emit_text (out, "######\n");
val () = emit_text (out, "## The Python3 code is generated by atscc2py\n")
val () = emit_text (out, "## The starting compilation time is: ")
//
val () =
if
p_tm > 0
then let
  prval Some_v @(pf1, fpf1) = pfopt
  val tm_min = $TM.tm_get_min (!p_tm)
  val tm_hour = $TM.tm_get_hour (!p_tm)
  val tm_mday = $TM.tm_get_mday (!p_tm)
  val tm_mon = 1 + $TM.tm_get_mon (!p_tm)
  val tm_year = 1900 + $TM.tm_get_year (!p_tm)
  prval () = fpf1 (pf1)
in
  $extfcall
  (
    void
  , "fprintf"
  , out, "%i-%i-%i: %2ih:%2im\n", tm_year, tm_mon, tm_mday, tm_hour, tm_min
  )
end // end of [then]
else let
  prval None_v () = pfopt
in
  emit_text (out, "**TIME-ERROR**\n")
end // end of [else]
//
val () = emit_text (out, "######\n")
//
in
  // emit_newline (out)
end // end of [emit_time_stamp]

end // end of [local]

(* ****** ****** *)
//
implement
emit_PMVint
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVint]
//
implement
emit_PMVintrep
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVintrep]
//
(* ****** ****** *)
//
implement
emit_PMVbool
  (out, tfv) =
(
  emit_text (out, if tfv then "True" else "False")
) (* end of [emit_PMVbool] *)
//
(* ****** ****** *)

implement
emit_PMVfloat
  (out, tok) = let
//
val-T_FLOAT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVfloat]

(* ****** ****** *)

implement
emit_PMVstring
  (out, tok) = let
//
val-T_STRING(rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVstring]

(* ****** ****** *)

implement
emit_PMVi0nt
  (out, tok) = let
//
val-T_INT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVi0nt]

(* ****** ****** *)

implement
emit_PMVf0loat
  (out, tok) = let
//
val-T_FLOAT(base, rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_PMVf0loat]

(* ****** ****** *)

implement
emit_PMVfunlab
  (out, flab) = let
in
  emit_label (out, flab)
end // end of [emit_PMVfunlab]

(* ****** ****** *)

implement
emit_PMVcfunlab
  (out, fl, d0es) =
{
//
val () =
  emit_label (out, fl)
val () =
  emit_text (out, "__closurerize")
//
val () = emit_LPAREN (out)
val () = emit_d0explst (out, d0es)
val () = emit_RPAREN (out)
//
} (* end of [emit_PMVcfunlab] *)

(* ****** ****** *)

implement
emit_CSTSPmyloc
  (out, tok) = let
//
val-T_STRING(rep) = tok.token_node
//
in
  emit_text (out, rep)
end // end of [emit_CSTSPmyloc]

(* ****** ****** *)

implement
emit_ATSCKpat_con0
  (out, d0e, tag) =
{
  val () =
  emit_text (out, "ATSCKpat_con0(")
  val () = (
    emit_d0exp (out, d0e); emit_text (out, ", "); emit_int (out, tag); emit_RPAREN (out)
  ) (* end of [val] *)
} (* end of [emit_ATSCKpat_con0] *)

implement
emit_ATSCKpat_con1
  (out, d0e, tag) =
{
  val () =
  emit_text (out, "ATSCKpat_con1(")
  val () = (
    emit_d0exp (out, d0e); emit_text (out, ", "); emit_int (out, tag); emit_RPAREN (out)
  ) (* end of [val] *)
} (* end of [emit_ATSCKpat_con1] *)

(* ****** ****** *)
//
implement
emit_tmpvar
  (out, tmp) = emit_i0de (out, tmp)
//
(* ****** ****** *)

implement
emit_d0exp
  (out, d0e0) = let
in
//
case+
d0e0.d0exp_node of
//
| D0Eide (tmp) =>
  {
    val () = emit_tmpvar (out, tmp)
  }
//
| D0Eappid (fid, d0es) =>
  {
    val () = emit_i0de (out, fid)
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
| D0Eappexp (d0e, d0es) =>
  {
    val () = emit_d0exp (out, d0e)
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
//
| D0Elist (d0es) =>
  {
    val () = emit_text (out, "D0Elist")
    val () = emit_LPAREN (out)
    val () = emit_d0explst (out, d0es)
    val () = emit_RPAREN (out)
  }
//
| ATSempty (x) => emit_text (out, "None")
//
| ATSPMVint (tok) => emit_PMVint (out, tok)
| ATSPMVintrep (tok) => emit_PMVintrep (out, tok)
//
| ATSPMVbool (tfv) => emit_PMVbool (out, tfv)
//
| ATSPMVfloat (tok) => emit_PMVfloat (out, tok)
//
| ATSPMVstring (tok) => emit_PMVstring (out, tok)
//
| ATSPMVi0nt (tok) => emit_PMVi0nt (out, tok)
| ATSPMVf0loat (tok) => emit_PMVfloat (out, tok)
//
| ATSPMVfunlab (fl) => emit_PMVfunlab (out, fl)
| ATSPMVcfunlab
    (knd, fl, d0es) => emit_PMVcfunlab (out, fl, d0es)
//
| ATSPMVcastfn
    (_(*fid*), _(*s0e*), arg) => emit_d0exp (out, arg)
//
| ATSCSTSPmyloc (tok) => emit_CSTSPmyloc (out, tok)
//
| ATSCKpat_con0
    (d0e, tag) => emit_ATSCKpat_con0 (out, d0e, tag)
| ATSCKpat_con1
    (d0e, tag) => emit_ATSCKpat_con1 (out, d0e, tag)
//
| ATSSELcon _ => emit_SELcon (out, d0e0)
//
| ATSSELrecsin _ => emit_text (out, "ATSSELrecsin(...)")
//
| ATSSELboxrec _ => emit_SELboxrec (out, d0e0)
//
| ATSSELfltrec _ => emit_text (out, "ATSSELfltrec(...)")
//
| ATSfunclo_fun
    (d2e, _(*arg*), _(*res*)) => emit_d0exp (out, d2e)
| ATSfunclo_clo
    (d2e, _(*arg*), _(*res*)) =>
  (
    emit_d0exp (out, d2e);
    emit_LBRACKET (out); emit_int (out, 0); emit_RBRACKET (out)
  ) (* end of [ATSfunclo_clo] *)
//
end // end of [emit_d0exp]

(* ****** ****** *)

local

fun
loop
(
  out: FILEref, d0es: d0explst, i: int
) : void =
(
case+ d0es of
| list_nil () => ()
| list_cons (d0e, d0es) => let
    val () =
      if i > 0 then emit_text (out, ", ")
    // end of [val]
  in
    emit_d0exp (out, d0e); loop (out, d0es, i+1)
  end // end of [list_cons]
)

in (* in-of-local *)

implement
emit_d0explst (out, d0es) = loop (out, d0es, 0)
implement
emit_d0explst_1 (out, d0es) = loop (out, d0es, 1)

end // end of [local]

(* ****** ****** *)
//
extern
fun
tyrec_labsel
  (tyrec: tyrec, lab: symbol): int
//
implement
tyrec_labsel
  (tyrec, lab) = let
//
fun loop
(
  xs: tyfldlst, i: int
) : int =
(
case+ xs of
| list_cons (x, xs) => let
    val TYFLD (id, s0e) = x.tyfld_node
  in
    if lab = id.i0de_sym then i else loop (xs, i+1)
  end // end of [list_cons
| list_nil ((*void*)) => ~1(*error*)
)
//
in
  loop (tyrec.tyrec_node, 0)
end // end of [tyrec_labsel]
//
(* ****** ****** *)

implement
emit_SELcon
  (out, d0e) = let
//
val-ATSSELcon
  (d0rec, s0e, id) = d0e.d0exp_node
val-S0Eide (name) = s0e.s0exp_node
val-~Some_vt (s0rec) = typedef_search_opt (name)
//
val index = tyrec_labsel (s0rec, id.i0de_sym)
//
val () =
  emit_d0exp (out, d0rec)
//
val () = emit_LBRACKET (out)
val () = emit_int (out, index)
val () = emit_RBRACKET (out)
//
in
  // nothing
end // end of [emit_SELcon]

(* ****** ****** *)

implement
emit_SELboxrec
  (out, d0e) = let
//
val-ATSSELboxrec
  (d0rec, s0e, id) = d0e.d0exp_node
val-S0Eide (name) = s0e.s0exp_node
val-~Some_vt (s0rec) = typedef_search_opt (name)
//
val index = tyrec_labsel (s0rec, id.i0de_sym)
//
val () =
  emit_d0exp (out, d0rec)
//
val () = emit_LBRACKET (out)
val () = emit_int (out, index)
val () = emit_RBRACKET (out)
//
in
  // nothing
end // end of [emit_SELboxrec]

(* ****** ****** *)
//
implement
emit_COMMENT_line (out) =
  emit_text (out, "#COMMENT_line\n")
//
implement
emit_COMMENT_block (out) = ((*ignored*))
//
(* ****** ****** *)

local

fun
aux0_arglst
(
  out: FILEref
, s0es: s0explst
, n0: int, i: int
) : void =
(
case+ s0es of
| list_nil () => ()
| list_cons
    (s0e, s0es) => let
    val () =
    if n0+i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "arg"); emit_int (out, i)
    ) (* end of [val] *)
  in
    aux0_arglst (out, s0es, n0, i+1)
  end // end of [list_cons]
) (* end of [aux0_arglst] *)

fun
aux0_envlst
(
  out: FILEref
, s0es: s0explst
, n0: int, i: int
) : void =
(
case+ s0es of
| list_nil () => ()
| list_cons
    (s0e, s0es) => let
    val () =
    if n0+i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "env"); emit_int (out, i)
    ) (* end of [val] *)
  in
    aux0_envlst (out, s0es, n0, i+1)
  end // end of [list_cons]
) (* end of [aux0_envlst] *)

fun
aux1_envlst
(
  out: FILEref
, s0es: s0explst, i: int
) : int =
(
case+ s0es of
| list_nil () => (i)
| list_cons
    (s0e, s0es) => let
    val () =
    if i > 0 then emit_text (out, ", ")
    val () =
    (
      emit_text (out, "cenv");
      emit_LBRACKET (out); emit_int (out, i+1); emit_RBRACKET (out)
    ) (* end of [val] *)
  in
    aux1_envlst (out, s0es, i+1)
  end // end of [list_cons]
) (* end of [aux1_envlst] *)

in (* in-of-local *)

implement
emit_closurerize
(
  out, fl, env, arg, res
) = let
//
val-S0Elist(s0es_env) = env.s0exp_node
val-S0Elist(s0es_arg) = arg.s0exp_node
//
val () = emit_ENDL (out)
val () = emit_text (out, "def ")
val () = emit_label (out, fl)
val () =
emit_text (out, "__closurerize(")
val () = aux0_envlst (out, s0es_env, 0, 0)
val ((*closing*)) = emit_text (out, "):\n")
//
val () = emit_nspc (out, 2)
val () = emit_text (out, "def ")
val () = emit_label (out, fl)
val () = emit_text (out, "__cfun(")
val () = emit_text (out, "cenv")
val () = aux0_arglst (out, s0es_arg, 1, 0)
val () = emit_text (out, "): return ")
val () =
(
  emit_label (out, fl); emit_LPAREN (out)
)
val n0 = aux1_envlst (out, s0es_env, 0)
val () = aux0_arglst (out, s0es_arg, n0, 0)
val ((*closing*)) = emit_text (out, ")\n")
//
val () = emit_nspc (out, 2)
val () = emit_text (out, "return (")
val () = emit_label (out, fl)
val () = emit_text (out, "__cfun, ")
val () = aux0_envlst (out, s0es_env, 0, 0)
val ((*closing*)) = emit_text (out, ")")
//
val () = emit_newline (out)
//
in
  // nothing
end // end of [emit_closurerize]

end // end of [local]

(* ****** ****** *)

(* end of [atsparemit_emit_py.dats] *)


Updating: improving arduino/QueenPuzzle

Updating: improving arduino/QueenPuzzle

(*
#
# QueenPuzzle
#
*)
(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"{$ARDUINO}/staloadall.hats"
//
(* ****** ****** *)

staload UN = "prelude/SATS/unsafe.sats"

(* ****** ****** *)
//
%{^
typedef char *charptr;
%} // end of [%{^]
//
abstype charptr = $extype"charptr"
//
(* ****** ****** *)
//
%{^
#define N 8
int theArray[N] =
{
  0,0,0,0,0,0,0,0
} ;
%} // end of [%{^]
#define N 8
macdef theArray =
  $extval(arrayref(int,N),"theArray")
//
(* ****** ****** *)
//
fnx
find_next
  {n:pos}
(
  A: arrayref(int, n), n: int(n)
) : bool = let
//
fun
loop
(
  i: natLte(n)
) : natLte(n) =
(
if
i < n
then
  if A[i] > 0 then loop (i+1) else i
else n
) (* end of [loop] *)
//
val i0 = loop (0)
//
in
//
if
i0 < n
then
(
  A[i0] := 1; find2_next (A, n, i0)
) (* end of [then] *)
else
(
  A[n-1] := A[n-1] + 1; find2_next (A, n, n-1)
) (* end of [else] *)
//
end // end of [find_next]

and
find2_next
  {n:pos}
(
  A: arrayref(int, n), n: int(n), i: natLt(n)
) : bool = let
//
fun
test
(
  A: arrayref(int, n), i: natLt(n), j: intGte(0)
) : bool =
(
if j >= i then true else
  (if A[i] = A[j] then false else if (i-j=abs(A[i]-A[j])) then false else test (A, i, j+1))
) (* end of [test] *)
//
in
//
if
A[i] <= n
then let
in
//
if test(A, i, 0)
  then
  (if i+1=n then true else find_next(A, n))
  else (A[i] := A[i]+1; find2_next(A, n, i))
//
end // end of [then]
else let
  val () = A[i] := 0
in
  if i > 0 then (A[i-1] := A[i-1]+1; find2_next (A, n, i-1)) else false
end // end of [else]
//
end // end of [find2_next]

(* ****** ****** *)

macdef LEDPIN = 13
macdef BAUD_RATE = 9600

(* ****** ****** *)
//
extern
fun
setup (): void = "mac#"
//
implement
setup () = () where
{
//
val () = pinMode(LEDPIN, OUTPUT)
val () = Serial_ptr._begin(BAUD_RATE)
//
} (* end of [setup] *)
//
(* ****** ****** *)
//
implement
fprint_val<int>
  (out, x) = let
//
fun
ndot (n: int): void =
  if n > 0 then (Serial_ptr.print(". "); ndot(n-1))
//
val () = ndot(x-1)
val () = Serial_ptr.print("Q ")
val () = ndot(N-x)
val () = Serial_ptr.println()
//
in
  // nothing
end // end of [fprint_val]

(* ****** ****** *)
//
implement
fprint_string (out, x) = Serial_ptr.print(x)
//
(* ****** ****** *)
//
implement
fprint_array$sep<> (out) = ()
//
(* ****** ****** *)
//
extern
fun loop (): void = "mac#"
//
implement
loop () =
myloop() where
{
fun
myloop(): void = let
//
val
out = $extval (FILEref, "0")
//
(*
val () =
randomSeed($UN.cast{uint}(millis()))
*)
//
val A = theArray
val found = find_next (A, N)
//
val () =
if found then
{
  val () =
  fprint_arrayref (out, A, i2sz(N))
  val () = Serial_ptr.println()
} (* end of [then] *)
//
val () =
if ~found then
{
//
  val () =
  fprint_string (out, "All solutions are found!")
  val () = Serial_ptr.println()
//
} (* end of [then] *)
//
val () = digitalWrite(LEDPIN, 1)
val () = delay(250)
val () = digitalWrite(LEDPIN, 0)
val () = delay(1000)
//
in
  myloop ()
end // end of [myloop]
//
} (* end of [loop] *)
//
(* ****** ****** *)

(* end of [QueenPuzzle.dats] *)

(*
#
# QueenPuzzle
#
*)
(* ****** ****** *)

#define ATS_DYNLOADFLAG 0

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
#include
"{$ARDUINO}/staloadall.hats"
//
(* ****** ****** *)

staload UN = "prelude/SATS/unsafe.sats"

(* ****** ****** *)
//
%{^
typedef char *charptr;
%} // end of [%{^]
//
abstype charptr = $extype"charptr"
//
(* ****** ****** *)
//
%{^
#define N 8
int theArray[N] =
{
  0,0,0,0,0,0,0,0
} ;
%} // end of [%{^]
#define N 8
macdef theArray =
  $extval(arrayref(int,N),"theArray")
//
(* ****** ****** *)
//
fnx
find_next
  {n:pos}
(
  A: arrayref(int, n), n: int(n)
) : bool = let
//
fun
loop
(
  i: natLte(n)
) : natLte(n) =
(
if
i < n
then
  if A[i] > 0 then loop (i+1) else i
else n
) (* end of [loop] *)
//
val i0 = loop (0)
//
in
//
if
i0 < n
then
(
  A[i0] := 1; find2_next (A, n, i0)
) (* end of [then] *)
else
(
  A[n-1] := A[n-1] + 1; find2_next (A, n, n-1)
) (* end of [else] *)
//
end // end of [find_next]

and
find2_next
  {n:pos}
(
  A: arrayref(int, n), n: int(n), i: natLt(n)
) : bool = let
//
fun
test
(
  A: arrayref(int, n), i: natLt(n), j: intGte(0)
) : bool =
(
if j >= i then true else
  (if A[i] = A[j] then false else if (i-j=abs(A[i]-A[j])) then false else test (A, i, j+1))
) (* end of [test] *)
//
in
//
if
A[i] <= n
then let
in
//
if test(A, i, 0)
  then
  (if i+1=n then true else find_next(A, n))
  else (A[i] := A[i]+1; find2_next(A, n, i))
//
end // end of [then]
else let
  val () = A[i] := 0
in
  if i > 0 then (A[i-1] := A[i-1]+1; find2_next (A, n, i-1)) else false
end // end of [else]
//
end // end of [find2_next]

(* ****** ****** *)

macdef LEDPIN = 13
macdef BAUD_RATE = 9600

(* ****** ****** *)
//
extern
fun
setup (): void = "mac#"
//
implement
setup () = () where
{
//
val () = pinMode(LEDPIN, OUTPUT)
val () = Serial_ptr._begin(BAUD_RATE)
//
} (* end of [setup] *)
//
(* ****** ****** *)
//
implement
fprint_val<int>
  (out, x) = Serial_ptr.print(x)
//
(* ****** ****** *)
//
implement
fprint_string (out, x) = Serial_ptr.print(x)
//
(* ****** ****** *)
//
implement
fprint_array$sep<> (out) = Serial_ptr.print(" ")
//
(* ****** ****** *)
//
extern
fun loop (): void = "mac#"
//
implement
loop () =
myloop() where
{
fun
myloop(): void = let
//
val
out = $extval (FILEref, "0")
//
(*
val () =
randomSeed($UN.cast{uint}(millis()))
*)
//
val A = theArray
val found = find_next (A, N)
//
val () =
if found then
{
  val () =
  fprint_arrayref (out, A, i2sz(N))
  val () = Serial_ptr.println()
} (* end of [then] *)
//
val () =
if ~found then
{
//
  val () =
  fprint_string (out, "All solutions are found!")
  val () = Serial_ptr.println()
//
} (* end of [then] *)
//
val () = digitalWrite(LEDPIN, 1)
val () = delay(250)
val () = digitalWrite(LEDPIN, 0)
val () = delay(1000)
//
in
  myloop ()
end // end of [myloop]
//
} (* end of [loop] *)
//
(* ****** ****** *)

(* end of [QueenPuzzle.dats] *)


Cleaned up the main json parsing function to use a type that wraps around the @ view and the proof that a certain pointer was allocated by libc.

(**
  Implementing jsonval using jsmn
*)
//
#include
"patsolve.hats"
//
(* ****** ****** *)

#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"

(* ****** ****** *)

staload "parsing/jsonval.sats"

(* ****** ****** *)

staload "{$LIBATSWDBLAIR}/jsmn/SATS/jsmn.sats"
staload _ = "{$LIBATSWDBLAIR}/jsmn/DATS/jsmn.dats"

(* ****** ****** *)

staload "libc/SATS/string.sats"
staload "libc/SATS/stdio.sats"
staload "libc/SATS/stdlib.sats"

(* ****** ****** *)

staload UN = "prelude/SATS/unsafe.sats"

(* ****** ****** *)

assume jsonval = jsmntokptr

(* ****** ****** *)

implement{}
jsmn_src () = jsonval_src ()

(* ****** ****** *)

#define bufsize 1024

local

vtypedef buffer_gc ( l:addr, n:int) = @{
    pf= bytes n @ l,
    fpf= mfree_gc_v l,
    p= ptr l
}

(**
    This is unsafe because it assumes that bytes
    that lie outside the boundary m are initialized
    after the call, which they are not.
*)
extern
fun realloc_unsafe {l:addr} {m,n:int} (
    buffer_gc(l, m), size_t n
): [k:addr] (
    buffer_gc(k, n)
)  = "ext#"

%{
void* realloc_unsafe (void *p, size_t n) {
    void *r = realloc (p, n);

    if (r == NULL) {
        fprintf(stderr, "realloc failed!\n");
        exit(1);
    }

    return r;
}
%}

fun
buffer_malloc_gc {n:int} (
    n: size_t n
): [l:addr] buffer_gc (l, n) = let
    val (pf, pfgc | p) = malloc_gc (n)
    prval pf = b0ytes2bytes_v (pf) (** cheating *)
in
    @{pf=pf, fpf=pfgc, p= p}
end

fun
buffer_mfree_gc {l:addr} {n:int} (
    buf: buffer_gc (l, n)
): void = let
    prval pf = buf.pf
    prval pfgc = buf.fpf
    val p = buf.p
in
    mfree_gc (pf, pfgc | p)
end

in

implement
jsonval_parse_from_stdin () = let
    var parser : jsmn_parser
    val () = jsmn_init (parser)

    val (js) = buffer_malloc_gc (i2sz(0))
    val (tok) = buffer_malloc_gc (sizeof<jsmntok_t> * i2sz(2))

in
    loop (js, i2sz(0), tok, i2sz(2), parser, false)
end where {

    fun loop {k,l:addr} {m,n:int} (
        js: buffer_gc (k, m), m: size_t m,
        tok: buffer_gc (l, sizeof(jsmntok_t)*n), n: size_t (n),
        parser: &jsmn_parser, parsed: bool
    ): (string, jsonval) = let
        val stdin = stdin_ref
        var buf : @[byte][bufsize]
        prval () = b0ytes2bytes (buf)

        val r = fread (buf, i2sz(1), i2sz(bufsize), stdin)
    in
        if r < i2sz (0) then let
            (** An error occured *)
            val () = buffer_mfree_gc (js)
            val () = buffer_mfree_gc (tok)
            val () = prerrln! ("fread failed!")
        in
            exit (1)
        end
        else if r = 0 then
            (** Reached end of file *)

            if feof (stdin) != 0 andalso parsed then let
                (**
                     Make sure we have room for the null byte
                *)
                val js =
                    realloc_unsafe (js, m+i2sz(1))
                val ending = $UN.cast{ptr}(add_ptr_bsz (js.p, m))
                val () = $UN.ptr0_set (ending, '\0')

                val str = $UN.castvwtp0{string} (js)
                val jsv = $UN.castvwtp0{jsonval} (tok)
            in
                (str, jsv)
            end
            else let
                val () = buffer_mfree_gc (js)
                val () = buffer_mfree_gc (tok)
                val () = prerrln! ("unexpected end of file!")
            in
                exit (1)
            end
        else let
            (** Try parsing again. *)
            val (js) =
                realloc_unsafe (js, m+r)
            val newjs = add_ptr_bsz (js.p, m)
            val _ = strncpy_unsafe (newjs, $UN.cast{string} (buf), r)
            val jslen = m+r

            fun parse {k,l:addr} {m,n:int} (
                js: !buffer_gc (k, m), m: size_t m,
                tok: buffer_gc (l, sizeof(jsmntok_t)*n), n: size_t n,
                parser: &jsmn_parser
            ): [q:addr] [o:int] (
                buffer_gc (q, sizeof(jsmntok_t)*o), size_t o, bool
            ) = let
                prval pfjs = js.pf
                prval pftok = tok.pf

                val err = jsmn_parse (pfjs, pftok | parser, js.p, m, tok.p, sz2u(n))

                prval () = js.pf := pfjs
                prval () = tok.pf := pftok
            in
                if err < 0 then
                    if err = JSMN_ERROR_NOMEM then let
                        val tokcount = n * i2sz(2)
                        val newbytes = sizeof<jsmntok_t> * tokcount
                        val (tok) =
                            realloc_unsafe (tok, newbytes)
                    in
                        parse (js, m, tok, tokcount, parser)
                    end
                    else
                        (tok, n, false)
                else
                    (tok, n, true)
            end

            val (tok, tokcount, finished) = parse (js, jslen, tok, n, parser)
        in
            loop (js, jslen, tok, tokcount, parser, finished)
        end  // end of [else]

    end  // end of [loop]

}// end of [jsonval_parse_stdin]

end // end of [local]

(* ****** ****** *)

(**
	Need to account for negative numbers.
	Should just use "atoi" instead.
*)
implement{}
jsonval_is_int (jsv) =
  if jsv.type != JSMN_PRIMITIVE then
    false
  else let
    val [n:int] n = g1ofg0(jsv.size)
    val () = assertloc (n >= 0)
    val src = $UN.cast{string(n)} (jsv.string)

    fun loop {i:nat | i <= n} (src: string(n), i: int i): bool =
      if i = n then
        true
      else let
        val ok = $extfcall (bool, "isdigit", src[i])
      in
        if ~ok then
          false
        else
          loop (src, succ(i))
      end
   in
    loop (src, 0)
   end

implement{}
jsonval_is_string (jsv) = jsv.type = JSMN_STRING

(**
  Need to search for "true" or "false" at its token
  value.
*)
implement{}
jsonval_is_bool (jsv) =
  jsv.type = JSMN_PRIMITIVE andalso
    (strncmp("true", jsv.string, i2sz(4)) = 0 orelse
     strncmp("false", jsv.string, i2sz(4)) = 0)

implement{}
jsonval_is_array (jsv) = jsv.type = JSMN_ARRAY

implement{}
jsonval_is_object (jsv) = jsv.type = JSMN_OBJECT

(* ****** ****** *)

implement{}
int_of_jsonval (jsv) = let
    val str = jsv.string
    val i = strtol (str, 10)
in
    $UN.cast{int} (i)
end

implement{}
bool_of_jsonval (jsv) = let
    val str = jsv.string
in
    strcmp (str, "true") = 0
end

(* ****** ****** *)

implement{}
jsonval_get_string (jsv) = let
  val src = jsonval_src ()
  val buf = add_ptr_bsz($UN.cast{ptr}(src), g0i2u(jsv.start))
in
  $UN.cast{string} (buf)
end

implement{}
jsonval_get_copy_string (jsv) = let
    val str = jsv.string
    val size = g1ofg0(jsv.ending - jsv.start)

    val () = assertloc(size >= 0)
    val size = i2sz(size)

    val buf = arrayptr_make_elt<char> (size+i2sz(1), '\0')
    val copy = $UN.castvwtp0{Ptr} (buf)
    val _ = strncpy_unsafe (copy, str, size)
in
    $UN.cast{string} (copy)
end

implement{}
jsonval_get_string_unsafe (jsv) = let
    val str = jsv.string
    val size = jsv.ending - jsv.start

    val p = $UN.cast{ptr} (str)
    val pend = add_ptr_bsz (p, g0i2u(size))
    val () = $UN.ptr0_set (pend, '\0')
in
    str
end

implement
jsonval_size (jsv) = jsmntok_size (jsv)

implement{}
jsonval_array_get_at_exn (jsv, i) = let
  val () = assertloc(i >= 0 andalso i < jsv.size)
  val p = $UN.cast{ptr} (jsv)

  fun loop (jsv: jsonval, j:int, n:int): int =
      if j = i then
          n
      else let
          val p = $UN.cast{ptr} (jsv)
          val ofs =  g0i2u(n)*sizeof<jsmntok_t>
          val nextjsv = $UN.cast{jsonval} (add_ptr_bsz(p, ofs))
      in
          loop (jsv, succ(j), n + nextjsv.numtokens)
      end

  val j = loop (jsv, 0, 1)
  val p = $UN.cast{ptr} (jsv)
  val ofs = g0i2u(j)*sizeof<jsmntok_t>
  val q = add_ptr_bsz(p, ofs)
in
  $UN.cast{jsonval}(q)
end

implement{}
jsonval_object_get_key_exn (jsv, label) = let
     (**
     val () =
        if ~jsonval_is_object (jsv) then {
            val () = println! ("Expected object but found: ", jsv.type)
	    val () = println! ("Looking for label:", label)
            val () = println! ("Token starts @  ", jsv.start)
            val () = println! ("Data:", jsv.string_unsafe)
        }
     *)
    val () = assertloc (jsonval_is_object (jsv))

    fun loop (jsv: jsonval, i:int, n:int): jsonval =
         if i = jsv.size then let
            val () = prerrln! ("key ", label, " not found")
         in
             exit(1)
         end
         else let
             val p = $UN.cast{ptr} (jsv)
             val ofs = g0i2u(n)*sizeof<jsmntok_t>
             val keyjsv = $UN.cast{jsonval} (add_ptr_bsz (p, ofs))
             (**
             val () =
                 if ~jsonval_is_string (keyjsv) then begin
                     println! ("Key is not string! While looking for key ", label);
                     println! ("Found type: ", keyjsv.type);
                     println! ("ofs = ", n);
                     println! ("start =", keyjsv.start);
                 end
             *)
             val () = assertloc (jsonval_is_string (keyjsv))
             val key = keyjsv.string
             val ofs = g0i2u(n+1)*sizeof<jsmntok_t>
             val valjsv = $UN.cast{jsonval} (add_ptr_bsz(p, ofs))
         in
            if strncmp (key, label, length (label)) = 0 then let
               (**
               val () = println! ("Found value for key ", label)
               val () = println! ("JSON key is ", keyjsv.string_unsafe)
               val () = println! ("JSON value is ", valjsv.string_unsafe)
               *)
            in
               valjsv
            end
            else let
               val valsize = valjsv.numtokens
               (**
               val () = println! ("object_get_key: at offset ", n)
               val () = println! ("object_get_key: at key i=", i)
               val () = println! ("object_get_key: found object of size", valsize)
               *)
               val nextoffset = n + 1 + valsize
               // val () = println! ("object_get_key: looking at offset ", nextoffset, " next")
            in
               loop (jsv, succ(i), nextoffset)
            end
        end
in
    loop (jsv, 0, 1)
end

implement{}
jsonval_object_has_key (jsv, label) = let
    (**
    val () =
        if ~jsonval_is_object (jsv) then {
            val () = println! ("Expected object but found: ", jsv.type)
	    val () = println! ("Looking for label:", label)
            val () = println! ("Token starts @  ", jsv.start)
            val () = println! ("Data:", jsv.string_unsafe)
        }
    *)
    val () = assertloc (jsonval_is_object (jsv))

    fun loop (jsv: jsonval, i:int, n:int): bool =
        if i = jsv.size then
            false
        else let
             val p = $UN.cast{ptr} (jsv)
             val ofs = g0i2u(n)*sizeof<jsmntok_t>
             val keyjsv = $UN.cast{jsonval} (add_ptr_bsz (p, ofs))
             val () = assertloc (jsonval_is_string (keyjsv))
             val key = keyjsv.string
             val targetlen = length (label)
             val srclen = keyjsv.ending - keyjsv.start
        in
            if targetlen = srclen andalso
                   strncmp (key, label, length (label)) = 0 then
                true
            else let
                val ofs = g0i2u(n+1)*sizeof<jsmntok_t>
                val valjsv = $UN.cast{jsonval} (add_ptr_bsz(p, ofs))
            in
                loop (jsv, succ(i), n+1+valjsv.numtokens)
            end
        end
in
    loop (jsv, 0, 1)
end

local

#define :: list_vt_cons
#define nil list_vt_nil

in

implement {a}
jsonval_array_map (jsv0) = let

    val () = assertloc (jsonval_is_array (jsv0))

    fun loop (
        jsv: jsonval, i:int, n: int, rs: List0_vt (a)
    ): List0_vt (a) =
        if i = jsv.size then
            list_vt_reverse (rs)
        else let
            val pjs = $UN.cast{ptr} (jsv)
            val ofs = g0i2u(n)*sizeof<jsmntok_t>
            val jsvi = $UN.cast{jsonval} (add_ptr_bsz (pjs, ofs))
            val jsmni = $UN.cast{jsmntokptr}(jsvi)
            (**
            val () = println! ("Parsing element i=", i)
            val () = println! ("Token starts @", jsmni.start)
            *)
            val x = jsonval_parse<a> (jsvi)
         in
             loop (jsv, succ(i), n+jsvi.numtokens, x :: rs)
         end
in
    loop (jsv0, 0, 1, nil)
end

end // end of [local]

(**
  Implementing jsonval using jsmn
*)
//
#include
"patsolve.hats"
//
(* ****** ****** *)

#include
"share/atspre_define.hats"
#include
"share/atspre_staload.hats"

(* ****** ****** *)

staload "parsing/jsonval.sats"

(* ****** ****** *)

staload "{$LIBATSWDBLAIR}/jsmn/SATS/jsmn.sats"
staload _ = "{$LIBATSWDBLAIR}/jsmn/DATS/jsmn.dats"

(* ****** ****** *)

staload "libc/SATS/string.sats"
staload "libc/SATS/stdio.sats"
staload "libc/SATS/stdlib.sats"

(* ****** ****** *)

staload UN = "prelude/SATS/unsafe.sats"

(* ****** ****** *)

assume jsonval = jsmntokptr

(* ****** ****** *)

implement{}
jsmn_src () = jsonval_src ()

(* ****** ****** *)

#define bufsize 1024

(**
    This is unsafe because it assumes that bytes
    that lie outside the boundary m are initialized
    after the call, which they are not.
*)
extern
fun realloc_unsafe {l:addr} {m,n:int} (
    bytes m @ l, mfree_gc_v l |
        ptr l, size_t n
): [k:addr] (
    bytes n @ k, mfree_gc_v k | ptr k
)  = "ext#"

%{

void* realloc_unsafe (void *p, size_t n) {
    void *r = realloc (p, n);

    if (r == NULL) {
        fprintf(stderr, "realloc failed!\n");
        exit(1);
    }

    return r;
}
%}

extern
praxi remove_proof {a:vt@ype} {l:addr} (
    a @ l , mfree_gc_v (l)
): void

extern
praxi array_to_bytes {a:t@ype} {n:int} {l:addr} (
    @[a][n] @ l
): bytes(n*sizeof(a)) @ l

extern
praxi bytes_to_array {a:t@ype} {n:int} {l:addr} (
    bytes(n*sizeof(a)) @ l
):  @[a][n] @ l

(**
    This is as ugly as sin. It would be good to
    clean it up a little bit.
*)
implement
jsonval_parse_from_stdin () = let
    var parser : jsmn_parser
    val () = jsmn_init (parser)

    val (pfjs, pffjs | js) = malloc_gc (i2sz(0))
    val (pftok, pfftok | tok) = malloc_gc (sizeof<jsmntok_t> * i2sz(2))

    prval pfjs = b0ytes2bytes_v (pfjs)
    prval pftok = b0ytes2bytes_v (pftok)

    fun loop {k,l:addr} {m,n:int} (
        pfjson: bytes(m) @ k, pftok: bytes(sizeof(jsmntok_t)*n) @ l,
        pffjson: mfree_gc_v(k), pfftok: mfree_gc_v(l) |
            parser: &jsmn_parser, json: ptr (k), tokens: ptr (l),
            m: size_t (m), n: size_t (n),
            parsed: bool
    ): (string, jsonval) = let
        val stdin = stdin_ref
        var buf : @[byte][bufsize]
        prval () = b0ytes2bytes (buf)

        val r = fread (buf, i2sz(1), i2sz(bufsize), stdin)
    in
        if r < i2sz(0) then let
            (** An error occured *)
            val () = mfree_gc (pfjson, pffjson | json)
            val () = mfree_gc (pftok, pfftok | tokens)
            val () = prerrln! ("fread failed!")
        in
            exit (1)
        end
        else if r = 0 then
            (** Reached end of file *)

            if feof (stdin) != 0 andalso parsed then let
                (**
                     Make sure we have room for the null byte
                *)
                val (pfjson, pffjson | js) =
                    realloc_unsafe (pfjson, pffjson | json, m+i2sz(1))
                val ending = $UN.cast{ptr}(add_ptr_bsz (js, m))
                val () = $UN.ptr0_set (ending, '\0')

                prval () = remove_proof (pfjson, pffjson)
                prval () = remove_proof (pftok, pfftok)

                val str = $UN.cast{string} (js)
                val jsv = $UN.cast{jsonval} (tokens)
            in
                (str, jsv)
            end
            else let
                val () = mfree_gc (pfjson, pffjson | json)
                val () = mfree_gc (pftok, pfftok | tokens)
                val () = prerrln! ("unexpected end of file!")
            in
                exit (1)
            end
        else let
            (** Try parsing again. *)
            val (pfjs, pffjs | js) =
                realloc_unsafe (pfjson, pffjson | json, m+r)
            val newjs = add_ptr_bsz (js, m)
            val _ = strncpy_unsafe (newjs, $UN.cast{string} (buf), r)
            val jslen = m+r

            fun parse {k,l:addr} {m,n:int} (
                pfjs: !bytes(m) @ k, pftok: bytes(sizeof(jsmntok_t)*n) @ l,
                pfftok: mfree_gc_v(l) |
                    parser: &jsmn_parser, js: ptr k, tok: ptr l, m: size_t m, n: size_t n
            ): [q:addr] [o:int](
                bytes(sizeof(jsmntok_t)*o) @ q, mfree_gc_v(q) | ptr q, size_t o, bool
            ) = let
                val err = jsmn_parse (pfjs, pftok | parser, js, m, tok, sz2u(n))
            in
                if err < 0 then
                    if err = JSMN_ERROR_NOMEM then let
                        val tokcount = n * i2sz(2)
                        val newbytes = sizeof<jsmntok_t> * tokcount
                        val (pftok, pfftok | tok) =
                            realloc_unsafe (pftok, pfftok | tok, newbytes)
                    in
                        parse (pfjs, pftok, pfftok | parser, js, tok, m, tokcount)
                    end
                    else
                        (pftok, pfftok |  tok, n, false)
                else
                    (pftok, pfftok | tok, n, true)
            end

            val (pftok, pfftok | tok, tokcount, finished) =
                parse (pfjs, pftok, pfftok | parser, js, tokens, jslen, n)
        in
            loop (pfjs, pftok, pffjs, pfftok | parser, js, tok, jslen, tokcount, finished)
        end  // end of [else]

    end  // end of [loop]
in
    loop (pfjs, pftok, pffjs, pfftok | parser, js, tok, i2sz(0), i2sz(2), false)
end // end of [jsonval_parse_stdin]

(* ****** ****** *)

(**
	Need to account for negative numbers.
	Should just use "atoi" instead.
*)
implement{}
jsonval_is_int (jsv) =
  if jsv.type != JSMN_PRIMITIVE then
    false
  else let
    val [n:int] n = g1ofg0(jsv.size)
    val () = assertloc (n >= 0)
    val src = $UN.cast{string(n)} (jsv.string)

    fun loop {i:nat | i <= n} (src: string(n), i: int i): bool =
      if i = n then
        true
      else let
        val ok = $extfcall (bool, "isdigit", src[i])
      in
        if ~ok then
          false
        else
          loop (src, succ(i))
      end
   in
    loop (src, 0)
   end

implement{}
jsonval_is_string (jsv) = jsv.type = JSMN_STRING

(**
  Need to search for "true" or "false" at its token
  value.
*)
implement{}
jsonval_is_bool (jsv) =
  jsv.type = JSMN_PRIMITIVE andalso
    (strncmp("true", jsv.string, i2sz(4)) = 0 orelse
     strncmp("false", jsv.string, i2sz(4)) = 0)

implement{}
jsonval_is_array (jsv) = jsv.type = JSMN_ARRAY

implement{}
jsonval_is_object (jsv) = jsv.type = JSMN_OBJECT

(* ****** ****** *)

implement{}
int_of_jsonval (jsv) = let
    val str = jsv.string
    val i = strtol (str, 10)
in
    $UN.cast{int} (i)
end

implement{}
bool_of_jsonval (jsv) = let
    val str = jsv.string
in
    strcmp (str, "true") = 0
end

(* ****** ****** *)

implement{}
jsonval_get_string (jsv) = let
  val src = jsonval_src ()
  val buf = add_ptr_bsz($UN.cast{ptr}(src), g0i2u(jsv.start))
in
  $UN.cast{string} (buf)
end

implement{}
jsonval_get_copy_string (jsv) = let
    val str = jsv.string
    val size = g1ofg0(jsv.ending - jsv.start)

    val () = assertloc(size >= 0)
    val size = i2sz(size)

    val buf = arrayptr_make_elt<char> (size+i2sz(1), '\0')
    val copy = $UN.castvwtp0{Ptr} (buf)
    val _ = strncpy_unsafe (copy, str, size)
in
    $UN.cast{string} (copy)
end

implement{}
jsonval_get_string_unsafe (jsv) = let
    val str = jsv.string
    val size = jsv.ending - jsv.start

    val p = $UN.cast{ptr} (str)
    val pend = add_ptr_bsz (p, g0i2u(size))
    val () = $UN.ptr0_set (pend, '\0')
in
    str
end

implement
jsonval_size (jsv) = jsmntok_size (jsv)

implement{}
jsonval_array_get_at_exn (jsv, i) = let
  val () = assertloc(i >= 0 andalso i < jsv.size)
  val p = $UN.cast{ptr} (jsv)

  fun loop (jsv: jsonval, j:int, n:int): int =
      if j = i then
          n
      else let
          val p = $UN.cast{ptr} (jsv)
          val ofs =  g0i2u(n)*sizeof<jsmntok_t>
          val nextjsv = $UN.cast{jsonval} (add_ptr_bsz(p, ofs))
      in
          loop (jsv, succ(j), n + nextjsv.numtokens)
      end

  val j = loop (jsv, 0, 1)
  val p = $UN.cast{ptr} (jsv)
  val ofs = g0i2u(j)*sizeof<jsmntok_t>
  val q = add_ptr_bsz(p, ofs)
in
  $UN.cast{jsonval}(q)
end

implement{}
jsonval_object_get_key_exn (jsv, label) = let
     val () =
        if ~jsonval_is_object (jsv) then {
            val () = println! ("Expected object but found: ", jsv.type)
	    val () = println! ("Looking for label:", label)
            val () = println! ("Token starts @  ", jsv.start)
            val () = println! ("Data:", jsv.string_unsafe)
        }

    val () = assertloc (jsonval_is_object (jsv))

    fun loop (jsv: jsonval, i:int, n:int): jsonval =
         if i = jsv.size then let
            val () = prerrln! ("key ", label, " not found")
         in
             exit(1)
         end
         else let
             val p = $UN.cast{ptr} (jsv)
             val ofs = g0i2u(n)*sizeof<jsmntok_t>
             val keyjsv = $UN.cast{jsonval} (add_ptr_bsz (p, ofs))
             val () =
                 if ~jsonval_is_string (keyjsv) then begin
                     println! ("Key is not string! While looking for key ", label);
                     println! ("Found type: ", keyjsv.type);
                     println! ("ofs = ", n);
                     println! ("start =", keyjsv.start);
                 end

             val () = assertloc (jsonval_is_string (keyjsv))
             val key = keyjsv.string
             val ofs = g0i2u(n+1)*sizeof<jsmntok_t>
             val valjsv = $UN.cast{jsonval} (add_ptr_bsz(p, ofs))
         in
            if strncmp (key, label, length (label)) = 0 then let
               (**
               val () = println! ("Found value for key ", label)
               val () = println! ("JSON key is ", keyjsv.string_unsafe)
               val () = println! ("JSON value is ", valjsv.string_unsafe)
               *)
            in
               valjsv
            end
            else let
               val valsize = valjsv.numtokens
               (**
               val () = println! ("object_get_key: at offset ", n)
               val () = println! ("object_get_key: at key i=", i)
               val () = println! ("object_get_key: found object of size", valsize)
               *)
               val nextoffset = n + 1 + valsize
               // val () = println! ("object_get_key: looking at offset ", nextoffset, " next")
            in
               loop (jsv, succ(i), nextoffset)
            end
        end
in
    loop (jsv, 0, 1)
end

implement{}
jsonval_object_has_key (jsv, label) = let
    val () =
        if ~jsonval_is_object (jsv) then {
            val () = println! ("Expected object but found: ", jsv.type)
	    val () = println! ("Looking for label:", label)
            val () = println! ("Token starts @  ", jsv.start)
            val () = println! ("Data:", jsv.string_unsafe)
        }

    val () = assertloc (jsonval_is_object (jsv))

    fun loop (jsv: jsonval, i:int, n:int): bool =
        if i = jsv.size then
            false
        else let
             val p = $UN.cast{ptr} (jsv)
             val ofs = g0i2u(n)*sizeof<jsmntok_t>
             val keyjsv = $UN.cast{jsonval} (add_ptr_bsz (p, ofs))
             val () = assertloc (jsonval_is_string (keyjsv))
             val key = keyjsv.string
             val targetlen = length (label)
             val srclen = keyjsv.ending - keyjsv.start
        in
            if targetlen = srclen andalso
                   strncmp (key, label, length (label)) = 0 then
                true
            else let
                val ofs = g0i2u(n+1)*sizeof<jsmntok_t>
                val valjsv = $UN.cast{jsonval} (add_ptr_bsz(p, ofs))
            in
                loop (jsv, succ(i), n+1+valjsv.numtokens)
            end
        end
in
    loop (jsv, 0, 1)
end

local

#define :: list_vt_cons
#define nil list_vt_nil

in

implement {a}
jsonval_array_map (jsv0) = let

    val () = assertloc (jsonval_is_array (jsv0))

    fun loop (
        jsv: jsonval, i:int, n: int, rs: List0_vt (a)
    ): List0_vt (a) =
        if i = jsv.size then
            list_vt_reverse (rs)
        else let
            val pjs = $UN.cast{ptr} (jsv)
            val ofs = g0i2u(n)*sizeof<jsmntok_t>
            val jsvi = $UN.cast{jsonval} (add_ptr_bsz (pjs, ofs))
            val jsmni = $UN.cast{jsmntokptr}(jsvi)
            (**
            val () = println! ("Parsing element i=", i)
            val () = println! ("Token starts @", jsmni.start)
            *)
            val x = jsonval_parse<a> (jsvi)
         in
             loop (jsv, succ(i), n+jsvi.numtokens, x :: rs)
         end
in
    loop (jsv0, 0, 1, nil)
end

end // end of [local]


Remove effect annotations

Remove effect annotations

staload "static/errno.sats"

absview filedes (fd: int)

prfn lemma_filedes_natural {n: int} (pf: !filedes n):
  [n >= 0] void

(* Even if close fails, we shouldn't consider the fd still open.
 From close(2) on my system:
 > Not checking the return value of close() is a common but nevertheless serious
 > programming error. It is quite possible that errors on a previous write(2)
 > operation are first reported at the final close(). Not checking the return
 > value when closing the file may lead to silent loss of data. This can espe‐
 > cially be observed with NFS and with disk quota. Note that the return value
 > should only be used for diagnostics. In particular close() should not be
 > retried after an EINTR since this may cause a reused descriptor from another
 > thread to be closed
*)
fn close {fd: nat} (filedes fd | int fd):
  [res: int] (option_v(errno_obligation, res == ~1) | int res)

staload "static/errno.sats"

absview filedes (fd: int)

prfn lemma_filedes_natural {n: int} (pf: !filedes n):<prf>
  [n >= 0] void

(* Even if close fails, we shouldn't consider the fd still open.
 From close(2) on my system:
 > Not checking the return value of close() is a common but nevertheless serious
 > programming error. It is quite possible that errors on a previous write(2)
 > operation are first reported at the final close(). Not checking the return
 > value when closing the file may lead to silent loss of data. This can espe‐
 > cially be observed with NFS and with disk quota. Note that the return value
 > should only be used for diagnostics. In particular close() should not be
 > retried after an EINTR since this may cause a reused descriptor from another
 > thread to be closed
*)
fn close {fd: nat} (filedes fd | int fd):
  [res: int] (option_v(errno_obligation, res == ~1) | int res)


Updating: very minorly fixing

Updating: very minorly fixing

(***********************************************************************)
(*                                                                     *)
(*                       ATS/contrib/libats-hwxi                       *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2014 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
** OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
** THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
** IN THE SOFTWARE.
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
staload UN =
"prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

#define NULL the_null_ptr

(* ****** ****** *)

staload "{$GTK}/SATS/gdk.sats"
staload "{$GTK}/SATS/gtk.sats"
staload "{$GLIB}/SATS/glib.sats"
staload "{$GLIB}/SATS/glib-object.sats"

(* ****** ****** *)
//
staload "./gtkcairotimer_toplevel.dats"
//
(* ****** ****** *)

extern
fun{} button_on (btn: ptr): void
extern
fun{} button_off (btn: ptr): void

implement{
} button_on (btn) =
{
  val btn = $UN.castvwtp0{GtkButton1}(btn)
  val () = gtk_widget_set_sensitive (btn, GTRUE)
  prval () = $UN.cast2void (btn)
}
implement{
} button_off (btn) =
{
  val btn = $UN.castvwtp0{GtkButton1}(btn)
  val () = gtk_widget_set_sensitive (btn, GFALSE)
  prval () = $UN.cast2void (btn)
}

(* ****** ****** *)

extern
fun{}
on_start_clicked
(
  widget: !GtkWidget1, event: &GdkEvent, _: gpointer
) : void
implement{
} on_start_clicked (widget, event, _) =
{
  val () = the_timer_start ()
  val () = button_on ($BUTTONfinish.get ())
  val () = button_on ($BUTTONpause.get ())
  val () = button_on ($BUTTONreset.get ())
  val () = button_off ($BUTTONstart.get ())
}

(* ****** ****** *)

extern
fun{}
on_finish_clicked
(
  widget: !GtkWidget1, event: &GdkEvent, _: gpointer
) : void
implement{
} on_finish_clicked (widget, event, _) =
{
  val () = the_timer_finish ()
  val () = button_off ($BUTTONfinish.get ())
  val () = button_off ($BUTTONpause.get ())
  val () = button_off ($BUTTONresume.get ())
}

(* ****** ****** *)

extern
fun{}
on_pause_clicked
(
  widget: !GtkWidget1, event: &GdkEvent, _: gpointer
) : void
implement{
} on_pause_clicked (widget, event, _) =
{
  val () = the_timer_pause ()
  val () = button_on ($BUTTONresume.get ())
  val () = button_off ($BUTTONpause.get ())
}

(* ****** ****** *)

extern
fun{}
on_resume_clicked
(
  widget: !GtkWidget1, event: &GdkEvent, _: gpointer
) : void
implement{
} on_resume_clicked (widget, event, _) =
{
  val () = the_timer_resume ()
  val () = button_on ($BUTTONpause.get ())
  val () = button_off ($BUTTONresume.get ())
}

(* ****** ****** *)

extern
fun{}
on_reset_clicked
(
  widget: !GtkWidget1, event: &GdkEvent, _: gpointer
) : void
implement{
} on_reset_clicked (widget, event, _) =
{
  val () = the_timer_reset ()
  val () = the_timer_reset_after<> ()
  val () = button_on ($BUTTONstart.get ())
  val () = button_off ($BUTTONfinish.get ())
  val () = button_off ($BUTTONpause.get ())
  val () = button_off ($BUTTONresume.get ())
  val () = button_off ($BUTTONreset.get ())
}

(* ****** ****** *)

extern
fun{}
on_quit_clicked
(
  widget: !GtkWidget1, event: &GdkEvent, _: gpointer
) : void
implement{
} on_quit_clicked (widget, event, _) = gtk_main_quit ((*void*))

(* ****** ****** *)

extern
fun{}
on_quit_clicked_dialog
(
  wdgt: !GtkWidget1
, event: &GdkEvent, gdata: gpointer
) : void
implement{
} on_quit_clicked_dialog
  (widget, event, gdata) = let
//
typedef charptr = $extype"char*"
//
val flags =
  GTK_DIALOG_DESTROY_WITH_PARENT
val mtype = GTK_MESSAGE_QUESTION
val buttons = GTK_BUTTONS_NONE
//
val topwin = $TOPWIN.get ()
//
val p0 =
$extfcall (ptr
, "atscntrb_gtk_message_dialog_new"
, topwin, flags, mtype, buttons, $UN.cast{charptr}("Quit?")
) (* end of [val] *)
val () = assertloc (p0 > 0)
val p1 = $extfcall (ptr, "g_object_ref_sink", p0)
val dialog = $UN.castvwtp0{gobjref1(GtkMessageDialog)}(p1)
val () = gtk_window_set_title (dialog, gstring("Confirmation"))
val () =
$extfcall (void
, "atscntrb_gtk_dialog_add_buttons"
, p1, $UN.cast{charptr}("Yes"), GTK_RESPONSE_YES, $UN.cast{charptr}("No"), GTK_RESPONSE_NO, NULL
) (* end of [val] *)
//
val topwin =
$UN.castvwtp0{GtkWindow1}(topwin)
val () = gtk_window_set_transient_for (dialog, topwin(*parent*))
prval () = $UN.cast2void (topwin)
//
val yn = gtk_dialog_run (dialog)
val ((*freed*)) = gtk_widget_destroy0 (dialog)
val yes = $UN.cast2int(GTK_RESPONSE_YES)
//
in
//
case+ 0 of
| _ when yn = yes =>
    on_quit_clicked (widget, event, gdata)
| _ (*non-yes*) => () // quit is not confirmed
//
end (* end of [on_quit_clicked_dialog] *)

(* ****** ****** *)

local
//
extern
fun{}
ftimeout
  {c:cls;l:agz | c <= GtkWidget} (!gobjref (c, l)): gboolean
//
in (* in-of-local *)

implement{
} ftimeout
  (widget) = let
//
val n = $NCLICK.get ()
//
val () =
if n > 0 then {
  val () = $NCLICK.set (0)
  val (pf, fpf | p_event) = $UN.ptr0_vtake{GdkEvent}(NULL)
  val () = on_quit_clicked_dialog (widget, !p_event, (gpointer)NULL)
  prval ((*void*)) = fpf (pf)
} (* end of [if] *)
//
in
  GFALSE
end // end of [ftimeout]

(* ****** ****** *)

extern
fun{}
on_quit_clicked2
(
  wdgt: !GtkWidget1
, event: &GdkEvent, gdata: gpointer
) : void
implement{
} on_quit_clicked2
  (widget, event, gdata) = let
//
val n = $NCLICK.get ()
val () = if n = 0 then $NCLICK.set (1) else $NCLICK.set (0)
//
in
//
case+ 0 of
| _ when n = 0 =>
  {
    val p = ptrcast(widget)
    val _ = g_timeout_add
      ((guint)200, (GSourceFunc)ftimeout, (gpointer)p)
    // end of [g_timeout_add]
  }
| _ when n = 1 => on_quit_clicked (widget, event, gdata)
| _ (*impossible*) => ()
//
end // end of [on_quit_clicked2]

end // end of [local]

(* ****** ****** *)

extern
fun{}
ControlPanel_make (): gobjref1(GtkBox)

(* ****** ****** *)

implement{
} ControlPanel_make
(
  // argumentless
) = let
//
val vbox0 =
gtk_box_new
(
  GTK_ORIENTATION_VERTICAL(*orient*), (gint)10(*spacing*)
) (* end of [val] *)
val () = assertloc (ptrcast (vbox0) > 0)
//
val hbox1 =
gtk_box_new
(
  GTK_ORIENTATION_HORIZONTAL(*orient*), (gint)0(*spacing*)
) (* end of [val] *)
val () = assertloc (ptrcast (hbox1) > 0)
val () =
gtk_box_pack_start
(
  vbox0, hbox1, GTRUE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val () = g_object_unref (hbox1)
//
val button_start =
gtk_button_new_with_label((gstring)"Start")
val p_button_start = ptrcast (button_start)
val () = assertloc (p_button_start > the_null_ptr)
val () = $BUTTONstart.set (p_button_start)
val () =
gtk_box_pack_start
(
  vbox0, button_start, GFALSE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val _sid = g_signal_connect
(
  button_start, (gsignal)"clicked", G_CALLBACK(on_start_clicked), (gpointer)NULL
)
val () = g_object_unref (button_start)
//
val button_finish =
gtk_button_new_with_label((gstring)"Finish")
val p_button_finish = ptrcast (button_finish)
val () = assertloc (p_button_finish > the_null_ptr)
val () = $BUTTONfinish.set (p_button_finish)
val () =
gtk_box_pack_start
(
  vbox0, button_finish, GFALSE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val _sid = g_signal_connect
(
  button_finish, (gsignal)"clicked", G_CALLBACK(on_finish_clicked), (gpointer)NULL
)
val () = g_object_unref (button_finish)
//
val button_pause =
gtk_button_new_with_label((gstring)"Pause")
val p_button_pause = ptrcast (button_pause)
val () = $BUTTONpause.set (p_button_pause)
val () = assertloc (p_button_pause > the_null_ptr)
val () =
gtk_box_pack_start
(
  vbox0, button_pause, GFALSE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val _sid = g_signal_connect
(
  button_pause, (gsignal)"clicked", G_CALLBACK(on_pause_clicked), (gpointer)NULL
)
val () = g_object_unref (button_pause)
//
val button_resume =
gtk_button_new_with_label((gstring)"Resume")
val p_button_resume = ptrcast (button_resume)
val () = $BUTTONresume.set (p_button_resume)
val () = assertloc (p_button_resume > the_null_ptr)
val () =
gtk_box_pack_start
(
  vbox0, button_resume, GFALSE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val _sid = g_signal_connect
(
  button_resume, (gsignal)"clicked", G_CALLBACK(on_resume_clicked), (gpointer)NULL
)
val () = g_object_unref (button_resume)
//
val button_reset =
gtk_button_new_with_label ((gstring)"Reset")
val p_button_reset = ptrcast (button_reset)
val () = assertloc (p_button_reset > the_null_ptr)
val () = $BUTTONreset.set (p_button_reset)
val () =
gtk_box_pack_start
(
  vbox0, button_reset, GFALSE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val _sid = g_signal_connect
(
  button_reset, (gsignal)"clicked", G_CALLBACK(on_reset_clicked), (gpointer)NULL
)
val () = g_object_unref (button_reset)
//
val button_quit =
gtk_button_new_with_mnemonic ((gstring)"_Quit")
val () = assertloc (ptrcast (button_quit) > 0)
val () =
gtk_box_pack_start
(
  vbox0, button_quit, GFALSE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val _sid = g_signal_connect
(
  button_quit, (gsignal)"clicked", G_CALLBACK(on_quit_clicked2), (gpointer)NULL
)
val () = g_object_unref (button_quit)
//
val hbox2 =
gtk_box_new
(
  GTK_ORIENTATION_HORIZONTAL(*orient*), (gint)0(*spacing*)
) (* end of [val] *)
val () = assertloc (ptrcast (hbox2) > 0)
val () =
gtk_box_pack_start
(
  vbox0, hbox2, GTRUE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val () = g_object_unref (hbox2)
//
val () = button_on ($BUTTONstart.get ())
val () = button_off ($BUTTONfinish.get ())
val () = button_off ($BUTTONpause.get ())
val () = button_off ($BUTTONresume.get ())
val () = button_off ($BUTTONreset.get ())
//
in
  vbox0
end // end of [ControlPanel_make]

(* ****** ****** *)

(* end of [ControlPanel.dats] *)

(***********************************************************************)
(*                                                                     *)
(*                       ATS/contrib/libats-hwxi                       *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2014 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
** OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
** THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
** IN THE SOFTWARE.
*)

(* ****** ****** *)
//
#include
"share/atspre_define.hats"
//
(* ****** ****** *)
//
staload UN =
"prelude/SATS/unsafe.sats"
//
(* ****** ****** *)

#define NULL the_null_ptr

(* ****** ****** *)

staload "{$GTK}/SATS/gdk.sats"
staload "{$GTK}/SATS/gtk.sats"
staload "{$GLIB}/SATS/glib.sats"
staload "{$GLIB}/SATS/glib-object.sats"

(* ****** ****** *)
//
staload "./gtkcairotimer_toplevel.dats"
//
(* ****** ****** *)

extern
fun{} button_on (btn: ptr): void
extern
fun{} button_off (btn: ptr): void

implement{
} button_on (btn) =
{
  val btn = $UN.castvwtp0{GtkButton1}(btn)
  val () = gtk_widget_set_sensitive (btn, GTRUE)
  prval () = $UN.cast2void (btn)
}
implement{
} button_off (btn) =
{
  val btn = $UN.castvwtp0{GtkButton1}(btn)
  val () = gtk_widget_set_sensitive (btn, GFALSE)
  prval () = $UN.cast2void (btn)
}

(* ****** ****** *)

extern
fun{}
on_start_clicked
(
  widget: !GtkWidget1, event: &GdkEvent, _: gpointer
) : void
implement{
} on_start_clicked (widget, event, _) =
{
  val () = the_timer_start ()
  val () = button_on ($BUTTONfinish.get ())
  val () = button_on ($BUTTONpause.get ())
  val () = button_on ($BUTTONreset.get ())
  val () = button_off ($BUTTONstart.get ())
}

(* ****** ****** *)

extern
fun{}
on_finish_clicked
(
  widget: !GtkWidget1, event: &GdkEvent, _: gpointer
) : void
implement{
} on_finish_clicked (widget, event, _) =
{
  val () = the_timer_finish ()
  val () = button_off ($BUTTONfinish.get ())
  val () = button_off ($BUTTONpause.get ())
}

(* ****** ****** *)

extern
fun{}
on_pause_clicked
(
  widget: !GtkWidget1, event: &GdkEvent, _: gpointer
) : void
implement{
} on_pause_clicked (widget, event, _) =
{
  val () = the_timer_pause ()
  val () = button_on ($BUTTONresume.get ())
  val () = button_off ($BUTTONpause.get ())
}

(* ****** ****** *)

extern
fun{}
on_resume_clicked
(
  widget: !GtkWidget1, event: &GdkEvent, _: gpointer
) : void
implement{
} on_resume_clicked (widget, event, _) =
{
  val () = the_timer_resume ()
  val () = button_on ($BUTTONpause.get ())
  val () = button_off ($BUTTONresume.get ())
}

(* ****** ****** *)

extern
fun{}
on_reset_clicked
(
  widget: !GtkWidget1, event: &GdkEvent, _: gpointer
) : void
implement{
} on_reset_clicked (widget, event, _) =
{
  val () = the_timer_reset ()
  val () = the_timer_reset_after<> ()
  val () = button_on ($BUTTONstart.get ())
  val () = button_off ($BUTTONfinish.get ())
  val () = button_off ($BUTTONpause.get ())
  val () = button_off ($BUTTONresume.get ())
  val () = button_off ($BUTTONreset.get ())
}

(* ****** ****** *)

extern
fun{}
on_quit_clicked
(
  widget: !GtkWidget1, event: &GdkEvent, _: gpointer
) : void
implement{
} on_quit_clicked (widget, event, _) = gtk_main_quit ((*void*))

(* ****** ****** *)

extern
fun{}
on_quit_clicked_dialog
(
  wdgt: !GtkWidget1
, event: &GdkEvent, gdata: gpointer
) : void
implement{
} on_quit_clicked_dialog
  (widget, event, gdata) = let
//
typedef charptr = $extype"char*"
//
val flags =
  GTK_DIALOG_DESTROY_WITH_PARENT
val mtype = GTK_MESSAGE_QUESTION
val buttons = GTK_BUTTONS_NONE
//
val topwin = $TOPWIN.get ()
//
val p0 =
$extfcall (ptr
, "atscntrb_gtk_message_dialog_new"
, topwin, flags, mtype, buttons, $UN.cast{charptr}("Quit?")
) (* end of [val] *)
val () = assertloc (p0 > 0)
val p1 = $extfcall (ptr, "g_object_ref_sink", p0)
val dialog = $UN.castvwtp0{gobjref1(GtkMessageDialog)}(p1)
val () = gtk_window_set_title (dialog, gstring("Confirmation"))
val () =
$extfcall (void
, "atscntrb_gtk_dialog_add_buttons"
, p1, $UN.cast{charptr}("Yes"), GTK_RESPONSE_YES, $UN.cast{charptr}("No"), GTK_RESPONSE_NO, NULL
) (* end of [val] *)
//
val topwin =
$UN.castvwtp0{GtkWindow1}(topwin)
val () = gtk_window_set_transient_for (dialog, topwin(*parent*))
prval () = $UN.cast2void (topwin)
//
val yn = gtk_dialog_run (dialog)
val ((*freed*)) = gtk_widget_destroy0 (dialog)
val yes = $UN.cast2int(GTK_RESPONSE_YES)
//
in
//
case+ 0 of
| _ when yn = yes =>
    on_quit_clicked (widget, event, gdata)
| _ (*non-yes*) => () // quit is not confirmed
//
end (* end of [on_quit_clicked_dialog] *)

(* ****** ****** *)

local
//
extern
fun{}
ftimeout
  {c:cls;l:agz | c <= GtkWidget} (!gobjref (c, l)): gboolean
//
in (* in-of-local *)

implement{
} ftimeout
  (widget) = let
//
val n = $NCLICK.get ()
//
val () =
if n > 0 then {
  val () = $NCLICK.set (0)
  val (pf, fpf | p_event) = $UN.ptr0_vtake{GdkEvent}(NULL)
  val () = on_quit_clicked_dialog (widget, !p_event, (gpointer)NULL)
  prval ((*void*)) = fpf (pf)
} (* end of [if] *)
//
in
  GFALSE
end // end of [ftimeout]

(* ****** ****** *)

extern
fun{}
on_quit_clicked2
(
  wdgt: !GtkWidget1
, event: &GdkEvent, gdata: gpointer
) : void
implement{
} on_quit_clicked2
  (widget, event, gdata) = let
//
val n = $NCLICK.get ()
val () = if n = 0 then $NCLICK.set (1) else $NCLICK.set (0)
//
in
//
case+ 0 of
| _ when n = 0 =>
  {
    val p = ptrcast(widget)
    val _ = g_timeout_add
      ((guint)200, (GSourceFunc)ftimeout, (gpointer)p)
    // end of [g_timeout_add]
  }
| _ when n = 1 => on_quit_clicked (widget, event, gdata)
| _ (*impossible*) => ()
//
end // end of [on_quit_clicked2]

end // end of [local]

(* ****** ****** *)

extern
fun{}
ControlPanel_make (): gobjref1(GtkBox)

(* ****** ****** *)

implement{
} ControlPanel_make
(
  // argumentless
) = let
//
val vbox0 =
gtk_box_new
(
  GTK_ORIENTATION_VERTICAL(*orient*), (gint)10(*spacing*)
) (* end of [val] *)
val () = assertloc (ptrcast (vbox0) > 0)
//
val hbox1 =
gtk_box_new
(
  GTK_ORIENTATION_HORIZONTAL(*orient*), (gint)0(*spacing*)
) (* end of [val] *)
val () = assertloc (ptrcast (hbox1) > 0)
val () =
gtk_box_pack_start
(
  vbox0, hbox1, GTRUE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val () = g_object_unref (hbox1)
//
val button_start =
gtk_button_new_with_label((gstring)"Start")
val p_button_start = ptrcast (button_start)
val () = assertloc (p_button_start > the_null_ptr)
val () = $BUTTONstart.set (p_button_start)
val () =
gtk_box_pack_start
(
  vbox0, button_start, GFALSE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val _sid = g_signal_connect
(
  button_start, (gsignal)"clicked", G_CALLBACK(on_start_clicked), (gpointer)NULL
)
val () = g_object_unref (button_start)
//
val button_finish =
gtk_button_new_with_label((gstring)"Finish")
val p_button_finish = ptrcast (button_finish)
val () = assertloc (p_button_finish > the_null_ptr)
val () = $BUTTONfinish.set (p_button_finish)
val () =
gtk_box_pack_start
(
  vbox0, button_finish, GFALSE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val _sid = g_signal_connect
(
  button_finish, (gsignal)"clicked", G_CALLBACK(on_finish_clicked), (gpointer)NULL
)
val () = g_object_unref (button_finish)
//
val button_pause =
gtk_button_new_with_label((gstring)"Pause")
val p_button_pause = ptrcast (button_pause)
val () = $BUTTONpause.set (p_button_pause)
val () = assertloc (p_button_pause > the_null_ptr)
val () =
gtk_box_pack_start
(
  vbox0, button_pause, GFALSE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val _sid = g_signal_connect
(
  button_pause, (gsignal)"clicked", G_CALLBACK(on_pause_clicked), (gpointer)NULL
)
val () = g_object_unref (button_pause)
//
val button_resume =
gtk_button_new_with_label((gstring)"Resume")
val p_button_resume = ptrcast (button_resume)
val () = $BUTTONresume.set (p_button_resume)
val () = assertloc (p_button_resume > the_null_ptr)
val () =
gtk_box_pack_start
(
  vbox0, button_resume, GFALSE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val _sid = g_signal_connect
(
  button_resume, (gsignal)"clicked", G_CALLBACK(on_resume_clicked), (gpointer)NULL
)
val () = g_object_unref (button_resume)
//
val button_reset =
gtk_button_new_with_label ((gstring)"Reset")
val p_button_reset = ptrcast (button_reset)
val () = assertloc (p_button_reset > the_null_ptr)
val () = $BUTTONreset.set (p_button_reset)
val () =
gtk_box_pack_start
(
  vbox0, button_reset, GFALSE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val _sid = g_signal_connect
(
  button_reset, (gsignal)"clicked", G_CALLBACK(on_reset_clicked), (gpointer)NULL
)
val () = g_object_unref (button_reset)
//
val button_quit =
gtk_button_new_with_mnemonic ((gstring)"_Quit")
val () = assertloc (ptrcast (button_quit) > 0)
val () =
gtk_box_pack_start
(
  vbox0, button_quit, GFALSE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val _sid = g_signal_connect
(
  button_quit, (gsignal)"clicked", G_CALLBACK(on_quit_clicked2), (gpointer)NULL
)
val () = g_object_unref (button_quit)
//
val hbox2 =
gtk_box_new
(
  GTK_ORIENTATION_HORIZONTAL(*orient*), (gint)0(*spacing*)
) (* end of [val] *)
val () = assertloc (ptrcast (hbox2) > 0)
val () =
gtk_box_pack_start
(
  vbox0, hbox2, GTRUE(*expand*), GFALSE(*fill*), (guint)2
) (* end of [val] *)
val () = g_object_unref (hbox2)
//
val () = button_on ($BUTTONstart.get ())
val () = button_off ($BUTTONfinish.get ())
val () = button_off ($BUTTONpause.get ())
val () = button_off ($BUTTONresume.get ())
val () = button_off ($BUTTONreset.get ())
//
in
  vbox0
end // end of [ControlPanel_make]

(* ****** ****** *)

(* end of [ControlPanel.dats] *)


Updating: very minorly improving

Updating: very minorly improving

(*
** For writing ATS code
** that translates into JavaScript
*)

(* ****** ****** *)

(*
** Permission to use, copy, modify, and distribute this software for any
** purpose with or without fee is hereby granted, provided that the above
** copyright notice and this permission notice appear in all copies.
**
** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
** WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
** MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
** ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
** WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
** ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)

(* ****** ****** *)

(*
** Author: Hongwei Xi
** Authoremail: gmhwxi AT gmail DOT com
** Start Time: April, 2015
*)

(* ****** ****** *)

#define
ATS_STALOADFLAG 0 // no staloading at run-time
#define
ATS_EXTERN_PREFIX "ats2js_bacon_" // prefix for external names

(* ****** ****** *)
//
staload
"./../../basics_js.sats"
//
(* ****** ****** *)
//
(*
For Opaque values
*)
abstype Value = ptr
//
abstype Event = ptr
//
abstype
EStream(a:t@ype) = ptr // invariant!
abstype
Property(a:t@ype) = ptr // invariant!
//
(* ****** ****** *)

fun Bacon_more(): Value = "mac#%"
fun Bacon_noMore(): Value = "mac#%"

(* ****** ****** *)
//
fun
Bacon_once
  {a:t0p}(x: a): EStream(a) = "mac#%"
fun
Bacon_never
  {a:t0p}((*void*)): EStream(a) = "mac#%"
//
(* ****** ****** *)
//
fun
Bacon_delay
  {a:t0p}
  (ms: intGte(0), x: a): EStream(a) = "mac#%"
//
(* ****** ****** *)
//
fun
Bacon_interval
  {a:t0p}
  (ms: intGte(0), x: a): EStream(a) = "mac#%"
//
fun
Bacon_repeatedly
  {a:t0p}
  (ms: intGte(0), xs: JSarray(a)): EStream(a) = "mac#%"
//
fun
Bacon_sequentially
  {a:t0p}
  (ms: intGte(0), xs: JSarray(a)): EStream(a) = "mac#%"
//
(* ****** ****** *)
//
fun
Bacon_repeat{a:t0p}
(
  fopr: cfun(intGte(0), EStream(a))
) : EStream(a) = "mac#%" // end-of-fun
//
(* ****** ****** *)
//
fun
EStream_map
  {a:t0p}{b:t0p}
(
  xs: EStream(a), fopr: cfun(a, b)
) : EStream(b) = "mac#%" // end-of-fun
fun
Property_map
  {a:t0p}{b:t0p}
(
  xs: Property(a), fopr: cfun(a, b)
) : Property(b) = "mac#%" // end-of-fun
//
overload map with EStream_map
overload map with Property_map
overload .map with EStream_map
overload .map with Property_map
//
(* ****** ****** *)
//
fun
EStream_map_property
  {a:t0p}{b:t0p}
(
  xs: EStream(a), ys: Property(b)
) : EStream(b) = "mac#%" // end-of-fun
//
overload map with EStream_map_property
overload .map with EStream_map_property
//
(* ****** ****** *)
//
fun
EStream_filter
  {a:t0p}
(
  xs: EStream(a), test: cfun(a, bool)
) : EStream(a) = "mac#%" // end-of-fun
//
overload filter with EStream_filter
overload .filter with EStream_filter
//
(* ****** ****** *)
//
fun
EStream_filter_property
  {a:t0p}
(
  xs: EStream(a), bs: Property(bool)
) : EStream(a) = "mac#%" // end-of-fun
//
overload filter with EStream_filter_property
overload .filter with EStream_filter_property
//
(* ****** ****** *)
//
fun
EStream_scan
  {a,b:t0p}
(
  xs: EStream(b), ini: a, fopr: cfun(a, b, a)
) : Property(a) = "mac#%" // end-of-function
//
overload scan with EStream_scan
overload .scan with EStream_scan
//
(* ****** ****** *)
//
fun
EStream_merge2
  {a:t0p}
  (EStream(a), EStream(a)): EStream(a) = "mac#%"
fun
EStream_merge3
  {a:t0p}
  (EStream(a), EStream(a), EStream(a)): EStream(a) = "mac#%"
//
overload merge with EStream_merge2
overload merge with EStream_merge3
//
overload .merge with EStream_merge2
overload .merge with EStream_merge3
//
(* ****** ****** *)
//
fun
Bacon_combineWith2
  {a,b:t0p}{c:t0p}
(
  Property(a), Property(b), cfun(a, b, c)
) : Property(c) = "mac#%" // end-of-function
fun
Bacon_combineWith3
  {a,b,c:t0p}{d:t0p}
(
  Property(a), Property(b), Property(c), cfun(a, b, c, d)
) : Property(d) = "mac#%" // end-of-function
//
overload combineWith with Bacon_combineWith2
overload combineWith with Bacon_combineWith3
//
(* ****** ****** *)
//
fun
EStream_toProperty
  {a:t0p}(EStream(a)): Property(a) = "mac#%"
fun
EStream_toProperty_init
  {a:t0p}(EStream(a), x0: a): Property(a) = "mac#%"
//
overload toProperty with EStream_toProperty
overload toProperty with EStream_toProperty_init
overload .toProperty with EStream_toProperty
overload .toProperty with EStream_toProperty_init
//
fun
Property_toEventStream
  {a:t0p}(Property(a)): EStream(a) = "mac#%"
//
overload toEventStream with Property_toEventStream
overload .toEventStream with Property_toEventStream
//
(* ****** ****** *)
//
fun
EStream_onValue
  {a:t0p}(EStream(a), cfun(a, void)): void = "mac#%"
fun
Property_onValue
  {a:t0p}(Property(a), cfun(a, void)): void = "mac#%"
//
overload onValue with EStream_onValue
overload onValue with Property_onValue
overload .onValue with EStream_onValue
overload .onValue with Property_onValue
//
(* ****** ****** *)
//
fun
EStream_subscribe
  {a:t0p}(EStream(a), cfun(Event, void)): void = "mac#%"
fun
Property_subscribe
  {a:t0p}(Property(a), cfun(Event, void)): void = "mac#%"
//
overload subscribe with EStream_subscribe
overload subscribe with Property_subscribe
overload .subscribe with EStream_subscribe
overload .subscribe with Property_subscribe
//
(* ****** ****** *)
//
fun
Property_startWith
  {a:t0p}(Property(a), a): Property(a) = "mac#%"
//
(* ****** ****** *)
//
fun
EStream_doAction
  {a:t0p}
  (xs: EStream(a), f: cfun(a, void)): EStream(a) = "mac#%"
fun
Property_doAction
  {a:t0p}
  (xs: Property(a), f: cfun(a, void)): Property(a) = "mac#%"
//
overload doAction with EStream_doAction
overload doAction with Property_doAction
overload .doAction with EStream_doAction
overload .doAction with Property_doAction
//
(* ****** ****** *)
//
fun
Property_sampledBy_estream
  {a,b:t0p}(Property(a), EStream(b)): EStream(a) = "mac#%"
fun
Property_sampledBy_property
  {a,b:t0p}(Property(a), Property(b)): Property(a) = "mac#%"
//
overload sampledBy with Property_sampledBy_estream
overload sampledBy with Property_sampledBy_property
overload .sampledBy with Property_sampledBy_estream
overload .sampledBy with Property_sampledBy_property
//
(* ****** ****** *)
//
fun
Property_sampledBy_estream_cfun
  {a,b:t0p}{c:t0p}
(
  Property(a), EStream(b), cfun(a, b, c)
) : EStream(c) = "mac#%" // end-of-function
fun
Property_sampledBy_property_cfun
  {a,b:t0p}{c:t0p}
(
  Property(a), Property(b), cfun(a, b, c)
) : Property(c) = "mac#%" // end-of-function
//
overload sampledBy with Property_sampledBy_estream_cfun
overload sampledBy with Property_sampledBy_property_cfun
overload .sampledBy with Property_sampledBy_estream_cfun
overload .sampledBy with Property_sampledBy_property_cfun
//
(* ****** ****** *)
//
fun
EStream_zip_estream_cfun
  {a,b:t0p}{c:t0p}
(
  xs: EStream(a), ys: EStream(b), cfun(a, b, c)
) : EStream(c) = "mac#%" // end-of-function
//
overload zip with EStream_zip_estream_cfun
overload .zip with EStream_zip_estream_cfun
//
(* ****** ****** *)
//
// HX-2015-10-10:
// Bus: an estream
// onto which values can be pushed
//
fun
Bacon_new_bus{a:t0p}(): EStream(a) = "mac#%"
//
fun
EStream_bus_push
  {a:t0p}(bus: EStream(a), x0: a): void = "mac#%"
fun
EStream_bus_plug
  {a:t0p}(bus: EStream(a), xs: EStream(a)): void = "mac#%"
//
overload push with EStream_bus_push
overload plug with EStream_bus_plug
//
overload .push with EStream_bus_push
overload .plug with EStream_bus_plug
//
(* ****** ****** *)

(* end of [baconjs.sats] *)

(*
** For writing ATS code
** that translates into JavaScript
*)

(* ****** ****** *)

(*
** Permission to use, copy, modify, and distribute this software for any
** purpose with or without fee is hereby granted, provided that the above
** copyright notice and this permission notice appear in all copies.
**
** THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
** WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
** MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
** ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
** WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
** ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
** OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
*)

(* ****** ****** *)

(*
** Author: Hongwei Xi
** Authoremail: gmhwxi AT gmail DOT com
** Start Time: April, 2015
*)

(* ****** ****** *)

#define
ATS_STALOADFLAG 0 // no staloading at run-time
#define
ATS_EXTERN_PREFIX "ats2js_bacon_" // prefix for external names

(* ****** ****** *)
//
staload
"./../../basics_js.sats"
//
(* ****** ****** *)
//
(*
For Opaque values
*)
abstype Value = ptr
//
abstype Event = ptr
//
abstype
EStream(a:t@ype) = ptr // invariant!
abstype
Property(a:t@ype) = ptr // invariant!
//
(* ****** ****** *)

fun Bacon_more(): Value = "mac#%"
fun Bacon_noMore(): Value = "mac#%"

(* ****** ****** *)
//
fun
Bacon_once
  {a:t0p}(x: a): EStream(a) = "mac#%"
fun
Bacon_never
  {a:t0p}((*void*)): EStream(a) = "mac#%"
//
(* ****** ****** *)
//
fun
Bacon_delay
  {a:t0p}
  (ms: intGte(0), x: a): EStream(a) = "mac#%"
//
(* ****** ****** *)
//
fun
Bacon_interval
  {a:t0p}
  (ms: intGte(0), x: a): EStream(a) = "mac#%"
//
fun
Bacon_repeatedly
  {a:t0p}
  (ms: intGte(0), xs: JSarray(a)): EStream(a) = "mac#%"
//
fun
Bacon_sequentially
  {a:t0p}
  (ms: intGte(0), xs: JSarray(a)): EStream(a) = "mac#%"
//
(* ****** ****** *)
//
fun
Bacon_repeat{a:t0p}
(
  fopr: cfun(intGte(0), EStream(a))
) : EStream(a) = "mac#%" // end-of-fun
//
(* ****** ****** *)
//
fun
EStream_map
  {a,b:t0p}
(
  xs: EStream(a), fopr: cfun(a, b)
) : EStream(b) = "mac#%" // end-of-fun
fun
Property_map
  {a,b:t0p}
(
  xs: Property(a), fopr: cfun(a, b)
) : Property(b) = "mac#%" // end-of-fun
//
overload map with EStream_map
overload map with Property_map
overload .map with EStream_map
overload .map with Property_map
//
(* ****** ****** *)
//
fun
EStream_map_property
  {a,b:t0p}
(
  xs: EStream(a), ys: Property(b)
) : EStream(b) = "mac#%" // end-of-fun
//
overload map with EStream_map_property
overload .map with EStream_map_property
//
(* ****** ****** *)
//
fun
EStream_filter
  {a:t0p}
(
  xs: EStream(a), test: cfun(a, bool)
) : EStream(a) = "mac#%" // end-of-fun
//
overload filter with EStream_filter
overload .filter with EStream_filter
//
(* ****** ****** *)
//
fun
EStream_filter_property
  {a:t0p}
(
  xs: EStream(a), bs: Property(bool)
) : EStream(a) = "mac#%" // end-of-fun
//
overload filter with EStream_filter_property
overload .filter with EStream_filter_property
//
(* ****** ****** *)
//
fun
EStream_scan
  {a,b:t0p}
(
  xs: EStream(b), ini: a, fopr: cfun(a, b, a)
) : Property(a) = "mac#%" // end-of-function
//
overload scan with EStream_scan
overload .scan with EStream_scan
//
(* ****** ****** *)
//
fun
EStream_merge2
  {a:t0p}
  (EStream(a), EStream(a)): EStream(a) = "mac#%"
fun
EStream_merge3
  {a:t0p}
  (EStream(a), EStream(a), EStream(a)): EStream(a) = "mac#%"
//
overload merge with EStream_merge2
overload merge with EStream_merge3
//
overload .merge with EStream_merge2
overload .merge with EStream_merge3
//
(* ****** ****** *)
//
fun
Bacon_combineWith2
  {a,b,c:t0p}
(
  Property(a), Property(b), cfun(a, b, c)
) : Property(c) = "mac#%" // end-of-function
fun
Bacon_combineWith3
  {a,b,c,d:t0p}
(
  Property(a), Property(b), Property(c), cfun(a, b, c, d)
) : Property(d) = "mac#%" // end-of-function
//
overload combineWith with Bacon_combineWith2
overload combineWith with Bacon_combineWith3
//
(* ****** ****** *)
//
fun
EStream_toProperty
  {a:t0p}(EStream(a)): Property(a) = "mac#%"
fun
EStream_toProperty_init
  {a:t0p}(EStream(a), x0: a): Property(a) = "mac#%"
//
overload toProperty with EStream_toProperty
overload toProperty with EStream_toProperty_init
overload .toProperty with EStream_toProperty
overload .toProperty with EStream_toProperty_init
//
fun
Property_toEventStream
  {a:t0p}(Property(a)): EStream(a) = "mac#%"
//
overload toEventStream with Property_toEventStream
overload .toEventStream with Property_toEventStream
//
(* ****** ****** *)
//
fun
EStream_onValue
  {a:t0p}(EStream(a), cfun(a, void)): void = "mac#%"
fun
Property_onValue
  {a:t0p}(Property(a), cfun(a, void)): void = "mac#%"
//
overload onValue with EStream_onValue
overload onValue with Property_onValue
overload .onValue with EStream_onValue
overload .onValue with Property_onValue
//
(* ****** ****** *)
//
fun
EStream_subscribe
  {a:t0p}(EStream(a), cfun(Event, void)): void = "mac#%"
fun
Property_subscribe
  {a:t0p}(Property(a), cfun(Event, void)): void = "mac#%"
//
overload subscribe with EStream_subscribe
overload subscribe with Property_subscribe
overload .subscribe with EStream_subscribe
overload .subscribe with Property_subscribe
//
(* ****** ****** *)
//
fun
Property_startWith
  {a:t0p}(Property(a), a): Property(a) = "mac#%"
//
(* ****** ****** *)
//
fun
EStream_doAction
  {a:t0p}
  (xs: EStream(a), f: cfun(a, void)): EStream(a) = "mac#%"
fun
Property_doAction
  {a:t0p}
  (xs: Property(a), f: cfun(a, void)): Property(a) = "mac#%"
//
overload doAction with EStream_doAction
overload doAction with Property_doAction
overload .doAction with EStream_doAction
overload .doAction with Property_doAction
//
(* ****** ****** *)
//
fun
Property_sampledBy_estream
  {a,b:t0p}(Property(a), EStream(b)): EStream(a) = "mac#%"
fun
Property_sampledBy_property
  {a,b:t0p}(Property(a), Property(b)): Property(a) = "mac#%"
//
overload sampledBy with Property_sampledBy_estream
overload sampledBy with Property_sampledBy_property
overload .sampledBy with Property_sampledBy_estream
overload .sampledBy with Property_sampledBy_property
//
(* ****** ****** *)
//
fun
Property_sampledBy_estream_cfun
  {a,b:t0p}{c:t0p}
(
  Property(a), EStream(b), cfun(a, b, c)
) : EStream(c) = "mac#%" // end-of-function
fun
Property_sampledBy_property_cfun
  {a,b:t0p}{c:t0p}
(
  Property(a), Property(b), cfun(a, b, c)
) : Property(c) = "mac#%" // end-of-function
//
overload sampledBy with Property_sampledBy_estream_cfun
overload sampledBy with Property_sampledBy_property_cfun
overload .sampledBy with Property_sampledBy_estream_cfun
overload .sampledBy with Property_sampledBy_property_cfun
//
(* ****** ****** *)
//
fun
EStream_zip_estream_cfun
  {a,b:t0p}{c:t0p}
(
  xs: EStream(a), ys: EStream(b), cfun(a, b, c)
) : EStream(c) = "mac#%" // end-of-function
//
overload zip with EStream_zip_estream_cfun
overload .zip with EStream_zip_estream_cfun
//
(* ****** ****** *)
//
// HX-2015-10-10:
// Bus: an estream
// onto which values can be pushed
//
fun
Bacon_new_bus{a:t0p}(): EStream(a) = "mac#%"
//
fun
EStream_bus_push
  {a:t0p}(bus: EStream(a), x0: a): void = "mac#%"
fun
EStream_bus_plug
  {a:t0p}(bus: EStream(a), xs: EStream(a)): void = "mac#%"
//
overload push with EStream_bus_push
overload plug with EStream_bus_plug
//
overload .push with EStream_bus_push
overload .plug with EStream_bus_plug
//
(* ****** ****** *)

(* end of [baconjs.sats] *)


Updating: improving libats/hashtbl_linprb

(***********************************************************************)
(*                                                                     *)
(*                         ATS/contrib/atshwxi                         *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2014 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
** OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
** THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
** IN THE SOFTWARE.
*)

(* ****** ****** *)

(*
abst@ype key
absvt@ype itm
#define CAPACITY
*)

(* ****** ****** *)
//
// HX-2014-03:
// the current number of items
//
extern
fun get_size ((*void*)): size_t
//
// HX-2014-03:
// the size of the underlying array
//
extern
fun get_capacity ((*void*)): size_t
//
(* ****** ****** *)
//
extern
fun search
(
  k0: key, res: &itm? >> opt (itm, b)
) : #[b:bool] bool(b) // endfun
extern
fun search_ref (k0: key): cPtr0 (itm)
extern
fun search_opt (k0: key): Option_vt (itm)
//
(* ****** ****** *)
//
extern
fun insert
(
  k0: key, x0: itm, res: &itm? >> opt (itm, b)
) : #[b:bool] bool (b) // endfun
extern
fun insert_opt (k0: key, x0: itm): Option_vt (itm)
//
(* ****** ****** *)
//
extern
fun takeout
(
  k0: key, res: &itm? >> opt(itm, b)
) : #[b:bool] bool(b) // end-of-fun
extern
fun takeout_opt (k0: key): Option_vt (itm)
//
(* ****** ****** *)
//
local
//
val the_hashtbl =
  hashtbl_make_nil<key,itm> (i2sz(CAPACITY))
val the_hashtbl_ptr = $UNSAFE.castvwtp0{ptr}(the_hashtbl)
//
vtypedef HTBL = hashtbl (key, itm)
//
in (* in-of-local *)

(* ****** ****** *)

implement
get_size () = res where
{
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val res = hashtbl_get_size (htbl)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
} (* end of [get_size] *)

implement
get_capacity () = res where
{
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val res = hashtbl_get_capacity (htbl)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
} (* end of [get_capacity] *)

(* ****** ****** *)

implement
search (k0, res) = ans where
{
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val ans = hashtbl_search (htbl, k0, res)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
} (* end of [search] *)

implement
search_ref (k0) = ref where
{
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val ref = hashtbl_search_ref (htbl, k0)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
} (* end of [search_ref] *)

implement
search_opt (k0) = opt where
{
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val opt = hashtbl_search_opt (htbl, k0)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
} (* end of [search_opt] *)

(* ****** ****** *)

implement
insert (k0, x0, res) = let
//
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val ans = hashtbl_insert (htbl, k0, x0, res)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
//
in
  ans
end (* end of [insert] *)

implement
insert_opt (k0, x0) = let
//
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val opt = hashtbl_insert_opt (htbl, k0, x0)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
//
in
  opt
end (* end of [insert_opt] *)

(* ****** ****** *)

implement
takeout (k0, res) = let
//
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val ans = hashtbl_takeout (htbl, k0, res)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
//
in
  ans
end (* end of [takeout] *)

implement
takeout_opt (k0) = let
//
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val opt = hashtbl_takeout_opt (htbl, k0)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
//
in
  opt
end (* end of [takeout_opt] *)

(* ****** ****** *)

end // end of [local]
//
(* ****** ****** *)

(* end of [ghashtbl_linprb.hats] *)

(***********************************************************************)
(*                                                                     *)
(*                         ATS/contrib/atshwxi                         *)
(*                                                                     *)
(***********************************************************************)

(*
** Copyright (C) 2014 Hongwei Xi, ATS Trustful Software, Inc.
**
** Permission is hereby granted, free of charge, to any person obtaining a
** copy of this software and associated documentation files (the "Software"),
** to deal in the Software without restriction, including without limitation
** the rights to use, copy, modify, merge, publish, distribute, sublicense,
** and/or sell copies of the Software, and to permit persons to whom the
** Software is furnished to do so, subject to the following stated conditions:
**
** The above copyright notice and this permission notice shall be included in
** all copies or substantial portions of the Software.
**
** THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
** OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
** FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
** THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
** LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
** FROM OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS
** IN THE SOFTWARE.
*)

(* ****** ****** *)

(*
abst@ype key
absvt@ype itm
#define CAPACITY
*)

(* ****** ****** *)
//
// HX-2014-03:
// the current number of items
//
extern
fun get_size ((*void*)): size_t
//
// HX-2014-03:
// the size of the underlying array
//
extern
fun get_capacity ((*void*)): size_t
//
(* ****** ****** *)
//
extern
fun search
(
  k0: key, res: &itm? >> opt (itm, b)
) : #[b:bool] bool(b) // endfun
extern
fun search_ref (k0: key): cPtr0 (itm)
extern
fun search_opt (k0: key): Option_vt (itm)
//
(* ****** ****** *)
//
extern
fun insert
(
  k0: key, x0: itm, res: &itm? >> opt (itm, b)
) : #[b:bool] bool (b) // endfun
extern
fun insert_opt (k0: key, x0: itm): Option_vt (itm)
//
(* ****** ****** *)
//
local
//
val the_hashtbl =
  hashtbl_make_nil<key,itm> (i2sz(CAPACITY))
val the_hashtbl_ptr = $UNSAFE.castvwtp0{ptr}(the_hashtbl)
//
vtypedef HTBL = hashtbl (key, itm)
//
in (* in-of-local *)

(* ****** ****** *)

implement
get_size () = res where
{
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val res = hashtbl_get_size (htbl)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
} (* end of [get_size] *)

implement
get_capacity () = res where
{
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val res = hashtbl_get_capacity (htbl)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
} (* end of [get_capacity] *)

(* ****** ****** *)

implement
search (k0, res) = ans where
{
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val ans = hashtbl_search (htbl, k0, res)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
} (* end of [search] *)

implement
search_ref (k0) = ref where
{
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val ref = hashtbl_search_ref (htbl, k0)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
} (* end of [search_ref] *)

implement
search_opt (k0) = opt where
{
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val opt = hashtbl_search_opt (htbl, k0)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
} (* end of [search_opt] *)

(* ****** ****** *)

implement
insert (k0, x0, res) = let
//
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val ans = hashtbl_insert (htbl, k0, x0, res)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
//
in
  ans
end (* end of [insert] *)

implement
insert_opt (k0, x0) = let
//
val htbl =
$UNSAFE.castvwtp0{HTBL}(the_hashtbl_ptr)
val opt = hashtbl_insert_opt (htbl, k0, x0)
prval ((*void*)) = $UNSAFE.cast2void (htbl)
//
in
  opt
end (* end of [insert_opt] *)

(* ****** ****** *)

end // end of [local]
//
(* ****** ****** *)

(* end of [ghashtbl_linprb.hats] *)