Mercurial > hg > sonic-visualiser

changeset 1740:669bd699082d

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Update vext
author Chris Cannam
date Thu, 13 Jul 2017 15:34:33 +0100
parents 713ab804d16e
children 287a1d388b8d
files vext vext.ps1 vext.sml
diffstat 3 files changed, 145 insertions(+), 57 deletions(-) [+]
line wrap: on
line diff
--- a/vext	Thu Jul 13 15:33:43 2017 +0100
+++ b/vext	Thu Jul 13 15:34:33 2017 +0100
@@ -11,12 +11,44 @@
 mydir=$(dirname "$0")
 program="$mydir/vext.sml"
 
+hasher=
+local_install=
+if [ -w "$mydir" ]; then
+    if echo | sha256sum >/dev/null 2>&1 ; then
+	hasher=sha256sum
+        local_install=true
+    elif echo | shasum >/dev/null 2>&1 ; then
+	hasher=shasum
+	local_install=true
+    else
+        echo "WARNING: sha256sum or shasum program not found" 1>&2
+    fi
+fi
+
+if [ -n "$local_install" ]; then
+    hash=$(echo "$sml" | cat "$program" - | $hasher | cut -c1-16)
+    gen_sml=$mydir/.vext-$hash.sml
+    gen_out=$mydir/.vext-$hash.bin
+    trap 'rm -f $gen_sml' 0
+else
+    gen_sml=$(mktemp /tmp/vext-XXXXXXXX.sml)
+    gen_out=$(mktemp /tmp/vext-XXXXXXXX.bin)
+    trap 'rm -f $gen_sml $gen_out' 0
+fi
+
+if [ -x "$gen_out" ]; then
+    exec "$gen_out" "$@"
+fi
+
 # We need one of Poly/ML, SML/NJ, or MLton. Since we're running a
 # single-file SML program as if it were a script, our order of
-# preference is based on startup speed.
+# preference is based on startup speed, except in the local_install
+# case where we retain a persistent binary.
 
 if [ -z "$sml" ]; then
-    if sml -h 2>&1 | grep -q 'Standard ML of New Jersey'; then
+    if [ -n "$local_install" ] && mlton 2>&1 | grep -q 'MLton'; then
+	sml="mlton"
+    elif sml -h 2>&1 | grep -q 'Standard ML of New Jersey'; then
 	sml="smlnj"
     # We would prefer Poly/ML to SML/NJ, except that Poly v5.7 has a
     # nasty bug that occasionally causes it to deadlock on startup.
@@ -55,11 +87,6 @@
     fi
 fi
 
-tmp_sml=$(mktemp /tmp/vext-XXXXXXXX.sml)
-tmp_out=$(mktemp /tmp/vext-XXXXXXXX.bin)
-
-trap 'rm -f $tmp_sml $tmp_out' 0
-
 arglist=""
 for arg in "$@"; do
     if [ -n "$arglist" ]; then arglist="$arglist,"; fi
@@ -71,13 +98,22 @@
 done
 
 case "$sml" in
-    poly) echo 'use "'"$program"'"; vext ['"$arglist"'];' |
-		poly -q --error-exit ;;
+    poly)
+        if [ -n "$local_install" ] && polyc --help >/dev/null 2>&1 ; then
+            if [ ! -x "$gen_out" ]; then
+                polyc -o "$gen_out" "$program"
+            fi
+	    "$gen_out" "$@"
+        else
+            echo 'use "'"$program"'"; vext ['"$arglist"'];' |
+                poly -q --error-exit
+        fi ;;
     mlton)
-	cat "$program" > "$tmp_sml"
-	echo 'val _ = main ()' >> "$tmp_sml"
-	mlton -output "$tmp_out" "$tmp_sml"
-	"$tmp_out" "$@" ;;
+        if [ ! -x "$gen_out" ]; then
+	    echo "val _ = main ()" | cat "$program" - > "$gen_sml"
+	    mlton -output "$gen_out" "$gen_sml"
+        fi
+	"$gen_out" "$@" ;;
     smlnj)
 	cat "$program" | (
 	    cat <<EOF
@@ -102,8 +138,8 @@
 val _ = vext [$arglist];
 val _ = OS.Process.exit (OS.Process.success);
 EOF
-            ) > "$tmp_sml"
-	CM_VERBOSE=false sml "$tmp_sml" ;;
+            ) > "$gen_sml"
+	CM_VERBOSE=false sml "$gen_sml" ;;
     *)
 	echo "Unknown SML implementation name: $sml";
 	exit 2 ;;
--- a/vext.ps1	Thu Jul 13 15:33:43 2017 +0100
+++ b/vext.ps1	Thu Jul 13 15:34:33 2017 +0100
@@ -14,10 +14,10 @@
 # We need either Poly/ML or SML/NJ. No great preference as to which.
 
 if (!$sml) {
-    if (Get-Command "polyml" -ErrorAction SilentlyContinue) {
+    if (Get-Command "sml" -ErrorAction SilentlyContinue) {
+       $sml = "smlnj"
+    } elseif (Get-Command "polyml" -ErrorAction SilentlyContinue) {
        $sml = "poly"
-    } elseif (Get-Command "sml" -ErrorAction SilentlyContinue) {
-       $sml = "smlnj"
     } else {
        echo @"
 
@@ -29,12 +29,12 @@
   Please ensure you have one of the following SML implementations
   installed and present in your PATH, and try again.
 
-    1. Poly/ML
+    1. Standard ML of New Jersey
+       - executable name: sml
+
+    2. Poly/ML
        - executable name: polyml
 
-    2. Standard ML of New Jersey
-       - executable name: sml
-
 "@
        exit 1
     }
--- a/vext.sml	Thu Jul 13 15:33:43 2017 +0100
+++ b/vext.sml	Thu Jul 13 15:34:33 2017 +0100
@@ -33,7 +33,7 @@
     Software without prior written authorization.
 *)
 
-val vext_version = "0.9.4"
+val vext_version = "0.9.6"
 
 
 datatype vcs =
@@ -48,9 +48,11 @@
              repo : string option
          }
 
+type id_or_tag = string
+
 datatype pin =
          UNPINNED |
-         PINNED of string
+         PINNED of id_or_tag
 
 datatype libstate =
          ABSENT |
@@ -60,7 +62,8 @@
 
 datatype localstate =
          MODIFIED |
-         UNMODIFIED
+         LOCK_MISMATCHED |
+         CLEAN
 
 datatype branch =
          BRANCH of string |
@@ -77,21 +80,20 @@
 
 type libname = string
 
-type id_or_tag = string
-
 type libspec = {
     libname : libname,
     vcs : vcs,
     source : source,
     branch : branch,
-    pin : pin
+    project_pin : pin,
+    lock_pin : pin
 }
 
 type lock = {
     libname : libname,
     id_or_tag : id_or_tag
 }
-                   
+
 type remote_spec = {
     anon : string option,
     auth : string option
@@ -177,6 +179,7 @@
     val review : context -> libspec -> (libstate * localstate) result
     val status : context -> libspec -> (libstate * localstate) result
     val update : context -> libspec -> id_or_tag result
+    val id_of : context -> libspec -> id_or_tag result
 end
 
 structure FileBits :> sig
@@ -402,7 +405,8 @@
        - ABSENT: Repo doesn't exist here at all.
     *)
 
-    fun check with_network context ({ libname, branch, pin, ... } : libspec) =
+    fun check with_network context
+              ({ libname, branch, project_pin, lock_pin, ... } : libspec) =
         let fun check_unpinned () =
                 let val is_newest = if with_network
                                     then V.is_newest
@@ -422,26 +426,39 @@
                     ERROR e => ERROR e
                   | OK true => OK CORRECT
                   | OK false => OK WRONG
-            fun check' () =
-                case pin of
+            fun check_remote () =
+                case project_pin of
                     UNPINNED => check_unpinned ()
                   | PINNED target => check_pinned target
+            fun check_local () =
+                case V.is_modified_locally context libname of
+                    ERROR e => ERROR e
+                  | OK true  => OK MODIFIED
+                  | OK false => 
+                    case lock_pin of
+                        UNPINNED => OK CLEAN
+                      | PINNED target =>
+                        case V.is_at context (libname, target) of
+                            ERROR e => ERROR e
+                          | OK true => OK CLEAN
+                          | OK false => OK LOCK_MISMATCHED
         in
             case V.exists context libname of
                 ERROR e => ERROR e
-              | OK false => OK (ABSENT, UNMODIFIED)
+              | OK false => OK (ABSENT, CLEAN)
               | OK true =>
-                case (check' (), V.is_modified_locally context libname) of
+                case (check_remote (), check_local ()) of
                     (ERROR e, _) => ERROR e
                   | (_, ERROR e) => ERROR e
-                  | (OK state, OK true) => OK (state, MODIFIED)
-                  | (OK state, OK false) => OK (state, UNMODIFIED)
+                  | (OK r, OK l) => OK (r, l)
         end
 
     val review = check true
     val status = check false
-                         
-    fun update context ({ libname, source, branch, pin, ... } : libspec) =
+
+    fun update context
+               ({ libname, source, branch,
+                  project_pin, lock_pin, ... } : libspec) =
         let fun update_unpinned () =
                 case V.is_newest context (libname, branch) of
                     ERROR e => ERROR e
@@ -453,9 +470,12 @@
                   | OK true => OK target
                   | OK false => V.update_to context (libname, target)
             fun update' () =
-                case pin of
-                    UNPINNED => update_unpinned ()
-                  | PINNED target => update_pinned target
+                case lock_pin of
+                    PINNED target => update_pinned target
+                  | UNPINNED =>
+                    case project_pin of
+                        PINNED target => update_pinned target
+                      | UNPINNED => update_unpinned ()
         in
             case V.exists context libname of
                 ERROR e => ERROR e
@@ -465,6 +485,10 @@
                     ERROR e => ERROR e
                   | OK () => update' ()
         end
+
+    fun id_of context ({ libname, ... } : libspec) =
+        V.id_of context libname
+                
 end
 
 (* Simple Standard ML JSON parser
@@ -1369,6 +1393,9 @@
 
     fun update context (spec as { vcs, ... } : libspec) =
         (fn HG => H.update | GIT => G.update) vcs context spec
+
+    fun id_of context (spec as { vcs, ... } : libspec) =
+        (fn HG => H.id_of | GIT => G.id_of) vcs context spec
 end
 
 val libobjname = "libraries"
@@ -1383,10 +1410,14 @@
         val repo     = retrieve ["repository"]
         val url      = retrieve ["url"]
         val branch   = retrieve ["branch"]
-        val user_pin = retrieve ["pin"]
+        val project_pin = case retrieve ["pin"] of
+                              NONE => UNPINNED
+                            | SOME p => PINNED p
         val lock_pin = case lookup_optional lock_json [libobjname, libname] of
-                           SOME ll => lookup_optional_string ll ["pin"]
-                         | NONE => NONE
+                           NONE => UNPINNED
+                         | SOME ll => case lookup_optional_string ll ["pin"] of
+                                          SOME p => PINNED p
+                                        | NONE => UNPINNED
     in
         {
           libname = libname,
@@ -1401,12 +1432,8 @@
                        SERVICE_SOURCE { service = ss, owner = owner, repo = repo }
                      | _ => raise Fail ("Must have exactly one of service " ^
                                         "or url string"),
-          pin = case lock_pin of
-                    SOME p => PINNED p
-                  | NONE =>
-                    case user_pin of
-                        SOME p => PINNED p
-                      | NONE => UNPINNED,
+          project_pin = project_pin,
+          lock_pin = lock_pin,
           branch = case branch of
                        SOME b => BRANCH b
                      | NONE => DEFAULT_BRANCH
@@ -1502,12 +1529,13 @@
 
 val libname_width = 25
 val libstate_width = 11
-val localstate_width = 9
+val localstate_width = 17
 val notes_width = 5
 val divider = " | "
+val clear_line = "\r" ^ pad_to 80 "";
 
 fun print_status_header () =
-    print ("\r" ^ pad_to 80 "" ^ "\n " ^
+    print (clear_line ^ "\n " ^
            pad_to libname_width "Library" ^ divider ^
            pad_to libstate_width "State" ^ divider ^
            pad_to localstate_width "Local" ^ divider ^
@@ -1518,7 +1546,7 @@
            hline_to notes_width ^ "\n")
 
 fun print_outcome_header () =
-    print ("\r" ^ pad_to 80 "" ^ "\n " ^
+    print (clear_line ^ "\n " ^
            pad_to libname_width "Library" ^ divider ^
            pad_to libstate_width "Outcome" ^ divider ^
            "Notes" ^ "\n " ^
@@ -1537,8 +1565,9 @@
         val localstate_str =
             case status of
                 OK (_, MODIFIED) => "Modified"
-              | OK (_, UNMODIFIED) => "Clean"
-              | _ => ""
+              | OK (_, LOCK_MISMATCHED) => "Differs from Lock"
+              | OK (_, CLEAN) => "Clean"
+              | ERROR _ => ""
         val error_str =
             case status of
                 ERROR e => e
@@ -1612,6 +1641,26 @@
         return_code
     end
 
+fun lock_project ({ context, libs } : project) =
+    let val outcomes = map (fn lib =>
+                               (#libname lib, AnyLibControl.id_of context lib))
+                           libs
+        val locks =
+            List.concat
+                (map (fn (libname, result) =>
+                         case result of
+                             ERROR _ => []
+                           | OK id => [{ libname = libname, id_or_tag = id }])
+                     outcomes)
+        val return_code = return_code_for outcomes
+        val _ = print clear_line
+    in
+        if OS.Process.isSuccess return_code
+        then save_lock_file (#rootpath context) locks
+        else ();
+        return_code
+    end
+        
 fun load_local_project pintype =
     let val userconfig = load_userconfig ()
         val rootpath = OS.FileSys.getDir ()
@@ -1630,9 +1679,10 @@
         return_code
     end
         
-fun review () = with_local_project NO_LOCKFILE review_project
-fun status () = with_local_project NO_LOCKFILE status_of_project
+fun review () = with_local_project USE_LOCKFILE review_project
+fun status () = with_local_project USE_LOCKFILE status_of_project
 fun update () = with_local_project NO_LOCKFILE update_project
+fun lock () = with_local_project NO_LOCKFILE lock_project
 fun install () = with_local_project USE_LOCKFILE update_project
 
 fun version () =
@@ -1650,6 +1700,7 @@
             ^ "  review   check configured libraries against their providers, and report\n"
             ^ "  install  update configured libraries according to project specs and lock file\n"
             ^ "  update   update configured libraries and lock file according to project specs\n"
+            ^ "  lock     update lock file to match local library status\n"
             ^ "  version  print the Vext version number and exit\n\n");
     OS.Process.failure)
 
@@ -1660,6 +1711,7 @@
               | ["status"] => status ()
               | ["install"] => install ()
               | ["update"] => update ()
+              | ["lock"] => lock ()
               | ["version"] => version ()
               | _ => usage ()
     in