Fix CLI scripts calling the wrong function, and the errors that hid it

backend/src/Builtins/Builtins.CliHost/Libs/Cli.fs

@@ -33,7 +33,9 @@ module WT2PT = LibParser.WrittenTypesToProgramTypes
 module WTSourceFile = LibParser.SourceFile
 module Validation = LibParser.Validation
 module NRslv = LibParser.NameResolver
-module Hashing = LibSerialization.Hashing.Hashing
+module HashStabilization = LibDB.HashStabilization
+module AstTransformer = LibDB.AstTransformer
+module PackageLocation = LibDB.PackageLocation
 
 
 /// Load all DBs from the global toplevel set.
@@ -166,28 +168,29 @@ let private declarationsToModule
           (WT2PT.PackageValue.Name.toModules v.name)
           v)
 
-    // WT2PT gives each declaration an empty `Hash ""` placeholder. The graft
-    // below keys declarations by hash, so without real content hashes a script's
-    // types, values, or fns can collapse to one entry and only the last one
-    // survives.
-    //
-    // Use the same `Hashing.compute*Hash` helpers package playback uses for
-    // `Hash ""` declarations. SCC-aware hash stabilization is not needed here
-    // because pass-1 bodies do not contain resolved sibling references.
-    let hashType (t : PT.PackageType.PackageType) =
-      { t with hash = Hashing.computeTypeHash Hashing.Normal t }
-    let hashValue (v : PT.PackageValue.PackageValue) =
-      { v with hash = Hashing.computeValueHash Hashing.Normal v }
-    let hashFn (f : PT.PackageFn.PackageFn) =
-      { f with hash = Hashing.computeFnHash Hashing.Normal f }
+    // WT2PT leaves each declaration with an empty `Hash ""`, and the graft below
+    // keys declarations by hash, so each needs a distinct one before it can be
+    // grafted. Use a location placeholder, not a content hash: a hash taken
+    // before resolution is computed over unresolved references, which serialise
+    // without their names, so two declarations differing only in which sibling
+    // they mention would hash the same and the graft would keep one of them.
+    let stampFn (f : PT.PackageFn.PackageFn) loc =
+      { f with hash = PackageLocation.placeholderHash loc }
+    let stampType (t : PT.PackageType.PackageType) loc =
+      { t with hash = PackageLocation.placeholderHash loc }
+    let stampValue (v : PT.PackageValue.PackageValue) loc =
+      { v with hash = PackageLocation.placeholderHash loc }
 
     // Pass 1: lower against the base pm (intra-script refs unresolved, allowed).
     // The resolver looks up packages on `state.branchId` (threaded through WT2PT),
     // so WIP on this branch resolves without wrapping the pm.
     let pm0 = LibDB.PackageManager.pt
-    let! fns1 = lowerFns pm0 |> Ply.map (List.map hashFn)
-    let! types1 = lowerTypes pm0 |> Ply.map (List.map hashType)
-    let! values1 = lowerValues pm0 |> Ply.map (List.map hashValue)
+    let! fns1 =
+      lowerFns pm0 |> Ply.map (fun fns -> List.map2 stampFn fns fnLocations)
+    let! types1 =
+      lowerTypes pm0 |> Ply.map (fun ts -> List.map2 stampType ts typeLocations)
+    let! values1 =
+      lowerValues pm0 |> Ply.map (fun vs -> List.map2 stampValue vs valueLocations)
 
     // Graft the script's own declarations into the pm, keyed by location.
     let pm1 =
@@ -198,40 +201,100 @@ let private declarationsToModule
         (List.zip fns1 fnLocations)
 
     // Pass 2: re-lower with the grafted pm so intra-script references resolve.
-    // Keep each declaration's pass-1 hash, because pass-2 bodies contain refs to
-    // those hashes. Re-hashing the resolved bodies would make registered hashes
-    // disagree with refs embedded in callers.
-    let! fns = lowerFns pm1
+    let! fns2 =
+      lowerFns pm1 |> Ply.map (fun fns -> List.map2 stampFn fns fnLocations)
+    let! types2 =
+      lowerTypes pm1 |> Ply.map (fun ts -> List.map2 stampType ts typeLocations)
+    let! values2 =
+      lowerValues pm1 |> Ply.map (fun vs -> List.map2 stampValue vs valueLocations)
+
+    // References are resolved now, so hash for real. That keeps script
+    // declarations content-addressed: one structurally identical to a package
+    // declaration lands on the same hash, and a rename changes nothing.
+    //
+    // Pass-2 bodies still reference siblings by placeholder, so the hashes have
+    // to be computed in dependency order with each sibling's real hash
+    // substituted in. Stabilization does exactly that, batching SCCs, so
+    // mutually recursive script declarations work too.
+    let stabilization =
+      HashStabilization.stabilize
+        AstTransformer.emptyMapping
+        { types =
+            List.map2
+              (fun (t : PT.PackageType.PackageType) loc ->
+                PackageLocation.toFQN loc, (t, t.hash, loc))
+              types2
+              typeLocations
+            |> Map.ofList
+          fns =
+            List.map2
+              (fun (f : PT.PackageFn.PackageFn) loc ->
+                PackageLocation.toFQN loc, (f, f.hash, loc))
+              fns2
+              fnLocations
+            |> Map.ofList
+          values =
+            List.map2
+              (fun (v : PT.PackageValue.PackageValue) loc ->
+                PackageLocation.toFQN loc, (v, v.hash, loc))
+              values2
+              valueLocations
+            |> Map.ofList }
+
+    let finalHash (current : PT.Hash) (loc : PT.PackageLocation) : PT.Hash =
+      Map.tryFind (PackageLocation.toFQN loc) stabilization.fqnHashes
+      |> Option.defaultValue current
+
+    // Rewrite each body so its sibling references point at the final hashes.
     let fns =
       List.map2
-        (fun (f1 : PT.PackageFn.PackageFn) (f2 : PT.PackageFn.PackageFn) ->
-          { f2 with hash = f1.hash })
-        fns1
-        fns
-    let! types = lowerTypes pm1
+        (fun (f : PT.PackageFn.PackageFn) loc ->
+          { AstTransformer.transformFn stabilization.mapping f with
+              hash = finalHash f.hash loc })
+        fns2
+        fnLocations
     let types =
       List.map2
-        (fun (t1 : PT.PackageType.PackageType) (t2 : PT.PackageType.PackageType) ->
-          { t2 with hash = t1.hash })
-        types1
-        types
-    let! values = lowerValues pm1
+        (fun (t : PT.PackageType.PackageType) loc ->
+          { AstTransformer.transformType stabilization.mapping t with
+              hash = finalHash t.hash loc })
+        types2
+        typeLocations
     let values =
       List.map2
-        (fun (v1 : PT.PackageValue.PackageValue) (v2 : PT.PackageValue.PackageValue) ->
-          { v2 with hash = v1.hash })
-        values1
-        values
-
-    // Graft the pass-2 declarations (resolved bodies, pass-1 hashes) for the
-    // expressions' lowering — their refs then match the returned decls exactly.
+        (fun (v : PT.PackageValue.PackageValue) loc ->
+          { AstTransformer.transformValue stabilization.mapping v with
+              hash = finalHash v.hash loc })
+        values2
+        valueLocations
+
+    // Graft the final declarations for the expressions' lowering, so their refs
+    // match the returned decls exactly.
     let pm2 =
       pm0
       |> PT.PackageManager.withExtras
         (List.zip types typeLocations)
         (List.zip values valueLocations)
         (List.zip fns fnLocations)
 
+    // Register the same declarations so a runtime error can still name them. The
+    // error outlives this graft: the CLI renders it once execution has returned,
+    // and the pretty-printer turns hashes back into names by asking where a hash
+    // is bound.
+    LibDB.EphemeralPackages.register
+      (List.map2
+        (fun (t : PT.PackageType.PackageType) loc -> t.hash, loc)
+        types
+        typeLocations)
+      (List.map2
+        (fun (v : PT.PackageValue.PackageValue) loc -> v.hash, loc)
+        values
+        valueLocations)
+      (List.map2
+        (fun (f : PT.PackageFn.PackageFn) loc -> f.hash, loc)
+        fns
+        fnLocations)
+
     let emptyContext =
       { WT2PT.Context.currentFnName = None
         WT2PT.Context.argMap = Map.empty
@@ -486,7 +549,12 @@ let fns () : List<BuiltInFn> =
 
             try
               // A parse failure surfaces a precise diagnostic as a `ParseError`
-              let! parseResult = parseCliScript branchState "CliScript" filename code
+              // No module for the script's own declarations. A module named after
+              // the file put the whole path into every name the runtime prints
+              // back (`CliScript.rundir/tmp/x.dark.Celsius`), and it buys nothing:
+              // one script runs per process, and two that declare the same thing
+              // share a hash anyway. The filename reaches traces via `RunScript`.
+              let! parseResult = parseCliScript branchState "CliScript" "" code
               let! parsedScript =
                 match parseResult with
                 | Ok m -> Ply(Ok m)

backend/src/Builtins/Builtins.Http.Client/Libs/HttpClient.fs

@@ -729,6 +729,7 @@ let fns (config : Configuration) : List<BuiltInFn> =
                         ),
                         2,
                         "headers",
+                        None,
                         VT.list (VT.tuple VT.string VT.string []),
                         Dval.toValueType notAPair,
                         notAPair
@@ -909,6 +910,7 @@ let fns (config : Configuration) : List<BuiltInFn> =
                         ),
                         2,
                         "headers",
+                        None,
                         VT.list (VT.tuple VT.string VT.string []),
                         Dval.toValueType notAPair,
                         notAPair

backend/src/LibDB/EphemeralPackages.fs

@@ -0,0 +1,76 @@
+/// Declarations that exist in this process but were never written to the store:
+/// the types, values and fns a CLI script declares for itself.
+///
+/// A runtime error carries content hashes, and it is rendered well after the
+/// executor that raised it is gone. The pretty-printer turns a hash back into a
+/// name by asking the package manager which locations that hash is bound to, so
+/// a declaration the store has never seen renders as a 64-character hash, and a
+/// message about the wrong function reads as an ordinary type mismatch.
+///
+/// Registering the declarations here puts them in reach of that lookup without
+/// threading a second package manager through every pretty-printer entry point.
+///
+/// Registrations accumulate rather than replace, so an error can still name a
+/// declaration from an enclosing script after a nested one has run. Growth is
+/// bounded by content addressing: a hash is registered once however many times
+/// its declaration is parsed, and a REPL session's worth of declarations is
+/// small. Two names for one hash mean two names for one declaration, which is
+/// the situation `pickLocation` already exists to resolve.
+module LibDB.EphemeralPackages
+
+open Prelude
+
+module PT = LibExecution.ProgramTypes
+
+/// Hash to every location it is known by.
+type private Registry =
+  { types : Map<PT.Hash, List<PT.PackageLocation>>
+    values : Map<PT.Hash, List<PT.PackageLocation>>
+    fns : Map<PT.Hash, List<PT.PackageLocation>> }
+
+let private empty = { types = Map.empty; values = Map.empty; fns = Map.empty }
+
+let mutable private registry = empty
+let private writeLock = obj ()
+
+let private add
+  (entries : List<PT.Hash * PT.PackageLocation>)
+  (m : Map<PT.Hash, List<PT.PackageLocation>>)
+  : Map<PT.Hash, List<PT.PackageLocation>> =
+  entries
+  |> List.fold
+    (fun acc (hash, loc) ->
+      let existing = Map.tryFind hash acc |> Option.defaultValue []
+      if List.contains loc existing then
+        acc
+      else
+        Map.add hash (existing @ [ loc ]) acc)
+    m
+
+/// Make these declarations nameable by hash for the rest of the process.
+///
+/// Locked because this is a read-modify-write: two lowerings racing would
+/// silently lose one of them. Reads stay lock-free, each seeing whichever
+/// immutable snapshot is current.
+let register
+  (types : List<PT.Hash * PT.PackageLocation>)
+  (values : List<PT.Hash * PT.PackageLocation>)
+  (fns : List<PT.Hash * PT.PackageLocation>)
+  : unit =
+  lock writeLock (fun () ->
+    registry <-
+      { types = add types registry.types
+        values = add values registry.values
+        fns = add fns registry.fns })
+
+/// Reverse lookups only. Resolution reads the store directly, and adding a layer
+/// to `findType`/`getType` would put this on the parser's hot path for the sake
+/// of an error message.
+let typeLocations (hash : PT.Hash) : List<PT.PackageLocation> =
+  Map.tryFind hash registry.types |> Option.defaultValue []
+
+let valueLocations (hash : PT.Hash) : List<PT.PackageLocation> =
+  Map.tryFind hash registry.values |> Option.defaultValue []
+
+let fnLocations (hash : PT.Hash) : List<PT.PackageLocation> =
+  Map.tryFind hash registry.fns |> Option.defaultValue []

backend/src/LibDB/LibDB.fsproj

@@ -39,6 +39,7 @@
     <Compile Include="WipRefresh.fs" />
     <Compile Include="Propagation.fs" />
     <Compile Include="RuntimeTypes.fs" />
+    <Compile Include="EphemeralPackages.fs" />
     <Compile Include="PackageManager.fs" />
     <Compile Include="Scripts.fs" />
     <Compile Include="PackageRefsGenerator.fs" />

backend/src/LibDB/PackageLocation.fs

@@ -9,3 +9,17 @@ let toFQN (loc : PT.PackageLocation) : string =
   | modules ->
     let modulesStr = modules |> String.concat "."
     $"{loc.owner}.{modulesStr}.{loc.name}"
+
+
+/// Deterministic per-location stand-in for a content hash, for use before an
+/// item's references are resolved. A content hash computed at that point is
+/// lossy: an unresolved reference carries no name, so two items differing only
+/// in which unresolved name they mention hash identically, and any hash-keyed
+/// registry silently drops one of them. One placeholder per location cannot
+/// collide. The real content hash replaces it after resolution.
+let placeholderHash (loc : PT.PackageLocation) : PT.Hash =
+  let bytes =
+    System.Security.Cryptography.SHA256.HashData(
+      System.Text.Encoding.UTF8.GetBytes(toFQN loc)
+    )
+  PT.Hash(System.Convert.ToHexString(bytes).ToLowerInvariant())

backend/src/LibDB/PackageManager.fs

@@ -90,18 +90,34 @@ let pt : PT.PackageManager =
     getFn = withCache PMPT.Fn.get
     getValue = withCache PMPT.Value.get
 
+    // A CLI script's declarations are never in the store, so without a fallback
+    // they render as hashes. Only as a fallback, though: hashes are content
+    // addressed, so a script's private name for some shape is also a name for
+    // every stored declaration of that shape, and `pickLocation` breaks ties by
+    // shortest path, which a script's one-segment path always wins. Consulted
+    // ahead of the store, `type MyErr = | BadFormat` in a script would rename
+    // `Stdlib.Int.ParseError` for the rest of the process.
     getTypeLocations =
       fun branchId id ->
-        let chain = getBranchChain branchId
-        PMPT.Type.getLocations chain id
+        uply {
+          match! PMPT.Type.getLocations (getBranchChain branchId) id with
+          | [] -> return EphemeralPackages.typeLocations id
+          | stored -> return stored
+        }
     getValueLocations =
       fun branchId id ->
-        let chain = getBranchChain branchId
-        PMPT.Value.getLocations chain id
+        uply {
+          match! PMPT.Value.getLocations (getBranchChain branchId) id with
+          | [] -> return EphemeralPackages.valueLocations id
+          | stored -> return stored
+        }
     getFnLocations =
       fun branchId id ->
-        let chain = getBranchChain branchId
-        PMPT.Fn.getLocations chain id
+        uply {
+          match! PMPT.Fn.getLocations (getBranchChain branchId) id with
+          | [] -> return EphemeralPackages.fnLocations id
+          | stored -> return stored
+        }
 
     search =
       fun (branchId, query) ->

backend/src/LibExecution/Interpreter.fs

@@ -2310,6 +2310,7 @@ let private frameReturnTypeCheckAsync
         Ply.toTask (TypeReference.toVT exeState.types tst expectedReturnType)
       RuntimeError.Applications.FnResultNotExpectedType(
         fnName,
+        Some expectedReturnType,
         expectedVT,
         Dval.toValueType resultOfFrame,
         resultOfFrame