⅄ trunk → 23-08-31-one-reference-type

.github/workflows/release.yaml

@@ -1,5 +1,7 @@
 name: "release"
 
+run-name: "release ${{inputs.version}}"
+
 defaults:
   run:
     shell: bash

CONTRIBUTORS.markdown

@@ -77,3 +77,4 @@ The format for this list: name, GitHub handle
 * Chris Krycho (@chriskrycho)
 * Hatim Khambati (@hatimkhambati26)
 * Kyle Goetz (@kylegoetz)
+* Ethan Morgan (@sixfourtwelve)

codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs

@@ -107,6 +107,7 @@ module U.Codebase.Sqlite.Queries
 
     -- * projects
     projectExists,
+    doProjectsExist,
     projectExistsByName,
     loadProject,
     loadProjectByName,
@@ -3224,6 +3225,12 @@ projectExists projectId =
       )
     |]
 
+-- | Check if any projects exist
+doProjectsExist :: Transaction Bool
+doProjectsExist =
+  queryOneCol
+    [sql| SELECT EXISTS (SELECT 1 FROM project) |]
+
 -- | Does a project exist by this name?
 projectExistsByName :: ProjectName -> Transaction Bool
 projectExistsByName name =

codebase2/core/Unison/ShortHash.hs

@@ -18,13 +18,21 @@ where
 import Data.Text qualified as Text
 import Unison.Prelude
 
+-- A ShortHash is used to query the Codebase for anonymous definitions. The prefix should look like base32hex, but is
+-- not decoded here because the prefix doesn't correspond to anything useful - we'll just compare strings against the
+-- codebase later.
+--
 -- ##Text.++
---   ^^^^^^^-- builtin
-
--- #abc123.a#0
---  ^      ^ ^-cid
---  |      \-cycle
---  \-- prefix
+--   ^^^^^^^
+--   |
+--   builtin
+--
+-- #abc123.1#2
+--  ^^^^^^ ^ ^
+--  |      | |
+--  |      | cid
+--  |      cycle
+--  prefix
 data ShortHash
   = Builtin Text
   | ShortHash {prefix :: Text, cycle :: Maybe Word64, cid :: Maybe Word64}

flake.nix

@@ -119,6 +119,13 @@
                   ormolu = { version = ormolu-ver; };
                   haskell-language-server = {
                     version = "latest";
+                    modules = [
+                      {
+                        packages.haskell-language-server.components.exes.haskell-language-server.postInstall = ''
+                          ln -sr "$out/bin/haskell-language-server" "$out/bin/haskell-language-server-wrapper"
+                        '';
+                      }
+                    ];
                     # specify flags via project file rather than a module override
                     # https://github.com/input-output-hk/haskell.nix/issues/1509
                     cabalProject = ''

parser-typechecker/src/U/Codebase/Branch/Diff.hs

@@ -1,5 +1,6 @@
 module U.Codebase.Branch.Diff
   ( TreeDiff (..),
+    hoistTreeDiff,
     NameChanges (..),
     DefinitionDiffs (..),
     Diff (..),
@@ -12,6 +13,7 @@ module U.Codebase.Branch.Diff
 where
 
 import Control.Comonad.Cofree
+import Control.Comonad.Cofree qualified as Cofree
 import Control.Lens (ifoldMap)
 import Control.Lens qualified as Lens
 import Data.Functor.Compose (Compose (..))
@@ -20,6 +22,7 @@ import Data.Semialign qualified as Align
 import Data.Set qualified as Set
 import Data.These
 import U.Codebase.Branch
+import U.Codebase.Branch qualified as V2Branch
 import U.Codebase.Branch.Type qualified as Branch
 import U.Codebase.Causal qualified as Causal
 import U.Codebase.Reference (Reference)
@@ -29,6 +32,7 @@ import Unison.Name (Name)
 import Unison.Name qualified as Name
 import Unison.NameSegment (NameSegment)
 import Unison.Prelude
+import Unison.Sqlite qualified as Sqlite
 import Unison.Util.Monoid (foldMapM, ifoldMapM)
 import Unison.Util.Relation (Relation)
 import Unison.Util.Relation qualified as Relation
@@ -76,6 +80,10 @@ instance (Applicative m) => Semigroup (TreeDiff m) where
 instance (Applicative m) => Monoid (TreeDiff m) where
   mempty = TreeDiff (mempty :< Compose mempty)
 
+hoistTreeDiff :: Functor m => (forall x. m x -> n x) -> TreeDiff m -> TreeDiff n
+hoistTreeDiff f (TreeDiff cfr) =
+  TreeDiff $ Cofree.hoistCofree (\(Compose m) -> Compose (fmap f m)) cfr
+
 -- | A summary of a 'TreeDiff', containing all names added and removed.
 -- Note that there isn't a clear notion of a name "changing" since conflicts might muddy the notion
 -- by having multiple copies of both the from and to names, so we just talk about adds and
@@ -114,37 +122,40 @@ instance Semigroup NameBasedDiff where
     NameBasedDiff (terms0 <> terms1) (types0 <> types1)
 
 -- | Diff two Branches, returning a tree containing all of the changes
-diffBranches :: forall m. (Monad m) => Branch m -> Branch m -> TreeDiff m
-diffBranches from to =
+diffBranches :: Branch Sqlite.Transaction -> Branch Sqlite.Transaction -> Sqlite.Transaction (TreeDiff Sqlite.Transaction)
+diffBranches from to = do
+  fromChildren <- V2Branch.nonEmptyChildren from
+  toChildren <- V2Branch.nonEmptyChildren to
   let termDiffs = diffMap (Branch.terms from) (Branch.terms to)
-      typeDiffs = diffMap (Branch.types from) (Branch.types to)
-      defDiff = DefinitionDiffs {termDiffs, typeDiffs}
-      childDiff :: (Map NameSegment (m (Cofree (Compose (Map NameSegment) m) DefinitionDiffs)))
-      childDiff = do
-        Align.align (children from) (children to)
+  let typeDiffs = diffMap (Branch.types from) (Branch.types to)
+  let defDiff = DefinitionDiffs {termDiffs, typeDiffs}
+  let childDiff :: Map NameSegment (Sqlite.Transaction (Cofree (Compose (Map NameSegment) Sqlite.Transaction) DefinitionDiffs))
+      childDiff =
+        Align.align fromChildren toChildren
           & mapMaybe \case
             This ca -> Just do
               -- TODO: For the names index we really don't need to know which exact
               -- names were removed, we just need to delete from the index using a
               -- prefix query, this would be faster than crawling to get all the deletes.
               removedChildBranch <- Causal.value ca
-              pure . unTreeDiff $ diffBranches removedChildBranch Branch.empty
+              unTreeDiff <$> diffBranches removedChildBranch Branch.empty
             That ca -> Just do
               newChildBranch <- Causal.value ca
-              pure . unTreeDiff $ diffBranches Branch.empty newChildBranch
+              unTreeDiff <$> diffBranches Branch.empty newChildBranch
             These fromC toC
               | Causal.valueHash fromC == Causal.valueHash toC ->
                   -- This child didn't change.
                   Nothing
               | otherwise -> Just $ do
                   fromChildBranch <- Causal.value fromC
                   toChildBranch <- Causal.value toC
-                  case diffBranches fromChildBranch toChildBranch of
+                  diffBranches fromChildBranch toChildBranch >>= \case
                     TreeDiff (defDiffs :< Compose mchildren) -> do
                       pure $ (defDiffs :< Compose mchildren)
-   in TreeDiff (defDiff :< Compose childDiff)
+  pure $
+    TreeDiff (defDiff :< Compose childDiff)
   where
-    diffMap :: forall ref. (Ord ref) => Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Diff ref)
+    diffMap :: forall ref. (Ord ref) => Map NameSegment (Map ref (Sqlite.Transaction MdValues)) -> Map NameSegment (Map ref (Sqlite.Transaction MdValues)) -> Map NameSegment (Diff ref)
     diffMap l r =
       Align.align l r
         & fmap \case
@@ -211,7 +222,10 @@ streamNameChanges namePrefix (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :
             let name = appendName ns
              in (listifyNames name $ adds diff, listifyNames name $ removals diff)
   let nameChanges = NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals}
-  acc <- f namePrefix nameChanges
+  acc <-
+    if nameChanges == mempty
+      then pure mempty
+      else f namePrefix nameChanges
   childAcc <-
     children
       & ifoldMapM

parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs

@@ -640,7 +640,7 @@ ensureNameLookupForBranchHash getDeclType mayFromBranchHash toBranchHash = do
       toBranch <- Ops.expectBranchByBranchHash toBranchHash
       depMounts <- Projects.inferDependencyMounts toBranch <&> fmap (first (coerce @_ @PathSegments . Path.toList))
       let depMountPaths = (Path.fromList . coerce) . fst <$> depMounts
-      let treeDiff = ignoreDepMounts depMountPaths $ BranchDiff.diffBranches fromBranch toBranch
+      treeDiff <- ignoreDepMounts depMountPaths <$> BranchDiff.diffBranches fromBranch toBranch
       let namePrefix = Nothing
       Ops.buildNameLookupForBranchHash
         mayExistingLookupBH

scheme-libs/racket/unison/io-handles.rkt

@@ -1,33 +1,15 @@
 #lang racket/base
-(require racket/exn
-         racket/string
-         racket/file
+(require racket/string
          rnrs/io/ports-6
          (only-in rnrs standard-error-port standard-input-port standard-output-port vector-map)
          (only-in racket empty? with-output-to-string system/exit-code system false?)
-         compatibility/mlist
          (only-in unison/boot data-case define-unison)
          unison/data
          unison/chunked-seq
-         unison/core
-         unison/tcp
-         unison/pem
-          unison/core
-          unison/data
-          unison/data-info
-          unison/math
-          unison/chunked-seq
-          unison/chunked-bytes
-          unison/bytes-nat
-          unison/pattern
-          unison/crypto
-          unison/data
-          unison/io
-          unison/tls
-          unison/tcp
-          unison/gzip
-          unison/zlib
-          unison/concurrent
+         unison/data
+         unison/data-info
+         unison/chunked-seq
+         unison/data
          )
 
 (provide
@@ -46,6 +28,8 @@
     getEnv.impl.v1
     getChar.impl.v1
     isFileOpen.impl.v3
+    isSeekable.impl.v3
+    handlePosition.impl.v3
     process.call
     getCurrentDirectory.impl.v3
     ready.impl.v1
@@ -78,6 +62,13 @@
     (unison-either-right
       (string->chunked-string (path->string (current-directory)))))
 
+(define-unison (isSeekable.impl.v3 handle)
+    (unison-either-right
+        (if (port-has-set-port-position!? handle) unison-boolean-true unison-boolean-false)))
+
+(define-unison (handlePosition.impl.v3 handle)
+    (unison-either-right (port-position handle)))
+
 (define-unison (seekHandle.impl.v3 handle mode amount)
     (data-case mode
         (0 ()

scheme-libs/racket/unison/io.rkt

@@ -35,6 +35,11 @@
         renameFile.impl.v3
         createDirectory.impl.v3
         removeDirectory.impl.v3
+        setCurrentDirectory.impl.v3
+        renameDirectory.impl.v3
+        isDirectory.impl.v3
+        systemTime.impl.v3
+        systemTimeMicroseconds.impl.v3
         createTempDirectory.impl.v3)))
 
 (define (getFileSize.impl.v3 path)
@@ -62,6 +67,10 @@
 (define (getTempDirectory.impl.v3)
     (right (string->chunked-string (path->string (find-system-path 'temp-dir)))))
 
+(define-unison (setCurrentDirectory.impl.v3 path)
+    (current-directory (chunked-string->string path))
+    (unison-either-right none))
+
 (define-unison (createTempDirectory.impl.v3 prefix)
     (unison-either-right
         (string->chunked-string
@@ -75,14 +84,31 @@
     (unison-either-right none))
 
 (define-unison (removeDirectory.impl.v3 file)
-    (delete-directory (chunked-string->string file))
+    (delete-directory/files (chunked-string->string file))
+    (unison-either-right none))
+
+(define-unison (isDirectory.impl.v3 path)
+    (unison-either-right
+        (if (directory-exists? (chunked-string->string path))
+            unison-boolean-true
+            unison-boolean-false)))
+
+(define-unison (renameDirectory.impl.v3 old new)
+    (rename-file-or-directory (chunked-string->string old)
+        (chunked-string->string new))
     (unison-either-right none))
 
 (define-unison (renameFile.impl.v3 old new)
     (rename-file-or-directory (chunked-string->string old)
         (chunked-string->string new))
     (unison-either-right none))
 
+(define-unison (systemTime.impl.v3 unit)
+    (unison-either-right (current-seconds)))
+
+(define-unison (systemTimeMicroseconds.impl.v3 unit)
+    (unison-either-right (inexact->exact (* 1000 (current-inexact-milliseconds)))))
+
 (define (threadCPUTime.v1)
     (right (current-process-milliseconds (current-thread))))
 (define (processCPUTime.v1)

scheme-libs/racket/unison/primops.ss

@@ -88,6 +88,13 @@
     builtin-IO.renameFile.impl.v3
     builtin-IO.createTempDirectory.impl.v3
     builtin-IO.createDirectory.impl.v3
+    builtin-IO.setCurrentDirectory.impl.v3
+    builtin-IO.renameDirectory.impl.v3
+    builtin-IO.isDirectory.impl.v3
+    builtin-IO.isSeekable.impl.v3
+    builtin-IO.handlePosition.impl.v3
+    builtin-IO.systemTime.impl.v3
+    builtin-IO.systemTimeMicroseconds.impl.v3
     unison-FOp-IO.getFileSize.impl.v3
     unison-FOp-IO.getFileTimestamp.impl.v3
     unison-FOp-IO.fileExists.impl.v3

unison-cli/src/Unison/Codebase/Editor/HandleInput.hs

@@ -1320,7 +1320,7 @@ loop e = do
                 Cli.runTransaction do
                   fromBranch <- Codebase.expectCausalBranchByCausalHash fromCH >>= V2Causal.value
                   toBranch <- Codebase.expectCausalBranchByCausalHash toCH >>= V2Causal.value
-                  let treeDiff = V2Branch.Diff.diffBranches fromBranch toBranch
+                  treeDiff <- V2Branch.Diff.diffBranches fromBranch toBranch
                   nameChanges <- V2Branch.Diff.allNameChanges Nothing treeDiff
                   pure (DisplayDebugNameDiff nameChanges)
               Cli.respond output
@@ -1909,7 +1909,7 @@ handleDiffNamespaceToPatch description input = do
         branch1 <- ExceptT (Cli.resolveAbsBranchIdV2 absBranchId1)
         branch2 <- ExceptT (Cli.resolveAbsBranchIdV2 absBranchId2)
         lift do
-          branchDiff <- V2Branch.Diff.nameBasedDiff (V2Branch.Diff.diffBranches branch1 branch2)
+          branchDiff <- V2Branch.Diff.diffBranches branch1 branch2 >>= V2Branch.Diff.nameBasedDiff
           termEdits <-
             (branchDiff ^. #terms)
               & Relation.domain

unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs

@@ -749,7 +749,24 @@ makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do
               branchOldCausalHash = Just remoteBranchHead,
               branchNewCausalHash = localBranchHead
             }
+    let onSuccess =
+          case pushing of
+            PushingLooseCode -> pure ()
+            PushingProjectBranch (ProjectAndBranch localProject localBranch) -> do
+              Cli.runTransaction do
+                Queries.ensureBranchRemoteMapping
+                  (localProject ^. #projectId)
+                  (localBranch ^. #branchId)
+                  (remoteBranch ^. #projectId)
+                  Share.hardCodedUri
+                  (remoteBranch ^. #branchId)
     Share.setProjectBranchHead request >>= \case
+      Share.SetProjectBranchHeadResponseSuccess -> onSuccess
+      -- Sometimes a different request gets through in between checking the remote head and
+      -- executing the check-and-set push, if it managed to set the head to what we wanted
+      -- then the goal was achieved and we can consider it a success.
+      Share.SetProjectBranchHeadResponseExpectedCausalHashMismatch _expected actual
+        | actual == localBranchHead -> onSuccess
       Share.SetProjectBranchHeadResponseExpectedCausalHashMismatch _expected _actual ->
         Cli.returnEarly (RemoteProjectBranchHeadMismatch Share.hardCodedUri remoteProjectAndBranchNames)
       Share.SetProjectBranchHeadResponseNotFound -> do
@@ -758,17 +775,6 @@ makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do
         Cli.returnEarly (Output.RemoteProjectReleaseIsDeprecated Share.hardCodedUri remoteProjectAndBranchNames)
       Share.SetProjectBranchHeadResponsePublishedReleaseIsImmutable -> do
         Cli.returnEarly (Output.RemoteProjectPublishedReleaseCannotBeChanged Share.hardCodedUri remoteProjectAndBranchNames)
-      Share.SetProjectBranchHeadResponseSuccess -> do
-        case pushing of
-          PushingLooseCode -> pure ()
-          PushingProjectBranch (ProjectAndBranch localProject localBranch) -> do
-            Cli.runTransaction do
-              Queries.ensureBranchRemoteMapping
-                (localProject ^. #projectId)
-                (localBranch ^. #branchId)
-                (remoteBranch ^. #projectId)
-                Share.hardCodedUri
-                (remoteBranch ^. #branchId)
   where
     remoteBranchHead =
       Share.API.hashJWTHash (remoteBranch ^. #branchHead)