[MLton-commit] r6652
Vesa Karvonen
vesak at mlton.org
Wed Jun 11 03:29:13 PDT 2008
A simple interactive program variable editor library.
----------------------------------------------------------------------
A mltonlib/trunk/org/mlton/vesak/var-ed/
A mltonlib/trunk/org/mlton/vesak/var-ed/unstable/
A mltonlib/trunk/org/mlton/vesak/var-ed/unstable/detail/
A mltonlib/trunk/org/mlton/vesak/var-ed/unstable/detail/var-ed.sml
A mltonlib/trunk/org/mlton/vesak/var-ed/unstable/lib.mlb
A mltonlib/trunk/org/mlton/vesak/var-ed/unstable/public/
A mltonlib/trunk/org/mlton/vesak/var-ed/unstable/public/export.sml
A mltonlib/trunk/org/mlton/vesak/var-ed/unstable/public/var-ed.sig
----------------------------------------------------------------------
Added: mltonlib/trunk/org/mlton/vesak/var-ed/unstable/detail/var-ed.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/var-ed/unstable/detail/var-ed.sml 2008-06-11 09:55:31 UTC (rev 6651)
+++ mltonlib/trunk/org/mlton/vesak/var-ed/unstable/detail/var-ed.sml 2008-06-11 10:29:04 UTC (rev 6652)
@@ -0,0 +1,178 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+structure VarEd :> VAR_ED = struct
+ datatype tree = VAR of var
+ | GROUP of group
+ withtype group = {name : String.t,
+ children : tree List.t Ref.t,
+ refresh : Bool.t Ref.t}
+ and var = {name : String.t,
+ read : String.t Effect.t,
+ pretty : Prettier.t Thunk.t,
+ refresh : Bool.t Ref.t}
+
+ fun assertName name =
+ if String.length name > 0
+ andalso String.all (neg Char.isSpace) name
+ then ()
+ else fail "Names must not be empty or contain spaces"
+
+ structure Group = struct
+ type t = group
+ fun newRoot name =
+ (assertName name
+ ; {name = name, children = ref [], refresh = ref true})
+ fun new {parent = {children, refresh, ...} : t, name} =
+ case newRoot name
+ of result => (push children (GROUP result)
+ ; refresh := true
+ ; result)
+ end
+
+ structure Var = struct
+ datatype 'a t =
+ IN of {cell : 'a Ref.t,
+ assert : 'a UnOp.t,
+ signal : 'a t Effect.t,
+ refresh : Bool.t Ref.t}
+ val ! = fn IN {cell, ...} => !cell
+ val op := = fn (self as IN {cell, assert, signal, refresh, ...}, value) =>
+ (cell := assert value ; refresh := true ; signal self)
+ fun new {group = {children, refresh, ...} : Group.t,
+ name, rep, value, assert, signal} = let
+ val () = assertName name
+ val var = IN {cell = ref (assert value),
+ assert = assert,
+ signal = signal,
+ refresh = refresh}
+ val read = Generic.read rep
+ val pretty = Generic.pretty rep
+ in
+ push children
+ (VAR {name = name,
+ read = fn s => var := read s,
+ pretty = fn () => pretty (!var),
+ refresh = refresh})
+ ; var
+ end
+ end
+
+ datatype t =
+ IN of {root : group,
+ current : group Ref.t,
+ parents : group List.t Ref.t}
+
+ fun new {name} =
+ case Group.newRoot name
+ of root => IN {root = root,
+ current = ref root,
+ parents = ref []}
+
+ fun root (IN {root, ...}) = root
+
+ fun update (IN {current, parents, ...})
+ {instream, outstream, ansi, columns} = let
+ fun print s =
+ (TextIO.output (outstream, s)
+ ; TextIO.flushOut outstream)
+
+ local
+ open Cvt Prettier
+ in
+ fun pprintln d =
+ (output outstream columns (group d) ; print "\n")
+ val D = D
+ val P = P
+ val fillSep = fillSep
+ val txt = txt
+ val nest = nest 4
+ val op <^> = op <^>
+ val op <+> = op <+>
+ val op <$> = op <$>
+ val colon = colon
+ end
+
+ fun prompt () = print "> "
+
+ fun maybeRefresh () =
+ if !(#refresh (!current))
+ then (#refresh (!current) := false
+ ; if ansi then print "\027[1J\027[H" else ()
+ ; pprintln
+ (fillSep
+ (List.intersperse
+ (txt "->")
+ (rev (txt (#name (!current)) ::
+ map (txt o #name) (!parents)))))
+ ; (List.fori (rev (!(#children (!current)))))
+ (fn (i, n) =>
+ pprintln
+ (nest
+ (txt (P#l 2 (D i)) <^> colon <+>
+ (case n
+ of GROUP {name, ...} =>
+ txt name <+> txt ".."
+ | VAR {name, pretty, ...} =>
+ txt name <$> pretty ()))))
+ ; prompt ())
+ else ()
+
+ fun processInput () =
+ case TextIO.canInput (instream, 1)
+ of NONE => NONE
+ | _ =>
+ case TextIO.inputLine instream
+ of NONE => NONE
+ | SOME ln =>
+ case Substring.string
+ (Substring.droplr Char.isSpace (Substring.full ln))
+ of "" => (#refresh (!current) := true ; NONE)
+ | ".." => (Option.app (fn c => current := c) (pop parents)
+ ; #refresh (!current) := true
+ ; NONE)
+ | cmd => let
+ val (i, v) =
+ Substring.splitl (neg Char.isSpace) (Substring.full cmd)
+ in
+ case case Int.fromString (Substring.string i)
+ of SOME i => let
+ val n = length (!(#children (!current)))
+ in
+ if 0 <= i andalso i < n then SOME (n-i-1) else NONE
+ end
+ | NONE =>
+ Option.map
+ #1
+ (List.findi
+ (fn (_, c) =>
+ Substring.compare
+ (i,
+ Substring.full
+ (case c
+ of GROUP {name, ...} => name
+ | VAR {name, ...} => name)) = EQUAL)
+ (!(#children (!current))))
+ of NONE => (prompt () ; SOME cmd)
+ | SOME i =>
+ case List.sub (!(#children (!current)), i)
+ of GROUP group =>
+ (push parents (!current)
+ ; current := group
+ ; #refresh (!current) := true
+ ; NONE)
+ | VAR {read, ...} =>
+ (read
+ (Substring.string (Substring.dropl Char.isSpace v))
+ handle e => println (Exn.message e)
+ ; prompt ()
+ ; NONE)
+ end
+ in
+ maybeRefresh ()
+ ; processInput ()
+ end
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/var-ed/unstable/detail/var-ed.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/var-ed/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/org/mlton/vesak/var-ed/unstable/lib.mlb 2008-06-11 09:55:31 UTC (rev 6651)
+++ mltonlib/trunk/org/mlton/vesak/var-ed/unstable/lib.mlb 2008-06-11 10:29:04 UTC (rev 6652)
@@ -0,0 +1,26 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+local
+ $(MLTON_LIB)/com/ssh/extended-basis/unstable/basis.mlb
+ $(MLTON_LIB)/com/ssh/generic/unstable/lib.mlb
+ $(MLTON_LIB)/com/ssh/prettier/unstable/lib.mlb
+
+ $(APPLICATION)/generic.mlb
+in
+ ann
+ "forceUsed"
+ "sequenceNonUnit warn"
+ "warnUnused true"
+ in
+ local
+ public/var-ed.sig
+ detail/var-ed.sml
+ in
+ public/export.sml
+ end
+ end
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/var-ed/unstable/lib.mlb
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/var-ed/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/org/mlton/vesak/var-ed/unstable/public/export.sml 2008-06-11 09:55:31 UTC (rev 6651)
+++ mltonlib/trunk/org/mlton/vesak/var-ed/unstable/public/export.sml 2008-06-11 10:29:04 UTC (rev 6652)
@@ -0,0 +1,13 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(** == Exported Signatures == *)
+
+signature VAR_ED = VAR_ED
+
+(** == Exported Structures == *)
+
+structure VarEd : VAR_ED = VarEd
Property changes on: mltonlib/trunk/org/mlton/vesak/var-ed/unstable/public/export.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Added: mltonlib/trunk/org/mlton/vesak/var-ed/unstable/public/var-ed.sig
===================================================================
--- mltonlib/trunk/org/mlton/vesak/var-ed/unstable/public/var-ed.sig 2008-06-11 09:55:31 UTC (rev 6651)
+++ mltonlib/trunk/org/mlton/vesak/var-ed/unstable/public/var-ed.sig 2008-06-11 10:29:04 UTC (rev 6652)
@@ -0,0 +1,91 @@
+(* Copyright (C) 2008 Vesa Karvonen
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * Signature for a simple program variable editor module {VarEd}.
+ *
+ * Suppose, for example, that you're implementing a real-time physics
+ * simulation of some sort. It is typical that such a simulation has many
+ * heuristic parameters (e.g. damping factors, friction coefficients,
+ * ...). In order to achieve good results, it is imperative to be able to
+ * quickly experiment with different parameters. {VarEd} makes it easy to
+ * implement a simple command-line / console editor for program variables.
+ *)
+signature VAR_ED = sig
+ (**
+ * Variables are attached to a hierarchy of groups.
+ *)
+ structure Group : sig
+ type t
+ (** The tyoe if variable groups. *)
+
+ val new : {parent : t,
+ name : String.t} -> t
+ (** Creates a new group. *)
+ end
+
+ (**
+ * Like a ref cell, each variable holds a value that can be accessed by
+ * the program and can additionally be accessed interactively using the
+ * editor.
+ *)
+ structure Var : sig
+ type 'a t
+ (** Type of variables. *)
+
+ val new : {group : Group.t,
+ name : String.t,
+ rep : 'a Generic.Rep.t,
+ value : 'a,
+ assert : 'a UnOp.t,
+ signal : 'a t Effect.t} -> 'a t
+ (**
+ * Creates a new variable.
+ *
+ * Generic functions obtained from the type representation {rep} are
+ * used to show the values of variables and read new values from the
+ * user.
+ *
+ * Values assigned to the variable (either by the user or by the
+ * program) go through the {assert} function before the variable is
+ * changed and the {signal} function is called after the variable has
+ * been changed. Both the assert function and the signal function
+ * may raise exceptions.
+ *)
+
+ val ! : 'a t -> 'a
+ (** Returns the current value of the variable. *)
+
+ val := : ('a t * 'a) Effect.t
+ (** Assigns a new value to the variable. *)
+ end
+
+ type t
+ (** Type of variable editors. *)
+
+ val new : {name : String.t} -> t
+ (** Creates a new variable editor. The name is for the root group. *)
+
+ val root : t -> Group.t
+ (** Returns the root group of a variable editor. *)
+
+ val update : t -> {instream : TextIO.instream,
+ outstream : TextIO.outstream,
+ ansi : Bool.t,
+ columns : Int.t Option.t} -> String.t Option.t
+ (**
+ * Updates the interactive variable editor.
+ *
+ * The editor is written to the given output stream and input is read
+ * from the given input stream. This function does not block; the
+ * input stream is read only when it doesn't block. Input that is not
+ * recognized by the editor is returned as {SOME text} and does not
+ * change the state of the editor or variables.
+ *
+ * The {ansi} flag specifies whether the editor may use ANSI control
+ * codes to better control the output.
+ *)
+end
Property changes on: mltonlib/trunk/org/mlton/vesak/var-ed/unstable/public/var-ed.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list