Merge trunk and resolve basic conflicts

sellout · Jul 1, 2024 · dadc4e4 · dadc4e4
2 parents c206059 + 1f34de9
commit dadc4e4
Show file tree

Hide file tree

Showing 111 changed files with 3,901 additions and 4,126 deletions.
diff --git a/Sync.hs b/Sync.hs
diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs
@@ -1,10 +1,5 @@
 module U.Codebase.Sqlite.Operations
   ( -- * branches
-    saveRootBranch,
-    loadRootCausalHash,
-    expectRootCausalHash,
-    expectRootCausal,
-    expectRootBranchHash,
     loadCausalHashAtPath,
     expectCausalHashAtPath,
     loadCausalBranchAtPath,
@@ -13,6 +8,7 @@ module U.Codebase.Sqlite.Operations
     saveBranchV3,
     loadCausalBranchByCausalHash,
     expectCausalBranchByCausalHash,
+    expectBranchByCausalHashId,
     expectBranchByBranchHash,
     expectBranchByBranchHashId,
     expectNamespaceStatsByHash,
@@ -100,9 +96,15 @@ module U.Codebase.Sqlite.Operations
     fuzzySearchDefinitions,
     namesPerspectiveForRootAndPath,
 
+    -- * Projects
+    expectProjectAndBranchNames,
+    expectProjectBranchHead,
+
     -- * reflog
     getReflog,
     appendReflog,
+    getProjectReflog,
+    appendProjectReflog,
 
     -- * low-level stuff
     expectDbBranch,
@@ -183,6 +185,9 @@ import U.Codebase.Sqlite.Patch.TermEdit qualified as S
 import U.Codebase.Sqlite.Patch.TermEdit qualified as S.TermEdit
 import U.Codebase.Sqlite.Patch.TypeEdit qualified as S
 import U.Codebase.Sqlite.Patch.TypeEdit qualified as S.TypeEdit
+import U.Codebase.Sqlite.Project (Project (..))
+import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
+import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog
 import U.Codebase.Sqlite.Queries qualified as Q
 import U.Codebase.Sqlite.Reference qualified as S
 import U.Codebase.Sqlite.Reference qualified as S.Reference
@@ -200,6 +205,7 @@ import U.Codebase.TypeEdit qualified as C.TypeEdit
 import U.Codebase.WatchKind (WatchKind)
 import U.Util.Base32Hex qualified as Base32Hex
 import U.Util.Serialization qualified as S
+import Unison.Core.Project (ProjectBranchName, ProjectName)
 import Unison.Hash qualified as H
 import Unison.Hash32 qualified as Hash32
 import Unison.NameSegment (NameSegment)
@@ -232,23 +238,10 @@ expectValueHashByCausalHashId = loadValueHashById <=< Q.expectCausalValueHashId
     loadValueHashById :: Db.BranchHashId -> Transaction BranchHash
     loadValueHashById = fmap BranchHash . Q.expectHash . Db.unBranchHashId
 
-expectRootCausalHash :: Transaction CausalHash
-expectRootCausalHash = Q.expectCausalHash =<< Q.expectNamespaceRoot
-
-expectRootBranchHash :: Transaction BranchHash
-expectRootBranchHash = do
-  rootCausalHashId <- Q.expectNamespaceRoot
-  expectValueHashByCausalHashId rootCausalHashId
-
-loadRootCausalHash :: Transaction (Maybe CausalHash)
-loadRootCausalHash =
-  runMaybeT $
-    lift . Q.expectCausalHash =<< MaybeT Q.loadNamespaceRoot
-
 -- | Load the causal hash at the given path from the provided root, if Nothing, use the
 -- codebase root.
-loadCausalHashAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction (Maybe CausalHash)
-loadCausalHashAtPath mayRootCausalHash =
+loadCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe CausalHash)
+loadCausalHashAtPath rootCausalHash =
   let go :: Db.CausalHashId -> [NameSegment] -> MaybeT Transaction CausalHash
       go hashId = \case
         [] -> lift (Q.expectCausalHash hashId)
@@ -258,15 +251,13 @@ loadCausalHashAtPath mayRootCausalHash =
           (_, hashId') <- MaybeT (pure (Map.lookup tid children))
           go hashId' ts
    in \path -> do
-        hashId <- case mayRootCausalHash of
-          Nothing -> Q.expectNamespaceRoot
-          Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH
+        hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash
         runMaybeT (go hashId path)
 
 -- | Expect the causal hash at the given path from the provided root, if Nothing, use the
 -- codebase root.
-expectCausalHashAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction CausalHash
-expectCausalHashAtPath mayRootCausalHash =
+expectCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction CausalHash
+expectCausalHashAtPath rootCausalHash =
   let go :: Db.CausalHashId -> [NameSegment] -> Transaction CausalHash
       go hashId = \case
         [] -> Q.expectCausalHash hashId
@@ -276,23 +267,21 @@ expectCausalHashAtPath mayRootCausalHash =
           let (_, hashId') = children Map.! tid
           go hashId' ts
    in \path -> do
-        hashId <- case mayRootCausalHash of
-          Nothing -> Q.expectNamespaceRoot
-          Just rootCH -> Q.expectCausalHashIdByCausalHash rootCH
+        hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash
         go hashId path
 
 loadCausalBranchAtPath ::
-  Maybe CausalHash ->
+  CausalHash ->
   [NameSegment] ->
   Transaction (Maybe (C.Branch.CausalBranch Transaction))
-loadCausalBranchAtPath maybeRootCausalHash path =
-  loadCausalHashAtPath maybeRootCausalHash path >>= \case
+loadCausalBranchAtPath rootCausalHash path =
+  loadCausalHashAtPath rootCausalHash path >>= \case
     Nothing -> pure Nothing
     Just causalHash -> Just <$> expectCausalBranchByCausalHash causalHash
 
-loadBranchAtPath :: Maybe CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction))
-loadBranchAtPath maybeRootCausalHash path =
-  loadCausalBranchAtPath maybeRootCausalHash path >>= \case
+loadBranchAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction))
+loadBranchAtPath rootCausalHash path =
+  loadCausalBranchAtPath rootCausalHash path >>= \case
     Nothing -> pure Nothing
     Just causal -> Just <$> C.Causal.value causal
 
@@ -613,16 +602,6 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) =
           boId <- Q.expectBranchObjectIdByCausalHashId chId
           expectBranch boId
 
-saveRootBranch ::
-  HashHandle ->
-  C.Branch.CausalBranch Transaction ->
-  Transaction (Db.BranchObjectId, Db.CausalHashId)
-saveRootBranch hh c = do
-  when debug $ traceM $ "Operations.saveRootBranch " ++ show (C.causalHash c)
-  (boId, chId) <- saveBranch hh c
-  Q.setNamespaceRoot chId
-  pure (boId, chId)
-
 -- saveBranch is kind of a "deep save causal"
 
 -- we want a "shallow save causal" that could take a
@@ -749,9 +728,6 @@ saveCausalObject hh (C.Causal.Causal hc he parents _) = do
     Q.saveCausal hh chId bhId parentCausalHashIds
     pure (chId, bhId)
 
-expectRootCausal :: Transaction (C.Branch.CausalBranch Transaction)
-expectRootCausal = Q.expectNamespaceRoot >>= expectCausalBranchByCausalHashId
-
 loadCausalBranchByCausalHash :: CausalHash -> Transaction (Maybe (C.Branch.CausalBranch Transaction))
 loadCausalBranchByCausalHash hc = do
   Q.loadCausalHashIdByCausalHash hc >>= \case
@@ -1520,6 +1496,17 @@ appendReflog entry = do
   dbEntry <- (bitraverse Q.saveCausalHash pure) entry
   Q.appendReflog dbEntry
 
+-- | Gets the specified number of reflog entries in chronological order, most recent first.
+getProjectReflog :: Int -> Transaction [ProjectReflog.Entry CausalHash]
+getProjectReflog numEntries = do
+  entries <- Q.getProjectReflog numEntries
+  (traverse . traverse) Q.expectCausalHash entries
+
+appendProjectReflog :: ProjectReflog.Entry CausalHash -> Transaction ()
+appendProjectReflog entry = do
+  dbEntry <- traverse Q.saveCausalHash entry
+  Q.appendProjectReflog dbEntry
+
 -- | Delete any name lookup that's not in the provided list.
 --
 -- This can be used to garbage collect unreachable name lookups.
@@ -1584,3 +1571,14 @@ stripPrefixFromNamedRef (PathSegments prefix) namedRef =
                 Nothing -> reversedName
                 Just strippedReversedPath -> S.ReversedName (name NonEmpty.:| strippedReversedPath)
    in namedRef {S.reversedSegments = newReversedName}
+
+expectProjectAndBranchNames :: Db.ProjectId -> Db.ProjectBranchId -> Transaction (ProjectName, ProjectBranchName)
+expectProjectAndBranchNames projectId projectBranchId = do
+  Project {name = pName} <- Q.expectProject projectId
+  ProjectBranch {name = bName} <- Q.expectProjectBranch projectId projectBranchId
+  pure (pName, bName)
+
+expectProjectBranchHead :: Db.ProjectId -> Db.ProjectBranchId -> Transaction CausalHash
+expectProjectBranchHead projId projectBranchId = do
+  chId <- Q.expectProjectBranchHead projId projectBranchId
+  Q.expectCausalHash chId
diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs
@@ -14,5 +14,5 @@ data Project = Project
   { projectId :: !ProjectId,
     name :: !ProjectName
   }
-  deriving stock (Generic, Show)
+  deriving stock (Generic, Show, Eq)
   deriving anyclass (ToRow, FromRow)
diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs
@@ -0,0 +1,33 @@
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module U.Codebase.Sqlite.ProjectReflog where
+
+import Data.Text (Text)
+import Data.Time (UTCTime)
+import U.Codebase.Sqlite.DbId (CausalHashId, ProjectBranchId, ProjectId)
+import Unison.Sqlite (FromRow (..), ToRow (..), field)
+
+data Entry causal = Entry
+  { project :: ProjectId,
+    branch :: ProjectBranchId,
+    time :: UTCTime,
+    fromRootCausalHash :: Maybe causal,
+    toRootCausalHash :: causal,
+    reason :: Text
+  }
+  deriving stock (Show, Functor, Foldable, Traversable)
+
+instance ToRow (Entry CausalHashId) where
+  toRow (Entry proj branch time fromRootCausalHash toRootCausalHash reason) =
+    toRow (proj, branch, time, fromRootCausalHash, toRootCausalHash, reason)
+
+instance FromRow (Entry CausalHashId) where
+  fromRow = do
+    project <- field
+    branch <- field
+    time <- field
+    fromRootCausalHash <- field
+    toRootCausalHash <- field
+    reason <- field
+    pure $ Entry {..}