Skip to content

Commit

Permalink
Update Repoint
Browse files Browse the repository at this point in the history
  • Loading branch information
@cannam
cannam committed Sep 29, 2021
1 parent 170587f commit 271bbe7
Show file tree
Hide file tree
Showing 2 changed files with 97 additions and 27 deletions.
7 changes: 7 additions & 0 deletions repoint.ps1
View file
Original file line number Diff line number Diff line change
Expand Up @@ -18,6 +18,7 @@ $program = "$mydir/repoint.sml"
# We need either Poly/ML or SML/NJ. No great preference as to which.

# Typical locations
$former_path = $env:PATH
$env:PATH = "$env:PATH;C:\Program Files (x86)\SMLNJ\bin;C:\Program Files\Poly ML;C:\Program Files (x86)\Poly ML"

if (!$sml) {
Expand All @@ -43,6 +44,7 @@ ERROR: No supported SML compiler or interpreter found
- executable name: polyml
"@
$env:PATH = $former_path
exit 1
}
}
Expand All @@ -59,6 +61,7 @@ if ($sml -eq "poly") {
echo "use ""$program""; repoint $arglist" | polyml -q --error-exit | Out-Host

if (-not $?) {
$env:PATH = $former_path
exit $LastExitCode
}

Expand Down Expand Up @@ -105,6 +108,7 @@ val _ = OS.Process.exit (OS.Process.success);

if (-not $?) {
del $tmpfile
$env:PATH = $former_path
exit $LastExitCode
}

Expand All @@ -113,5 +117,8 @@ val _ = OS.Process.exit (OS.Process.success);
} else {

"Unknown SML implementation name: $sml"
$env:PATH = $former_path
exit 2
}

$env:PATH = $former_path
117 changes: 90 additions & 27 deletions repoint.sml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -38,7 +38,7 @@
authorization.
*)

val repoint_version = "1.2"
val repoint_version = "1.3"


datatype vcs =
Expand Down Expand Up @@ -257,13 +257,27 @@ structure FileBits :> sig
val project_lock_path : string -> string
val project_completion_path : string -> string
val verbose : unit -> bool
val insecure : unit -> bool
end = struct

fun verbose () =
case OS.Process.getEnv "REPOINT_VERBOSE" of
SOME "0" => false
| SOME _ => true
| NONE => false
| _ => true

val insecure_warned = ref false

fun insecure () =
case OS.Process.getEnv "REPOINT_INSECURE" of
SOME "0" => false
| NONE => false
| _ =>
(if ! insecure_warned (* deref not negate, so "if we have warned" *)
then ()
else (print "Warning: Insecure mode active in environment, skipping security checks\n";
insecure_warned := true);
true)

fun split_relative path desc =
case OS.Path.fromString path of
Expand Down Expand Up @@ -954,7 +968,16 @@ structure Json :> JSON = struct
in
implode (escape' [] (explode s))
end


fun serialiseNumber n =
implode (map (fn #"~" => #"-" | c => c)
(explode
(if Real.isFinite n andalso
Real.== (n, Real.realRound n) andalso
Real.<= (Real.abs n, 1e6)
then Int.toString (Real.round n)
else Real.toString n)))

fun serialise json =
case json of
OBJECT pp => "{" ^ String.concatWith
Expand All @@ -963,8 +986,7 @@ structure Json :> JSON = struct
serialise value) pp) ^
"}"
| ARRAY arr => "[" ^ String.concatWith "," (map serialise arr) ^ "]"
| NUMBER n => implode (map (fn #"~" => #"-" | c => c)
(explode (Real.toString n)))
| NUMBER n => serialiseNumber n
| STRING s => "\"" ^ stringEscape s ^ "\""
| BOOL b => Bool.toString b
| NULL => "null"
Expand Down Expand Up @@ -1239,6 +1261,10 @@ structure HgControl :> VCS_CONTROL = struct

val hg_args = [ "--config", "ui.interactive=true",
"--config", "ui.merge=:merge" ]

val hg_extra_clone_pull_args = if FileBits.insecure ()
then [ "--insecure" ]
else []

fun hg_command context libname args =
FileBits.command context libname (hg_program :: hg_args @ args)
Expand Down Expand Up @@ -1347,9 +1373,10 @@ structure HgControl :> VCS_CONTROL = struct
val url = remote_for context (libname, source)
in
hg_command context libname
(if FileBits.verbose ()
then ["pull", url]
else ["pull", "-q", url])
((if FileBits.verbose ()
then ["pull", url]
else ["pull", "-q", url])
@ hg_extra_clone_pull_args)
end

fun is_newest context (libname, source, branch) =
Expand All @@ -1373,8 +1400,8 @@ structure HgControl :> VCS_CONTROL = struct
case FileBits.mkpath (FileBits.libpath context libname) of
ERROR e => ERROR e
| _ => hg_command context ""
["clone", "-u", branch_name branch,
url, libname]
(["clone", "-u", branch_name branch,
url, libname] @ hg_extra_clone_pull_args)
end

fun update context (libname, source, branch) =
Expand Down Expand Up @@ -1737,7 +1764,7 @@ structure SubXml :> SUBXML = struct

fun entity pos cc =
let fun entity' decoder pos text [] =
error pos "Document ends during hex character entity"
error pos "Document ends during character entity"
| entity' decoder pos text (c :: rest) =
if c <> #";"
then entity' decoder (pos+1) (c :: text) rest
Expand Down Expand Up @@ -2599,17 +2626,47 @@ fun load_project (userconfig : userconfig) rootpath pintype : project =
}
end

fun save_lock_file rootpath locks =
fun make_lock_properties locks =
map (fn { libname, id_or_tag } =>
(libname, Json.OBJECT [ ("pin", Json.STRING id_or_tag) ]))
locks

fun make_lock_json_from_properties properties =
Json.OBJECT [ (libobjname, Json.OBJECT properties) ]

fun make_lock_json locks =
make_lock_json_from_properties (make_lock_properties locks)

fun save_lock_file_afresh rootpath locks =
let val lock_file = FileBits.project_lock_path rootpath
val lock_json = make_lock_json locks
in
JsonBits.save_json_to lock_file lock_json
end

fun save_lock_file_updating rootpath locks =
let val lock_file = FileBits.project_lock_path rootpath
open Json
val prior_lock_json = JsonBits.load_json_from lock_file
handle IO.Io _ => Json.OBJECT []
val new_lock_properties = make_lock_properties locks
val updated_prior_properties =
case prior_lock_json of
Json.OBJECT [ (_, Json.OBJECT properties) ] =>
map (fn (entry as (lib, _)) =>
case List.find (fn (lib', _) => lib = lib')
new_lock_properties of
NONE => entry
| SOME updated => updated)
properties
| _ => []
val filtered_new_properties =
List.filter (fn (lib, _) =>
not (List.exists (fn (lib', _) => lib = lib')
updated_prior_properties))
new_lock_properties
val lock_json =
OBJECT [
(libobjname,
OBJECT (map (fn { libname, id_or_tag } =>
(libname,
OBJECT [ ("pin", STRING id_or_tag) ]))
locks))
]
make_lock_json_from_properties
(updated_prior_properties @ filtered_new_properties)
in
JsonBits.save_json_to lock_file lock_json
end
Expand Down Expand Up @@ -2755,12 +2812,14 @@ fun review_project ({ context, libs } : project) =
print_status_header (print_status true)
context libs)

fun lock_project ({ context, libs } : project) =
fun lock_project (update_only : libspec list option)
({ context, libs } : project) =
let val _ = if FileBits.verbose ()
then print ("Scanning IDs for lock file...\n")
else ()
val to_update = Option.getOpt (update_only, libs)
val outcomes = map (fn lib => (lib, AnyLibControl.id_of context lib))
libs
to_update
val locks =
List.concat
(map (fn (lib : libspec, result) =>
Expand All @@ -2773,7 +2832,9 @@ fun lock_project ({ context, libs } : project) =
val _ = print clear_line
in
if OS.Process.isSuccess return_code
then save_lock_file (#rootpath context) locks
then (if Option.isSome update_only
then save_lock_file_updating
else save_lock_file_afresh) (#rootpath context) locks
else ();
return_code
end
Expand All @@ -2783,9 +2844,11 @@ fun update_project (project as { context, libs }) =
(AnyLibControl.update context)
print_outcome_header print_update_outcome
context libs
val _ = if List.exists (fn (_, OK _) => true | _ => false) outcomes
then lock_project project
else OS.Process.success
val successes = List.filter (fn (_, OK _) => true | _ => false)
outcomes
val _ = if null successes
then OS.Process.success (* ignored, not the return value *)
else lock_project (SOME (map #1 successes)) project
val return_code = return_code_for outcomes
in
if OS.Process.isSuccess return_code
Expand Down Expand Up @@ -2819,7 +2882,7 @@ fun with_local_project pintype f =
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 lock () = with_local_project NO_LOCKFILE (lock_project NONE)
fun install () = with_local_project USE_LOCKFILE update_project

fun version () =
Expand Down

0 comments on commit 271bbe7

Please sign in to comment.