# HG changeset patch # User Chris Cannam # Date 1499962376 -3600 # Thu Jul 13 17:12:56 2017 +0100 # Branch vext # Node ID 624725dc5b727e183856b7a607a4069e8b7330c8 # Parent ad5abcf3207c0544831cb39feb0da6584b57e86f Update Vext diff --git a/vext b/vext --- a/vext +++ b/vext @@ -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 < "$tmp_sml" - CM_VERBOSE=false sml "$tmp_sml" ;; + ) > "$gen_sml" + CM_VERBOSE=false sml "$gen_sml" ;; *) echo "Unknown SML implementation name: $sml"; exit 2 ;; diff --git a/vext.ps1 b/vext.ps1 --- a/vext.ps1 +++ b/vext.ps1 @@ -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,11 +29,11 @@ Please ensure you have one of the following SML implementations installed and present in your PATH, and try again. - 1. Poly/ML - - executable name: polyml + 1. Standard ML of New Jersey + - executable name: sml - 2. Standard ML of New Jersey - - executable name: sml + 2. Poly/ML + - executable name: polyml "@ exit 1 diff --git a/vext.sml b/vext.sml --- a/vext.sml +++ b/vext.sml @@ -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 @@ -889,11 +913,12 @@ | Json.ERROR e => raise Fail ("Failed to parse file: " ^ e) fun save_json_to filename json = + (* using binary I/O to avoid ever writing CR/LF line endings *) let val jstr = Json.serialiseIndented json - val stream = TextIO.openOut filename + val stream = BinIO.openOut filename in - TextIO.output (stream, jstr); - TextIO.closeOut stream + BinIO.output (stream, Byte.stringToBytes jstr); + BinIO.closeOut stream end fun lookup_optional json kk = @@ -1368,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" @@ -1382,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, @@ -1400,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 @@ -1435,7 +1463,11 @@ } end -fun load_project (userconfig : userconfig) rootpath use_locks : project = +datatype pintype = + NO_LOCKFILE | + USE_LOCKFILE + +fun load_project (userconfig : userconfig) rootpath pintype : project = let val spec_file = FileBits.project_spec_path rootpath val lock_file = FileBits.project_lock_path rootpath val _ = if OS.FileSys.access (spec_file, [OS.FileSys.A_READ]) @@ -1447,7 +1479,7 @@ ".\nPlease ensure the spec file is in the " ^ "project root and run this from there.") val spec_json = JsonBits.load_json_from spec_file - val lock_json = if use_locks + val lock_json = if pintype = USE_LOCKFILE then JsonBits.load_json_from lock_file handle IO.Io _ => Json.OBJECT [] else Json.OBJECT [] @@ -1497,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 ^ @@ -1513,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 " ^ @@ -1532,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 @@ -1607,15 +1641,35 @@ return_code end -fun load_local_project use_locks = +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 () in - load_project userconfig rootpath use_locks + load_project userconfig rootpath pintype end -fun with_local_project use_locks f = - let val return_code = f (load_local_project use_locks) +fun with_local_project pintype f = + let val return_code = f (load_local_project pintype) handle e => (print ("Failed with exception: " ^ (exnMessage e) ^ "\n"); @@ -1625,10 +1679,11 @@ return_code end -fun review () = with_local_project false review_project -fun status () = with_local_project false status_of_project -fun update () = with_local_project false update_project -fun install () = with_local_project true update_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 () = (print ("v" ^ vext_version ^ "\n"); @@ -1645,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) @@ -1655,6 +1711,7 @@ | ["status"] => status () | ["install"] => install () | ["update"] => update () + | ["lock"] => lock () | ["version"] => version () | _ => usage () in