From 57a402df5854c0279af66e2d208d56c1f13a0e6d Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 4 Dec 2021 13:57:32 -0500 Subject: [PATCH 001/529] Replace usage of sqlite-simple with unison-sqlite --- .../U/Codebase/Sqlite/Connection.hs | 15 - .../codebase-sqlite/U/Codebase/Sqlite/DbId.hs | 3 +- .../U/Codebase/Sqlite/JournalMode.hs | 5 - .../U/Codebase/Sqlite/ObjectType.hs | 4 +- .../U/Codebase/Sqlite/Operations.hs | 8 +- .../U/Codebase/Sqlite/Queries.hs | 400 ++++++------------ .../U/Codebase/Sqlite/Reference.hs | 6 +- .../U/Codebase/Sqlite/Referent.hs | 3 +- .../U/Codebase/Sqlite/Sync22.hs | 2 +- codebase2/codebase-sqlite/package.yaml | 7 +- .../unison-codebase-sqlite.cabal | 7 +- lib/unison-sqlite/src/Unison/Sqlite.hs | 23 +- .../src/Unison/Sqlite/Connection.hs | 13 +- lib/unison-sqlite/src/Unison/Sqlite/DB.hs | 7 - .../src/Unison/Sqlite/Exception.hs | 8 + .../src/Unison/Sqlite/JournalMode.hs | 7 +- parser-typechecker/package.yaml | 2 +- .../src/Unison/Codebase/SqliteCodebase.hs | 102 ++--- .../Codebase/SqliteCodebase/Conversions.hs | 20 +- .../unison-parser-typechecker.cabal | 2 +- 20 files changed, 226 insertions(+), 418 deletions(-) delete mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/Connection.hs delete mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/JournalMode.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Connection.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Connection.hs deleted file mode 100644 index 75ff0cc9e0..0000000000 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Connection.hs +++ /dev/null @@ -1,15 +0,0 @@ -module U.Codebase.Sqlite.Connection where - -import qualified Database.SQLite.Simple as Sqlite - -data Connection = Connection {name :: String, file :: FilePath, underlying :: Sqlite.Connection} - -instance Show Connection where - show (Connection name file underlying) = - "Connection " ++ show name - ++ (if showFile then " " ++ file else mempty) - ++ (if showHandle then " " ++ show (Sqlite.connectionHandle underlying) else mempty) - -showFile, showHandle :: Bool -showFile = False -showHandle = False diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs index 0cef8872ca..914f669c6a 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs @@ -10,8 +10,7 @@ module U.Codebase.Sqlite.DbId where import Data.Bits (Bits) import Data.Word (Word64) -import Database.SQLite.Simple.FromField -import Database.SQLite.Simple.ToField +import Unison.Sqlite (FromField, ToField) newtype ObjectId = ObjectId Word64 deriving (Eq, Ord, Show) deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via Word64 diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/JournalMode.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/JournalMode.hs deleted file mode 100644 index f8410f58f9..0000000000 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/JournalMode.hs +++ /dev/null @@ -1,5 +0,0 @@ -{- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted -module U.Codebase.Sqlite.JournalMode where - -data JournalMode = DELETE | TRUNCATE | PERSIST | MEMORY | WAL | OFF - deriving Show diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ObjectType.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ObjectType.hs index bc704fa30d..2a54f71ebb 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ObjectType.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ObjectType.hs @@ -1,9 +1,7 @@ {- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted module U.Codebase.Sqlite.ObjectType where -import Database.SQLite.Simple.FromField (FromField(..)) -import Database.SQLite.Simple.ToField (ToField(..)) -import Database.SQLite.Simple (SQLData(SQLInteger)) +import Unison.Sqlite (FromField(..), SQLData(SQLInteger), ToField(..)) -- |Don't reorder these, they are part of the database, -- and the ToField and FromField implementation currently diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 080cadd061..b9a773deb1 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -12,9 +12,6 @@ {-# LANGUAGE ViewPatterns #-} module U.Codebase.Sqlite.Operations ( - -- * data version - dataVersion, - -- * branches saveRootBranch, loadMaybeRootCausalHash, @@ -147,7 +144,6 @@ import qualified U.Codebase.Sqlite.Branch.Format as S.BranchFormat import qualified U.Codebase.Sqlite.Branch.Full as S import qualified U.Codebase.Sqlite.Branch.Full as S.Branch.Full import qualified U.Codebase.Sqlite.Branch.Full as S.MetadataSet -import U.Codebase.Sqlite.Connection (Connection) import qualified U.Codebase.Sqlite.DbId as Db import qualified U.Codebase.Sqlite.Decl.Format as S.Decl import U.Codebase.Sqlite.LocalIds @@ -199,6 +195,7 @@ import U.Util.Serialization (Get) import qualified U.Util.Serialization as S import qualified Unison.Util.Set as Set import qualified U.Util.Term as TermUtil +import Unison.Sqlite (Connection) -- * Error handling @@ -1078,9 +1075,6 @@ saveBranch (C.Causal hc he parents me) = do loadRootCausal :: EDB m => m (C.Branch.Causal m) loadRootCausal = liftQ Q.loadNamespaceRoot >>= loadCausalByCausalHashId -dataVersion :: DB m => m Q.DataVersion -dataVersion = Q.dataVersion - loadCausalBranchByCausalHash :: EDB m => CausalHash -> m (Maybe (C.Branch.Causal m)) loadCausalBranchByCausalHash hc = do Q.loadCausalHashIdByCausalHash hc >>= \case diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 23a7d02451..4f187b88b3 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -106,59 +106,33 @@ module U.Codebase.Sqlite.Queries ( -- * db misc createSchema, schemaVersion, - setFlags, - - DataVersion, - dataVersion, savepoint, release, rollbackRelease, - - setJournalMode, - traceConnectionFile, ) where -import qualified Control.Exception as Exception import Control.Monad (when) import Control.Monad.Except (MonadError) import qualified Control.Monad.Except as Except -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (MonadReader (ask)) -import qualified Control.Monad.Reader as Reader -import Control.Monad.Trans (MonadIO (liftIO)) import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) -import qualified Control.Monad.Writer as Writer import Data.ByteString (ByteString) -import qualified Data.Char as Char import Data.Foldable (traverse_) import Data.Functor ((<&>)) import Data.Int (Int8) import qualified Data.List.Extra as List import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel -import Data.Maybe (fromJust) import qualified Data.Set as Set import Data.String (fromString) import Data.String.Here.Uninterpolated (here, hereFile) import Data.Text (Text) -import Database.SQLite.Simple - ( FromRow, - Only (..), - ToRow (..), - (:.) (..), - ) -import qualified Database.SQLite.Simple as SQLite -import Database.SQLite.Simple.FromField (FromField (..)) -import Database.SQLite.Simple.ToField (ToField (..)) +import Data.Tuple.Only (Only (..)) import Debug.Trace (trace, traceM) import GHC.Stack (HasCallStack) -import Safe (headMay) import U.Codebase.HashTags (BranchHash (..), CausalHash (..)) import U.Codebase.Reference (Reference' (..)) import qualified U.Codebase.Reference as C.Reference -import U.Codebase.Sqlite.Connection (Connection) -import qualified U.Codebase.Sqlite.Connection as Connection import U.Codebase.Sqlite.DbId ( BranchHashId (..), BranchObjectId (..), @@ -168,8 +142,6 @@ import U.Codebase.Sqlite.DbId SchemaVersion, TextId, ) -import U.Codebase.Sqlite.JournalMode (JournalMode) -import qualified U.Codebase.Sqlite.JournalMode as JournalMode import U.Codebase.Sqlite.ObjectType (ObjectType) import qualified U.Codebase.Sqlite.Reference as Reference import qualified U.Codebase.Sqlite.Referent as Referent @@ -179,23 +151,19 @@ import qualified U.Util.Alternative as Alternative import U.Util.Base32Hex (Base32Hex (..)) import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash -import UnliftIO (MonadUnliftIO, throwIO, try, tryAny, withRunInIO) -import UnliftIO.Concurrent (myThreadId) --- * types +import Unison.Sqlite +import qualified Unison.Sqlite.DB as DB +import qualified Unison.Sqlite.Transaction as Transaction +import UnliftIO (MonadUnliftIO) -type DB m = (MonadIO m, MonadReader Connection m) +-- * types type EDB m = (DB m, Err m) type Err m = (MonadError Integrity m, HasCallStack) -debugQuery, debugThread, debugConnection :: Bool +debugQuery :: Bool debugQuery = False -debugThread = False -debugConnection = False - -alwaysTraceOnCrash :: Bool -alwaysTraceOnCrash = True crashOnError :: Bool crashOnError = False @@ -204,55 +172,22 @@ throwError :: Err m => Integrity -> m c throwError = if crashOnError then error . show else Except.throwError data Integrity - = UnknownHashId HashId - | UnknownTextId TextId - | UnknownObjectId ObjectId - | UnknownCausalHashId CausalHashId - | UnknownHash Hash - | NoObjectForHashId HashId - | NoObjectForPrimaryHashId HashId - | NoNamespaceRoot - | MultipleNamespaceRoots [CausalHashId] - | NoSchemaVersion - | MultipleSchemaVersions [SchemaVersion] - | NoTypeIndexForTerm Referent.Id + = NoNamespaceRoot deriving (Show) -orError :: Err m => Integrity -> Maybe b -> m b -orError e = maybe (throwError e) pure - -- * main squeeze createSchema :: (DB m, MonadUnliftIO m) => m () -createSchema = do - withImmediateTransaction . traverse_ (execute_ . fromString) $ - List.splitOn ";" [hereFile|sql/create.sql|] - -setJournalMode :: DB m => JournalMode -> m () -setJournalMode m = - let s = Char.toLower <$> show m - in map (fromOnly @String) - <$> query_ (fromString $ "PRAGMA journal_mode = " ++ s) >>= \case - [y] | y == s -> pure () - y -> - liftIO . putStrLn $ - "I couldn't set the codebase journal mode to " ++ s ++ - "; it's set to " ++ show y ++ "." - -setFlags :: DB m => m () -setFlags = do - execute_ "PRAGMA foreign_keys = ON;" - setJournalMode JournalMode.WAL +createSchema = + DB.runTransaction do + traverse_ (Transaction.execute_ . fromString) $ List.splitOn ";" [hereFile|sql/create.sql|] {- ORMOLU_DISABLE -} -- Remove this when the file is ready to be auto-formatted schemaVersion :: DB m => m SchemaVersion -schemaVersion = queryAtoms_ sql >>= \case - [] -> error $ show NoSchemaVersion - [v] -> pure v - vs -> error $ show (MultipleSchemaVersions vs) +schemaVersion = queryOneCol_ sql where sql = "SELECT version from schema_version;" saveHash :: DB m => Base32Hex -> m HashId -saveHash base32 = execute sql (Only base32) >> queryOne (loadHashId base32) +saveHash base32 = execute sql (Only base32) >> expectHashId base32 where sql = [here| INSERT INTO hash (base32) VALUES (?) ON CONFLICT DO NOTHING @@ -262,8 +197,14 @@ saveHashHash :: DB m => Hash -> m HashId saveHashHash = saveHash . Hash.toBase32Hex loadHashId :: DB m => Base32Hex -> m (Maybe HashId) -loadHashId base32 = queryAtom sql (Only base32) - where sql = [here| SELECT id FROM hash WHERE base32 = ? |] +loadHashId base32 = queryMaybeCol loadHashIdSql (Only base32) + +expectHashId :: DB m => Base32Hex -> m HashId +expectHashId base32 = queryOneCol loadHashIdSql (Only base32) + +loadHashIdSql :: Sql +loadHashIdSql = + [here| SELECT id FROM hash WHERE base32 = ? |] loadHashIdByHash :: DB m => Hash -> m (Maybe HashId) loadHashIdByHash = loadHashId . Hash.toBase32Hex @@ -286,25 +227,34 @@ loadCausalByCausalHash ch = runMaybeT do pure (CausalHashId hId, bhId) expectHashIdByHash :: EDB m => Hash -> m HashId -expectHashIdByHash h = loadHashIdByHash h >>= orError (UnknownHash h) +expectHashIdByHash = expectHashId . Hash.toBase32Hex +-- FIXME rename to expectHashHashById loadHashHashById :: EDB m => HashId -> m Hash loadHashHashById h = Hash.fromBase32Hex <$> loadHashById h +-- FIXME rename to expectHashById loadHashById :: EDB m => HashId -> m Base32Hex -loadHashById h = queryAtom sql (Only h) >>= orError (UnknownHashId h) +loadHashById h = queryOneCol sql (Only h) where sql = [here|ย SELECT base32 FROM hash WHERE id = ? |] saveText :: DB m => Text -> m TextId -saveText t = execute sql (Only t) >> queryOne (loadText t) +saveText t = execute sql (Only t) >> expectText t where sql = [here| INSERT INTO text (text) VALUES (?) ON CONFLICT DO NOTHING|] loadText :: DB m => Text -> m (Maybe TextId) -loadText t = queryAtom sql (Only t) - where sql = [here| SELECT id FROM text WHERE text = ? |] +loadText t = queryMaybeCol loadTextSql (Only t) + +expectText :: DB m => Text -> m TextId +expectText t = queryOneCol loadTextSql (Only t) + +loadTextSql :: Sql +loadTextSql = + [here| SELECT id FROM text WHERE text = ? |] +-- FIXME rename to expectTextById loadTextById :: EDB m => TextId -> m Text -loadTextById h = queryAtom sql (Only h) >>= orError (UnknownTextId h) +loadTextById h = queryOneCol sql (Only h) where sql = [here|ย SELECT text FROM text WHERE id = ? |] saveHashObject :: DB m => HashId -> ObjectId -> Int -> m () @@ -317,7 +267,7 @@ saveHashObject hId oId version = execute sql (hId, oId, version) where saveObject :: DB m => HashId -> ObjectType -> ByteString -> m ObjectId saveObject h t blob = do - oId <- execute sql (h, t, blob) >> queryOne (maybeObjectIdForPrimaryHashId h) + oId <- execute sql (h, t, blob) >> expectObjectIdForPrimaryHashId h saveHashObject h oId 1 -- todo: remove this from here, and add it to other relevant places once there are v1 and v2 hashes pure oId where @@ -327,50 +277,57 @@ saveObject h t blob = do ON CONFLICT DO NOTHING |] +-- FIXME rename to expectObjectById loadObjectById :: EDB m => ObjectId -> m ByteString loadObjectById id | debugQuery && trace ("loadObjectById " ++ show id) False = undefined loadObjectById oId = do - result <- queryAtom sql (Only oId) >>= orError (UnknownObjectId oId) + result <- queryOneCol sql (Only oId) when debugQuery $ traceM $ "loadObjectById " ++ show oId ++ " = " ++ show result pure result where sql = [here| SELECT bytes FROM object WHERE id = ? |] +-- FIXME rename to expectObjectWithTypeById loadObjectWithTypeById :: EDB m => ObjectId -> m (ObjectType, ByteString) -loadObjectWithTypeById oId = queryMaybe sql (Only oId) >>= orError (UnknownObjectId oId) +loadObjectWithTypeById oId = queryOneRow sql (Only oId) where sql = [here| SELECT type_id, bytes FROM object WHERE id = ? |] +-- | FIXME rename to expectObjectWithHashIdAndTypeById loadObjectWithHashIdAndTypeById :: EDB m => ObjectId -> m (HashId, ObjectType, ByteString) -loadObjectWithHashIdAndTypeById oId = queryMaybe sql (Only oId) >>= orError (UnknownObjectId oId) +loadObjectWithHashIdAndTypeById oId = queryOneRow sql (Only oId) where sql = [here| SELECT primary_hash_id, type_id, bytes FROM object WHERE id = ? |] -- |Not all hashes have corresponding objects; e.g., hashes of term types -expectObjectIdForPrimaryHashId :: EDB m => HashId -> m ObjectId +expectObjectIdForPrimaryHashId :: DB m => HashId -> m ObjectId expectObjectIdForPrimaryHashId h = - maybeObjectIdForPrimaryHashId h >>= orError (NoObjectForPrimaryHashId h) + queryOneCol maybeObjectIdForPrimaryHashIdSql (Only h) maybeObjectIdForPrimaryHashId :: DB m => HashId -> m (Maybe ObjectId) -maybeObjectIdForPrimaryHashId h = queryAtom sql (Only h) where sql = [here| - SELECT id FROM object WHERE primary_hash_id = ? -|] +maybeObjectIdForPrimaryHashId h = queryMaybeCol maybeObjectIdForPrimaryHashIdSql (Only h) + +maybeObjectIdForPrimaryHashIdSql :: Sql +maybeObjectIdForPrimaryHashIdSql = + [here| SELECT id FROM object WHERE primary_hash_id = ? |] expectObjectIdForAnyHashId :: EDB m => HashId -> m ObjectId expectObjectIdForAnyHashId h = - maybeObjectIdForAnyHashId h >>= orError (NoObjectForHashId h) + queryOneCol maybeObjectIdForAnyHashIdSql (Only h) maybeObjectIdForAnyHashId :: DB m => HashId -> m (Maybe ObjectId) -maybeObjectIdForAnyHashId h = queryAtom sql (Only h) where sql = [here| - SELECT object_id FROM hash_object WHERE hash_id = ? - |] +maybeObjectIdForAnyHashId h = queryMaybeCol maybeObjectIdForAnyHashIdSql (Only h) + +maybeObjectIdForAnyHashIdSql :: Sql +maybeObjectIdForAnyHashIdSql = + [here| SELECT object_id FROM hash_object WHERE hash_id = ? |] -- |All objects have corresponding hashes. loadPrimaryHashByObjectId :: EDB m => ObjectId -> m Base32Hex -loadPrimaryHashByObjectId oId = queryAtom sql (Only oId) >>= orError (UnknownObjectId oId) +loadPrimaryHashByObjectId oId = queryOneCol sql (Only oId) where sql = [here| SELECT hash.base32 FROM hash INNER JOIN object ON object.primary_hash_id = hash.id @@ -379,15 +336,15 @@ loadPrimaryHashByObjectId oId = queryAtom sql (Only oId) >>= orError (UnknownObj hashIdsForObject :: DB m => ObjectId -> m (NonEmpty HashId) hashIdsForObject oId = do - primaryHashId <- queryOne $ queryAtom sql1 (Only oId) - hashIds <- queryAtoms sql2 (Only oId) + primaryHashId <- queryOneCol sql1 (Only oId) + hashIds <- queryListCol sql2 (Only oId) pure $ primaryHashId Nel.:| filter (/= primaryHashId) hashIds where sql1 = "SELECT primary_hash_id FROM object WHERE id = ?" sql2 = "SELECT hash_id FROM hash_object WHERE object_id = ?" hashIdWithVersionForObject :: DB m => ObjectId -> m [(HashId, Int)] -hashIdWithVersionForObject = query sql . Only where sql = [here| +hashIdWithVersionForObject = queryListRow sql . Only where sql = [here| SELECT hash_id, hash_version FROM hash_object WHERE object_id = ? |] @@ -422,26 +379,29 @@ saveCausal self value = execute sql (self, value) where sql = [here| -- SELECT MAX(gc_generation) FROM causal; -- |] +-- FIXME rename to expectCausalValueHashId loadCausalValueHashId :: EDB m => CausalHashId -> m BranchHashId -loadCausalValueHashId chId@(CausalHashId id) = - loadMaybeCausalValueHashId (id) >>= orError (UnknownCausalHashId chId) +loadCausalValueHashId (CausalHashId id) = + queryOneCol loadMaybeCausalValueHashIdSql (Only id) loadCausalHash :: EDB m => CausalHashId -> m CausalHash loadCausalHash (CausalHashId id) = CausalHash <$> loadHashHashById id loadMaybeCausalValueHashId :: DB m => HashId -> m (Maybe BranchHashId) loadMaybeCausalValueHashId id = - queryAtom sql (Only id) where sql = [here| - SELECT value_hash_id FROM causal WHERE self_hash_id = ? -|] + queryMaybeCol loadMaybeCausalValueHashIdSql (Only id) + +loadMaybeCausalValueHashIdSql :: Sql +loadMaybeCausalValueHashIdSql = + [here| SELECT value_hash_id FROM causal WHERE self_hash_id = ? |] isCausalHash :: DB m => HashId -> m Bool -isCausalHash = queryOne . queryAtom sql . Only where sql = [here| +isCausalHash = queryOneCol sql . Only where sql = [here| SELECT EXISTS (SELECT 1 FROM causal WHERE self_hash_id = ?) |] loadBranchObjectIdByCausalHashId :: EDB m => CausalHashId -> m (Maybe BranchObjectId) -loadBranchObjectIdByCausalHashId id = queryAtom sql (Only id) where sql = [here| +loadBranchObjectIdByCausalHashId id = queryMaybeCol sql (Only id) where sql = [here| SELECT object_id FROM hash_object INNER JOIN causal ON hash_id = causal.value_hash_id WHERE causal.self_hash_id = ? @@ -455,37 +415,25 @@ saveCausalParents child parents = executeMany sql $ (child,) <$> parents where |] loadCausalParents :: DB m => CausalHashId -> m [CausalHashId] -loadCausalParents h = queryAtoms sql (Only h) where sql = [here| +loadCausalParents h = queryListCol sql (Only h) where sql = [here| SELECT parent_id FROM causal_parent WHERE causal_id = ? |] --- | The data version will increase if there has been any external --- modification to the database since the last observed data version. -newtype DataVersion = DataVersion Int - deriving (Eq, Ord, Show) - deriving FromField via Int -dataVersion :: DB m => m DataVersion -dataVersion = queryOne . fmap (fmap fromOnly) . fmap headMay $ query_ [here| - PRAGMA data_version - |] - +-- FIXME rename to expectNamespaceRoot loadNamespaceRoot :: EDB m => m CausalHashId loadNamespaceRoot = loadMaybeNamespaceRoot >>= \case Nothing -> throwError NoNamespaceRoot Just id -> pure id loadMaybeNamespaceRoot :: EDB m => m (Maybe CausalHashId) -loadMaybeNamespaceRoot = query_ sql >>= \case - [] -> pure Nothing - [Only id] -> pure (Just id) - (fmap fromOnly -> ids) -> throwError (MultipleNamespaceRoots ids) - where sql = "SELECT causal_id FROM namespace_root" +loadMaybeNamespaceRoot = + queryMaybeCol_ "SELECT causal_id FROM namespace_root" setNamespaceRoot :: forall m. DB m => CausalHashId -> m () setNamespaceRoot id = - query_ @m @(Only CausalHashId) "SELECT * FROM namespace_root" >>= \case - [] -> execute insert (Only id) - _ -> execute update (Only id) + queryOneCol_ "SELECT EXISTS (SELECT 1 FROM namespace_root)" >>= \case + False -> execute insert (Only id) + True -> execute update (Only id) where insert = "INSERT INTO namespace_root VALUES (?)" update = "UPDATE namespace_root SET causal_id = ?" @@ -505,7 +453,7 @@ saveWatch k r blob = execute sql (r :. Only blob) >> execute sql2 (r :. Only k) |] loadWatch :: DB m => WatchKind -> Reference.IdH -> m (Maybe ByteString) -loadWatch k r = queryAtom sql (Only k :. r) where sql = [here| +loadWatch k r = queryMaybeCol sql (Only k :. r) where sql = [here| SELECT result FROM watch_result INNER JOIN watch ON watch_result.hash_id = watch.hash_id @@ -516,7 +464,7 @@ loadWatch k r = queryAtom sql (Only k :. r) where sql = [here| |] loadWatchKindsByReference :: DB m => Reference.IdH -> m [WatchKind] -loadWatchKindsByReference r = queryAtoms sql r where sql = [here| +loadWatchKindsByReference r = queryListCol sql r where sql = [here| SELECT watch_kind_id FROM watch_result INNER JOIN watch ON watch_result.hash_id = watch.hash_id @@ -526,7 +474,7 @@ loadWatchKindsByReference r = queryAtoms sql r where sql = [here| |] loadWatchesByWatchKind :: DB m => WatchKind -> m [Reference.IdH] -loadWatchesByWatchKind k = query sql (Only k) where sql = [here| +loadWatchesByWatchKind k = queryListRow sql (Only k) where sql = [here| SELECT hash_id, component_index FROM watch WHERE watch_kind_id = ? |] @@ -551,7 +499,7 @@ addToTypeIndex tp tm = execute sql (tp :. tm) where sql = [here| |] getReferentsByType :: DB m => Reference' TextId HashId -> m [Referent.Id] -getReferentsByType r = query sql r where sql = [here| +getReferentsByType r = queryListRow sql r where sql = [here| SELECT term_referent_object_id, term_referent_component_index, @@ -564,7 +512,7 @@ getReferentsByType r = query sql r where sql = [here| getTypeReferenceForReferent :: EDB m => Referent.Id -> m (Reference' TextId HashId) getTypeReferenceForReferent r = - queryMaybe sql r >>= orError (NoTypeIndexForTerm r) + queryOneRow sql r where sql = [here| SELECT type_reference_builtin, @@ -579,7 +527,7 @@ getTypeReferenceForReferent r = -- todo: error if no results getTypeReferencesForComponent :: EDB m => ObjectId -> m [(Reference' TextId HashId, Referent.Id)] getTypeReferencesForComponent oId = - query sql (Only oId) <&> map fixupTypeIndexRow where sql = [here| + queryListRow sql (Only oId) <&> map fixupTypeIndexRow where sql = [here| SELECT type_reference_builtin, type_reference_hash_id, @@ -605,7 +553,7 @@ addToTypeMentionsIndex tp tm = execute sql (tp :. tm) where sql = [here| |] getReferentsByTypeMention :: DB m => Reference' TextId HashId -> m [Referent.Id] -getReferentsByTypeMention r = query sql r where sql = [here| +getReferentsByTypeMention r = queryListRow sql r where sql = [here| SELECT term_referent_object_id, term_referent_component_index, @@ -619,7 +567,7 @@ getReferentsByTypeMention r = query sql r where sql = [here| -- todo: error if no results getTypeMentionsReferencesForComponent :: EDB m => ObjectId -> m [(Reference' TextId HashId, Referent.Id)] getTypeMentionsReferencesForComponent r = - query sql (Only r) <&> map fixupTypeIndexRow where sql = [here| + queryListRow sql (Only r) <&> map fixupTypeIndexRow where sql = [here| SELECT type_reference_builtin, type_reference_hash_id, @@ -650,7 +598,7 @@ addToDependentsIndex dependency dependent = execute sql (dependency :. dependent -- | Get non-self, user-defined dependents of a dependency. getDependentsForDependency :: DB m => Reference.Reference -> m [Reference.Id] getDependentsForDependency dependency = - filter isNotSelfReference <$> query sql dependency + filter isNotSelfReference <$> queryListRow sql dependency where sql = [here| @@ -670,14 +618,15 @@ getDependentsForDependency dependency = -- | Get non-self dependencies of a user-defined dependent. getDependenciesForDependent :: DB m => Reference.Id -> m [Reference.Reference] getDependenciesForDependent dependent@(C.Reference.Id oid0 _) = - filter isNotSelfReference <$> query sql dependent + filter isNotSelfReference <$> queryListRow sql dependent where - sql = [here| - SELECT dependency_builtin, dependency_object_id, dependency_component_index - FROM dependents_index - WHERE dependent_object_id IS ? - AND dependent_component_index IS ? - |] + sql = + [here| + SELECT dependency_builtin, dependency_object_id, dependency_component_index + FROM dependents_index + WHERE dependent_object_id IS ? + AND dependent_component_index IS ? + |] isNotSelfReference :: Reference.Reference -> Bool isNotSelfReference = \case @@ -687,7 +636,7 @@ getDependenciesForDependent dependent@(C.Reference.Id oid0 _) = -- | Get non-self, user-defined dependencies of a user-defined dependent. getDependencyIdsForDependent :: DB m => Reference.Id -> m [Reference.Id] getDependencyIdsForDependent dependent@(C.Reference.Id oid0 _) = - filter isNotSelfReference <$> query sql dependent + filter isNotSelfReference <$> queryListRow sql dependent where sql = [here| @@ -703,7 +652,7 @@ getDependencyIdsForDependent dependent@(C.Reference.Id oid0 _) = oid0 /= oid1 objectIdByBase32Prefix :: DB m => ObjectType -> Text -> m [ObjectId] -objectIdByBase32Prefix objType prefix = queryAtoms sql (objType, prefix <> "%") where sql = [here| +objectIdByBase32Prefix objType prefix = queryListCol sql (objType, prefix <> "%") where sql = [here| SELECT object.id FROM object INNER JOIN hash_object ON hash_object.object_id = object.id INNER JOIN hash ON hash_object.hash_id = hash.id @@ -712,14 +661,14 @@ objectIdByBase32Prefix objType prefix = queryAtoms sql (objType, prefix <> "%") |] causalHashIdByBase32Prefix :: DB m => Text -> m [CausalHashId] -causalHashIdByBase32Prefix prefix = queryAtoms sql (Only $ prefix <> "%") where sql = [here| +causalHashIdByBase32Prefix prefix = queryListCol sql (Only $ prefix <> "%") where sql = [here| SELECT self_hash_id FROM causal INNER JOIN hash ON id = self_hash_id WHERE base32 LIKE ? |] namespaceHashIdByBase32Prefix :: DB m => Text -> m [BranchHashId] -namespaceHashIdByBase32Prefix prefix = queryAtoms sql (Only $ prefix <> "%") where sql = [here| +namespaceHashIdByBase32Prefix prefix = queryListCol sql (Only $ prefix <> "%") where sql = [here| SELECT value_hash_id FROM causal INNER JOIN hash ON id = value_hash_id WHERE base32 LIKE ? @@ -727,37 +676,34 @@ namespaceHashIdByBase32Prefix prefix = queryAtoms sql (Only $ prefix <> "%") whe {- ORMOLU_ENABLE -} before :: DB m => CausalHashId -> CausalHashId -> m Bool -before chId1 chId2 = fmap fromOnly . queryOne $ queryMaybe sql (chId2, chId1) +before chId1 chId2 = queryOneCol sql (chId2, chId1) where sql = fromString $ "SELECT EXISTS (" ++ ancestorSql ++ " WHERE ancestor.id = ?)" -- the `Connection` arguments come second to fit the shape of Exception.bracket + uncurry curry lca :: CausalHashId -> CausalHashId -> Connection -> Connection -> IO (Maybe CausalHashId) lca x y _ _ | debugQuery && trace ("Q.lca " ++ show x ++ " " ++ show y) False = undefined -lca x y (Connection.underlying -> cx) (Connection.underlying -> cy) = Exception.bracket open close \(sx, sy) -> do - SQLite.bind sx (Only x) - SQLite.bind sy (Only y) - let getNext = (,) <$> SQLite.nextRow sx <*> SQLite.nextRow sy - loop2 seenX seenY = - getNext >>= \case - (Just (Only px), Just (Only py)) -> - let seenX' = Set.insert px seenX - seenY' = Set.insert py seenY - in if Set.member px seenY' then pure (Just px) - else if Set.member py seenX' then pure (Just py) - else loop2 seenX' seenY' - (Nothing, Nothing) -> pure Nothing - (Just (Only px), Nothing) -> loop1 (SQLite.nextRow sx) seenY px - (Nothing, Just (Only py)) -> loop1 (SQLite.nextRow sy) seenX py - loop1 getNext matches v = - if Set.member v matches then pure (Just v) - else getNext >>= \case - Just (Only v) -> loop1 getNext matches v - Nothing -> pure Nothing - loop2 (Set.singleton x) (Set.singleton y) +lca x y cx cy = + withStatement cx sql (Only x) \nextX -> + withStatement cy sql (Only y) \nextY -> do + let getNext = (,) <$> nextX <*> nextY + loop2 seenX seenY = + getNext >>= \case + (Just (Only px), Just (Only py)) -> + let seenX' = Set.insert px seenX + seenY' = Set.insert py seenY + in if Set.member px seenY' then pure (Just px) + else if Set.member py seenX' then pure (Just py) + else loop2 seenX' seenY' + (Nothing, Nothing) -> pure Nothing + (Just (Only px), Nothing) -> loop1 nextX seenY px + (Nothing, Just (Only py)) -> loop1 nextY seenX py + loop1 getNext matches v = + if Set.member v matches then pure (Just v) + else getNext >>= \case + Just (Only v) -> loop1 getNext matches v + Nothing -> pure Nothing + loop2 (Set.singleton x) (Set.singleton y) where - open = (,) <$> - SQLite.openStatement cx sql <*> SQLite.openStatement cy sql - close (cx, cy) = SQLite.closeStatement cx *> SQLite.closeStatement cy sql = fromString ancestorSql ancestorSql :: String @@ -777,108 +723,6 @@ ancestorSql = [here| -- * helper functions --- | composite input, atomic List output -queryAtoms :: (DB f, ToRow q, FromField b, Show q, Show b) => SQLite.Query -> q -> f [b] -queryAtoms q r = map fromOnly <$> query q r - --- | no input, atomic List output -queryAtoms_ :: (DB f, FromField b, Show b) => SQLite.Query -> f [b] -queryAtoms_ q = map fromOnly <$> query_ q - --- | composite input, composite Maybe output -queryMaybe :: (DB f, ToRow q, FromRow b, Show q, Show b) => SQLite.Query -> q -> f (Maybe b) -queryMaybe q r = headMay <$> query q r - --- | composite input, atomic Maybe output -queryAtom :: (DB f, ToRow q, FromField b, Show q, Show b) => SQLite.Query -> q -> f (Maybe b) -queryAtom q r = fmap fromOnly <$> queryMaybe q r - --- | Just output -queryOne :: Functor f => f (Maybe b) -> f b -queryOne = fmap fromJust - --- | composite input, composite List output -query :: (DB m, ToRow q, FromRow r, Show q, Show r) => SQLite.Query -> q -> m [r] -query q r = do - c <- Reader.reader Connection.underlying - header <- debugHeader - liftIO . queryTrace (header ++ " query") q r $ SQLite.query c q r - --- | no input, composite List output -query_ :: (DB m, FromRow r, Show r) => SQLite.Query -> m [r] -query_ q = do - c <- Reader.reader Connection.underlying - header <- debugHeader - liftIO . queryTrace_ (header ++ " query") q $ SQLite.query_ c q - -debugHeader :: DB m => m String -debugHeader = fmap (List.intercalate ", ") $ Writer.execWriterT do - when debugThread $ Writer.tell . pure . show =<< myThreadId - when debugConnection $ Writer.tell . pure . show =<< ask - -queryTrace :: (MonadUnliftIO m, Show q, Show a) => String -> SQLite.Query -> q -> m a -> m a -queryTrace title query input m = do - let showInput = title ++ " " ++ show query ++ "\n input: " ++ show input - if debugQuery || alwaysTraceOnCrash - then - do - try @_ @SQLite.SQLError m >>= \case - Right a -> do - when debugQuery . traceM $ showInput ++ - if " execute" `List.isSuffixOf` title then mempty else "\n output: " ++ show a - pure a - Left e -> do - traceM $ showInput ++ "\n(and crashed)\n" - throwIO e - else m - -queryTrace_ :: (MonadUnliftIO m, Show a) => String -> SQLite.Query -> m a -> m a -queryTrace_ title query m = - if debugQuery || alwaysTraceOnCrash - then - tryAny @_ m >>= \case - Right a -> do - when debugQuery . traceM $ title ++ " " ++ show query ++ - if " execute_" `List.isSuffixOf` title then mempty else "\n output: " ++ show a - pure a - Left e -> do - traceM $ title ++ " " ++ show query ++ "\n(and crashed)\n" - throwIO e - else m - --- |print the active database filename -traceConnectionFile :: DB m => m () -traceConnectionFile = do - c <- Reader.reader Connection.underlying - liftIO (SQLite.query_ c "PRAGMA database_list;") >>= \case - [(_seq :: Int, _name :: String, file)] -> traceM file - x -> error $ show x - -execute :: (DB m, ToRow q, Show q) => SQLite.Query -> q -> m () -execute q r = do - c <- Reader.reader Connection.underlying - header <- debugHeader - liftIO . queryTrace (header ++ " " ++ "execute") q r $ SQLite.execute c q r - -execute_ :: DB m => SQLite.Query -> m () -execute_ q = do - c <- Reader.reader Connection.underlying - header <- debugHeader - liftIO . queryTrace_ (header ++ " " ++ "execute_") q $ SQLite.execute_ c q - -executeMany :: (DB m, ToRow q, Show q) => SQLite.Query -> [q] -> m () -executeMany q r = do - c <- Reader.reader Connection.underlying - header <- debugHeader - liftIO . queryTrace (header ++ " " ++ "executeMany") q r $ SQLite.executeMany c q r - --- | transaction that blocks -withImmediateTransaction :: (DB m, MonadUnliftIO m) => m a -> m a -withImmediateTransaction action = do - c <- Reader.reader Connection.underlying - withRunInIO \run -> SQLite.withImmediateTransaction c (run action) - - -- | low-level transaction stuff savepoint, release, rollbackTo, rollbackRelease :: DB m => String -> m () savepoint name = execute_ (fromString $ "SAVEPOINT " ++ name) @@ -894,8 +738,8 @@ deriving via Text instance FromField Base32Hex instance ToField WatchKind where toField = \case - WatchKind.RegularWatch -> SQLite.SQLInteger 0 - WatchKind.TestWatch -> SQLite.SQLInteger 1 + WatchKind.RegularWatch -> SQLInteger 0 + WatchKind.TestWatch -> SQLInteger 1 instance FromField WatchKind where fromField = fromField @Int8 <&> fmap \case diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs index 31b8e5d024..a54fe9279d 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs @@ -5,13 +5,11 @@ module U.Codebase.Sqlite.Reference where import Control.Applicative (liftA3) -import Database.SQLite.Simple (Only (..), SQLData (..), ToRow (toRow)) -import Database.SQLite.Simple.FromField (FromField) -import Database.SQLite.Simple.FromRow (FromRow (fromRow), RowParser, field) -import Database.SQLite.Simple.ToField (ToField) +import Data.Tuple.Only (Only (..)) import U.Codebase.Reference (Id' (Id), Reference' (ReferenceBuiltin, ReferenceDerived)) import U.Codebase.Sqlite.DbId (HashId, ObjectId, TextId) import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalHashId, LocalTextId) +import Unison.Sqlite (FromField, FromRow (fromRow), RowParser, SQLData (SQLNull), ToField, ToRow (toRow), field) type Reference = Reference' TextId ObjectId diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs index bf69b3bffa..cfa424dadc 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs @@ -7,12 +7,13 @@ module U.Codebase.Sqlite.Referent where import Control.Applicative (liftA3) -import Database.SQLite.Simple (FromRow (..), Only (..), SQLData (..), ToRow (..), field) +import Data.Tuple.Only (Only (..)) import qualified U.Codebase.Reference as Reference import U.Codebase.Referent (Id', Referent') import qualified U.Codebase.Referent as Referent import U.Codebase.Sqlite.DbId (ObjectId) import qualified U.Codebase.Sqlite.Reference as Sqlite +import Unison.Sqlite (FromRow (..), SQLData (..), ToRow (..), field) type Referent = Referent' Sqlite.Reference Sqlite.Reference diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs index 1965a97f0d..8f43180365 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs @@ -25,7 +25,6 @@ import Data.List.Extra (nubOrd) import qualified Data.Set as Set import qualified U.Codebase.Reference as Reference import qualified U.Codebase.Sqlite.Branch.Format as BL -import U.Codebase.Sqlite.Connection (Connection) import U.Codebase.Sqlite.DbId import qualified U.Codebase.Sqlite.LocalIds as L import qualified U.Codebase.Sqlite.ObjectType as OT @@ -42,6 +41,7 @@ import qualified U.Codebase.WatchKind as WK import U.Util.Cache (Cache) import qualified U.Util.Cache as Cache import Unison.Prelude +import Unison.Sqlite (Connection) data Entity = O ObjectId diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index f531843915..2767698cef 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -8,6 +8,7 @@ extra-source-files: - sql/* dependencies: + - Only - base - bytes - bytestring @@ -18,15 +19,15 @@ dependencies: - monad-validate - mtl - safe - - sqlite-simple - text - transformers - - unliftio - - vector - unison-codebase - unison-codebase-sync - unison-core - unison-prelude + - unison-sqlite - unison-util - unison-util-serialization - unison-util-term + - unliftio + - vector diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index eb6795e3fa..29856ac295 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -21,10 +21,8 @@ library U.Codebase.Sqlite.Branch.Diff U.Codebase.Sqlite.Branch.Format U.Codebase.Sqlite.Branch.Full - U.Codebase.Sqlite.Connection U.Codebase.Sqlite.DbId U.Codebase.Sqlite.Decl.Format - U.Codebase.Sqlite.JournalMode U.Codebase.Sqlite.LocalIds U.Codebase.Sqlite.ObjectType U.Codebase.Sqlite.Operations @@ -45,7 +43,8 @@ library hs-source-dirs: ./ build-depends: - base + Only + , base , bytes , bytestring , containers @@ -55,13 +54,13 @@ library , monad-validate , mtl , safe - , sqlite-simple , text , transformers , unison-codebase , unison-codebase-sync , unison-core , unison-prelude + , unison-sqlite , unison-util , unison-util-serialization , unison-util-term diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index a41b58980a..8d3259b387 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -82,23 +82,44 @@ module Unison.Sqlite -- * Exceptions SqliteException (..), + isCantOpenException, SqliteExceptionReason, SomeSqliteExceptionReason (..), ExpectedAtMostOneRowException (..), ExpectedExactlyOneRowException (..), SetJournalModeException (..), + + -- * Re-exports + Sqlite.Simple.field, + (Sqlite.Simple.:.) (..), + Sqlite.Simple.FromField (fromField), + Sqlite.Simple.FromRow (fromRow), + Sqlite.Simple.RowParser, + Sqlite.Simple.SQLData (..), + Sqlite.Simple.ToField (toField), + Sqlite.Simple.ToRow (toRow), ) where +import qualified Database.SQLite.Simple as Sqlite.Simple +import qualified Database.SQLite.Simple.FromField as Sqlite.Simple +import qualified Database.SQLite.Simple.FromRow as Sqlite.Simple +import qualified Database.SQLite.Simple.ToField as Sqlite.Simple import Unison.Sqlite.Connection ( Connection, ExpectedAtMostOneRowException (..), ExpectedExactlyOneRowException (..), withConnection, + withStatement, ) import Unison.Sqlite.DB import Unison.Sqlite.DataVersion (DataVersion (..), getDataVersion) -import Unison.Sqlite.Exception (SomeSqliteExceptionReason (..), SqliteException (..), SqliteExceptionReason) +import Unison.Sqlite.Exception + ( SomeSqliteExceptionReason (..), + SqliteException (..), + SqliteExceptionReason, + isCantOpenException, + ) import Unison.Sqlite.JournalMode (JournalMode (..), SetJournalModeException (..), trySetJournalMode) import Unison.Sqlite.Sql (Sql (..)) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index f2675fa310..1d3a768be0 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -93,26 +93,25 @@ withConnection :: (Connection -> m a) -> m a withConnection name file = - bracket (openConnection name file) closeConnection + bracket (liftIO (openConnection name file)) (liftIO . closeConnection) -- Open a connection to a SQLite database. openConnection :: - MonadIO m => -- Connection name, for debugging. String -> -- Path to SQLite database file. FilePath -> - m Connection + IO Connection openConnection name file = do - conn0 <- liftIO (Sqlite.open file) + conn0 <- Sqlite.open file let conn = Connection {conn = conn0, file, name} - liftIO (execute_ conn "PRAGMA foreign_keys = ON") + execute_ conn "PRAGMA foreign_keys = ON" pure conn -- Close a connection opened with 'openConnection'. -closeConnection :: MonadIO m => Connection -> m () +closeConnection :: Connection -> IO () closeConnection (Connection _ _ conn) = - liftIO (Sqlite.close conn) + Sqlite.close conn -- Without results, with parameters diff --git a/lib/unison-sqlite/src/Unison/Sqlite/DB.hs b/lib/unison-sqlite/src/Unison/Sqlite/DB.hs index 6bddcc6595..2afd089078 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/DB.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/DB.hs @@ -52,7 +52,6 @@ module Unison.Sqlite.DB -- * Low-level operations withSavepoint, - withStatement, ) where @@ -265,9 +264,3 @@ withSavepoint name action = do conn <- ask withRunInIO \unlift -> liftIO (Connection.withSavepoint conn name (unlift . action . liftIO)) - -withStatement :: (DB m, MonadUnliftIO m, Sqlite.FromRow a, Sqlite.ToRow b) => Sql -> b -> (m (Maybe a) -> m c) -> m c -withStatement s params callback = do - conn <- ask - withRunInIO \unlift -> - Connection.withStatement conn s params (unlift . callback . liftIO) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs b/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs index 77b5e8728e..56ee006584 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs @@ -5,10 +5,12 @@ module Unison.Sqlite.Exception SomeSqliteExceptionReason (..), SqliteExceptionInfo (..), throwSqliteException, + isCantOpenException, ) where import Control.Concurrent (ThreadId, myThreadId) +import Data.Typeable (cast) import qualified Database.SQLite.Simple as Sqlite import Debug.RecoverRTTI (anythingToString) import Unison.Prelude @@ -73,3 +75,9 @@ data SqliteException = SqliteException } deriving stock (Show) deriving anyclass (Exception) + +isCantOpenException :: SqliteException -> Bool +isCantOpenException SqliteException {exception = SomeSqliteExceptionReason reason} = + case cast reason of + Just (Sqlite.SQLError Sqlite.ErrorCan'tOpen _ _) -> True + _ -> False diff --git a/lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs b/lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs index 5d5a9c7692..ba8932cfcd 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs @@ -10,7 +10,7 @@ import qualified Database.SQLite.Simple as Sqlite import Unison.Prelude import Unison.Sqlite.Exception (SqliteExceptionReason) import Unison.Sqlite.Sql -import Unison.Sqlite.Transaction +import Unison.Sqlite.Connection -- | https://www.sqlite.org/pragma.html#pragma_journal_mode data JournalMode @@ -45,9 +45,10 @@ journalModeToText = \case JournalMode'WAL -> "WAL" JournalMode'OFF -> "OFF" -trySetJournalMode :: JournalMode -> Transaction () -trySetJournalMode mode0 = do +trySetJournalMode :: Connection -> JournalMode -> IO () +trySetJournalMode conn mode0 = do queryOneRowCheck_ + conn (Sql ("PRAGMA journal_mode = " <> journalModeToText mode0)) \(Sqlite.Only mode1s) -> let mode1 = unsafeJournalModeFromText mode1s diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 19c33817a7..549b71a974 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -106,7 +106,6 @@ library: - shellmet - stm - strings - - sqlite-simple - tagged - temporary - terminal-size @@ -133,6 +132,7 @@ library: - unison-core - unison-core1 - unison-prelude + - unison-sqlite - unison-util - unison-util-relation - open-browser diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 5a6c7fa04f..672199b3fc 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -39,7 +39,6 @@ import qualified Data.Text as Text import qualified Data.Text.IO as TextIO import Data.Traversable (for) import Data.Word (Word64) -import qualified Database.SQLite.Simple as Sqlite import GHC.Stack (HasCallStack) import qualified System.Console.ANSI as ANSI import System.FilePath (()) @@ -47,10 +46,7 @@ import qualified System.FilePath as FilePath import U.Codebase.HashTags (CausalHash (CausalHash, unCausalHash)) import qualified U.Codebase.Reference as C.Reference import qualified U.Codebase.Referent as C.Referent -import U.Codebase.Sqlite.Connection (Connection (Connection)) -import qualified U.Codebase.Sqlite.Connection as Connection -import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion), ObjectId) -import qualified U.Codebase.Sqlite.JournalMode as JournalMode +import U.Codebase.Sqlite.DbId (ObjectId, SchemaVersion (SchemaVersion)) import qualified U.Codebase.Sqlite.ObjectType as OT import U.Codebase.Sqlite.Operations (EDB) import qualified U.Codebase.Sqlite.Operations as Ops @@ -60,9 +56,7 @@ import qualified U.Codebase.Sync as Sync import qualified U.Codebase.WatchKind as WK import qualified U.Util.Cache as Cache import qualified U.Util.Hash as H2 -import qualified Unison.Hashing.V2.Convert as Hashing import qualified U.Util.Monoid as Monoid -import qualified Unison.Util.Set as Set import U.Util.Timing (time) import qualified Unison.Builtin as Builtins import Unison.Codebase (Codebase, CodebasePath) @@ -83,13 +77,14 @@ import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import qualified Unison.Codebase.SqliteCodebase.GitError as GitError import qualified Unison.Codebase.SqliteCodebase.SyncEphemeral as SyncEphemeral import Unison.Codebase.SyncMode (SyncMode) -import Unison.Codebase.Type (PushGitBranchOpts(..)) +import Unison.Codebase.Type (PushGitBranchOpts (..)) import qualified Unison.Codebase.Type as C -import Unison.ConstructorReference (GConstructorReference(..)) +import Unison.ConstructorReference (GConstructorReference (..)) import qualified Unison.ConstructorType as CT import Unison.DataDeclaration (Decl) import qualified Unison.DataDeclaration as Decl import Unison.Hash (Hash) +import qualified Unison.Hashing.V2.Convert as Hashing import Unison.Parser.Ann (Ann) import Unison.Prelude (MaybeT (runMaybeT), fromMaybe, isJust, trace, traceM) import Unison.Reference (Reference) @@ -98,18 +93,22 @@ import qualified Unison.Referent as Referent import Unison.ShortHash (ShortHash) import qualified Unison.ShortHash as SH import qualified Unison.ShortHash as ShortHash +import Unison.Sqlite (Connection) +import qualified Unison.Sqlite as Sqlite +import qualified Unison.Sqlite.Transaction as Sqlite.Transaction import Unison.Symbol (Symbol) import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) import qualified Unison.Type as Type import qualified Unison.Util.Pretty as P +import qualified Unison.Util.Set as Set import qualified Unison.WatchKind as UF -import UnliftIO (MonadIO, catchIO, finally, liftIO, MonadUnliftIO, throwIO) +import UnliftIO (MonadIO, MonadUnliftIO, catchIO, finally, liftIO, throwIO) import qualified UnliftIO import UnliftIO.Directory (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist, doesFileExist) +import UnliftIO.Exception (catch) import UnliftIO.STM -import UnliftIO.Exception (catch, bracket) debug, debugProcessBranches, debugCommitFailedTransaction :: Bool debug = False @@ -258,29 +257,6 @@ type TermBufferEntry = BufferEntry (Term Symbol Ann, Type Symbol Ann) type DeclBufferEntry = BufferEntry (Decl Symbol Ann) --- | Create a new sqlite connection to the database at the given path. --- the caller is responsible for calling the returned cleanup method once finished with the --- connection. --- The connection may not be used after it has been cleaned up. --- Prefer using 'withConnection' if you can, as it guarantees the connection will be properly --- closed for you. -unsafeGetConnection :: - MonadIO m => - Codebase.DebugName -> - CodebasePath -> - m (IO (), Connection) -unsafeGetConnection name root = do - let path = root codebasePath - Monad.when debug $ traceM $ "unsafeGetconnection " ++ name ++ " " ++ root ++ " -> " ++ path - (Connection name path -> conn) <- liftIO $ Sqlite.open path - runReaderT Q.setFlags conn - pure (shutdownConnection conn, conn) - where - shutdownConnection :: MonadIO m => Connection -> m () - shutdownConnection conn = do - Monad.when debug $ traceM $ "shutdown connection " ++ show conn - liftIO $ Sqlite.close (Connection.underlying conn) - -- | Run an action with a connection to the codebase, closing the connection on completion or -- failure. withConnection :: @@ -289,11 +265,10 @@ withConnection :: CodebasePath -> (Connection -> m a) -> m a -withConnection name root act = do - bracket - (unsafeGetConnection name root) - (\(closeConn, _) -> liftIO closeConn) - (\(_, conn) -> act conn) +withConnection name root act = + Sqlite.withConnection name root \conn -> do + liftIO (Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL) + act conn sqliteCodebase :: (MonadUnliftIO m) => @@ -321,13 +296,11 @@ sqliteCodebase debugName root action = do getTerm (Reference.Id h1@(Cv.hash1to2 -> h2) i _n) = runDB' conn do term2 <- Ops.loadTermByReference (C.Reference.Id h2 i) - lift $ Cv.term2to1 h1 (getCycleLen "getTerm") getDeclType term2 + lift $ Cv.term2to1 h1 getCycleLen getDeclType term2 - getCycleLen :: EDB m => String -> Hash -> m Reference.Size - getCycleLen source = Cache.apply cycleLengthCache \h -> - (Ops.getCycleLen . Cv.hash1to2) h `Except.catchError` \case - e@(Ops.DatabaseIntegrityError (Q.NoObjectForPrimaryHashId {})) -> pure . error $ show e ++ " in " ++ source - e -> Except.throwError e + getCycleLen :: EDB m => Hash -> m Reference.Size + getCycleLen = Cache.apply cycleLengthCache \h -> + (Ops.getCycleLen . Cv.hash1to2) h getDeclType :: EDB m => C.Reference.Reference -> m CT.ConstructorType getDeclType = Cache.apply declTypeCache \case @@ -349,13 +322,13 @@ sqliteCodebase debugName root action = do getTypeOfTermImpl (Reference.Id (Cv.hash1to2 -> h2) i _n) = runDB' conn do type2 <- Ops.loadTypeOfTermByTermReference (C.Reference.Id h2 i) - Cv.ttype2to1 (getCycleLen "getTypeOfTermImpl") type2 + Cv.ttype2to1 getCycleLen type2 getTypeDeclaration :: MonadIO m => Reference.Id -> m (Maybe (Decl Symbol Ann)) getTypeDeclaration (Reference.Id h1@(Cv.hash1to2 -> h2) i _n) = runDB' conn do decl2 <- Ops.loadDeclByReference (C.Reference.Id h2 i) - Cv.decl2to1 h1 (getCycleLen "getTypeDeclaration") decl2 + Cv.decl2to1 h1 getCycleLen decl2 putTerm :: MonadIO m => Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m () putTerm id tm tp | debug && trace (show "SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined @@ -518,14 +491,14 @@ sqliteCodebase debugName root action = do tryFlushDeclBuffer h ) - getRootBranch :: MonadIO m => TVar (Maybe (Q.DataVersion, Branch m)) -> m (Either Codebase1.GetRootBranchError (Branch m)) + getRootBranch :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, Branch m)) -> m (Either Codebase1.GetRootBranchError (Branch m)) getRootBranch rootBranchCache = readTVarIO rootBranchCache >>= \case Nothing -> forceReload Just (v, b) -> do -- check to see if root namespace hash has been externally modified -- and reload it if necessary - v' <- runDB conn Ops.dataVersion + v' <- Sqlite.Transaction.runTransaction conn Sqlite.getDataVersion if v == v' then pure (Right b) else do newRootHash <- runDB conn Ops.loadRootCausalHash if Branch.headHash b == Cv.branchHash2to1 newRootHash @@ -540,7 +513,7 @@ sqliteCodebase debugName root action = do . flip runReaderT conn . fmap (Branch.transform (runDB conn)) $ Cv.causalbranch2to1 getCycleLen getDeclType =<< Ops.loadRootCausal - v <- runDB conn Ops.dataVersion + v <- Sqlite.Transaction.runTransaction conn Sqlite.getDataVersion for_ b (atomically . writeTVar rootBranchCache . Just . (v,)) pure b err :: Ops.Error -> Codebase1.GetRootBranchError @@ -554,7 +527,7 @@ sqliteCodebase debugName root action = do Codebase1.CouldntLoadRootBranch $ Cv.causalHash2to1 ch e -> error $ show e - putRootBranch :: MonadIO m => TVar (Maybe (Q.DataVersion, Branch m)) -> Branch m -> m () + putRootBranch :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, Branch m)) -> Branch m -> m () putRootBranch rootBranchCache branch1 = do -- todo: check to see if root namespace hash has been externally modified -- and do something (merge?) it if necessary. But for now, we just overwrite it. @@ -565,7 +538,7 @@ sqliteCodebase debugName root action = do $ Branch.transform (lift . lift) branch1 atomically $ modifyTVar rootBranchCache (fmap . second $ const branch1) - rootBranchUpdates :: MonadIO m => TVar (Maybe (Q.DataVersion, a)) -> m (IO (), IO (Set Branch.Hash)) + rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.Hash)) rootBranchUpdates _rootBranchCache = do -- branchHeadChanges <- TQueue.newIO -- (cancelWatch, watcher) <- Watch.watchDirectory' (v2dir root) @@ -638,7 +611,7 @@ sqliteCodebase debugName root action = do dependentsImpl :: MonadIO m => Reference -> m (Set Reference.Id) dependentsImpl r = runDB conn $ - Set.traverse (Cv.referenceid2to1 (getCycleLen "dependentsImpl")) + Set.traverse (Cv.referenceid2to1 getCycleLen) =<< Ops.dependents (Cv.reference1to2 r) syncFromDirectory :: MonadUnliftIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m () @@ -658,14 +631,14 @@ sqliteCodebase debugName root action = do watches w = runDB conn $ Ops.listWatches (Cv.watchKind1to2 w) - >>= traverse (Cv.referenceid2to1 (getCycleLen "watches")) + >>= traverse (Cv.referenceid2to1 getCycleLen) getWatch :: MonadIO m => UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann)) getWatch k r@(Reference.Id h _i _n) | elem k standardWatchKinds = runDB' conn $ Ops.loadWatch (Cv.watchKind1to2 k) (Cv.referenceid1to2 r) - >>= Cv.term2to1 h (getCycleLen "getWatch") getDeclType + >>= Cv.term2to1 h getCycleLen getDeclType getWatch _unknownKind _ = pure Nothing standardWatchKinds = [UF.RegularWatch, UF.TestWatch] @@ -713,13 +686,13 @@ sqliteCodebase debugName root action = do termsOfTypeImpl r = runDB conn $ Ops.termsHavingType (Cv.reference1to2 r) - >>= Set.traverse (Cv.referentid2to1 (getCycleLen "termsOfTypeImpl") getDeclType) + >>= Set.traverse (Cv.referentid2to1 getCycleLen getDeclType) termsMentioningTypeImpl :: MonadIO m => Reference -> m (Set Referent.Id) termsMentioningTypeImpl r = runDB conn $ Ops.termsMentioningType (Cv.reference1to2 r) - >>= Set.traverse (Cv.referentid2to1 (getCycleLen "termsMentioningTypeImpl") getDeclType) + >>= Set.traverse (Cv.referentid2to1 getCycleLen getDeclType) hashLength :: Applicative m => m Int hashLength = pure 10 @@ -736,7 +709,7 @@ sqliteCodebase debugName root action = do >>= traverse (C.Reference.idH Ops.loadHashByObjectId) >>= pure . Set.fromList - Set.fromList <$> traverse (Cv.referenceid2to1 (getCycleLen "defnReferencesByPrefix")) (Set.toList refs) + Set.fromList <$> traverse (Cv.referenceid2to1 getCycleLen) (Set.toList refs) termReferencesByPrefix :: MonadIO m => ShortHash -> m (Set Reference.Id) termReferencesByPrefix = defnReferencesByPrefix OT.TermComponent @@ -749,7 +722,7 @@ sqliteCodebase debugName root action = do referentsByPrefix (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to2 -> cycle) cid) = runDB conn do termReferents <- Ops.termReferentsByPrefix prefix cycle - >>= traverse (Cv.referentid2to1 (getCycleLen "referentsByPrefix") getDeclType) + >>= traverse (Cv.referentid2to1 getCycleLen getDeclType) declReferents' <- Ops.declReferentsByPrefix prefix cycle (read . Text.unpack <$> cid) let declReferents = [ Referent.ConId (ConstructorReference (Reference.Id (Cv.hash2to1 h) pos len) (fromIntegral cid)) (Cv.decltype2to1 ct) @@ -1055,11 +1028,10 @@ viewRemoteBranch' (repo, sbh, path) action = UnliftIO.try do -- -- FIXME it would probably make more sense to define some proper preconditions on `sqliteCodebase`, and perhaps update -- its output type, which currently indicates the only way it can fail is with an `UnknownSchemaVersion` error. - (withConnection "codebase exists check" remotePath \_ -> pure ()) `catch` \sqlError -> - case Sqlite.sqlError sqlError of - Sqlite.ErrorCan'tOpen -> throwIO (C.GitSqliteCodebaseError (GitError.NoDatabaseFile repo remotePath)) - -- Unexpected error from sqlite - _ -> throwIO sqlError + (withConnection "codebase exists check" remotePath \_ -> pure ()) `catch` \exception -> + if Sqlite.isCantOpenException exception + then throwIO (C.GitSqliteCodebaseError (GitError.NoDatabaseFile repo remotePath)) + else throwIO exception result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath \codebase -> do -- try to load the requested branch from it @@ -1148,7 +1120,7 @@ pushGitBranch srcConn branch repo (PushGitBranchOpts setRoot _syncMode) = runExc Q.release "push" pure $ Right () - Q.setJournalMode JournalMode.DELETE + liftIO (Sqlite.trySetJournalMode destConn Sqlite.JournalMode'DELETE) pure result liftIO do void $ push remotePath repo diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs index 44c9bd1a03..5839d6d2c2 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs @@ -414,10 +414,10 @@ type1to2' convertRef = V1.Kind.Arrow i o -> V2.Kind.Arrow (convertKind i) (convertKind o) -- | forces loading v1 branches even if they may not exist -causalbranch2to1 :: Monad m => (String -> Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.Branch m) +causalbranch2to1 :: Monad m => (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.Branch m) causalbranch2to1 lookupSize lookupCT = fmap V1.Branch.Branch . causalbranch2to1' lookupSize lookupCT -causalbranch2to1' :: Monad m => (String -> Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.UnwrappedBranch m) +causalbranch2to1' :: Monad m => (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.UnwrappedBranch m) causalbranch2to1' lookupSize lookupCT (V2.Causal hc _he (Map.toList -> parents) me) = do let currentHash = causalHash2to1 hc case parents of @@ -501,27 +501,27 @@ causalbranch1to2 (V1.Branch.Branch c) = causal1to2' hash1to2cb hash1to2c branch1 patch2to1 :: forall m. Monad m => - (String -> Hash -> m V1.Reference.Size) -> + (Hash -> m V1.Reference.Size) -> V2.Branch.Patch -> m V1.Patch patch2to1 lookupSize (V2.Branch.Patch v2termedits v2typeedits) = do termEdits <- Map.bitraverse referent2to1' (Set.traverse termedit2to1) v2termedits - typeEdits <- Map.bitraverse (reference2to1 (lookupSize "patch->old type")) (Set.traverse typeedit2to1) v2typeedits + typeEdits <- Map.bitraverse (reference2to1 lookupSize) (Set.traverse typeedit2to1) v2typeedits pure $ V1.Patch (Relation.fromMultimap termEdits) (Relation.fromMultimap typeEdits) where referent2to1' :: V2.Referent -> m V1.Reference referent2to1' = \case - V2.Referent.Ref r -> reference2to1 (lookupSize "patch->old term") r + V2.Referent.Ref r -> reference2to1 lookupSize r V2.Referent.Con {} -> error "found referent on LHS when converting patch2to1" termedit2to1 :: V2.TermEdit.TermEdit -> m V1.TermEdit.TermEdit termedit2to1 = \case V2.TermEdit.Replace (V2.Referent.Ref r) t -> - V1.TermEdit.Replace <$> reference2to1 (lookupSize "patch->new term") r <*> typing2to1 t + V1.TermEdit.Replace <$> reference2to1 lookupSize r <*> typing2to1 t V2.TermEdit.Replace {} -> error "found referent on RHS when converting patch2to1" V2.TermEdit.Deprecate -> pure V1.TermEdit.Deprecate typeedit2to1 :: V2.TypeEdit.TypeEdit -> m V1.TypeEdit.TypeEdit typeedit2to1 = \case - V2.TypeEdit.Replace r -> V1.TypeEdit.Replace <$> reference2to1 (lookupSize "patch->new type") r + V2.TypeEdit.Replace r -> V1.TypeEdit.Replace <$> reference2to1 lookupSize r V2.TypeEdit.Deprecate -> pure V1.TypeEdit.Deprecate typing2to1 t = pure $ case t of V2.TermEdit.Same -> V1.TermEdit.Same @@ -560,13 +560,13 @@ namesegment1to2 (V1.NameSegment t) = V2.Branch.NameSegment t branch2to1 :: Monad m => - (String -> Hash -> m V1.Reference.Size) -> + (Hash -> m V1.Reference.Size) -> (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Branch m -> m (V1.Branch.Branch0 m) branch2to1 lookupSize lookupCT (V2.Branch.Branch v2terms v2types v2patches v2children) = do - v1terms <- toStar (reference2to1 $ lookupSize "term metadata") =<< Map.bitraverse (pure . namesegment2to1) (Map.bitraverse (referent2to1 (lookupSize "term") lookupCT) id) v2terms - v1types <- toStar (reference2to1 $ lookupSize "type metadata") =<< Map.bitraverse (pure . namesegment2to1) (Map.bitraverse (reference2to1 (lookupSize "type")) id) v2types + v1terms <- toStar (reference2to1 lookupSize) =<< Map.bitraverse (pure . namesegment2to1) (Map.bitraverse (referent2to1 lookupSize lookupCT) id) v2terms + v1types <- toStar (reference2to1 lookupSize) =<< Map.bitraverse (pure . namesegment2to1) (Map.bitraverse (reference2to1 lookupSize) id) v2types v1patches <- Map.bitraverse (pure . namesegment2to1) (bitraverse (pure . edithash2to1) (fmap (patch2to1 lookupSize))) v2patches v1children <- Map.bitraverse (pure . namesegment2to1) (causalbranch2to1 lookupSize lookupCT) v2children pure $ V1.Branch.branch0 v1terms v1types v1children v1patches diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 137bbdf70b..d0cd196f1f 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -260,7 +260,6 @@ library , servant-openapi3 , servant-server , shellmet - , sqlite-simple , stm , strings , tagged @@ -279,6 +278,7 @@ library , unison-core , unison-core1 , unison-prelude + , unison-sqlite , unison-util , unison-util-relation , unliftio From 86a41d05eff06dfbc3bf505e0507021e8da20fad Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sun, 5 Dec 2021 12:28:37 -0500 Subject: [PATCH 002/529] fix path --- parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 672199b3fc..2a688e9ceb 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -266,7 +266,7 @@ withConnection :: (Connection -> m a) -> m a withConnection name root act = - Sqlite.withConnection name root \conn -> do + Sqlite.withConnection name (root codebasePath) \conn -> do liftIO (Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL) act conn From c8a9a90ef58bd5c4a525625917a6e7afc3299d98 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sun, 5 Dec 2021 12:30:28 -0500 Subject: [PATCH 003/529] EDB -> DB --- .../U/Codebase/Sqlite/Queries.hs | 32 +++++++++---------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 4f187b88b3..4f6a849791 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -226,15 +226,15 @@ loadCausalByCausalHash ch = runMaybeT do bhId <- MaybeT $ loadMaybeCausalValueHashId hId pure (CausalHashId hId, bhId) -expectHashIdByHash :: EDB m => Hash -> m HashId +expectHashIdByHash :: DB m => Hash -> m HashId expectHashIdByHash = expectHashId . Hash.toBase32Hex -- FIXME rename to expectHashHashById -loadHashHashById :: EDB m => HashId -> m Hash +loadHashHashById :: DB m => HashId -> m Hash loadHashHashById h = Hash.fromBase32Hex <$> loadHashById h -- FIXME rename to expectHashById -loadHashById :: EDB m => HashId -> m Base32Hex +loadHashById :: DB m => HashId -> m Base32Hex loadHashById h = queryOneCol sql (Only h) where sql = [here|ย SELECT base32 FROM hash WHERE id = ? |] @@ -253,7 +253,7 @@ loadTextSql = [here| SELECT id FROM text WHERE text = ? |] -- FIXME rename to expectTextById -loadTextById :: EDB m => TextId -> m Text +loadTextById :: DB m => TextId -> m Text loadTextById h = queryOneCol sql (Only h) where sql = [here|ย SELECT text FROM text WHERE id = ? |] @@ -278,7 +278,7 @@ saveObject h t blob = do |] -- FIXME rename to expectObjectById -loadObjectById :: EDB m => ObjectId -> m ByteString +loadObjectById :: DB m => ObjectId -> m ByteString loadObjectById id | debugQuery && trace ("loadObjectById " ++ show id) False = undefined loadObjectById oId = do result <- queryOneCol sql (Only oId) @@ -289,14 +289,14 @@ loadObjectById oId = do |] -- FIXME rename to expectObjectWithTypeById -loadObjectWithTypeById :: EDB m => ObjectId -> m (ObjectType, ByteString) +loadObjectWithTypeById :: DB m => ObjectId -> m (ObjectType, ByteString) loadObjectWithTypeById oId = queryOneRow sql (Only oId) where sql = [here| SELECT type_id, bytes FROM object WHERE id = ? |] -- | FIXME rename to expectObjectWithHashIdAndTypeById -loadObjectWithHashIdAndTypeById :: EDB m => ObjectId -> m (HashId, ObjectType, ByteString) +loadObjectWithHashIdAndTypeById :: DB m => ObjectId -> m (HashId, ObjectType, ByteString) loadObjectWithHashIdAndTypeById oId = queryOneRow sql (Only oId) where sql = [here| SELECT primary_hash_id, type_id, bytes FROM object WHERE id = ? @@ -314,7 +314,7 @@ maybeObjectIdForPrimaryHashIdSql :: Sql maybeObjectIdForPrimaryHashIdSql = [here| SELECT id FROM object WHERE primary_hash_id = ? |] -expectObjectIdForAnyHashId :: EDB m => HashId -> m ObjectId +expectObjectIdForAnyHashId :: DB m => HashId -> m ObjectId expectObjectIdForAnyHashId h = queryOneCol maybeObjectIdForAnyHashIdSql (Only h) @@ -326,7 +326,7 @@ maybeObjectIdForAnyHashIdSql = [here| SELECT object_id FROM hash_object WHERE hash_id = ? |] -- |All objects have corresponding hashes. -loadPrimaryHashByObjectId :: EDB m => ObjectId -> m Base32Hex +loadPrimaryHashByObjectId :: DB m => ObjectId -> m Base32Hex loadPrimaryHashByObjectId oId = queryOneCol sql (Only oId) where sql = [here| SELECT hash.base32 @@ -380,11 +380,11 @@ saveCausal self value = execute sql (self, value) where sql = [here| -- |] -- FIXME rename to expectCausalValueHashId -loadCausalValueHashId :: EDB m => CausalHashId -> m BranchHashId +loadCausalValueHashId :: DB m => CausalHashId -> m BranchHashId loadCausalValueHashId (CausalHashId id) = queryOneCol loadMaybeCausalValueHashIdSql (Only id) -loadCausalHash :: EDB m => CausalHashId -> m CausalHash +loadCausalHash :: DB m => CausalHashId -> m CausalHash loadCausalHash (CausalHashId id) = CausalHash <$> loadHashHashById id loadMaybeCausalValueHashId :: DB m => HashId -> m (Maybe BranchHashId) @@ -400,7 +400,7 @@ isCausalHash = queryOneCol sql . Only where sql = [here| SELECT EXISTS (SELECT 1 FROM causal WHERE self_hash_id = ?) |] -loadBranchObjectIdByCausalHashId :: EDB m => CausalHashId -> m (Maybe BranchObjectId) +loadBranchObjectIdByCausalHashId :: DB m => CausalHashId -> m (Maybe BranchObjectId) loadBranchObjectIdByCausalHashId id = queryMaybeCol sql (Only id) where sql = [here| SELECT object_id FROM hash_object INNER JOIN causal ON hash_id = causal.value_hash_id @@ -425,7 +425,7 @@ loadNamespaceRoot = loadMaybeNamespaceRoot >>= \case Nothing -> throwError NoNamespaceRoot Just id -> pure id -loadMaybeNamespaceRoot :: EDB m => m (Maybe CausalHashId) +loadMaybeNamespaceRoot :: DB m => m (Maybe CausalHashId) loadMaybeNamespaceRoot = queryMaybeCol_ "SELECT causal_id FROM namespace_root" @@ -510,7 +510,7 @@ getReferentsByType r = queryListRow sql r where sql = [here| AND type_reference_component_index IS ? |] -getTypeReferenceForReferent :: EDB m => Referent.Id -> m (Reference' TextId HashId) +getTypeReferenceForReferent :: DB m => Referent.Id -> m (Reference' TextId HashId) getTypeReferenceForReferent r = queryOneRow sql r where sql = [here| @@ -525,7 +525,7 @@ getTypeReferenceForReferent r = |] -- todo: error if no results -getTypeReferencesForComponent :: EDB m => ObjectId -> m [(Reference' TextId HashId, Referent.Id)] +getTypeReferencesForComponent :: DB m => ObjectId -> m [(Reference' TextId HashId, Referent.Id)] getTypeReferencesForComponent oId = queryListRow sql (Only oId) <&> map fixupTypeIndexRow where sql = [here| SELECT @@ -565,7 +565,7 @@ getReferentsByTypeMention r = queryListRow sql r where sql = [here| |] -- todo: error if no results -getTypeMentionsReferencesForComponent :: EDB m => ObjectId -> m [(Reference' TextId HashId, Referent.Id)] +getTypeMentionsReferencesForComponent :: DB m => ObjectId -> m [(Reference' TextId HashId, Referent.Id)] getTypeMentionsReferencesForComponent r = queryListRow sql (Only r) <&> map fixupTypeIndexRow where sql = [here| SELECT From 56ff9bf3e5f82e89dec1692e216143df5ff48465 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 6 Dec 2021 11:55:28 -0500 Subject: [PATCH 004/529] fix compiler error --- parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 2a688e9ceb..5b716e08af 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -894,11 +894,9 @@ syncInternal progress srcConn destConn b = time "syncInternal" do processBranches @m sync progress (os ++ bs ++ b0 : rest) processBranches sync progress (O h : rest) = do when debugProcessBranches $ traceM $ "processBranches O " ++ take 10 (show h) - (runExceptT $ flip runReaderT srcConn (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId)) >>= \case - Left e -> error $ show e - Right oId -> do - r $ Sync.sync' sync progress [Sync22.O oId] - processBranches sync progress rest + oId <- flip runReaderT srcConn (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId) + r $ Sync.sync' sync progress [Sync22.O oId] + processBranches sync progress rest sync <- se . r $ Sync22.sync22 let progress' = Sync.transformProgress (lift . lift) progress bHash = Branch.headHash b From a1d1e1a50a3a2836183cef4d9d486c72be3bdd1d Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 17 Dec 2021 12:30:09 -0500 Subject: [PATCH 005/529] maybe query-maybe-check functions more convenient to use --- .../src/Unison/Sqlite/Connection.hs | 28 +++++++++---------- lib/unison-sqlite/src/Unison/Sqlite/DB.hs | 12 ++++---- .../src/Unison/Sqlite/Transaction.hs | 12 ++++---- 3 files changed, 26 insertions(+), 26 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index 345d70d66e..b4106b3451 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -240,12 +240,12 @@ queryMaybeRowCheck :: Connection -> Sql -> a -> - (Maybe b -> Either e r) -> - IO r + (b -> Either e r) -> + IO (Maybe r) queryMaybeRowCheck conn s params check = gqueryListCheck conn s params \case - [] -> mapLeft SomeSqliteExceptionReason (check Nothing) - [x] -> mapLeft SomeSqliteExceptionReason (check (Just x)) + [] -> pure Nothing + [x] -> bimap SomeSqliteExceptionReason Just (check x) xs -> Left (SomeSqliteExceptionReason (ExpectedAtMostOneRowException (anythingToString xs))) queryMaybeColCheck :: @@ -254,10 +254,10 @@ queryMaybeColCheck :: Connection -> Sql -> a -> - (Maybe b -> Either e r) -> - IO r + (b -> Either e r) -> + IO (Maybe r) queryMaybeColCheck conn s params check = - queryMaybeRowCheck conn s params (coerce @(Maybe b -> Either e r) @(Maybe (Sqlite.Only b) -> Either e r) check) + queryMaybeRowCheck conn s params (coerce @(b -> Either e r) @(Sqlite.Only b -> Either e r) check) queryOneRowCheck :: (Sqlite.FromRow b, Sqlite.ToRow a, SqliteExceptionReason e) => @@ -354,12 +354,12 @@ queryMaybeRowCheck_ :: (Sqlite.FromRow a, SqliteExceptionReason e) => Connection -> Sql -> - (Maybe a -> Either e r) -> - IO r + (a -> Either e r) -> + IO (Maybe r) queryMaybeRowCheck_ conn s check = gqueryListCheck_ conn s \case - [] -> mapLeft SomeSqliteExceptionReason (check Nothing) - [x] -> mapLeft SomeSqliteExceptionReason (check (Just x)) + [] -> pure Nothing + [x] -> bimap SomeSqliteExceptionReason Just (check x) xs -> Left (SomeSqliteExceptionReason (ExpectedAtMostOneRowException (anythingToString xs))) queryMaybeColCheck_ :: @@ -367,10 +367,10 @@ queryMaybeColCheck_ :: (Sqlite.FromField a, SqliteExceptionReason e) => Connection -> Sql -> - (Maybe a -> Either e r) -> - IO r + (a -> Either e r) -> + IO (Maybe r) queryMaybeColCheck_ conn s check = - queryMaybeRowCheck_ conn s (coerce @(Maybe a -> Either e r) @(Maybe (Sqlite.Only a) -> Either e r) check) + queryMaybeRowCheck_ conn s (coerce @(a -> Either e r) @(Sqlite.Only a -> Either e r) check) queryOneRowCheck_ :: (Sqlite.FromRow a, SqliteExceptionReason e) => Connection -> Sql -> (a -> Either e r) -> IO r queryOneRowCheck_ conn s check = diff --git a/lib/unison-sqlite/src/Unison/Sqlite/DB.hs b/lib/unison-sqlite/src/Unison/Sqlite/DB.hs index 2afd089078..4fd495e881 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/DB.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/DB.hs @@ -156,8 +156,8 @@ queryMaybeRowCheck :: (DB m, Sqlite.FromRow b, Sqlite.ToRow a, SqliteExceptionReason e) => Sql -> a -> - (Maybe b -> Either e r) -> - m r + (b -> Either e r) -> + m (Maybe r) queryMaybeRowCheck s params check = do conn <- ask liftIO (Connection.queryMaybeRowCheck conn s params check) @@ -166,8 +166,8 @@ queryMaybeColCheck :: (DB m, Sqlite.FromField b, Sqlite.ToRow a, SqliteExceptionReason e) => Sql -> a -> - (Maybe b -> Either e r) -> - m r + (b -> Either e r) -> + m (Maybe r) queryMaybeColCheck s params check = do conn <- ask liftIO (Connection.queryMaybeColCheck conn s params check) @@ -236,12 +236,12 @@ queryListColCheck_ s check = do conn <- ask liftIO (Connection.queryListColCheck_ conn s check) -queryMaybeRowCheck_ :: (DB m, Sqlite.FromRow a, SqliteExceptionReason e) => Sql -> (Maybe a -> Either e r) -> m r +queryMaybeRowCheck_ :: (DB m, Sqlite.FromRow a, SqliteExceptionReason e) => Sql -> (a -> Either e r) -> m (Maybe r) queryMaybeRowCheck_ s check = do conn <- ask liftIO (Connection.queryMaybeRowCheck_ conn s check) -queryMaybeColCheck_ :: (DB m, Sqlite.FromField a, SqliteExceptionReason e) => Sql -> (Maybe a -> Either e r) -> m r +queryMaybeColCheck_ :: (DB m, Sqlite.FromField a, SqliteExceptionReason e) => Sql -> (a -> Either e r) -> m (Maybe r) queryMaybeColCheck_ s check = do conn <- ask liftIO (Connection.queryMaybeColCheck_ conn s check) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 66a47cb663..e80171d1a3 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -166,8 +166,8 @@ queryMaybeRowCheck :: (Sqlite.FromRow b, Sqlite.ToRow a, SqliteExceptionReason e) => Sql -> a -> - (Maybe b -> Either e r) -> - Transaction r + (b -> Either e r) -> + Transaction (Maybe r) queryMaybeRowCheck s params check = Transaction \conn -> Connection.queryMaybeRowCheck conn s params check @@ -175,8 +175,8 @@ queryMaybeColCheck :: (Sqlite.FromField b, Sqlite.ToRow a, SqliteExceptionReason e) => Sql -> a -> - (Maybe b -> Either e r) -> - Transaction r + (b -> Either e r) -> + Transaction (Maybe r) queryMaybeColCheck s params check = Transaction \conn -> Connection.queryMaybeColCheck conn s params check @@ -234,11 +234,11 @@ queryListColCheck_ :: (Sqlite.FromField a, SqliteExceptionReason e) => Sql -> ([ queryListColCheck_ s check = Transaction \conn -> Connection.queryListColCheck_ conn s check -queryMaybeRowCheck_ :: (Sqlite.FromRow a, SqliteExceptionReason e) => Sql -> (Maybe a -> Either e r) -> Transaction r +queryMaybeRowCheck_ :: (Sqlite.FromRow a, SqliteExceptionReason e) => Sql -> (a -> Either e r) -> Transaction (Maybe r) queryMaybeRowCheck_ s check = Transaction \conn -> Connection.queryMaybeRowCheck_ conn s check -queryMaybeColCheck_ :: (Sqlite.FromField a, SqliteExceptionReason e) => Sql -> (Maybe a -> Either e r) -> Transaction r +queryMaybeColCheck_ :: (Sqlite.FromField a, SqliteExceptionReason e) => Sql -> (a -> Either e r) -> Transaction (Maybe r) queryMaybeColCheck_ s check = Transaction \conn -> Connection.queryMaybeColCheck_ conn s check From 3409d6da9228097507d1ea53cb2fc37ef37d6810 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 17 Dec 2021 14:59:49 -0500 Subject: [PATCH 006/529] more porting over to unison-sqlite --- .../U/Codebase/Sqlite/Operations.hs | 399 ++++++++---------- .../U/Codebase/Sqlite/Queries.hs | 123 +++--- .../U/Codebase/Sqlite/Sync22.hs | 20 +- codebase2/codebase-sqlite/package.yaml | 23 + .../unison-codebase-sqlite.cabal | 22 + .../src/Unison/Sqlite/Connection.hs | 74 +++- .../src/Unison/Sqlite/Exception.hs | 6 +- parser-typechecker/src/Unison/Codebase.hs | 17 +- .../src/Unison/Codebase/Execute.hs | 9 +- .../src/Unison/Codebase/SqliteCodebase.hs | 133 +++--- .../src/Unison/Codebase/Type.hs | 9 +- .../src/Unison/Server/Backend.hs | 43 +- .../src/Unison/Server/Endpoints/FuzzyFind.hs | 2 +- .../Server/Endpoints/NamespaceListing.hs | 11 +- .../src/Unison/Server/Endpoints/Projects.hs | 16 +- .../src/Unison/Server/Errors.hs | 12 - .../src/Unison/Codebase/Editor/Command.hs | 3 +- .../Unison/Codebase/Editor/HandleCommand.hs | 5 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 53 +-- .../src/Unison/Codebase/Editor/Output.hs | 3 - .../src/Unison/Codebase/TranscriptParser.hs | 3 +- unison-cli/src/Unison/CommandLine/Main.hs | 3 +- .../src/Unison/CommandLine/OutputMessages.hs | 16 - unison-cli/src/Unison/CommandLine/Welcome.hs | 2 +- 24 files changed, 487 insertions(+), 520 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index b9a773deb1..154d96e8c7 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -73,9 +73,6 @@ module U.Codebase.Sqlite.Operations ( Error(..), DecodeError(..), - -- ** Constraint kinds - EDB, - -- * somewhat unexpectedly unused definitions c2sReferenceId, c2sReferentId, @@ -90,9 +87,8 @@ module U.Codebase.Sqlite.Operations ( import Control.Lens (Lens') import qualified Control.Lens as Lens -import Control.Monad (MonadPlus (mzero), join, unless, when, (<=<)) -import Control.Monad.Except (ExceptT, MonadError, MonadIO (liftIO), runExceptT) -import qualified Control.Monad.Except as Except +import Control.Monad (join, unless, when, (<=<)) +import Control.Monad.Except (MonadIO (liftIO)) import qualified Control.Monad.Extra as Monad import Control.Monad.State (MonadState, StateT, evalStateT) import Control.Monad.Trans (MonadTrans (lift)) @@ -123,7 +119,6 @@ import Data.Tuple.Extra (uncurry3) import qualified Data.Vector as Vector import Data.Word (Word64) import Debug.Trace -import GHC.Stack (HasCallStack) import qualified U.Codebase.Branch as C.Branch import qualified U.Codebase.Causal as C import U.Codebase.Decl (ConstructorId) @@ -168,7 +163,6 @@ import qualified U.Codebase.Sqlite.Patch.TermEdit as S import qualified U.Codebase.Sqlite.Patch.TermEdit as S.TermEdit import qualified U.Codebase.Sqlite.Patch.TypeEdit as S import qualified U.Codebase.Sqlite.Patch.TypeEdit as S.TypeEdit -import U.Codebase.Sqlite.Queries (DB) import qualified U.Codebase.Sqlite.Queries as Q import qualified U.Codebase.Sqlite.Reference as S import qualified U.Codebase.Sqlite.Reference as S.Reference @@ -195,24 +189,13 @@ import U.Util.Serialization (Get) import qualified U.Util.Serialization as S import qualified Unison.Util.Set as Set import qualified U.Util.Term as TermUtil -import Unison.Sqlite (Connection) +import Unison.Sqlite -- * Error handling -throwError :: Err m => Error -> m a -throwError = if crashOnError then error . show else Except.throwError - -debug, crashOnError :: Bool +debug :: Bool debug = False --- | crashOnError can be helpful for debugging. --- If it is False, the errors will be delivered to the user elsewhere. -crashOnError = False - -type Err m = (MonadError Error m, HasCallStack) - -type EDB m = (Err m, DB m) - type ErrString = String data DecodeError @@ -226,54 +209,40 @@ data DecodeError | ErrObjectDependencies OT.ObjectType Db.ObjectId deriving (Show) +-- TODO rename data Error = DecodeError DecodeError ByteString ErrString - | DatabaseIntegrityError Q.Integrity - | UnknownDependency H.Hash - | UnknownText Text - | ExpectedBranch CausalHash BranchHash - | ExpectedBranch' Db.CausalHashId - | LegacyUnknownCycleLen H.Hash - | LegacyUnknownConstructorType H.Hash C.Reference.Pos - | NeedTypeForBuiltinMetadata Text - deriving (Show) + deriving stock (Show) + deriving anyclass (SqliteExceptionReason) -getFromBytesOr :: Err m => DecodeError -> Get a -> ByteString -> m a -getFromBytesOr e get bs = case runGetS get bs of - Left err -> throwError (DecodeError e bs err) - Right a -> pure a +newtype NeedTypeForBuiltinMetadata + = NeedTypeForBuiltinMetadata Text + deriving stock (Show) + deriving anyclass (SqliteExceptionReason) -liftQ :: Err m => ExceptT Q.Integrity m a -> m a -liftQ a = - runExceptT a >>= \case - Left e -> throwError (DatabaseIntegrityError e) - Right a -> pure a +getFromBytesOr :: DecodeError -> Get a -> ByteString -> Either Error a +getFromBytesOr e get bs = case runGetS get bs of + Left err -> Left (DecodeError e bs err) + Right a -> Right a -- * Database lookups -lookupTextId :: EDB m => Text -> m Db.TextId -lookupTextId t = - Q.loadText t >>= \case - Just textId -> pure textId - Nothing -> throwError $ UnknownText t - -loadTextById :: EDB m => Db.TextId -> m Text -loadTextById = liftQ . Q.loadTextById +loadTextById :: DB m => Db.TextId -> m Text +loadTextById = Q.loadTextById -- | look up an existing object by its primary hash -primaryHashToExistingObjectId :: EDB m => H.Hash -> m Db.ObjectId +primaryHashToExistingObjectId :: DB m => H.Hash -> m Db.ObjectId primaryHashToExistingObjectId h = do - (Q.loadHashId . H.toBase32Hex) h >>= \case - Just hashId -> liftQ $ Q.expectObjectIdForPrimaryHashId hashId - Nothing -> throwError $ UnknownDependency h + hashId <- Q.expectHashIdByHash h + Q.expectObjectIdForPrimaryHashId hashId primaryHashToMaybeObjectId :: DB m => H.Hash -> m (Maybe Db.ObjectId) primaryHashToMaybeObjectId h = do - (Q.loadHashId . H.toBase32Hex) h >>= \case + Q.loadHashIdByHash h >>= \case Just hashId -> Q.maybeObjectIdForPrimaryHashId hashId Nothing -> pure Nothing -primaryHashToMaybePatchObjectId :: EDB m => PatchHash -> m (Maybe Db.PatchObjectId) +primaryHashToMaybePatchObjectId :: DB m => PatchHash -> m (Maybe Db.PatchObjectId) primaryHashToMaybePatchObjectId = (fmap . fmap) Db.PatchObjectId . primaryHashToMaybeObjectId . unPatchHash @@ -283,68 +252,68 @@ objectExistsForHash h = id <- MaybeT . Q.loadHashId . H.toBase32Hex $ h MaybeT $ Q.maybeObjectIdForAnyHashId id -loadHashByObjectId :: EDB m => Db.ObjectId -> m H.Hash -loadHashByObjectId = fmap H.fromBase32Hex . liftQ . Q.loadPrimaryHashByObjectId +loadHashByObjectId :: DB m => Db.ObjectId -> m H.Hash +loadHashByObjectId = fmap H.fromBase32Hex . Q.loadPrimaryHashByObjectId -loadHashByHashId :: EDB m => Db.HashId -> m H.Hash -loadHashByHashId = fmap H.fromBase32Hex . liftQ . Q.loadHashById +loadHashByHashId :: DB m => Db.HashId -> m H.Hash +loadHashByHashId = fmap H.fromBase32Hex . Q.loadHashById -loadCausalHashById :: EDB m => Db.CausalHashId -> m CausalHash -loadCausalHashById = fmap (CausalHash . H.fromBase32Hex) . liftQ . Q.loadHashById . Db.unCausalHashId +loadCausalHashById :: DB m => Db.CausalHashId -> m CausalHash +loadCausalHashById = fmap (CausalHash . H.fromBase32Hex) . Q.loadHashById . Db.unCausalHashId -loadValueHashByCausalHashId :: EDB m => Db.CausalHashId -> m BranchHash -loadValueHashByCausalHashId = loadValueHashById <=< liftQ . Q.loadCausalValueHashId +loadValueHashByCausalHashId :: DB m => Db.CausalHashId -> m BranchHash +loadValueHashByCausalHashId = loadValueHashById <=< Q.loadCausalValueHashId where - loadValueHashById :: EDB m => Db.BranchHashId -> m BranchHash - loadValueHashById = fmap (BranchHash . H.fromBase32Hex) . liftQ . Q.loadHashById . Db.unBranchHashId + loadValueHashById :: DB m => Db.BranchHashId -> m BranchHash + loadValueHashById = fmap (BranchHash . H.fromBase32Hex) . Q.loadHashById . Db.unBranchHashId -loadRootCausalHash :: EDB m => m CausalHash -loadRootCausalHash = loadCausalHashById =<< liftQ Q.loadNamespaceRoot +loadRootCausalHash :: DB m => m CausalHash +loadRootCausalHash = loadCausalHashById =<< Q.loadNamespaceRoot -loadMaybeRootCausalHash :: EDB m => m (Maybe CausalHash) +loadMaybeRootCausalHash :: DB m => m (Maybe CausalHash) loadMaybeRootCausalHash = runMaybeT $ - loadCausalHashById =<< MaybeT (liftQ Q.loadMaybeNamespaceRoot) + loadCausalHashById =<< MaybeT Q.loadMaybeNamespaceRoot -- * Reference transformations -- ** read existing references -c2sReference :: EDB m => C.Reference -> m S.Reference -c2sReference = bitraverse lookupTextId primaryHashToExistingObjectId +c2sReference :: DB m => C.Reference -> m S.Reference +c2sReference = bitraverse Q.expectText primaryHashToExistingObjectId -s2cReference :: EDB m => S.Reference -> m C.Reference +s2cReference :: DB m => S.Reference -> m C.Reference s2cReference = bitraverse loadTextById loadHashByObjectId -c2sReferenceId :: EDB m => C.Reference.Id -> m S.Reference.Id +c2sReferenceId :: DB m => C.Reference.Id -> m S.Reference.Id c2sReferenceId = C.Reference.idH primaryHashToExistingObjectId -s2cReferenceId :: EDB m => S.Reference.Id -> m C.Reference.Id +s2cReferenceId :: DB m => S.Reference.Id -> m C.Reference.Id s2cReferenceId = C.Reference.idH loadHashByObjectId -h2cReferenceId :: EDB m => S.Reference.IdH -> m C.Reference.Id +h2cReferenceId :: DB m => S.Reference.IdH -> m C.Reference.Id h2cReferenceId = C.Reference.idH loadHashByHashId -h2cReference :: EDB m => S.ReferenceH -> m C.Reference +h2cReference :: DB m => S.ReferenceH -> m C.Reference h2cReference = bitraverse loadTextById loadHashByHashId c2hReference :: DB m => C.Reference -> MaybeT m S.ReferenceH c2hReference = bitraverse (MaybeT . Q.loadText) (MaybeT . Q.loadHashIdByHash) -s2cReferent :: EDB m => S.Referent -> m C.Referent +s2cReferent :: DB m => S.Referent -> m C.Referent s2cReferent = bitraverse s2cReference s2cReference -s2cReferentId :: EDB m => S.Referent.Id -> m C.Referent.Id +s2cReferentId :: DB m => S.Referent.Id -> m C.Referent.Id s2cReferentId = bitraverse loadHashByObjectId loadHashByObjectId -c2sReferentId :: EDB m => C.Referent.Id -> m S.Referent.Id +c2sReferentId :: DB m => C.Referent.Id -> m S.Referent.Id c2sReferentId = bitraverse primaryHashToExistingObjectId primaryHashToExistingObjectId -h2cReferent :: EDB m => S.ReferentH -> m C.Referent +h2cReferent :: DB m => S.ReferentH -> m C.Referent h2cReferent = bitraverse h2cReference h2cReference -- ** Edits transformations -s2cTermEdit :: EDB m => S.TermEdit -> m C.TermEdit +s2cTermEdit :: DB m => S.TermEdit -> m C.TermEdit s2cTermEdit = \case S.TermEdit.Replace r t -> C.TermEdit.Replace <$> s2cReferent r <*> pure (s2cTyping t) S.TermEdit.Deprecate -> pure C.TermEdit.Deprecate @@ -361,13 +330,13 @@ c2sTyping = \case C.TermEdit.Subtype -> S.TermEdit.Subtype C.TermEdit.Different -> S.TermEdit.Different -s2cTypeEdit :: EDB m => S.TypeEdit -> m C.TypeEdit +s2cTypeEdit :: DB m => S.TypeEdit -> m C.TypeEdit s2cTypeEdit = \case S.TypeEdit.Replace r -> C.TypeEdit.Replace <$> s2cReference r S.TypeEdit.Deprecate -> pure C.TypeEdit.Deprecate -- | assumes that all relevant values are already in the DB -c2lPatch :: EDB m => C.Branch.Patch -> m (S.PatchLocalIds, S.LocalPatch) +c2lPatch :: DB m => C.Branch.Patch -> m (S.PatchLocalIds, S.LocalPatch) c2lPatch (C.Branch.Patch termEdits typeEdits) = done =<< (runWriterT . flip evalStateT startState) do S.Patch @@ -376,12 +345,12 @@ c2lPatch (C.Branch.Patch termEdits typeEdits) = where startState = mempty @(Map Text LocalTextId, Map H.Hash LocalHashId, Map H.Hash LocalDefnId) done :: - EDB m => + DB m => (a, (Seq Text, Seq H.Hash, Seq H.Hash)) -> m (S.PatchFormat.PatchLocalIds, a) done (lPatch, (textValues, hashValues, defnValues)) = do - textIds <- liftQ $ traverse Q.saveText textValues - hashIds <- liftQ $ traverse Q.saveHashHash hashValues + textIds <- traverse Q.saveText textValues + hashIds <- traverse Q.saveHashHash hashValues objectIds <- traverse primaryHashToExistingObjectId defnValues let ids = S.PatchFormat.LocalIds @@ -457,53 +426,49 @@ diffPatch (S.Patch fullTerms fullTypes) (S.Patch refTerms refTypes) = -- * Deserialization helpers -decodeComponentLengthOnly :: Err m => ByteString -> m Word64 +decodeComponentLengthOnly :: ByteString -> Either Error Word64 decodeComponentLengthOnly = getFromBytesOr ErrFramedArrayLen (Get.skip 1 >> S.lengthFramedArray) -decodeTermElementWithType :: Err m => C.Reference.Pos -> ByteString -> m (LocalIds, S.Term.Term, S.Term.Type) +decodeTermElementWithType :: C.Reference.Pos -> ByteString -> Either Error (LocalIds, S.Term.Term, S.Term.Type) decodeTermElementWithType i = getFromBytesOr (ErrTermElement i) (S.lookupTermElement i) -decodeTermElementDiscardingTerm :: Err m => C.Reference.Pos -> ByteString -> m (LocalIds, S.Term.Type) +decodeTermElementDiscardingTerm :: C.Reference.Pos -> ByteString -> Either Error (LocalIds, S.Term.Type) decodeTermElementDiscardingTerm i = getFromBytesOr (ErrTermElement i) (S.lookupTermElementDiscardingTerm i) -decodeTermElementDiscardingType :: Err m => C.Reference.Pos -> ByteString -> m (LocalIds, S.Term.Term) +decodeTermElementDiscardingType :: C.Reference.Pos -> ByteString -> Either Error (LocalIds, S.Term.Term) decodeTermElementDiscardingType i = getFromBytesOr (ErrTermElement i) (S.lookupTermElementDiscardingType i) -decodeDeclElement :: Err m => Word64 -> ByteString -> m (LocalIds, S.Decl.Decl Symbol) +decodeDeclElement :: Word64 -> ByteString -> Either Error (LocalIds, S.Decl.Decl Symbol) decodeDeclElement i = getFromBytesOr (ErrDeclElement i) (S.lookupDeclElement i) -- * legacy conversion helpers -getCycleLen :: EDB m => H.Hash -> m Word64 +getCycleLen :: DB m => H.Hash -> m Word64 getCycleLen h = do when debug $ traceM $ "\ngetCycleLen " ++ (Text.unpack . Base32Hex.toText $ H.toBase32Hex h) - runMaybeT (primaryHashToExistingObjectId h) - >>= maybe (throwError $ LegacyUnknownCycleLen h) pure - >>= liftQ . Q.loadObjectById - -- todo: decodeComponentLengthOnly is unintentionally a hack that relies on - -- the fact the two things that references can refer to (term and decl - -- components) have the same basic serialized structure: first a format - -- byte that is always 0 for now, followed by a framed array representing - -- the strongly-connected component. :grimace: - >>= decodeComponentLengthOnly - >>= pure . fromIntegral - -getDeclTypeByReference :: EDB m => C.Reference.Id -> m C.Decl.DeclType -getDeclTypeByReference r@(C.Reference.Id h pos) = - runMaybeT (loadDeclByReference r) - >>= maybe (throwError $ LegacyUnknownConstructorType h pos) pure - >>= pure . C.Decl.declType - -componentByObjectId :: EDB m => Db.ObjectId -> m [S.Reference.Id] + oId <- primaryHashToExistingObjectId h + -- todo: decodeComponentLengthOnly is unintentionally a hack that relies on + -- the fact the two things that references can refer to (term and decl + -- components) have the same basic serialized structure: first a format + -- byte that is always 0 for now, followed by a framed array representing + -- the strongly-connected component. :grimace: + Q.loadObjectById oId decodeComponentLengthOnly + +-- TODO rename to expectDeclTypeByReference +getDeclTypeByReference :: DB m => C.Reference.Id -> m C.Decl.DeclType +getDeclTypeByReference = + fmap C.Decl.declType . expectDeclByReference + +componentByObjectId :: DB m => Db.ObjectId -> m [S.Reference.Id] componentByObjectId id = do when debug . traceM $ "Operations.componentByObjectId " ++ show id - len <- (liftQ . Q.loadObjectById) id >>= decodeComponentLengthOnly + len <- Q.loadObjectById id decodeComponentLengthOnly pure [C.Reference.Id id i | i <- [0 .. len - 1]] -- * Codebase operations -- ** Saving & loading terms -saveTermComponent :: EDB m => H.Hash -> [(C.Term Symbol, C.Term.Type Symbol)] -> m Db.ObjectId +saveTermComponent :: DB m => H.Hash -> [(C.Term Symbol, C.Term.Type Symbol)] -> m Db.ObjectId saveTermComponent h terms = do when debug . traceM $ "Operations.saveTermComponent " ++ show h sTermElements <- traverse (uncurry c2sTerm) terms @@ -656,45 +621,40 @@ c2xTerm saveText saveDefn tm tp = (Vector.fromList (Foldable.toList defnIds)) pure (ids, void tm, void <$> tp) -loadTermWithTypeByReference :: EDB m => C.Reference.Id -> MaybeT m (C.Term Symbol, C.Term.Type Symbol) +loadTermWithTypeByReference :: DB m => C.Reference.Id -> MaybeT m (C.Term Symbol, C.Term.Type Symbol) loadTermWithTypeByReference (C.Reference.Id h i) = MaybeT (primaryHashToMaybeObjectId h) - >>= liftQ . Q.loadObjectById -- retrieve and deserialize the blob - >>= decodeTermElementWithType i + >>= (\oId -> Q.loadObjectById oId (decodeTermElementWithType i)) >>= uncurry3 s2cTermWithType -loadTermByReference :: EDB m => C.Reference.Id -> MaybeT m (C.Term Symbol) +loadTermByReference :: DB m => C.Reference.Id -> MaybeT m (C.Term Symbol) loadTermByReference r@(C.Reference.Id h i) = do when debug . traceM $ "loadTermByReference " ++ show r MaybeT (primaryHashToMaybeObjectId h) - >>= liftQ . Q.loadObjectWithTypeById - >>= \case (OT.TermComponent, blob) -> pure blob; _ -> mzero -- retrieve and deserialize the blob - >>= decodeTermElementDiscardingType i + >>= (\oid -> lift (Q.expectTermObjectById oid (decodeTermElementDiscardingType i))) >>= uncurry s2cTerm -loadTypeOfTermByTermReference :: EDB m => C.Reference.Id -> MaybeT m (C.Term.Type Symbol) +loadTypeOfTermByTermReference :: DB m => C.Reference.Id -> MaybeT m (C.Term.Type Symbol) loadTypeOfTermByTermReference id@(C.Reference.Id h i) = do when debug . traceM $ "loadTypeOfTermByTermReference " ++ show id MaybeT (primaryHashToMaybeObjectId h) - >>= liftQ . Q.loadObjectWithTypeById - >>= \case (OT.TermComponent, blob) -> pure blob; _ -> mzero -- retrieve and deserialize the blob - >>= decodeTermElementDiscardingTerm i + >>= (\oid -> lift (Q.expectTermObjectById oid (decodeTermElementDiscardingTerm i))) >>= uncurry s2cTypeOfTerm -s2cTermWithType :: EDB m => LocalIds -> S.Term.Term -> S.Term.Type -> m (C.Term Symbol, C.Term.Type Symbol) +s2cTermWithType :: DB m => LocalIds -> S.Term.Term -> S.Term.Type -> m (C.Term Symbol, C.Term.Type Symbol) s2cTermWithType ids tm tp = do (substText, substHash) <- localIdsToLookups loadTextById loadHashByObjectId ids pure (x2cTerm substText substHash tm, x2cTType substText substHash tp) -s2cTerm :: EDB m => LocalIds -> S.Term.Term -> m (C.Term Symbol) +s2cTerm :: DB m => LocalIds -> S.Term.Term -> m (C.Term Symbol) s2cTerm ids tm = do (substText, substHash) <- localIdsToLookups loadTextById loadHashByObjectId ids pure $ x2cTerm substText substHash tm -s2cTypeOfTerm :: EDB m => LocalIds -> S.Term.Type -> m (C.Term.Type Symbol) +s2cTypeOfTerm :: DB m => LocalIds -> S.Term.Type -> m (C.Term.Type Symbol) s2cTypeOfTerm ids tp = do (substText, substHash) <- localIdsToLookups loadTextById loadHashByObjectId ids pure $ x2cTType substText substHash tp @@ -766,24 +726,23 @@ lookup_ stateLens writerLens mk t = do pure id Just t' -> pure t' -c2sTerm :: EDB m => C.Term Symbol -> C.Term.Type Symbol -> m (LocalIds, S.Term.Term, S.Term.Type) +c2sTerm :: DB m => C.Term Symbol -> C.Term.Type Symbol -> m (LocalIds, S.Term.Term, S.Term.Type) c2sTerm tm tp = c2xTerm Q.saveText primaryHashToExistingObjectId tm (Just tp) <&> \(w, tm, Just tp) -> (w, tm, tp) -- *** Watch expressions -listWatches :: EDB m => WatchKind -> m [C.Reference.Id] +listWatches :: DB m => WatchKind -> m [C.Reference.Id] listWatches k = Q.loadWatchesByWatchKind k >>= traverse h2cReferenceId -- | returns Nothing if the expression isn't cached. -loadWatch :: EDB m => WatchKind -> C.Reference.Id -> MaybeT m (C.Term Symbol) +loadWatch :: DB m => WatchKind -> C.Reference.Id -> MaybeT m (C.Term Symbol) loadWatch k r = C.Reference.idH Q.saveHashHash r - >>= MaybeT . Q.loadWatch k - >>= getFromBytesOr (ErrWatch k r) S.getWatchResultFormat + >>= (\r' -> MaybeT (Q.loadWatch k r' (getFromBytesOr (ErrWatch k r) S.getWatchResultFormat))) >>= \case S.Term.WatchResult wlids t -> w2cTerm wlids t -saveWatch :: EDB m => WatchKind -> C.Reference.Id -> C.Term Symbol -> m () +saveWatch :: DB m => WatchKind -> C.Reference.Id -> C.Term Symbol -> m () saveWatch w r t = do rs <- C.Reference.idH Q.saveHashHash r wterm <- c2wTerm t @@ -793,17 +752,17 @@ saveWatch w r t = do clearWatches :: DB m => m () clearWatches = Q.clearWatches -c2wTerm :: EDB m => C.Term Symbol -> m (WatchLocalIds, S.Term.Term) +c2wTerm :: DB m => C.Term Symbol -> m (WatchLocalIds, S.Term.Term) c2wTerm tm = c2xTerm Q.saveText Q.saveHashHash tm Nothing <&> \(w, tm, _) -> (w, tm) -w2cTerm :: EDB m => WatchLocalIds -> S.Term.Term -> m (C.Term Symbol) +w2cTerm :: DB m => WatchLocalIds -> S.Term.Term -> m (C.Term Symbol) w2cTerm ids tm = do (substText, substHash) <- localIdsToLookups loadTextById loadHashByHashId ids pure $ x2cTerm substText substHash tm -- ** Saving & loading type decls -saveDeclComponent :: EDB m => H.Hash -> [C.Decl Symbol] -> m Db.ObjectId +saveDeclComponent :: DB m => H.Hash -> [C.Decl Symbol] -> m Db.ObjectId saveDeclComponent h decls = do when debug . traceM $ "Operations.saveDeclComponent " ++ show h sDeclElements <- traverse (c2sDecl Q.saveText primaryHashToExistingObjectId) decls @@ -827,7 +786,7 @@ saveDeclComponent h decls = do pure oId -c2sDecl :: forall m t d. EDB m => (Text -> m t) -> (H.Hash -> m d) -> C.Decl Symbol -> m (LocalIds' t d, S.Decl.Decl Symbol) +c2sDecl :: forall m t d. DB m => (Text -> m t) -> (H.Hash -> m d) -> C.Decl Symbol -> m (LocalIds' t d, S.Decl.Decl Symbol) c2sDecl saveText saveDefn (C.Decl.DataDeclaration dt m b cts) = do done =<< (runWriterT . flip evalStateT mempty) do cts' <- traverse (ABT.transformM goType) cts @@ -857,16 +816,25 @@ c2sDecl saveText saveDefn (C.Decl.DataDeclaration dt m b cts) = do (Vector.fromList (Foldable.toList defnIds)) pure (ids, decl) -loadDeclByReference :: EDB m => C.Reference.Id -> MaybeT m (C.Decl Symbol) +loadDeclByReference :: DB m => C.Reference.Id -> MaybeT m (C.Decl Symbol) loadDeclByReference r@(C.Reference.Id h i) = do when debug . traceM $ "loadDeclByReference " ++ show r -- retrieve the blob - (localIds, C.Decl.DataDeclaration dt m b ct) <- - MaybeT (primaryHashToMaybeObjectId h) - >>= liftQ . Q.loadObjectWithTypeById - >>= \case (OT.DeclComponent, blob) -> pure blob; _ -> mzero - >>= decodeDeclElement i + MaybeT (primaryHashToMaybeObjectId h) + >>= (\oid -> Q.expectDeclObjectById oid (decodeDeclElement i)) + >>= s2cDecl + +expectDeclByReference :: DB m => C.Reference.Id -> m (C.Decl Symbol) +expectDeclByReference r@(C.Reference.Id h i) = do + when debug . traceM $ "expectDeclByReference " ++ show r + -- retrieve the blob + primaryHashToExistingObjectId h + >>= (\oid -> Q.expectDeclObjectById oid (decodeDeclElement i)) + >>= s2cDecl +-- | Unlocalize a decl. +s2cDecl :: DB m => (LocalIds, S.Decl.Decl Symbol) -> m (C.Decl Symbol) +s2cDecl (localIds, C.Decl.DataDeclaration dt m b ct) = do -- look up the text and hashes that are used by the term texts <- traverse loadTextById $ LocalIds.textLookup localIds hashes <- traverse loadHashByObjectId $ LocalIds.defnLookup localIds @@ -880,7 +848,7 @@ loadDeclByReference r@(C.Reference.Id h i) = do -- * Branch transformation -s2cBranch :: EDB m => S.DbBranch -> m (C.Branch.Branch m) +s2cBranch :: DB m => S.DbBranch -> m (C.Branch.Branch m) s2cBranch (S.Branch.Full.Branch tms tps patches children) = C.Branch.Branch <$> doTerms tms @@ -888,15 +856,15 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = <*> doPatches patches <*> doChildren children where - loadMetadataType :: EDB m => S.Reference -> m C.Reference + loadMetadataType :: DB m => S.Reference -> m C.Reference loadMetadataType = \case C.ReferenceBuiltin tId -> - loadTextById tId >>= throwError . NeedTypeForBuiltinMetadata + Q.loadTextByIdCheck (Left . NeedTypeForBuiltinMetadata) tId C.ReferenceDerived id -> typeReferenceForTerm id >>= h2cReference loadTypesForMetadata rs = Map.fromList <$> traverse (\r -> (,) <$> s2cReference r <*> loadMetadataType r) (Foldable.toList rs) - doTerms :: EDB m => Map Db.TextId (Map S.Referent S.DbMetadataSet) -> m (Map C.Branch.NameSegment (Map C.Referent (m C.Branch.MdValues))) + doTerms :: DB m => Map Db.TextId (Map S.Referent S.DbMetadataSet) -> m (Map C.Branch.NameSegment (Map C.Referent (m C.Branch.MdValues))) doTerms = Map.bitraverse (fmap C.Branch.NameSegment . loadTextById) @@ -904,7 +872,7 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = S.MetadataSet.Inline rs -> pure $ C.Branch.MdValues <$> loadTypesForMetadata rs ) - doTypes :: EDB m => Map Db.TextId (Map S.Reference S.DbMetadataSet) -> m (Map C.Branch.NameSegment (Map C.Reference (m C.Branch.MdValues))) + doTypes :: DB m => Map Db.TextId (Map S.Reference S.DbMetadataSet) -> m (Map C.Branch.NameSegment (Map C.Reference (m C.Branch.MdValues))) doTypes = Map.bitraverse (fmap C.Branch.NameSegment . loadTextById) @@ -912,37 +880,36 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = S.MetadataSet.Inline rs -> pure $ C.Branch.MdValues <$> loadTypesForMetadata rs ) - doPatches :: EDB m => Map Db.TextId Db.PatchObjectId -> m (Map C.Branch.NameSegment (PatchHash, m C.Branch.Patch)) + doPatches :: DB m => Map Db.TextId Db.PatchObjectId -> m (Map C.Branch.NameSegment (PatchHash, m C.Branch.Patch)) doPatches = Map.bitraverse (fmap C.Branch.NameSegment . loadTextById) \patchId -> do h <- PatchHash <$> (loadHashByObjectId . Db.unPatchObjectId) patchId pure (h, loadPatchById patchId) - doChildren :: EDB m => Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) -> m (Map C.Branch.NameSegment (C.Causal m CausalHash BranchHash (C.Branch.Branch m))) + doChildren :: DB m => Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) -> m (Map C.Branch.NameSegment (C.Causal m CausalHash BranchHash (C.Branch.Branch m))) doChildren = Map.bitraverse (fmap C.Branch.NameSegment . loadTextById) \(boId, chId) -> C.Causal <$> loadCausalHashById chId <*> loadValueHashByCausalHashId chId <*> headParents chId <*> pure (loadBranchByObjectId boId) where - headParents :: EDB m => Db.CausalHashId -> m (Map CausalHash (m (C.Causal m CausalHash BranchHash (C.Branch.Branch m)))) + headParents :: DB m => Db.CausalHashId -> m (Map CausalHash (m (C.Causal m CausalHash BranchHash (C.Branch.Branch m)))) headParents chId = do parentsChIds <- Q.loadCausalParents chId fmap Map.fromList $ traverse pairParent parentsChIds - pairParent :: EDB m => Db.CausalHashId -> m (CausalHash, m (C.Causal m CausalHash BranchHash (C.Branch.Branch m))) + pairParent :: DB m => Db.CausalHashId -> m (CausalHash, m (C.Causal m CausalHash BranchHash (C.Branch.Branch m))) pairParent chId = do h <- loadCausalHashById chId pure (h, loadCausal chId) - loadCausal :: EDB m => Db.CausalHashId -> m (C.Causal m CausalHash BranchHash (C.Branch.Branch m)) + loadCausal :: DB m => Db.CausalHashId -> m (C.Causal m CausalHash BranchHash (C.Branch.Branch m)) loadCausal chId = do C.Causal <$> loadCausalHashById chId <*> loadValueHashByCausalHashId chId <*> headParents chId <*> pure (loadValue chId) - loadValue :: EDB m => Db.CausalHashId -> m (C.Branch.Branch m) - loadValue chId = - liftQ (Q.loadBranchObjectIdByCausalHashId chId) >>= \case - Nothing -> throwError (ExpectedBranch' chId) - Just boId -> loadBranchByObjectId boId + loadValue :: DB m => Db.CausalHashId -> m (C.Branch.Branch m) + loadValue chId = do + boId <- Q.expectBranchObjectIdByCausalHashId chId + loadBranchByObjectId boId -- this maps from the key used by C.Branch to a local id type BranchSavingState = (Map Text LocalTextId, Map H.Hash LocalDefnId, Map Db.PatchObjectId LocalPatchObjectId, Map (Db.BranchObjectId, Db.CausalHashId) LocalBranchChildId) @@ -953,22 +920,22 @@ type BranchSavingConstraint m = (MonadState BranchSavingState m, MonadWriter Bra type BranchSavingMonad m = StateT BranchSavingState (WriterT BranchSavingWriter m) -saveRootBranch :: EDB m => C.Branch.Causal m -> m (Db.BranchObjectId, Db.CausalHashId) +saveRootBranch :: DB m => C.Branch.Causal m -> m (Db.BranchObjectId, Db.CausalHashId) saveRootBranch c = do when debug $ traceM $ "Operations.saveRootBranch " ++ show (C.causalHash c) (boId, chId) <- saveBranch c Q.setNamespaceRoot chId pure (boId, chId) -saveBranch :: EDB m => C.Branch.Causal m -> m (Db.BranchObjectId, Db.CausalHashId) +saveBranch :: DB m => C.Branch.Causal m -> m (Db.BranchObjectId, Db.CausalHashId) saveBranch (C.Causal hc he parents me) = do when debug $ traceM $ "\nOperations.saveBranch \n hc = " ++ show hc ++ ",\n he = " ++ show he ++ ",\n parents = " ++ show (Map.keys parents) - (chId, bhId) <- flip Monad.fromMaybeM (liftQ $ Q.loadCausalByCausalHash hc) do + (chId, bhId) <- flip Monad.fromMaybeM (Q.loadCausalByCausalHash hc) do -- if not exist, create these - chId <- liftQ (Q.saveCausalHash hc) - bhId <- liftQ (Q.saveBranchHash he) - liftQ (Q.saveCausal chId bhId) + chId <- Q.saveCausalHash hc + bhId <- Q.saveBranchHash he + Q.saveCausal chId bhId -- save the link between child and parents parentCausalHashIds <- -- so try to save each parent (recursively) before continuing to save hc @@ -976,17 +943,17 @@ saveBranch (C.Causal hc he parents me) = do -- check if we can short circuit the parent before loading it, -- by checking if there are causal parents associated with hc (flip Monad.fromMaybeM) - (liftQ $ Q.loadCausalHashIdByCausalHash parentHash) + (Q.loadCausalHashIdByCausalHash parentHash) (mcausal >>= fmap snd . saveBranch) unless (null parentCausalHashIds) $ - liftQ (Q.saveCausalParents chId parentCausalHashIds) + Q.saveCausalParents chId parentCausalHashIds pure (chId, bhId) - boId <- flip Monad.fromMaybeM (liftQ $ Q.loadBranchObjectIdByCausalHashId chId) do + boId <- flip Monad.fromMaybeM (Q.loadBranchObjectIdByCausalHashId chId) do (li, lBranch) <- c2lBranch =<< me saveBranchObject bhId li lBranch pure (boId, chId) where - c2lBranch :: EDB m => C.Branch.Branch m -> m (BranchLocalIds, S.Branch.Full.LocalBranch) + c2lBranch :: DB m => C.Branch.Branch m -> m (BranchLocalIds, S.Branch.Full.LocalBranch) c2lBranch (C.Branch.Branch terms types patches children) = done =<< (runWriterT . flip evalStateT startState) do S.Branch @@ -1003,14 +970,14 @@ saveBranch (C.Causal hc he parents me) = do saveMetadata mm = do C.Branch.MdValues m <- (lift . lift) mm S.Branch.Full.Inline <$> Set.traverse saveReference (Map.keysSet m) - savePatch' :: EDB m => (PatchHash, m C.Branch.Patch) -> BranchSavingMonad m LocalPatchObjectId + savePatch' :: DB m => (PatchHash, m C.Branch.Patch) -> BranchSavingMonad m LocalPatchObjectId savePatch' (h, mp) = do patchOID <- primaryHashToMaybePatchObjectId h >>= \case Just patchOID -> pure patchOID Nothing -> savePatch h =<< (lift . lift) mp lookupPatch patchOID - saveChild :: EDB m => C.Branch.Causal m -> BranchSavingMonad m LocalBranchChildId + saveChild :: DB m => C.Branch.Causal m -> BranchSavingMonad m LocalBranchChildId saveChild c = (lift . lift) (saveBranch c) >>= lookupChild lookupText :: ( MonadState s m, @@ -1059,10 +1026,10 @@ saveBranch (C.Causal hc he parents me) = do let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full li lBranch oId <- Q.saveObject hashId OT.Namespace bytes pure $ Db.BranchObjectId oId - done :: (EDB m, Show a) => (a, BranchSavingWriter) -> m (BranchLocalIds, a) + done :: (DB m, Show a) => (a, BranchSavingWriter) -> m (BranchLocalIds, a) done (lBranch, written@(textValues, defnHashes, patchObjectIds, branchCausalIds)) = do when debug $ traceM $ "saveBranch.done\n\tlBranch = " ++ show lBranch ++ "\n\twritten = " ++ show written - textIds <- liftQ $ traverse Q.saveText textValues + textIds <- traverse Q.saveText textValues defnObjectIds <- traverse primaryHashToExistingObjectId defnHashes let ids = S.BranchFormat.LocalIds @@ -1072,46 +1039,42 @@ saveBranch (C.Causal hc he parents me) = do (Vector.fromList (Foldable.toList branchCausalIds)) pure (ids, lBranch) -loadRootCausal :: EDB m => m (C.Branch.Causal m) -loadRootCausal = liftQ Q.loadNamespaceRoot >>= loadCausalByCausalHashId +loadRootCausal :: DB m => m (C.Branch.Causal m) +loadRootCausal = Q.loadNamespaceRoot >>= loadCausalByCausalHashId -loadCausalBranchByCausalHash :: EDB m => CausalHash -> m (Maybe (C.Branch.Causal m)) +loadCausalBranchByCausalHash :: DB m => CausalHash -> m (Maybe (C.Branch.Causal m)) loadCausalBranchByCausalHash hc = do Q.loadCausalHashIdByCausalHash hc >>= \case Just chId -> Just <$> loadCausalByCausalHashId chId Nothing -> pure Nothing -loadCausalByCausalHashId :: EDB m => Db.CausalHashId -> m (C.Branch.Causal m) +loadCausalByCausalHashId :: DB m => Db.CausalHashId -> m (C.Branch.Causal m) loadCausalByCausalHashId id = do hc <- loadCausalHashById id hb <- loadValueHashByCausalHashId id - let loadNamespace = - loadBranchByCausalHashId id >>= \case - Nothing -> throwError (ExpectedBranch' id) - Just b -> pure b parentHashIds <- Q.loadCausalParents id loadParents <- for parentHashIds \hId -> do h <- loadCausalHashById hId pure (h, loadCausalByCausalHashId hId) - pure $ C.Causal hc hb (Map.fromList loadParents) loadNamespace + pure $ C.Causal hc hb (Map.fromList loadParents) (loadBranchByCausalHashId id) -- | is this even a thing? loading a branch by causal hash? yes I guess so. -loadBranchByCausalHashId :: EDB m => Db.CausalHashId -> m (Maybe (C.Branch.Branch m)) +-- TODO rename to expectBranchByCausalHashId +loadBranchByCausalHashId :: DB m => Db.CausalHashId -> m (C.Branch.Branch m) loadBranchByCausalHashId id = do - (liftQ . Q.loadBranchObjectIdByCausalHashId) id - >>= traverse loadBranchByObjectId + boId <- Q.expectBranchObjectIdByCausalHashId id + loadBranchByObjectId boId -loadBranchByObjectId :: EDB m => Db.BranchObjectId -> m (C.Branch.Branch m) +loadBranchByObjectId :: DB m => Db.BranchObjectId -> m (C.Branch.Branch m) loadBranchByObjectId id = do deserializeBranchObject id >>= \case S.BranchFormat.Full li f -> s2cBranch (l2sFull li f) S.BranchFormat.Diff r li d -> doDiff r [l2sDiff li d] where - deserializeBranchObject :: EDB m => Db.BranchObjectId -> m S.BranchFormat + deserializeBranchObject :: DB m => Db.BranchObjectId -> m S.BranchFormat deserializeBranchObject id = do when debug $ traceM $ "deserializeBranchObject " ++ show id - (liftQ . Q.loadObjectById) (Db.unBranchObjectId id) - >>= getFromBytesOr (ErrBranch id) S.getBranchFormat + Q.expectNamespaceObjectById (Db.unBranchObjectId id) (getFromBytesOr (ErrBranch id) S.getBranchFormat) l2sFull :: S.BranchFormat.BranchLocalIds -> S.LocalBranch -> S.DbBranch l2sFull li = @@ -1120,13 +1083,13 @@ loadBranchByObjectId id = do l2sDiff :: S.BranchFormat.BranchLocalIds -> S.Branch.LocalDiff -> S.Branch.Diff l2sDiff li = S.BranchDiff.quadmap (lookupBranchLocalText li) (lookupBranchLocalDefn li) (lookupBranchLocalPatch li) (lookupBranchLocalChild li) - doDiff :: EDB m => Db.BranchObjectId -> [S.Branch.Diff] -> m (C.Branch.Branch m) + doDiff :: DB m => Db.BranchObjectId -> [S.Branch.Diff] -> m (C.Branch.Branch m) doDiff ref ds = deserializeBranchObject ref >>= \case S.BranchFormat.Full li f -> joinFull (l2sFull li f) ds S.BranchFormat.Diff ref' li' d' -> doDiff ref' (l2sDiff li' d' : ds) where - joinFull :: EDB m => S.DbBranch -> [S.Branch.Diff] -> m (C.Branch.Branch m) + joinFull :: DB m => S.DbBranch -> [S.Branch.Diff] -> m (C.Branch.Branch m) joinFull f [] = s2cBranch f joinFull (S.Branch.Full.Branch tms tps patches children) @@ -1229,18 +1192,18 @@ loadBranchByObjectId id = do -- * Patch transformation -loadPatchById :: EDB m => Db.PatchObjectId -> m C.Branch.Patch +loadPatchById :: DB m => Db.PatchObjectId -> m C.Branch.Patch loadPatchById patchId = deserializePatchObject patchId >>= \case S.PatchFormat.Full li p -> s2cPatch (l2sPatchFull li p) S.PatchFormat.Diff ref li d -> doDiff ref [l2sPatchDiff li d] where - doDiff :: EDB m => Db.PatchObjectId -> [S.PatchDiff] -> m C.Branch.Patch + doDiff :: DB m => Db.PatchObjectId -> [S.PatchDiff] -> m C.Branch.Patch doDiff ref ds = deserializePatchObject ref >>= \case S.PatchFormat.Full li f -> joinFull (l2sPatchFull li f) ds S.PatchFormat.Diff ref' li' d' -> doDiff ref' (l2sPatchDiff li' d' : ds) - joinFull :: EDB m => S.Patch -> [S.PatchDiff] -> m C.Branch.Patch + joinFull :: DB m => S.Patch -> [S.PatchDiff] -> m C.Branch.Patch joinFull f [] = s2cPatch f joinFull (S.Patch termEdits typeEdits) (S.PatchDiff addedTermEdits addedTypeEdits removedTermEdits removedTypeEdits : ds) = joinFull f' ds where @@ -1277,31 +1240,30 @@ loadPatchById patchId = (lookupPatchLocalHash li) (lookupPatchLocalDefn li) -savePatch :: EDB m => PatchHash -> C.Branch.Patch -> m Db.PatchObjectId +savePatch :: DB m => PatchHash -> C.Branch.Patch -> m Db.PatchObjectId savePatch h c = do (li, lPatch) <- c2lPatch c hashId <- Q.saveHashHash (unPatchHash h) let bytes = S.putBytes S.putPatchFormat $ S.PatchFormat.Full li lPatch Db.PatchObjectId <$> Q.saveObject hashId OT.Patch bytes -s2cPatch :: EDB m => S.Patch -> m C.Branch.Patch +s2cPatch :: DB m => S.Patch -> m C.Branch.Patch s2cPatch (S.Patch termEdits typeEdits) = C.Branch.Patch <$> Map.bitraverse h2cReferent (Set.traverse s2cTermEdit) termEdits <*> Map.bitraverse h2cReference (Set.traverse s2cTypeEdit) typeEdits -deserializePatchObject :: EDB m => Db.PatchObjectId -> m S.PatchFormat +deserializePatchObject :: DB m => Db.PatchObjectId -> m S.PatchFormat deserializePatchObject id = do when debug $ traceM $ "Operations.deserializePatchObject " ++ show id - (liftQ . Q.loadObjectById) (Db.unPatchObjectId id) - >>= getFromBytesOr (ErrPatch id) S.getPatchFormat + Q.expectPatchObjectById (Db.unPatchObjectId id) (getFromBytesOr (ErrPatch id) S.getPatchFormat) -lca :: EDB m => CausalHash -> CausalHash -> Connection -> Connection -> m (Maybe CausalHash) +lca :: DB m => CausalHash -> CausalHash -> Connection -> Connection -> m (Maybe CausalHash) lca h1 h2 c1 c2 = runMaybeT do chId1 <- MaybeT $ Q.loadCausalHashIdByCausalHash h1 chId2 <- MaybeT $ Q.loadCausalHashIdByCausalHash h2 chId3 <- MaybeT . liftIO $ Q.lca chId1 chId2 c1 c2 - liftQ $ Q.loadCausalHash chId3 + Q.loadCausalHash chId3 before :: DB m => CausalHash -> CausalHash -> m (Maybe Bool) before h1 h2 = runMaybeT do @@ -1312,7 +1274,7 @@ before h1 h2 = runMaybeT do -- * Searches -termsHavingType :: EDB m => C.Reference -> m (Set C.Referent.Id) +termsHavingType :: DB m => C.Reference -> m (Set C.Referent.Id) termsHavingType cTypeRef = do maySet <- runMaybeT $ do sTypeRef <- c2hReference cTypeRef @@ -1322,10 +1284,10 @@ termsHavingType cTypeRef = do Nothing -> mempty Just set -> Set.fromList set -typeReferenceForTerm :: EDB m => S.Reference.Id -> m S.ReferenceH -typeReferenceForTerm = liftQ . Q.getTypeReferenceForReferent . C.Referent.RefId +typeReferenceForTerm :: DB m => S.Reference.Id -> m S.ReferenceH +typeReferenceForTerm = Q.getTypeReferenceForReferent . C.Referent.RefId -termsMentioningType :: EDB m => C.Reference -> m (Set C.Referent.Id) +termsMentioningType :: DB m => C.Reference -> m (Set C.Referent.Id) termsMentioningType cTypeRef = do maySet <- runMaybeT $ do sTypeRef <- c2hReference cTypeRef @@ -1335,19 +1297,19 @@ termsMentioningType cTypeRef = do Nothing -> mempty Just set -> Set.fromList set -addTypeToIndexForTerm :: EDB m => S.Referent.Id -> C.Reference -> m () +addTypeToIndexForTerm :: DB m => S.Referent.Id -> C.Reference -> m () addTypeToIndexForTerm sTermId cTypeRef = do sTypeRef <- saveReferenceH cTypeRef Q.addToTypeIndex sTypeRef sTermId -addTypeMentionsToIndexForTerm :: EDB m => S.Referent.Id -> Set C.Reference -> m () +addTypeMentionsToIndexForTerm :: DB m => S.Referent.Id -> Set C.Reference -> m () addTypeMentionsToIndexForTerm sTermId cTypeMentionRefs = do traverse_ (flip Q.addToTypeMentionsIndex sTermId <=< saveReferenceH) cTypeMentionRefs -- something kind of funny here. first, we don't need to enumerate all the reference pos if we're just picking one -- second, it would be nice if we could leave these as S.References a little longer -- so that we remember how to blow up if they're missing -componentReferencesByPrefix :: EDB m => OT.ObjectType -> Text -> Maybe C.Reference.Pos -> m [S.Reference.Id] +componentReferencesByPrefix :: DB m => OT.ObjectType -> Text -> Maybe C.Reference.Pos -> m [S.Reference.Id] componentReferencesByPrefix ot b32prefix pos = do oIds :: [Db.ObjectId] <- Q.objectIdByBase32Prefix ot b32prefix let test = maybe (const True) (==) pos @@ -1355,24 +1317,24 @@ componentReferencesByPrefix ot b32prefix pos = do fmap Monoid.fromMaybe . runMaybeT $ join <$> traverse (fmap filterComponent . componentByObjectId) oIds -termReferencesByPrefix :: EDB m => Text -> Maybe Word64 -> m [C.Reference.Id] +termReferencesByPrefix :: DB m => Text -> Maybe Word64 -> m [C.Reference.Id] termReferencesByPrefix t w = componentReferencesByPrefix OT.TermComponent t w >>= traverse (C.Reference.idH loadHashByObjectId) -declReferencesByPrefix :: EDB m => Text -> Maybe Word64 -> m [C.Reference.Id] +declReferencesByPrefix :: DB m => Text -> Maybe Word64 -> m [C.Reference.Id] declReferencesByPrefix t w = componentReferencesByPrefix OT.DeclComponent t w >>= traverse (C.Reference.idH loadHashByObjectId) -termReferentsByPrefix :: EDB m => Text -> Maybe Word64 -> m [C.Referent.Id] +termReferentsByPrefix :: DB m => Text -> Maybe Word64 -> m [C.Referent.Id] termReferentsByPrefix b32prefix pos = fmap C.Referent.RefId <$> termReferencesByPrefix b32prefix pos -- todo: simplify this if we stop caring about constructor type -- todo: remove the cycle length once we drop it from Unison.Reference declReferentsByPrefix :: - EDB m => + DB m => Text -> Maybe C.Reference.Pos -> Maybe ConstructorId -> @@ -1381,7 +1343,7 @@ declReferentsByPrefix b32prefix pos cid = do componentReferencesByPrefix OT.DeclComponent b32prefix pos >>= traverse (loadConstructors cid) where - loadConstructors :: EDB m => Maybe Word64 -> S.Reference.Id -> m (H.Hash, C.Reference.Pos, Word64, C.DeclType, [ConstructorId]) + loadConstructors :: DB m => Maybe Word64 -> S.Reference.Id -> m (H.Hash, C.Reference.Pos, Word64, C.DeclType, [ConstructorId]) loadConstructors cid rid@(C.Reference.Id oId pos) = do (dt, len, ctorCount) <- getDeclCtorCount rid h <- loadHashByObjectId oId @@ -1389,28 +1351,27 @@ declReferentsByPrefix b32prefix pos cid = do test = maybe (const True) (==) cid cids = [cid | cid <- [0 :: ConstructorId .. ctorCount - 1], test cid] pure (h, pos, len, dt, cids) - getDeclCtorCount :: EDB m => S.Reference.Id -> m (C.Decl.DeclType, Word64, ConstructorId) + getDeclCtorCount :: DB m => S.Reference.Id -> m (C.Decl.DeclType, Word64, ConstructorId) getDeclCtorCount id@(C.Reference.Id r i) = do when debug $ traceM $ "getDeclCtorCount " ++ show id - bs <- liftQ (Q.loadObjectById r) - len <- decodeComponentLengthOnly bs - (_localIds, decl) <- decodeDeclElement i bs + (len, (_localIds, decl)) <- + Q.expectDeclObjectById r (\bs -> (,) <$> decodeComponentLengthOnly bs <*> decodeDeclElement i bs) pure (C.Decl.declType decl, len, fromIntegral $ length (C.Decl.constructorTypes decl)) -branchHashesByPrefix :: EDB m => ShortBranchHash -> m (Set BranchHash) +branchHashesByPrefix :: DB m => ShortBranchHash -> m (Set BranchHash) branchHashesByPrefix (ShortBranchHash b32prefix) = do hashIds <- Q.namespaceHashIdByBase32Prefix b32prefix - b32s <- traverse (liftQ . Q.loadHashById . Db.unBranchHashId) hashIds + b32s <- traverse (Q.loadHashById . Db.unBranchHashId) hashIds pure $ Set.fromList . fmap BranchHash . fmap H.fromBase32Hex $ b32s -causalHashesByPrefix :: EDB m => ShortBranchHash -> m (Set CausalHash) +causalHashesByPrefix :: DB m => ShortBranchHash -> m (Set CausalHash) causalHashesByPrefix (ShortBranchHash b32prefix) = do hashIds <- Q.causalHashIdByBase32Prefix b32prefix - b32s <- traverse (liftQ . Q.loadHashById . Db.unCausalHashId) hashIds + b32s <- traverse (Q.loadHashById . Db.unCausalHashId) hashIds pure $ Set.fromList . fmap CausalHash . fmap H.fromBase32Hex $ b32s -- | returns a list of known definitions referencing `r` -dependents :: EDB m => C.Reference -> m (Set C.Reference.Id) +dependents :: DB m => C.Reference -> m (Set C.Reference.Id) dependents r = do r' <- c2sReference r sIds :: [S.Reference.Id] <- Q.getDependentsForDependency r' @@ -1420,7 +1381,7 @@ dependents r = do pure $ Set.fromList cIds -- | returns empty set for unknown inputs; doesn't distinguish between term and decl -derivedDependencies :: EDB m => C.Reference.Id -> m (Set C.Reference.Id) +derivedDependencies :: DB m => C.Reference.Id -> m (Set C.Reference.Id) derivedDependencies cid = do sid <- c2sReferenceId cid sids <- Q.getDependencyIdsForDependent sid diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 4f6a849791..0edd9f9082 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -17,15 +17,12 @@ {-# LANGUAGE TypeOperators #-} module U.Codebase.Sqlite.Queries ( - -- * Constraint kinds - DB, Err, - -- * Error types - Integrity(..), - -- * text table saveText, loadText, + expectText, loadTextById, + loadTextByIdCheck, -- * hash table saveHash, @@ -52,6 +49,10 @@ module U.Codebase.Sqlite.Queries ( loadObjectById, loadPrimaryHashByObjectId, loadObjectWithTypeById, + expectDeclObjectById, + expectNamespaceObjectById, + expectPatchObjectById, + expectTermObjectById, loadObjectWithHashIdAndTypeById, updateObjectBlob, -- unused @@ -68,6 +69,7 @@ module U.Codebase.Sqlite.Queries ( loadCausalValueHashId, loadCausalByCausalHash, loadBranchObjectIdByCausalHashId, + expectBranchObjectIdByCausalHashId, -- ** causal_parent table saveCausalParents, @@ -112,9 +114,6 @@ module U.Codebase.Sqlite.Queries ( rollbackRelease, ) where -import Control.Monad (when) -import Control.Monad.Except (MonadError) -import qualified Control.Monad.Except as Except import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) import Data.ByteString (ByteString) import Data.Foldable (traverse_) @@ -128,8 +127,6 @@ import Data.String (fromString) import Data.String.Here.Uninterpolated (here, hereFile) import Data.Text (Text) import Data.Tuple.Only (Only (..)) -import Debug.Trace (trace, traceM) -import GHC.Stack (HasCallStack) import U.Codebase.HashTags (BranchHash (..), CausalHash (..)) import U.Codebase.Reference (Reference' (..)) import qualified U.Codebase.Reference as C.Reference @@ -142,7 +139,7 @@ import U.Codebase.Sqlite.DbId SchemaVersion, TextId, ) -import U.Codebase.Sqlite.ObjectType (ObjectType) +import U.Codebase.Sqlite.ObjectType (ObjectType(DeclComponent, Namespace, Patch, TermComponent)) import qualified U.Codebase.Sqlite.Reference as Reference import qualified U.Codebase.Sqlite.Referent as Referent import U.Codebase.WatchKind (WatchKind) @@ -156,25 +153,6 @@ import qualified Unison.Sqlite.DB as DB import qualified Unison.Sqlite.Transaction as Transaction import UnliftIO (MonadUnliftIO) --- * types - -type EDB m = (DB m, Err m) - -type Err m = (MonadError Integrity m, HasCallStack) - -debugQuery :: Bool -debugQuery = False - -crashOnError :: Bool -crashOnError = False - -throwError :: Err m => Integrity -> m c -throwError = if crashOnError then error . show else Except.throwError - -data Integrity - = NoNamespaceRoot - deriving (Show) - -- * main squeeze createSchema :: (DB m, MonadUnliftIO m) => m () createSchema = @@ -254,8 +232,14 @@ loadTextSql = -- FIXME rename to expectTextById loadTextById :: DB m => TextId -> m Text -loadTextById h = queryOneCol sql (Only h) - where sql = [here|ย SELECT text FROM text WHERE id = ? |] +loadTextById h = queryOneCol loadTextByIdSql (Only h) + +loadTextByIdCheck :: (DB m, SqliteExceptionReason e) => (Text -> Either e a) -> TextId -> m a +loadTextByIdCheck check h = queryOneColCheck loadTextByIdSql (Only h) check + +loadTextByIdSql :: Sql +loadTextByIdSql = + [here|ย SELECT text FROM text WHERE id = ? |] saveHashObject :: DB m => HashId -> ObjectId -> Int -> m () saveHashObject hId oId version = execute sql (hId, oId, version) where @@ -278,11 +262,9 @@ saveObject h t blob = do |] -- FIXME rename to expectObjectById -loadObjectById :: DB m => ObjectId -> m ByteString -loadObjectById id | debugQuery && trace ("loadObjectById " ++ show id) False = undefined -loadObjectById oId = do - result <- queryOneCol sql (Only oId) - when debugQuery $ traceM $ "loadObjectById " ++ show oId ++ " = " ++ show result +loadObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +loadObjectById oId check = do + result <- queryOneColCheck sql (Only oId) check pure result where sql = [here| SELECT bytes FROM object WHERE id = ? @@ -295,6 +277,37 @@ loadObjectWithTypeById oId = queryOneRow sql (Only oId) SELECT type_id, bytes FROM object WHERE id = ? |] +expectObjectOfTypeById :: (DB m, SqliteExceptionReason e) => ObjectId -> ObjectType -> (ByteString -> Either e a) -> m a +expectObjectOfTypeById oid ty = + queryOneColCheck + [here| + SELECT bytes + FROM object + WHERE id = ? + AND type_id = ? + |] + (oid, ty) + +-- | Expect a decl component object. +expectDeclObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectDeclObjectById oid = + expectObjectOfTypeById oid DeclComponent + +-- | Expect a namespace object. +expectNamespaceObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectNamespaceObjectById oid = + expectObjectOfTypeById oid Namespace + +-- | Expect a patch object. +expectPatchObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectPatchObjectById oid = + expectObjectOfTypeById oid Patch + +-- | Expect a term component object. +expectTermObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectTermObjectById oid = + expectObjectOfTypeById oid TermComponent + -- | FIXME rename to expectObjectWithHashIdAndTypeById loadObjectWithHashIdAndTypeById :: DB m => ObjectId -> m (HashId, ObjectType, ByteString) loadObjectWithHashIdAndTypeById oId = queryOneRow sql (Only oId) @@ -401,11 +414,18 @@ isCausalHash = queryOneCol sql . Only where sql = [here| |] loadBranchObjectIdByCausalHashId :: DB m => CausalHashId -> m (Maybe BranchObjectId) -loadBranchObjectIdByCausalHashId id = queryMaybeCol sql (Only id) where sql = [here| - SELECT object_id FROM hash_object - INNER JOIN causal ON hash_id = causal.value_hash_id - WHERE causal.self_hash_id = ? -|] +loadBranchObjectIdByCausalHashId id = queryMaybeCol loadBranchObjectIdByCausalHashIdSql (Only id) + +expectBranchObjectIdByCausalHashId :: DB m => CausalHashId -> m BranchObjectId +expectBranchObjectIdByCausalHashId id = queryOneCol loadBranchObjectIdByCausalHashIdSql (Only id) + +loadBranchObjectIdByCausalHashIdSql :: Sql +loadBranchObjectIdByCausalHashIdSql = + [here| + SELECT object_id FROM hash_object + INNER JOIN causal ON hash_id = causal.value_hash_id + WHERE causal.self_hash_id = ? + |] saveCausalParents :: DB m => CausalHashId -> [CausalHashId] -> m () saveCausalParents child parents = executeMany sql $ (child,) <$> parents where @@ -419,15 +439,17 @@ loadCausalParents h = queryListCol sql (Only h) where sql = [here| SELECT parent_id FROM causal_parent WHERE causal_id = ? |] --- FIXME rename to expectNamespaceRoot -loadNamespaceRoot :: EDB m => m CausalHashId -loadNamespaceRoot = loadMaybeNamespaceRoot >>= \case - Nothing -> throwError NoNamespaceRoot - Just id -> pure id +loadNamespaceRoot :: DB m => m CausalHashId +loadNamespaceRoot = + queryOneCol_ loadMaybeNamespaceRootSql loadMaybeNamespaceRoot :: DB m => m (Maybe CausalHashId) loadMaybeNamespaceRoot = - queryMaybeCol_ "SELECT causal_id FROM namespace_root" + queryMaybeCol_ loadMaybeNamespaceRootSql + +loadMaybeNamespaceRootSql :: Sql +loadMaybeNamespaceRootSql = + "SELECT causal_id FROM namespace_root" setNamespaceRoot :: forall m. DB m => CausalHashId -> m () setNamespaceRoot id = @@ -452,8 +474,8 @@ saveWatch k r blob = execute sql (r :. Only blob) >> execute sql2 (r :. Only k) ON CONFLICT DO NOTHING |] -loadWatch :: DB m => WatchKind -> Reference.IdH -> m (Maybe ByteString) -loadWatch k r = queryMaybeCol sql (Only k :. r) where sql = [here| +loadWatch :: (DB m, SqliteExceptionReason e) => WatchKind -> Reference.IdH -> (ByteString -> Either e a) -> m (Maybe a) +loadWatch k r check = queryMaybeColCheck sql (Only k :. r) check where sql = [here| SELECT result FROM watch_result INNER JOIN watch ON watch_result.hash_id = watch.hash_id @@ -681,7 +703,6 @@ before chId1 chId2 = queryOneCol sql (chId2, chId1) -- the `Connection` arguments come second to fit the shape of Exception.bracket + uncurry curry lca :: CausalHashId -> CausalHashId -> Connection -> Connection -> IO (Maybe CausalHashId) -lca x y _ _ | debugQuery && trace ("Q.lca " ++ show x ++ " " ++ show y) False = undefined lca x y cx cy = withStatement cx sql (Only x) \nextX -> withStatement cy sql (Only y) \nextY -> do diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs index 8f43180365..91161a4918 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs @@ -10,8 +10,7 @@ module U.Codebase.Sqlite.Sync22 where -import Control.Monad.Except (ExceptT, MonadError (throwError)) -import qualified Control.Monad.Except as Except +import Control.Monad.Except (MonadError (throwError)) import Control.Monad.RWS (MonadReader) import Control.Monad.Reader (ReaderT) import qualified Control.Monad.Reader as Reader @@ -23,6 +22,7 @@ import Data.Bytes.Get (getWord8, runGetS) import Data.Bytes.Put (putWord8, runPutS) import Data.List.Extra (nubOrd) import qualified Data.Set as Set +import Data.Void (Void) import qualified U.Codebase.Reference as Reference import qualified U.Codebase.Sqlite.Branch.Format as BL import U.Codebase.Sqlite.DbId @@ -62,8 +62,7 @@ data DecodeError type ErrString = String data Error - = DbIntegrity Q.Integrity - | DecodeError DecodeError ByteString ErrString + = DecodeError DecodeError ByteString ErrString | -- | hashes corresponding to a single object in source codebase -- correspond to multiple objects in destination codebase HashObjectCorrespondence ObjectId [HashId] [HashId] [ObjectId] @@ -367,7 +366,7 @@ trySync tCache hCache oCache cCache = \case r' <- traverse syncHashLiteral r doneKinds <- runDest (Q.loadWatchKindsByReference r') if (notElem wk doneKinds) then do - runSrc (Q.loadWatch wk r) >>= traverse \blob -> do + runSrc (Q.loadWatch wk r (Right :: ByteString -> Either Void ByteString)) >>= traverse \blob -> do TL.SyncWatchResult li body <- either (throwError . DecodeError ErrWatchResult blob) pure $ runGetS S.decomposeWatchFormat blob li' <- bitraverse syncTextLiteral syncHashLiteral li @@ -410,15 +409,12 @@ trySync tCache hCache oCache cCache = \case runSrc, runDest :: - (MonadError Error m, MonadReader Env m) => - ReaderT Connection (ExceptT Q.Integrity m) a -> + MonadReader Env m => + ReaderT Connection m a -> m a runSrc ma = Reader.reader srcDB >>= flip runDB ma runDest ma = Reader.reader destDB >>= flip runDB ma -runDB :: - MonadError Error m => Connection -> ReaderT Connection (ExceptT Q.Integrity m) a -> m a +runDB :: Connection -> ReaderT Connection m a -> m a runDB conn action = - Except.runExceptT (Reader.runReaderT action conn) >>= \case - Left e -> throwError (DbIntegrity e) - Right a -> pure a + Reader.runReaderT action conn diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index 2767698cef..bd5155258f 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -31,3 +31,26 @@ dependencies: - unison-util-term - unliftio - vector + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveAnyClass + - DeriveFunctor + - DeriveGeneric + - DerivingStrategies + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - TupleSections + - TypeApplications + - ViewPatterns diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 29856ac295..31b31add37 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -42,6 +42,28 @@ library Paths_unison_codebase_sqlite hs-source-dirs: ./ + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DerivingStrategies + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + ViewPatterns build-depends: Only , base diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index b4106b3451..5cd756f8fa 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -58,16 +58,23 @@ module Unison.Sqlite.Connection ) where +import Data.Bifunctor (bimap) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text import qualified Database.SQLite.Simple as Sqlite import qualified Database.SQLite.Simple.FromField as Sqlite import qualified Database.SQLite3.Direct as Sqlite (Database (..)) import Debug.RecoverRTTI (anythingToString) +import System.IO (stderr) import Unison.Prelude import Unison.Sqlite.Exception import Unison.Sqlite.Sql import UnliftIO (MonadUnliftIO) import UnliftIO.Exception +debugTraceQueries :: Bool +debugTraceQueries = False + -- | A /non-thread safe/ connection to a SQLite database. data Connection = Connection { name :: String, @@ -121,7 +128,7 @@ closeConnection (Connection _ _ conn) = execute :: Sqlite.ToRow a => Connection -> Sql -> a -> IO () execute conn@(Connection _ _ conn0) s params = - Sqlite.execute conn0 (coerce s) params `catch` \(exception :: Sqlite.SQLError) -> + doExecute `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException SqliteQueryExceptionInfo { connection = conn, @@ -129,10 +136,21 @@ execute conn@(Connection _ _ conn0) s params = params = Just params, sql = s } + where + doExecute = + if debugTraceQueries + then do + Text.hPutStrLn stderr ("query: " <> coerce s) + Text.hPutStrLn stderr ("params: " <> Text.pack (anythingToString params)) + Text.hPutStrLn stderr "----------" + run + else run + where + run = Sqlite.execute conn0 (coerce s) params executeMany :: Sqlite.ToRow a => Connection -> Sql -> [a] -> IO () executeMany conn@(Connection _ _ conn0) s params = - Sqlite.executeMany conn0 (coerce s) params `catch` \(exception :: Sqlite.SQLError) -> + doExecuteMany `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException SqliteQueryExceptionInfo { connection = conn, @@ -140,12 +158,23 @@ executeMany conn@(Connection _ _ conn0) s params = params = Just params, sql = s } + where + doExecuteMany = + if debugTraceQueries + then do + Text.hPutStrLn stderr ("query: " <> coerce s) + Text.hPutStrLn stderr ("params: " <> Text.pack (anythingToString params)) + Text.hPutStrLn stderr "----------" + run + else run + where + run = Sqlite.executeMany conn0 (coerce s) params -- Without results, without parameters execute_ :: Connection -> Sql -> IO () execute_ conn@(Connection _ _ conn0) s = - Sqlite.execute_ conn0 (coerce s) `catch` \(exception :: Sqlite.SQLError) -> + doExecute_ `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException SqliteQueryExceptionInfo { connection = conn, @@ -153,12 +182,22 @@ execute_ conn@(Connection _ _ conn0) s = params = Nothing, sql = s } + where + doExecute_ = + if debugTraceQueries + then do + Text.hPutStrLn stderr ("query: " <> coerce s) + Text.hPutStrLn stderr "----------" + run + else run + where + run = Sqlite.execute_ conn0 (coerce s) -- With results, with parameters, without checks queryListRow :: (Sqlite.FromRow b, Sqlite.ToRow a) => Connection -> Sql -> a -> IO [b] queryListRow conn@(Connection _ _ conn0) s params = - Sqlite.query conn0 (coerce s) params `catch` \(exception :: Sqlite.SQLError) -> + doQueryListRow `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException SqliteQueryExceptionInfo { connection = conn, @@ -166,6 +205,19 @@ queryListRow conn@(Connection _ _ conn0) s params = params = Just params, sql = s } + where + doQueryListRow = + if debugTraceQueries + then do + Text.hPutStrLn stderr ("query: " <> coerce s) + Text.hPutStrLn stderr ("params: " <> Text.pack (anythingToString params)) + result <- run + Text.hPutStrLn stderr ("result: " <> Text.pack (anythingToString result)) + Text.hPutStrLn stderr "----------" + pure result + else run + where + run = Sqlite.query conn0 (coerce s) params queryListCol :: forall a b. (Sqlite.FromField b, Sqlite.ToRow a) => Connection -> Sql -> a -> IO [b] queryListCol conn s params = @@ -286,7 +338,7 @@ queryOneColCheck conn s params check = queryListRow_ :: Sqlite.FromRow a => Connection -> Sql -> IO [a] queryListRow_ conn@(Connection _ _ conn0) s = - Sqlite.query_ conn0 (coerce s) `catch` \(exception :: Sqlite.SQLError) -> + doQueryListRow_ `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException SqliteQueryExceptionInfo { connection = conn, @@ -294,6 +346,18 @@ queryListRow_ conn@(Connection _ _ conn0) s = params = Nothing, sql = s } + where + doQueryListRow_ = + if debugTraceQueries + then do + Text.hPutStrLn stderr ("query: " <> coerce s) + result <- run + Text.hPutStrLn stderr ("result: " <> Text.pack (anythingToString result)) + Text.hPutStrLn stderr "----------" + pure result + else run + where + run = Sqlite.query_ conn0 (coerce s) queryListCol_ :: forall a. Sqlite.FromField a => Connection -> Sql -> IO [a] queryListCol_ conn s = diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs b/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs index abf97225e3..f076d3eeca 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs @@ -21,6 +21,7 @@ where import Control.Concurrent (ThreadId, myThreadId) import Data.Typeable (cast) +import Data.Void (Void) import qualified Database.SQLite.Simple as Sqlite import Debug.RecoverRTTI (anythingToString) import Unison.Prelude @@ -56,7 +57,7 @@ instance Show SomeSqliteException where isCantOpenException :: SomeSqliteException -> Bool isCantOpenException (SomeSqliteException exception) = case cast exception of - Just SqliteConnectException{exception = Sqlite.SQLError Sqlite.ErrorCan'tOpen _ _} -> True + Just SqliteConnectException {exception = Sqlite.SQLError Sqlite.ErrorCan'tOpen _ _} -> True _ -> False ------------------------------------------------------------------------------------------------------------------------ @@ -149,3 +150,6 @@ instance Show SomeSqliteExceptionReason where class (Show e, Typeable e) => SqliteExceptionReason e instance SqliteExceptionReason Sqlite.SQLError + + +instance SqliteExceptionReason Void diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 786793f249..4b0eb79aad 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -37,8 +37,6 @@ module Unison.Codebase -- * Root branch getRootBranch, - GetRootBranchError (..), - isBlank, putRootBranch, rootBranchUpdates, @@ -91,8 +89,6 @@ module Unison.Codebase ) where -import Control.Error (rightMay) -import Control.Error.Util (hush) import Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set @@ -109,7 +105,6 @@ import qualified Unison.Codebase.GitError as GitError import Unison.Codebase.SyncMode (SyncMode) import Unison.Codebase.Type ( Codebase (..), - GetRootBranchError (..), GitError (GitCodebaseError), PushGitBranchOpts (..), SyncToDir, @@ -153,10 +148,8 @@ getBranchForHash codebase h = find rb = List.find headHashEq (nestedChildrenForDepth 3 rb) in do - rootBranch <- hush <$> getRootBranch codebase - case rootBranch of - Just rb -> maybe (getBranchForHashImpl codebase h) (pure . Just) (find rb) - Nothing -> getBranchForHashImpl codebase h + rootBranch <- getRootBranch codebase + maybe (getBranchForHashImpl codebase h) (pure . Just) (find rootBranch) -- | Get the lowest common ancestor of two branches, i.e. the most recent branch that is an ancestor of both branches. lca :: Monad m => Codebase m v a -> Branch m -> Branch m -> m (Maybe (Branch m)) @@ -325,12 +318,6 @@ isType c r = case r of Reference.Builtin {} -> pure $ Builtin.isBuiltinType r Reference.DerivedId r -> isJust <$> getTypeDeclaration c r --- | Return whether the root branch is empty. -isBlank :: Applicative m => Codebase m v a -> m Bool -isBlank codebase = do - root <- fromMaybe Branch.empty . rightMay <$> getRootBranch codebase - pure (root == Branch.empty) - -- * Git stuff -- | An optional preprocessing step to run on branches diff --git a/parser-typechecker/src/Unison/Codebase/Execute.hs b/parser-typechecker/src/Unison/Codebase/Execute.hs index 23766fdf5c..c0bdd0a6b1 100644 --- a/parser-typechecker/src/Unison/Codebase/Execute.hs +++ b/parser-typechecker/src/Unison/Codebase/Execute.hs @@ -35,14 +35,7 @@ execute -> IO () execute codebase runtime mainName = (`finally` Runtime.terminate runtime) $ do - root <- Codebase.getRootBranch codebase >>= \case - Right r -> pure r - Left Codebase.NoRootBranch -> - die "Couldn't identify a root namespace." - Left (Codebase.CouldntLoadRootBranch h) -> - die ("Couldn't load root branch " ++ show h) - Left (Codebase.CouldntParseRootBranch h) -> - die ("Couldn't parse root branch head " ++ show h) + root <- Codebase.getRootBranch codebase let parseNames = Names.makeAbsolute (Branch.toNames (Branch.head root)) loadTypeOfTerm = Codebase.getTypeOfTerm codebase let mainType = Runtime.mainType runtime diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 5b716e08af..8a0253a011 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -13,7 +13,7 @@ module Unison.Codebase.SqliteCodebase where import qualified Control.Concurrent -import Control.Monad (filterM, unless, when, (>=>)) +import Control.Monad (filterM, unless, when) import Control.Monad.Except (ExceptT (ExceptT), runExceptT, withExceptT) import qualified Control.Monad.Except as Except import Control.Monad.Extra (ifM, unlessM) @@ -48,7 +48,6 @@ import qualified U.Codebase.Reference as C.Reference import qualified U.Codebase.Referent as C.Referent import U.Codebase.Sqlite.DbId (ObjectId, SchemaVersion (SchemaVersion)) import qualified U.Codebase.Sqlite.ObjectType as OT -import U.Codebase.Sqlite.Operations (EDB) import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Q import qualified U.Codebase.Sqlite.Sync22 as Sync22 @@ -56,7 +55,6 @@ import qualified U.Codebase.Sync as Sync import qualified U.Codebase.WatchKind as WK import qualified U.Util.Cache as Cache import qualified U.Util.Hash as H2 -import qualified U.Util.Monoid as Monoid import U.Util.Timing (time) import qualified Unison.Builtin as Builtins import Unison.Codebase (Codebase, CodebasePath) @@ -93,7 +91,7 @@ import qualified Unison.Referent as Referent import Unison.ShortHash (ShortHash) import qualified Unison.ShortHash as SH import qualified Unison.ShortHash as ShortHash -import Unison.Sqlite (Connection) +import Unison.Sqlite (Connection, DB) import qualified Unison.Sqlite as Sqlite import qualified Unison.Sqlite.Transaction as Sqlite.Transaction import Unison.Symbol (Symbol) @@ -165,9 +163,7 @@ createCodebaseOrError' debugName path action = do withConnection (debugName ++ ".createSchema") path $ ( runReaderT do Q.createSchema - runExceptT (void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty) >>= \case - Left e -> error $ show e - Right () -> pure () + void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty ) fmap (Either.mapLeft CreateCodebaseUnknownSchemaVersion) (sqliteCodebase debugName path action) @@ -292,17 +288,18 @@ sqliteCodebase debugName root action = do declBuffer :: TVar (Map Hash DeclBufferEntry) <- newTVarIO Map.empty cycleLengthCache <- Cache.semispaceCache 8192 declTypeCache <- Cache.semispaceCache 2048 - let getTerm :: MonadIO m => Reference.Id -> m (Maybe (Term Symbol Ann)) + let getTerm :: MonadUnliftIO m => Reference.Id -> m (Maybe (Term Symbol Ann)) getTerm (Reference.Id h1@(Cv.hash1to2 -> h2) i _n) = runDB' conn do term2 <- Ops.loadTermByReference (C.Reference.Id h2 i) lift $ Cv.term2to1 h1 getCycleLen getDeclType term2 - getCycleLen :: EDB m => Hash -> m Reference.Size + getCycleLen :: (DB m, MonadUnliftIO m) => Hash -> m Reference.Size getCycleLen = Cache.apply cycleLengthCache \h -> - (Ops.getCycleLen . Cv.hash1to2) h + (Ops.getCycleLen . Cv.hash1to2) h `catch` \(e :: Sqlite.SomeSqliteException) -> + pure (error ("getCycleLen failed: " ++ show e)) - getDeclType :: EDB m => C.Reference.Reference -> m CT.ConstructorType + getDeclType :: DB m => C.Reference.Reference -> m CT.ConstructorType getDeclType = Cache.apply declTypeCache \case C.Reference.ReferenceBuiltin t -> let err = @@ -314,21 +311,21 @@ sqliteCodebase debugName root action = do Map.lookup (Reference.Builtin t) Builtins.builtinConstructorType C.Reference.ReferenceDerived i -> getDeclTypeById i - getDeclTypeById :: EDB m => C.Reference.Id -> m CT.ConstructorType + getDeclTypeById :: DB m => C.Reference.Id -> m CT.ConstructorType getDeclTypeById = fmap Cv.decltype2to1 . Ops.getDeclTypeByReference - getTypeOfTermImpl :: MonadIO m => Reference.Id -> m (Maybe (Type Symbol Ann)) + getTypeOfTermImpl :: MonadUnliftIO m => Reference.Id -> m (Maybe (Type Symbol Ann)) getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined getTypeOfTermImpl (Reference.Id (Cv.hash1to2 -> h2) i _n) = runDB' conn do type2 <- Ops.loadTypeOfTermByTermReference (C.Reference.Id h2 i) - Cv.ttype2to1 getCycleLen type2 + lift (Cv.ttype2to1 getCycleLen type2) - getTypeDeclaration :: MonadIO m => Reference.Id -> m (Maybe (Decl Symbol Ann)) + getTypeDeclaration :: MonadUnliftIO m => Reference.Id -> m (Maybe (Decl Symbol Ann)) getTypeDeclaration (Reference.Id h1@(Cv.hash1to2 -> h2) i _n) = runDB' conn do decl2 <- Ops.loadDeclByReference (C.Reference.Id h2 i) - Cv.decl2to1 h1 getCycleLen decl2 + lift (Cv.decl2to1 h1 getCycleLen decl2) putTerm :: MonadIO m => Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m () putTerm id tm tp | debug && trace (show "SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined @@ -390,7 +387,7 @@ sqliteCodebase debugName root action = do addBufferDependent dependent tv dependency = withBuffer tv dependency \be -> do putBuffer tv dependency be {beWaitingDependents = Set.insert dependent $ beWaitingDependents be} tryFlushBuffer :: - (EDB m, Show a) => + (DB m, Show a) => TVar (Map Hash (BufferEntry a)) -> (H2.Hash -> [a] -> m ()) -> (Hash -> m ()) -> @@ -425,7 +422,7 @@ sqliteCodebase debugName root action = do -- it's never even been added, so there's nothing to do. pure () - addTermComponentTypeIndex :: EDB m => ObjectId -> [Type Symbol Ann] -> m () + addTermComponentTypeIndex :: DB m => ObjectId -> [Type Symbol Ann] -> m () addTermComponentTypeIndex oId types = for_ (types `zip` [0..]) \(tp, i) -> do let self = C.Referent.RefId (C.Reference.Id oId i) typeForIndexing = Hashing.typeToReference tp @@ -433,7 +430,7 @@ sqliteCodebase debugName root action = do Ops.addTypeToIndexForTerm self (Cv.reference1to2 typeForIndexing) Ops.addTypeMentionsToIndexForTerm self (Set.map Cv.reference1to2 typeMentionsForIndexing) - addDeclComponentTypeIndex :: EDB m => ObjectId -> [[Type Symbol Ann]] -> m () + addDeclComponentTypeIndex :: DB m => ObjectId -> [[Type Symbol Ann]] -> m () addDeclComponentTypeIndex oId ctorss = for_ (ctorss `zip` [0..]) \(ctors, i) -> for_ (ctors `zip` [0..]) \(tp, j) -> do @@ -443,7 +440,7 @@ sqliteCodebase debugName root action = do Ops.addTypeToIndexForTerm self (Cv.reference1to2 typeForIndexing) Ops.addTypeMentionsToIndexForTerm self (Set.map Cv.reference1to2 typeMentionsForIndexing) - tryFlushTermBuffer :: EDB m => Hash -> m () + tryFlushTermBuffer :: DB m => Hash -> m () tryFlushTermBuffer h | debug && trace ("tryFlushTermBuffer " ++ show h) False = undefined tryFlushTermBuffer h = tryFlushBuffer @@ -456,7 +453,7 @@ sqliteCodebase debugName root action = do tryFlushTermBuffer h - tryFlushDeclBuffer :: EDB m => Hash -> m () + tryFlushDeclBuffer :: DB m => Hash -> m () tryFlushDeclBuffer h | debug && trace ("tryFlushDeclBuffer " ++ show h) False = undefined tryFlushDeclBuffer h = tryFlushBuffer @@ -491,7 +488,7 @@ sqliteCodebase debugName root action = do tryFlushDeclBuffer h ) - getRootBranch :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, Branch m)) -> m (Either Codebase1.GetRootBranchError (Branch m)) + getRootBranch :: MonadUnliftIO m => TVar (Maybe (Sqlite.DataVersion, Branch m)) -> m (Branch m) getRootBranch rootBranchCache = readTVarIO rootBranchCache >>= \case Nothing -> forceReload @@ -499,33 +496,21 @@ sqliteCodebase debugName root action = do -- check to see if root namespace hash has been externally modified -- and reload it if necessary v' <- Sqlite.Transaction.runTransaction conn Sqlite.getDataVersion - if v == v' then pure (Right b) else do + if v == v' then pure b else do newRootHash <- runDB conn Ops.loadRootCausalHash if Branch.headHash b == Cv.branchHash2to1 newRootHash - then pure (Right b) + then pure b else do traceM $ "database was externally modified (" ++ show v ++ " -> " ++ show v' ++ ")" forceReload where forceReload = time "Get root branch" do - b <- fmap (Either.mapLeft err) - . runExceptT - . flip runReaderT conn + b <- runDB conn . fmap (Branch.transform (runDB conn)) $ Cv.causalbranch2to1 getCycleLen getDeclType =<< Ops.loadRootCausal v <- Sqlite.Transaction.runTransaction conn Sqlite.getDataVersion - for_ b (atomically . writeTVar rootBranchCache . Just . (v,)) + atomically (writeTVar rootBranchCache (Just (v,b))) pure b - err :: Ops.Error -> Codebase1.GetRootBranchError - err = \case - Ops.DatabaseIntegrityError Q.NoNamespaceRoot -> - Codebase1.NoRootBranch - Ops.DecodeError (Ops.ErrBranch oId) _bytes _msg -> - Codebase1.CouldntParseRootBranch $ - "Couldn't decode " ++ show oId ++ ": " ++ _msg - Ops.ExpectedBranch ch _bh -> - Codebase1.CouldntLoadRootBranch $ Cv.causalHash2to1 ch - e -> error $ show e putRootBranch :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, Branch m)) -> Branch m -> m () putRootBranch rootBranchCache branch1 = do @@ -535,7 +520,7 @@ sqliteCodebase debugName root action = do . void . Ops.saveRootBranch . Cv.causalbranch1to2 - $ Branch.transform (lift . lift) branch1 + $ Branch.transform lift branch1 atomically $ modifyTVar rootBranchCache (fmap . second $ const branch1) rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.Hash)) @@ -579,7 +564,7 @@ sqliteCodebase debugName root action = do -- if this blows up on cromulent hashes, then switch from `hashToHashId` -- to one that returns Maybe. - getBranchForHash :: MonadIO m => Branch.Hash -> m (Maybe (Branch m)) + getBranchForHash :: MonadUnliftIO m => Branch.Hash -> m (Maybe (Branch m)) getBranchForHash h = runDB conn do Ops.loadCausalBranchByCausalHash (Cv.branchHash1to2 h) >>= \case Just b -> @@ -593,12 +578,12 @@ sqliteCodebase debugName root action = do isCausalHash :: MonadIO m => Branch.Hash -> m Bool isCausalHash = runDB conn . isCausalHash' - getPatch :: MonadIO m => Branch.EditHash -> m (Maybe Patch) + getPatch :: MonadUnliftIO m => Branch.EditHash -> m (Maybe Patch) getPatch h = - runDB conn . runMaybeT $ + runDB' conn $ MaybeT (Ops.primaryHashToMaybePatchObjectId (Cv.patchHash1to2 h)) >>= Ops.loadPatchById - >>= Cv.patch2to1 getCycleLen + >>= lift . Cv.patch2to1 getCycleLen putPatch :: MonadIO m => Branch.EditHash -> Patch -> m () putPatch h p = @@ -608,7 +593,7 @@ sqliteCodebase debugName root action = do patchExists :: MonadIO m => Branch.EditHash -> m Bool patchExists = runDB conn . patchExists' - dependentsImpl :: MonadIO m => Reference -> m (Set Reference.Id) + dependentsImpl :: MonadUnliftIO m => Reference -> m (Set Reference.Id) dependentsImpl r = runDB conn $ Set.traverse (Cv.referenceid2to1 getCycleLen) @@ -627,18 +612,18 @@ sqliteCodebase debugName root action = do initSchemaIfNotExist destRoot syncInternal syncProgress conn destConn $ Branch.transform lift b - watches :: MonadIO m => UF.WatchKind -> m [Reference.Id] + watches :: MonadUnliftIO m => UF.WatchKind -> m [Reference.Id] watches w = runDB conn $ Ops.listWatches (Cv.watchKind1to2 w) >>= traverse (Cv.referenceid2to1 getCycleLen) - getWatch :: MonadIO m => UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann)) + getWatch :: MonadUnliftIO m => UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann)) getWatch k r@(Reference.Id h _i _n) | elem k standardWatchKinds = runDB' conn $ Ops.loadWatch (Cv.watchKind1to2 k) (Cv.referenceid1to2 r) - >>= Cv.term2to1 h getCycleLen getDeclType + >>= lift . Cv.term2to1 h getCycleLen getDeclType getWatch _unknownKind _ = pure Nothing standardWatchKinds = [UF.RegularWatch, UF.TestWatch] @@ -682,13 +667,13 @@ sqliteCodebase debugName root action = do reflogPath :: CodebasePath -> FilePath reflogPath root = root "reflog" - termsOfTypeImpl :: MonadIO m => Reference -> m (Set Referent.Id) + termsOfTypeImpl :: MonadUnliftIO m => Reference -> m (Set Referent.Id) termsOfTypeImpl r = runDB conn $ Ops.termsHavingType (Cv.reference1to2 r) >>= Set.traverse (Cv.referentid2to1 getCycleLen getDeclType) - termsMentioningTypeImpl :: MonadIO m => Reference -> m (Set Referent.Id) + termsMentioningTypeImpl :: MonadUnliftIO m => Reference -> m (Set Referent.Id) termsMentioningTypeImpl r = runDB conn $ Ops.termsMentioningType (Cv.reference1to2 r) @@ -700,10 +685,10 @@ sqliteCodebase debugName root action = do branchHashLength :: Applicative m => m Int branchHashLength = pure 10 - defnReferencesByPrefix :: MonadIO m => OT.ObjectType -> ShortHash -> m (Set Reference.Id) + defnReferencesByPrefix :: MonadUnliftIO m => OT.ObjectType -> ShortHash -> m (Set Reference.Id) defnReferencesByPrefix _ (ShortHash.Builtin _) = pure mempty defnReferencesByPrefix ot (ShortHash.ShortHash prefix (fmap Cv.shortHashSuffix1to2 -> cycle) _cid) = - Monoid.fromMaybe <$> runDB' conn do + runDB conn do refs <- do Ops.componentReferencesByPrefix ot prefix cycle >>= traverse (C.Reference.idH Ops.loadHashByObjectId) @@ -711,13 +696,13 @@ sqliteCodebase debugName root action = do Set.fromList <$> traverse (Cv.referenceid2to1 getCycleLen) (Set.toList refs) - termReferencesByPrefix :: MonadIO m => ShortHash -> m (Set Reference.Id) + termReferencesByPrefix :: MonadUnliftIO m => ShortHash -> m (Set Reference.Id) termReferencesByPrefix = defnReferencesByPrefix OT.TermComponent - declReferencesByPrefix :: MonadIO m => ShortHash -> m (Set Reference.Id) + declReferencesByPrefix :: MonadUnliftIO m => ShortHash -> m (Set Reference.Id) declReferencesByPrefix = defnReferencesByPrefix OT.DeclComponent - referentsByPrefix :: MonadIO m => ShortHash -> m (Set Referent.Id) + referentsByPrefix :: MonadUnliftIO m => ShortHash -> m (Set Referent.Id) referentsByPrefix SH.Builtin {} = pure mempty referentsByPrefix (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to2 -> cycle) cid) = runDB conn do termReferents <- @@ -799,19 +784,19 @@ sqliteCodebase debugName root action = do v -> pure $ Left v -- well one or the other. :zany_face: the thinking being that they wouldn't hash-collide -termExists', declExists' :: MonadIO m => Hash -> ReaderT Connection (ExceptT Ops.Error m) Bool +termExists', declExists' :: MonadIO m => Hash -> ReaderT Connection m Bool termExists' = fmap isJust . Ops.primaryHashToMaybeObjectId . Cv.hash1to2 declExists' = termExists' -patchExists' :: MonadIO m => Branch.EditHash -> ReaderT Connection (ExceptT Ops.Error m) Bool +patchExists' :: MonadIO m => Branch.EditHash -> ReaderT Connection m Bool patchExists' h = fmap isJust $ Ops.primaryHashToMaybePatchObjectId (Cv.patchHash1to2 h) -putBranch' :: MonadIO m => Branch m -> ReaderT Connection (ExceptT Ops.Error m) () +putBranch' :: MonadIO m => Branch m -> ReaderT Connection m () putBranch' branch1 = void . Ops.saveBranch . Cv.causalbranch1to2 $ - Branch.transform (lift . lift) branch1 + Branch.transform lift branch1 -isCausalHash' :: MonadIO m => Branch.Hash -> ReaderT Connection (ExceptT Ops.Error m) Bool +isCausalHash' :: MonadIO m => Branch.Hash -> ReaderT Connection m Bool isCausalHash' (Causal.RawHash h) = Q.loadHashIdByHash (Cv.hash1to2 h) >>= \case Nothing -> pure False @@ -864,7 +849,7 @@ syncInternal progress srcConn destConn b = time "syncInternal" do do when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in dest db" let h2 = CausalHash . Cv.hash1to2 $ Causal.unRawHash h - lift (flip runReaderT srcConn (Q.loadCausalHashIdByCausalHash h2)) >>= \case + lift (runDB srcConn (Q.loadCausalHashIdByCausalHash h2)) >>= \case Just chId -> do when debugProcessBranches $ traceM $ " " ++ show b0 ++ " exists in source db, so delegating to direct sync" r $ Sync.sync' sync progress [Sync22.C chId] @@ -894,7 +879,7 @@ syncInternal progress srcConn destConn b = time "syncInternal" do processBranches @m sync progress (os ++ bs ++ b0 : rest) processBranches sync progress (O h : rest) = do when debugProcessBranches $ traceM $ "processBranches O " ++ take 10 (show h) - oId <- flip runReaderT srcConn (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId) + oId <- runDB srcConn (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId) r $ Sync.sync' sync progress [Sync22.O oId] processBranches sync progress rest sync <- se . r $ Sync22.sync22 @@ -903,7 +888,7 @@ syncInternal progress srcConn destConn b = time "syncInternal" do se $ time "SyncInternal.processBranches" $ processBranches sync progress' [B bHash (pure b)] testWatchRefs <- time "SyncInternal enumerate testWatches" $ lift . fmap concat $ for [WK.TestWatch] \wk -> - fmap (Sync22.W wk) <$> flip runReaderT srcConn (Q.loadWatchesByWatchKind wk) + fmap (Sync22.W wk) <$> runDB srcConn (Q.loadWatchesByWatchKind wk) se . r $ Sync.sync sync progress' testWatchRefs let onSuccess a = runDB destConn (Q.release "sync") *> pure a onFailure e = do @@ -914,13 +899,11 @@ syncInternal progress srcConn destConn b = time "syncInternal" do runDB srcConn $ Q.rollbackRelease "sync" -- (we don't write to the src anyway) either onFailure onSuccess result -runDB' :: MonadIO m => Connection -> MaybeT (ReaderT Connection (ExceptT Ops.Error m)) a -> m (Maybe a) +runDB' :: MonadIO m => Connection -> MaybeT (ReaderT Connection m) a -> m (Maybe a) runDB' conn = runDB conn . runMaybeT -runDB :: MonadIO m => Connection -> ReaderT Connection (ExceptT Ops.Error m) a -> m a -runDB conn = (runExceptT >=> err) . flip runReaderT conn - where - err = \case Left err -> error $ show err; Right a -> pure a +runDB :: MonadIO m => Connection -> ReaderT Connection m a -> m a +runDB = flip runReaderT data Entity m = B Branch.Hash (m (Branch m)) @@ -1035,15 +1018,7 @@ viewRemoteBranch' (repo, sbh, path) action = UnliftIO.try do -- try to load the requested branch from it branch <- time "Git fetch (sbh)" $ case sbh of -- no sub-branch was specified, so use the root. - Nothing -> - (time "Get remote root branch" $ Codebase1.getRootBranch codebase) >>= \case - -- this NoRootBranch case should probably be an error too. - Left Codebase1.NoRootBranch -> pure Branch.empty - Left (Codebase1.CouldntLoadRootBranch h) -> - throwIO . C.GitCodebaseError $ GitError.CouldntLoadRootBranch repo h - Left (Codebase1.CouldntParseRootBranch s) -> - throwIO . C.GitSqliteCodebaseError $ GitError.GitCouldntParseRootBranchHash repo s - Right b -> pure b + Nothing -> time "Get remote root branch" $ Codebase1.getRootBranch codebase -- load from a specific `ShortBranchHash` Just sbh -> do branchCompletions <- Codebase1.branchHashesByPrefix codebase sbh @@ -1084,10 +1059,10 @@ pushGitBranch srcConn branch repo (PushGitBranchOpts setRoot _syncMode) = runExc -- set up the cache dir remotePath <- time "Git fetch" $ withExceptT C.GitProtocolError $ pullBranch (writeToRead repo) ExceptT . withOpenOrCreateCodebaseConnection "push.dest" remotePath $ \destConn -> do - flip runReaderT destConn $ Q.savepoint "push" + runDB destConn $ Q.savepoint "push" flip State.execStateT emptySyncProgressState $ syncInternal syncProgress srcConn destConn (Branch.transform lift branch) - flip runReaderT destConn do + runDB destConn do result <- if setRoot then do let newRootHash = Branch.headHash branch @@ -1124,7 +1099,7 @@ pushGitBranch srcConn branch repo (PushGitBranchOpts setRoot _syncMode) = runExc void $ push remotePath repo where repoString = Text.unpack $ printWriteRepo repo - setRepoRoot :: Q.DB m => Branch.Hash -> m () + setRepoRoot :: DB m => Branch.Hash -> m () setRepoRoot h = do let h2 = Cv.causalHash1to2 h err = error $ "Called SqliteCodebase.setNamespaceRoot on unknown causal hash " ++ show h2 diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 3352fb4cdb..8e18744c20 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -7,7 +7,6 @@ module Unison.Codebase.Type CodebasePath, PushGitBranchOpts (..), GitError (..), - GetRootBranchError (..), SyncToDir, ) where @@ -63,7 +62,7 @@ data Codebase m v a = Codebase -- choose to delay the put until all of the type declaration's references are stored as well. putTypeDeclaration :: Reference.Id -> Decl v a -> m (), -- | Get the root branch. - getRootBranch :: m (Either GetRootBranchError (Branch m)), + getRootBranch :: m (Branch m), -- | Like 'putBranch', but also adjusts the root branch pointer afterwards. putRootBranch :: Branch m -> m (), rootBranchUpdates :: m (IO (), IO (Set Branch.Hash)), @@ -155,12 +154,6 @@ data PushGitBranchOpts = PushGitBranchOpts syncMode :: SyncMode } -data GetRootBranchError - = NoRootBranch - | CouldntParseRootBranch String - | CouldntLoadRootBranch Branch.Hash - deriving (Show) - data GitError = GitProtocolError GitProtocolError | GitCodebaseError (GitCodebaseError Branch.Hash) diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index 22478835b4..df963665c5 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -123,7 +123,6 @@ listEntryName = \case data BackendError = NoSuchNamespace Path.Absolute - | BadRootBranch Codebase.GetRootBranchError | CouldntExpandBranchHash ShortBranchHash | AmbiguousBranchHash ShortBranchHash (Set ShortBranchHash) | NoBranchForHash Branch.Hash @@ -197,10 +196,6 @@ loadReferentType codebase = \case "Don't know how to getTypeOfConstructor " ++ show r -getRootBranch :: Functor m => Codebase m v Ann -> Backend m (Branch m) -getRootBranch = - ExceptT . (first BadRootBranch <$>) . Codebase.getRootBranch - data TermEntry v a = TermEntry { termEntryReferent :: Referent, termEntryName :: HQ'.HQSegment, @@ -266,10 +261,10 @@ findShallow :: (Monad m, Var v) => Codebase m v Ann -> Path.Absolute - -> Backend m [ShallowListEntry v Ann] + -> m [ShallowListEntry v Ann] findShallow codebase path' = do let path = Path.unabsolute path' - root <- getRootBranch codebase + root <- Codebase.getRootBranch codebase let mayb = Branch.getAt path root case mayb of Nothing -> pure [] @@ -320,9 +315,9 @@ termListEntry -> Branch0 m -> Referent -> HQ'.HQSegment - -> Backend m (TermEntry v Ann) + -> m (TermEntry v Ann) termListEntry codebase b0 r n = do - ot <- lift $ loadReferentType codebase r + ot <- loadReferentType codebase r -- A term is a test if it has a link of type `IsTest`. let isTest = Metadata.hasMetadataWithType' r Decls.isTestRef $ Branch.deepTermMetadata b0 @@ -342,12 +337,12 @@ typeListEntry => Codebase m v Ann -> Reference -> HQ'.HQSegment - -> Backend m TypeEntry + -> m TypeEntry typeListEntry codebase r n = do -- The tag indicates whether the type is a data declaration or an ability. tag <- case Reference.toId r of Just r -> do - decl <- lift $ Codebase.getTypeDeclaration codebase r + decl <- Codebase.getTypeDeclaration codebase r pure $ case decl of Just (Left _) -> Ability _ -> Data @@ -361,10 +356,10 @@ typeDeclHeader => Codebase m v Ann -> PPE.PrettyPrintEnv -> Reference - -> Backend m (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) + -> m (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) typeDeclHeader code ppe r = case Reference.toId r of Just rid -> - (lift $ Codebase.getTypeDeclaration code rid) <&> \case + Codebase.getTypeDeclaration code rid <&> \case Nothing -> DisplayObject.MissingObject (Reference.toShortHash r) Just decl -> DisplayObject.UserObject $ @@ -405,9 +400,9 @@ findShallowInBranch :: (Monad m, Var v) => Codebase m v Ann -> Branch m - -> Backend m [ShallowListEntry v Ann] + -> m [ShallowListEntry v Ann] findShallowInBranch codebase b = do - hashLength <- lift $ Codebase.hashLength codebase + hashLength <- Codebase.hashLength codebase let hqTerm b0 ns r = let refs = Star3.lookupD1 ns . Branch._terms $ b0 in case length refs of @@ -710,24 +705,24 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod docNames hqs = fmap docify . nubOrd . join . map toList . Set.toList $ hqs where docify n = Name.joinDot n "doc" - selectDocs :: [Referent] -> Backend IO [Reference] + selectDocs :: [Referent] -> IO [Reference] selectDocs rs = do rts <- fmap join . for rs $ \case Referent.Ref r -> - maybe [] (pure . (r,)) <$> lift (Codebase.getTypeOfTerm codebase r) + maybe [] (pure . (r,)) <$> Codebase.getTypeOfTerm codebase r _ -> pure [] pure [ r | (r, t) <- rts, Typechecker.isSubtype t (Type.ref mempty DD.doc2Ref) ] -- rs0 can be empty or the term fetched, so when viewing a doc term -- you get both its source and its rendered form - docResults :: [Reference] -> [Name] -> Backend IO [(HashQualifiedName, UnisonHash, Doc.Doc)] + docResults :: [Reference] -> [Name] -> IO [(HashQualifiedName, UnisonHash, Doc.Doc)] docResults rs0 docs = do let refsFor n = NamesWithHistory.lookupHQTerm (HQ.NameOnly n) parseNames let rs = Set.unions (refsFor <$> docs) <> Set.fromList (Referent.Ref <$> rs0) -- lookup the type of each, make sure it's a doc docs <- selectDocs (toList rs) -- render all the docs - liftIO (traverse (renderDoc ppe width rt codebase) docs) + traverse (renderDoc ppe width rt codebase) docs mkTermDefinition :: ( Reference -> @@ -739,11 +734,11 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod mkTermDefinition r tm = do ts <- lift (Codebase.getTypeOfTerm codebase r) let bn = bestNameForTerm @v (PPE.suffixifiedPPE ppe) width (Referent.Ref r) - tag <- termEntryTag <$> termListEntry codebase + tag <- lift $ fmap termEntryTag $ termListEntry codebase (Branch.head branch) (Referent.Ref r) (HQ'.NameOnly (NameSegment bn)) - docs <- docResults [r] $ docNames (NamesWithHistory.termName hqLength (Referent.Ref r) printNames) + docs <- lift . docResults [r] $ docNames (NamesWithHistory.termName hqLength (Referent.Ref r) printNames) mk docs ts bn tag where mk _ Nothing _ _ = throwError $ MissingSignatureForTerm r @@ -767,7 +762,7 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod tag (bimap mungeSyntaxText mungeSyntaxText tp) docs - typeDefinitions <- Map.traverseWithKey mkTypeDefinition + typeDefinitions <- lift . Map.traverseWithKey mkTypeDefinition $ typesToSyntax suffixifyBindings width ppe types termDefinitions <- Map.traverseWithKey mkTermDefinition $ termsToSyntax suffixifyBindings width ppe terms @@ -896,7 +891,7 @@ bestNameForType ppe width = resolveBranchHash :: Monad m => Maybe Branch.Hash -> Codebase m v Ann -> Backend m (Branch m) resolveBranchHash h codebase = case h of - Nothing -> getRootBranch codebase + Nothing -> lift (Codebase.getRootBranch codebase) Just bhash -> do mayBranch <- lift $ Codebase.getBranchForHash codebase bhash mayBranch ?? NoBranchForHash bhash @@ -906,7 +901,7 @@ resolveRootBranchHash :: Monad m => Maybe ShortBranchHash -> Codebase m v Ann -> Backend m (Branch m) resolveRootBranchHash mayRoot codebase = case mayRoot of Nothing -> - getRootBranch codebase + lift (Codebase.getRootBranch codebase) Just sbh -> do h <- expandShortBranchHash codebase sbh resolveBranchHash (Just h) codebase diff --git a/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs b/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs index 8fa3984b4e..3f33ea05df 100644 --- a/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs +++ b/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs @@ -152,7 +152,7 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query = take (fromMaybe 10 limit) $ Backend.fuzzyFind rel branch (fromMaybe "" query) -- Use AllNames to render source ppe = Backend.basicSuffixifiedNames hashLength branch (Backend.AllNames rel) - join <$> traverse (loadEntry root (Just rel) ppe b0) alignments + liftIO (join <$> traverse (loadEntry root (Just rel) ppe b0) alignments) errFromEither backendError ea where loadEntry _root _rel ppe b0 (a, HQ'.NameOnly . NameSegment -> n, refs) = diff --git a/parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs b/parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs index 50d4245eec..48a165b461 100644 --- a/parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs +++ b/parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs @@ -42,7 +42,6 @@ import qualified Unison.Server.Backend as Backend import Unison.Server.Errors ( backendError, badNamespace, - rootBranchError, ) import Unison.Server.Types ( APIGet, @@ -170,11 +169,7 @@ serve tryAuth codebase mayRoot mayRelativeTo mayNamespaceName = parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p - doBackend a = do - ea <- liftIO $ runExceptT a - errFromEither backendError ea - - findShallow branch = doBackend $ Backend.findShallowInBranch codebase branch + findShallow branch = liftIO $ Backend.findShallowInBranch codebase branch makeNamespaceListing ppe fqn hash entries = pure . NamespaceListing fqn hash $ fmap @@ -184,9 +179,7 @@ serve tryAuth codebase mayRoot mayRelativeTo mayNamespaceName = -- Lookup paths, root and listing and construct response namespaceListing = do root <- case mayRoot of - Nothing -> do - gotRoot <- liftIO $ Codebase.getRootBranch codebase - errFromEither rootBranchError gotRoot + Nothing -> liftIO $ Codebase.getRootBranch codebase Just sbh -> do ea <- liftIO . runExceptT $ do h <- Backend.expandShortBranchHash codebase sbh diff --git a/parser-typechecker/src/Unison/Server/Endpoints/Projects.hs b/parser-typechecker/src/Unison/Server/Endpoints/Projects.hs index 43af62af33..ab6394abf5 100644 --- a/parser-typechecker/src/Unison/Server/Endpoints/Projects.hs +++ b/parser-typechecker/src/Unison/Server/Endpoints/Projects.hs @@ -8,7 +8,7 @@ module Unison.Server.Endpoints.Projects where -import Control.Error (ExceptT, runExceptT) +import Control.Error (runExceptT) import Control.Error.Util ((??)) import Data.Aeson import Data.OpenApi (ToSchema) @@ -27,7 +27,7 @@ import qualified Unison.NameSegment as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.Server.Backend as Backend -import Unison.Server.Errors (backendError, badNamespace, rootBranchError) +import Unison.Server.Errors (backendError, badNamespace) import Unison.Server.Types (APIGet, APIHeaders, UnisonHash, addHeaders) import Unison.Util.Monoid (foldMapM) import Unison.Var (Var) @@ -100,9 +100,8 @@ serve tryAuth codebase mayRoot = addHeaders <$> (tryAuth *> projects) projects :: Handler [ProjectListing] projects = do root <- case mayRoot of - Nothing -> do - gotRoot <- liftIO $ Codebase.getRootBranch codebase - errFromEither rootBranchError gotRoot + Nothing -> + liftIO $ Codebase.getRootBranch codebase Just sbh -> do ea <- liftIO . runExceptT $ do h <- Backend.expandShortBranchHash codebase sbh @@ -127,7 +126,7 @@ serve tryAuth codebase mayRoot = addHeaders <$> (tryAuth *> projects) findShallow :: Branch.Branch IO -> Handler [Backend.ShallowListEntry v Ann] findShallow branch = - doBackend $ Backend.findShallowInBranch codebase branch + liftIO $ Backend.findShallowInBranch codebase branch parsePath :: String -> Handler Path.Path' parsePath p = @@ -136,8 +135,3 @@ serve tryAuth codebase mayRoot = addHeaders <$> (tryAuth *> projects) errFromEither :: (a -> ServerError) -> Either a a1 -> Handler a1 errFromEither f = either (throwError . f) pure - - doBackend :: ExceptT Backend.BackendError IO b -> Handler b - doBackend a = do - ea <- liftIO $ runExceptT a - errFromEither backendError ea diff --git a/parser-typechecker/src/Unison/Server/Errors.hs b/parser-typechecker/src/Unison/Server/Errors.hs index 0e3fe3058a..0f52b30efe 100644 --- a/parser-typechecker/src/Unison/Server/Errors.hs +++ b/parser-typechecker/src/Unison/Server/Errors.hs @@ -11,7 +11,6 @@ import qualified Data.Set as Set import qualified Data.Text.Lazy as Text import qualified Data.Text.Lazy.Encoding as Text import Servant (ServerError (..), err400, err404, err500, err409) -import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.ShortBranchHash as SBH import qualified Unison.Reference as Reference @@ -35,7 +34,6 @@ backendError :: Backend.BackendError -> ServerError backendError = \case Backend.NoSuchNamespace n -> noSuchNamespace . Path.toText $ Path.unabsolute n - Backend.BadRootBranch e -> rootBranchError e Backend.NoBranchForHash h -> noSuchNamespace . Text.toStrict . Text.pack $ show h Backend.CouldntLoadBranch h -> @@ -46,16 +44,6 @@ backendError = \case ambiguousNamespace (SBH.toText sbh) (Set.map SBH.toText hashes) Backend.MissingSignatureForTerm r -> missingSigForTerm $ Reference.toText r -rootBranchError :: Codebase.GetRootBranchError -> ServerError -rootBranchError rbe = err500 - { errBody = case rbe of - Codebase.NoRootBranch -> "Couldn't identify a root namespace." - Codebase.CouldntLoadRootBranch h -> - "Couldn't load root branch " <> mungeShow h - Codebase.CouldntParseRootBranch h -> - "Couldn't parse root branch head " <> mungeShow h - } - badNamespace :: String -> String -> ServerError badNamespace err namespace = err400 { errBody = "Malformed namespace: " diff --git a/unison-cli/src/Unison/Codebase/Editor/Command.hs b/unison-cli/src/Unison/Codebase/Editor/Command.hs index 42029a7c4f..2369784a66 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Command.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Command.hs @@ -22,7 +22,6 @@ import Control.Lens (_5,view) -- TODO: Don't import backend, but move dependencies to own modules import Unison.Server.Backend ( DefinitionResults , ShallowListEntry - , BackendError , IncludeCycles ) import Data.Configurator.Types ( Configured ) @@ -120,7 +119,7 @@ data Command FindShallow :: Path.Absolute - -> Command m i v (Either BackendError [ShallowListEntry v Ann]) + -> Command m i v [ShallowListEntry v Ann] ConfigLookup :: Configured a => Text -> Command m i v (Maybe a) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs index 4e4301f682..61c7d38b21 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs @@ -11,7 +11,6 @@ module Unison.Codebase.Editor.HandleCommand where import Unison.Prelude -import Control.Monad.Except (runExceptT) import qualified Crypto.Random as Random import qualified Data.Configurator as Config import Data.Configurator.Types (Config) @@ -135,7 +134,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour TypecheckFile file ambient -> lift $ typecheck' ambient codebase file Evaluate ppe unisonFile -> lift $ evalUnisonFile ppe unisonFile [] Evaluate1 ppe useCache term -> lift $ eval1 ppe useCache term - LoadLocalRootBranch -> lift $ either (const Branch.empty) id <$> Codebase.getRootBranch codebase + LoadLocalRootBranch -> lift $ Codebase.getRootBranch codebase LoadLocalBranch h -> lift $ fromMaybe Branch.empty <$> Codebase.getBranchForHash codebase h Merge mode b1 b2 -> lift $ Branch.merge'' (Codebase.lca codebase) mode b1 b2 @@ -203,7 +202,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour GetDefinitionsBySuffixes mayPath branch includeCycles query -> do let namingScope = Backend.AllNames $ fromMaybe Path.empty mayPath lift (Backend.definitionsBySuffixes namingScope branch codebase includeCycles query) - FindShallow path -> lift . runExceptT $ Backend.findShallow codebase path + FindShallow path -> liftIO $ Backend.findShallow codebase path MakeStandalone ppe ref out -> lift $ do let cl = Codebase.toCodeLookup codebase Runtime.compileTo rt (() <$ cl) ppe ref (out <> ".uc") diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 7e9279cd0b..bc9bf58975 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1039,27 +1039,24 @@ loop = do sbhLength root' (Backend.AllNames $ Path.fromPath' pathArg) - res <- eval $ FindShallow pathArgAbs - case res of - Left e -> handleBackendError e - Right entries -> do - -- caching the result as an absolute path, for easier jumping around - LoopState.numberedArgs .= fmap entryToHQString entries - respond $ ListShallow ppe entries + entries <- eval $ FindShallow pathArgAbs + -- caching the result as an absolute path, for easier jumping around + LoopState.numberedArgs .= fmap entryToHQString entries + respond $ ListShallow ppe entries + where + entryToHQString :: ShallowListEntry v Ann -> String + entryToHQString e = + fixup $ case e of + ShallowTypeEntry (TypeEntry _ hq _) -> HQ'.toString hq + ShallowTermEntry (TermEntry _ hq _ _) -> HQ'.toString hq + ShallowBranchEntry ns _ _ -> NameSegment.toString ns + ShallowPatchEntry ns -> NameSegment.toString ns where - entryToHQString :: ShallowListEntry v Ann -> String - entryToHQString e = - fixup $ case e of - ShallowTypeEntry (TypeEntry _ hq _) -> HQ'.toString hq - ShallowTermEntry (TermEntry _ hq _ _) -> HQ'.toString hq - ShallowBranchEntry ns _ _ -> NameSegment.toString ns - ShallowPatchEntry ns -> NameSegment.toString ns - where - fixup s = case pathArgStr of - "" -> s - p | last p == '.' -> p ++ s - p -> p ++ "." ++ s - pathArgStr = show pathArg + fixup s = case pathArgStr of + "" -> s + p | last p == '.' -> p ++ s + p -> p ++ "." ++ s + pathArgStr = show pathArg SearchByNameI isVerbose _showAll ws -> do let prettyPrintNames = basicPrettyPrintNames unlessError do @@ -2399,22 +2396,6 @@ searchBranchScored names0 score queries = Just score -> Set.singleton (Just score, result) Nothing -> mempty -handleBackendError :: Backend.BackendError -> Action m i v () -handleBackendError = \case - Backend.NoSuchNamespace path -> - respond . BranchNotFound $ Path.absoluteToPath' path - Backend.BadRootBranch e -> respond $ BadRootBranch e - Backend.NoBranchForHash h -> do - sbhLength <- eval BranchHashLength - respond . NoBranchWithHash $ SBH.fromHash sbhLength h - Backend.CouldntLoadBranch h -> do - respond . CouldntLoadBranch $ h - Backend.CouldntExpandBranchHash sbh -> respond $ NoBranchWithHash sbh - Backend.AmbiguousBranchHash h hashes -> - respond $ BranchHashAmbiguous h hashes - Backend.MissingSignatureForTerm r -> - respond $ TermMissingType r - respond :: MonadCommand n m i v => Output v -> n () respond output = eval $ Notify output diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 94ecbf89a9..e3efd1c370 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -18,7 +18,6 @@ module Unison.Codebase.Editor.Output where import qualified Data.Set as Set -import Unison.Codebase (GetRootBranchError) import qualified Unison.Codebase.Branch as Branch import Unison.Codebase.Editor.DisplayObject (DisplayObject) import Unison.Codebase.Editor.Input @@ -231,7 +230,6 @@ data Output v | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] | BadName String | DefaultMetadataNotification - | BadRootBranch GetRootBranchError | CouldntLoadBranch Branch.Hash | HelpMessage Input.InputPattern | NamespaceEmpty (NonEmpty AbsBranchId) @@ -271,7 +269,6 @@ isFailure :: Ord v => Output v -> Bool isFailure o = case o of Success {} -> False PrintMessage {} -> False - BadRootBranch {} -> True CouldntLoadBranch {} -> True NoUnisonFile {} -> True InvalidSourceName {} -> True diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 9a591bb080..3edbe8f5bb 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -58,7 +58,6 @@ import qualified Unison.Util.Pretty as P import qualified Unison.Util.TQueue as Q import qualified Unison.Codebase.Editor.Output as Output import Control.Lens (view) -import Control.Error (rightMay) import qualified Unison.Codebase.Editor.HandleInput as HandleInput -- | Render transcript errors at a width of 65 chars. @@ -130,7 +129,7 @@ run version dir configFile stanzas codebase = do "Running the provided transcript file...", "" ] - root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase + root <- Codebase.getRootBranch codebase do pathRef <- newIORef initialPath rootBranchRef <- newIORef root diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 5672d7a211..8a437ee6a3 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -44,7 +44,6 @@ import qualified Unison.Util.Pretty as P import qualified Unison.Util.TQueue as Q import qualified Unison.CommandLine.Welcome as Welcome import Control.Lens (view) -import Control.Error (rightMay) import UnliftIO (catchSyncOrAsync, throwIO, withException) import System.IO (hPutStrLn, stderr) import Unison.Codebase.Editor.Output (Output) @@ -112,7 +111,7 @@ main -> Maybe Server.BaseUrl -> IO () main dir welcome initialPath (config, cancelConfig) initialInputs runtime codebase serverBaseUrl = do - root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase + root <- Codebase.getRootBranch codebase eventQueue <- Q.newIO welcomeEvents <-Welcome.run codebase welcome do diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index cc33da27cc..b315a9eb51 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -30,7 +30,6 @@ import System.Directory import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) import qualified Unison.ABT as ABT import qualified Unison.Builtin.Decls as DD -import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Causal as Causal import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject)) import qualified Unison.Codebase.Editor.Input as Input @@ -355,21 +354,6 @@ notifyUser dir o = case o of Success -> pure $ P.bold "Done." PrintMessage pretty -> do pure pretty - BadRootBranch e -> case e of - Codebase.NoRootBranch -> - pure . P.fatalCallout $ "I couldn't find the codebase root!" - Codebase.CouldntParseRootBranch s -> - pure - . P.warnCallout - $ "I coulnd't parse a valid namespace from " - <> P.string (show s) - <> "." - Codebase.CouldntLoadRootBranch h -> - pure - . P.warnCallout - $ "I couldn't find a root namespace with the hash " - <> prettySBH (SBH.fullFromHash h) - <> "." CouldntLoadBranch h -> pure . P.fatalCallout . P.wrap $ "I have reason to believe that" diff --git a/unison-cli/src/Unison/CommandLine/Welcome.hs b/unison-cli/src/Unison/CommandLine/Welcome.hs index 5b58cc0062..61456a7ea8 100644 --- a/unison-cli/src/Unison/CommandLine/Welcome.hs +++ b/unison-cli/src/Unison/CommandLine/Welcome.hs @@ -95,7 +95,7 @@ toInput pretty = determineFirstStep :: DownloadBase -> Codebase IO v a -> IO Onboarding determineFirstStep downloadBase codebase = do - isBlankCodebase <- Codebase.isBlank codebase + isBlankCodebase <- pure True -- FIXME case downloadBase of DownloadBase ns | isBlankCodebase -> pure $ DownloadingBase ns From e8c1295ffe3406a06e5ff18298a50f7b8ea478ef Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simon=20H=C3=B8jberg?= Date: Thu, 3 Mar 2022 14:34:13 -0500 Subject: [PATCH 007/529] Remove the access control header to limit CORS --- parser-typechecker/src/Unison/Server/Types.hs | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/Server/Types.hs b/parser-typechecker/src/Unison/Server/Types.hs index 87a5240f1e..f89bac6bcf 100644 --- a/parser-typechecker/src/Unison/Server/Types.hs +++ b/parser-typechecker/src/Unison/Server/Types.hs @@ -50,8 +50,7 @@ import Unison.Util.Pretty (Width (..)) type APIHeaders x = Headers - '[ Header "Access-Control-Allow-Origin" String, - Header "Cache-Control" String + '[ Header "Cache-Control" String ] x @@ -261,7 +260,7 @@ mayDefaultWidth :: Maybe Width -> Width mayDefaultWidth = fromMaybe defaultWidth addHeaders :: v -> APIHeaders v -addHeaders = addHeader "*" . addHeader "public" +addHeaders = addHeader "public" branchToUnisonHash :: Branch.Branch m -> UnisonHash branchToUnisonHash b = From b39919d955880439b079d6faee25f53d7e3f833d Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 8 Mar 2022 11:58:30 -0500 Subject: [PATCH 008/529] add transcript demonstrating an update bug --- .../update-test-to-non-test.md | 18 ++++++ .../update-test-to-non-test.output.md | 62 +++++++++++++++++++ 2 files changed, 80 insertions(+) create mode 100644 unison-src/transcripts-using-base/update-test-to-non-test.md create mode 100644 unison-src/transcripts-using-base/update-test-to-non-test.output.md diff --git a/unison-src/transcripts-using-base/update-test-to-non-test.md b/unison-src/transcripts-using-base/update-test-to-non-test.md new file mode 100644 index 0000000000..d6eb7fbc93 --- /dev/null +++ b/unison-src/transcripts-using-base/update-test-to-non-test.md @@ -0,0 +1,18 @@ +When updating a term from a test to a non-test, we don't delete its metadata that indicates it's a test. + +```unison +test> foo = [] +``` + +```ucm +.> add +``` + +```unison +foo = 1 +``` + +```ucm +.> update +.> links foo +``` diff --git a/unison-src/transcripts-using-base/update-test-to-non-test.output.md b/unison-src/transcripts-using-base/update-test-to-non-test.output.md new file mode 100644 index 0000000000..d997e74660 --- /dev/null +++ b/unison-src/transcripts-using-base/update-test-to-non-test.output.md @@ -0,0 +1,62 @@ +When updating a term from a test to a non-test, we don't delete its metadata that indicates it's a test. + +```unison +test> foo = [] +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + foo : [Result] + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | test> foo = [] + + +``` +```ucm +.> add + + โŸ I've added these definitions: + + foo : [Result] + +``` +```unison +foo = 1 +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These names already exist. You can `update` them to your + new definition: + + foo : Nat + +``` +```ucm +.> update + + โŸ I've updated these names to your new definition: + + foo : Nat + +.> links foo + + 1. builtin.metadata.isTest : IsTest + + Tip: Try using `display 1` to display the first result or + `view 1` to view its source. + +``` From 97cce8d23147df30b0f80ae745968db09f4e1a44 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 8 Mar 2022 15:46:35 -0600 Subject: [PATCH 009/529] Disable windows release until we can fix it properly. We'll use a manual release for now. --- .github/workflows/release.yaml | 57 ++++++++++++++++------------------ 1 file changed, 27 insertions(+), 30 deletions(-) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 850972460f..2a1efe31ba 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -12,7 +12,7 @@ jobs: needs: - build_linux - build_macos - - build_windows + # - build_windows steps: - uses: actions/checkout@v2 @@ -101,32 +101,29 @@ jobs: name: build-macos path: ucm-macos.tar.gz - build_windows: - name: "build_windows" - runs-on: windows-2019 - - steps: - - uses: actions/checkout@v2 - - name: install stack - run: | - curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz | tar -xz - echo "$HOME/stack-2.5.1-osx-x86_64/" >> $GITHUB_PATH - - - name: build - run: stack --no-terminal build --flag unison-parser-typechecker:optimized - - - name: fetch latest codebase-ui and package with ucm - run: | - mkdir -p /tmp/ucm/ui - UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison - cp $UCM /tmp/ucm/ucm - wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip - unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip - tar -c -z -f ucm-windows.tar.gz -C /tmp/ucm . - - - name: Upload windows artifact - uses: actions/upload-artifact@v2 - with: - if-no-files-found: error - name: build-windows - path: ucm-windows.tar.gz + # build_windows: + # name: "build_windows" + # runs-on: windows-2019 + + # steps: + # - uses: actions/checkout@v2 + # - name: build + # run: stack --no-terminal build --flag unison-parser-typechecker:optimized + + # - name: fetch latest codebase-ui and package with ucm + # # Powershell + # run: | + # mkdir -p tmp\ui + # mkdir -p release\ui + # $UCM = stack exec -- where unison + # cp $UCM .\release\ucm.exe + # Invoke-WebRequest -Uri https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip -OutFile tmp\unisonLocal.zip + # Expand-Archive -Path tmp\unisonLocal.zip -DestinationPath release\ui + # Compress-Archive -Path .\release\* -DestinationPath ucm-windows.zip + + # - name: Upload windows artifact + # uses: actions/upload-artifact@v2 + # with: + # if-no-files-found: error + # name: build-windows + # path: ucm-windows.zip From ab9e33b7ceb3aa4a59e74f5bec6bb6978be0f95e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 9 Mar 2022 11:01:42 -0500 Subject: [PATCH 010/529] indicate the transcript shows a bug --- unison-src/transcripts-using-base/update-test-to-non-test.md | 2 +- .../transcripts-using-base/update-test-to-non-test.output.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-src/transcripts-using-base/update-test-to-non-test.md b/unison-src/transcripts-using-base/update-test-to-non-test.md index d6eb7fbc93..57972b36b2 100644 --- a/unison-src/transcripts-using-base/update-test-to-non-test.md +++ b/unison-src/transcripts-using-base/update-test-to-non-test.md @@ -1,4 +1,4 @@ -When updating a term from a test to a non-test, we don't delete its metadata that indicates it's a test. +When updating a term from a test to a non-test, we don't delete its metadata that indicates it's a test. This is a bug. ```unison test> foo = [] diff --git a/unison-src/transcripts-using-base/update-test-to-non-test.output.md b/unison-src/transcripts-using-base/update-test-to-non-test.output.md index d997e74660..65204c6667 100644 --- a/unison-src/transcripts-using-base/update-test-to-non-test.output.md +++ b/unison-src/transcripts-using-base/update-test-to-non-test.output.md @@ -1,4 +1,4 @@ -When updating a term from a test to a non-test, we don't delete its metadata that indicates it's a test. +When updating a term from a test to a non-test, we don't delete its metadata that indicates it's a test. This is a bug. ```unison test> foo = [] From 763e0ec834e952f55fdda81770bf91878d342171 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 9 Mar 2022 11:14:22 -0600 Subject: [PATCH 011/529] Split off pretty-printer package --- .github/workflows/release.yaml | 170 ++- lib/unison-pretty-printer/LICENSE | 19 + lib/unison-pretty-printer/package.yaml | 72 + .../prettyprintdemo/Main.hs | 0 .../src/Unison/Lexer/Pos.hs | 0 .../src/Unison/PrettyTerminal.hs | 0 .../src/Unison/Util/AnnotatedText.hs | 0 .../src/Unison/Util/ColorText.hs | 0 .../src/Unison/Util/Less.hs | 0 .../src/Unison/Util/Pretty.hs | 1154 +++++++++++++++++ .../src/Unison/Util/Range.hs | 0 .../src/Unison/Util/SyntaxText.hs | 0 lib/unison-pretty-printer/tests/Suite.hs | 83 ++ .../tests/Unison/Test/Pretty.hs | 33 + .../tests/Unison/Test/Range.hs | 0 .../unison-pretty-printer.cabal | 150 +++ parser-typechecker/package.yaml | 9 - .../unison-parser-typechecker.cabal | 45 - stack.yaml | 1 + 19 files changed, 1626 insertions(+), 110 deletions(-) create mode 100644 lib/unison-pretty-printer/LICENSE create mode 100644 lib/unison-pretty-printer/package.yaml rename {parser-typechecker => lib/unison-pretty-printer}/prettyprintdemo/Main.hs (100%) rename {parser-typechecker => lib/unison-pretty-printer}/src/Unison/Lexer/Pos.hs (100%) rename {parser-typechecker => lib/unison-pretty-printer}/src/Unison/PrettyTerminal.hs (100%) rename {parser-typechecker => lib/unison-pretty-printer}/src/Unison/Util/AnnotatedText.hs (100%) rename {parser-typechecker => lib/unison-pretty-printer}/src/Unison/Util/ColorText.hs (100%) rename {parser-typechecker => lib/unison-pretty-printer}/src/Unison/Util/Less.hs (100%) create mode 100644 lib/unison-pretty-printer/src/Unison/Util/Pretty.hs rename {parser-typechecker => lib/unison-pretty-printer}/src/Unison/Util/Range.hs (100%) rename {parser-typechecker => lib/unison-pretty-printer}/src/Unison/Util/SyntaxText.hs (100%) create mode 100644 lib/unison-pretty-printer/tests/Suite.hs create mode 100644 lib/unison-pretty-printer/tests/Unison/Test/Pretty.hs rename {parser-typechecker => lib/unison-pretty-printer}/tests/Unison/Test/Range.hs (100%) create mode 100644 lib/unison-pretty-printer/unison-pretty-printer.cabal diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 850972460f..7a86976fef 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -3,7 +3,7 @@ name: "release" on: push: tags: - - "release/*" + - "test-release/*" jobs: release: @@ -35,42 +35,45 @@ jobs: env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} with: - files: /tmp/ucm/**/*.tar.gz - - build_linux: - - name: "build_linux" - runs-on: ubuntu-18.04 - - steps: - - uses: actions/checkout@v2 - - name: install stack - run: | - curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz | tar -xz - echo "$HOME/stack-2.5.1-linux-x86_64/" >> $GITHUB_PATH - - - name: build - run: stack --no-terminal build --flag unison-parser-typechecker:optimized - - - name: fetch latest codebase-ui and package with ucm - run: | - mkdir -p /tmp/ucm/ui - UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison - cp $UCM /tmp/ucm/ucm - wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip - unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip - tar -c -z -f ucm-linux.tar.gz -C /tmp/ucm . - - - name: Upload linux artifact - uses: actions/upload-artifact@v2 - with: - if-no-files-found: error - name: build-linux - path: ucm-linux.tar.gz - - build_macos: - name: "build_macos" - runs-on: macos-10.15 + files: | + /tmp/ucm/**/*.tar.gz + /tmp/ucm/**/*.zip + + # build_linux: + + # name: "build_linux" + # runs-on: ubuntu-18.04 + + # steps: + # - uses: actions/checkout@v2 + # - name: install stack + # run: | + # curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz | tar -xz + # echo "$HOME/stack-2.5.1-linux-x86_64/" >> $GITHUB_PATH + + # - name: build + # run: stack --no-terminal build --flag unison-parser-typechecker:optimized + + # - name: fetch latest codebase-ui and package with ucm + # run: | + # mkdir -p /tmp/ucm/ui + # UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison + # cp $UCM /tmp/ucm/ucm + # wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip + # unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip + # tar -c -z -f ucm-linux.tar.gz -C /tmp/ucm . + + # - name: Upload linux artifact + # uses: actions/upload-artifact@v2 + # with: + # if-no-files-found: error + # name: build-linux + # path: ucm-linux.tar.gz + +<<<<<<< Updated upstream + build_windows: + name: "build_windows" + runs-on: windows-2019 steps: - uses: actions/checkout@v2 @@ -79,9 +82,6 @@ jobs: curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz | tar -xz echo "$HOME/stack-2.5.1-osx-x86_64/" >> $GITHUB_PATH - - name: remove ~/.stack/setup-exe-cache on macOS - run: rm -rf ~/.stack/setup-exe-cache - - name: build run: stack --no-terminal build --flag unison-parser-typechecker:optimized @@ -92,14 +92,74 @@ jobs: cp $UCM /tmp/ucm/ucm wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip - tar -c -z -f ucm-macos.tar.gz -C /tmp/ucm . + tar -c -z -f ucm-windows.tar.gz -C /tmp/ucm . - - name: Upload macos artifact + - name: Upload windows artifact uses: actions/upload-artifact@v2 with: if-no-files-found: error - name: build-macos - path: ucm-macos.tar.gz + name: build-windows + path: ucm-windows.tar.gz +||||||| constructed merge base + # build_windows: + # name: "build_windows" + # runs-on: windows-2019 + + # steps: + # - uses: actions/checkout@v2 + # - name: build + # run: stack --no-terminal build --flag unison-parser-typechecker:optimized + + # - name: fetch latest codebase-ui and package with ucm + # # Powershell + # run: | + # mkdir -p tmp\ui + # mkdir -p release\ui + # $UCM = stack exec -- where unison + # cp $UCM .\release\ucm.exe + # Invoke-WebRequest -Uri https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip -OutFile tmp\unisonLocal.zip + # Expand-Archive -Path tmp\unisonLocal.zip -DestinationPath release\ui + # Compress-Archive -Path .\release\* -DestinationPath ucm-windows.zip + + # - name: Upload windows artifact + # uses: actions/upload-artifact@v2 + # with: + # if-no-files-found: error + # name: build-windows + # path: ucm-windows.zip +======= + # build_macos: + # name: "build_macos" + # runs-on: macos-10.15 + + # steps: + # - uses: actions/checkout@v2 + # - name: install stack + # run: | + # curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz | tar -xz + # echo "$HOME/stack-2.5.1-osx-x86_64/" >> $GITHUB_PATH + + # - name: remove ~/.stack/setup-exe-cache on macOS + # run: rm -rf ~/.stack/setup-exe-cache + + # - name: build + # run: stack --no-terminal build --flag unison-parser-typechecker:optimized + + # - name: fetch latest codebase-ui and package with ucm + # run: | + # mkdir -p /tmp/ucm/ui + # UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison + # cp $UCM /tmp/ucm/ucm + # wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip + # unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip + # tar -c -z -f ucm-macos.tar.gz -C /tmp/ucm . + + # - name: Upload macos artifact + # uses: actions/upload-artifact@v2 + # with: + # if-no-files-found: error + # name: build-macos + # path: ucm-macos.tar.gz build_windows: name: "build_windows" @@ -107,26 +167,24 @@ jobs: steps: - uses: actions/checkout@v2 - - name: install stack - run: | - curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz | tar -xz - echo "$HOME/stack-2.5.1-osx-x86_64/" >> $GITHUB_PATH - - name: build run: stack --no-terminal build --flag unison-parser-typechecker:optimized - name: fetch latest codebase-ui and package with ucm + # Powershell run: | - mkdir -p /tmp/ucm/ui - UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison - cp $UCM /tmp/ucm/ucm - wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip - unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip - tar -c -z -f ucm-windows.tar.gz -C /tmp/ucm . + mkdir -p tmp\ui + mkdir -p release\ui + $UCM = stack exec -- where unison + cp $UCM .\release\ucm.exe + Invoke-WebRequest -Uri https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip -OutFile tmp\unisonLocal.zip + Expand-Archive -Path tmp\unisonLocal.zip -DestinationPath release\ui + Compress-Archive -Path .\release\* -DestinationPath ucm-windows.zip - name: Upload windows artifact uses: actions/upload-artifact@v2 with: if-no-files-found: error name: build-windows - path: ucm-windows.tar.gz + path: ucm-windows.zip +>>>>>>> Stashed changes diff --git a/lib/unison-pretty-printer/LICENSE b/lib/unison-pretty-printer/LICENSE new file mode 100644 index 0000000000..c45ac9a548 --- /dev/null +++ b/lib/unison-pretty-printer/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2013-2021, Unison Computing, public benefit corp and contributors + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/lib/unison-pretty-printer/package.yaml b/lib/unison-pretty-printer/package.yaml new file mode 100644 index 0000000000..8ec552f306 --- /dev/null +++ b/lib/unison-pretty-printer/package.yaml @@ -0,0 +1,72 @@ +name: unison-pretty-printer +github: unisonweb/unison +copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveFunctor + - DeriveGeneric + - DerivingStrategies + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - TupleSections + - TypeApplications + - ViewPatterns + +ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures + +flags: + optimized: + manual: true + default: true + +when: + - condition: flag(optimized) + ghc-options: -funbox-strict-fields -O2 + +library: + source-dirs: src + dependencies: + - base + - unison-core1 + - unison-prelude + - containers + - ListLike + - ansi-terminal + - text + - mtl + - unliftio + - process + - extra + - terminal-size + +executables: + prettyprintdemo: + source-dirs: prettyprintdemo + main: Main.hs + dependencies: + - base + - safe + - text + - unison-pretty-printer + + +tests: + pretty-printer-tests: + source-dirs: tests + main: Suite.hs + ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 + dependencies: + - base + - unison-pretty-printer diff --git a/parser-typechecker/prettyprintdemo/Main.hs b/lib/unison-pretty-printer/prettyprintdemo/Main.hs similarity index 100% rename from parser-typechecker/prettyprintdemo/Main.hs rename to lib/unison-pretty-printer/prettyprintdemo/Main.hs diff --git a/parser-typechecker/src/Unison/Lexer/Pos.hs b/lib/unison-pretty-printer/src/Unison/Lexer/Pos.hs similarity index 100% rename from parser-typechecker/src/Unison/Lexer/Pos.hs rename to lib/unison-pretty-printer/src/Unison/Lexer/Pos.hs diff --git a/parser-typechecker/src/Unison/PrettyTerminal.hs b/lib/unison-pretty-printer/src/Unison/PrettyTerminal.hs similarity index 100% rename from parser-typechecker/src/Unison/PrettyTerminal.hs rename to lib/unison-pretty-printer/src/Unison/PrettyTerminal.hs diff --git a/parser-typechecker/src/Unison/Util/AnnotatedText.hs b/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs similarity index 100% rename from parser-typechecker/src/Unison/Util/AnnotatedText.hs rename to lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs diff --git a/parser-typechecker/src/Unison/Util/ColorText.hs b/lib/unison-pretty-printer/src/Unison/Util/ColorText.hs similarity index 100% rename from parser-typechecker/src/Unison/Util/ColorText.hs rename to lib/unison-pretty-printer/src/Unison/Util/ColorText.hs diff --git a/parser-typechecker/src/Unison/Util/Less.hs b/lib/unison-pretty-printer/src/Unison/Util/Less.hs similarity index 100% rename from parser-typechecker/src/Unison/Util/Less.hs rename to lib/unison-pretty-printer/src/Unison/Util/Less.hs diff --git a/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs b/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs new file mode 100644 index 0000000000..760af3cd63 --- /dev/null +++ b/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs @@ -0,0 +1,1154 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Util.Pretty + ( Pretty, + ColorText, + align, + align', + alternations, + background, + backticked, + backticked', + boxForkLeft, + boxLeft, + boxLeftM, + boxRight, + boxRightM, + bulleted, + bracket, + -- breakable + callout, + excerptSep, + excerptSep', + excerptColumn2, + excerptColumn2Headed, + warnCallout, + blockedCallout, + fatalCallout, + okCallout, + column2, + column2sep, + column2Header, + column2M, + column2UnzippedM, + column3, + column3M, + column3UnzippedM, + column3sep, + commas, + commented, + oxfordCommas, + oxfordCommasWith, + plural, + dashed, + flatMap, + group, + hang', + hang, + hangUngrouped', + hangUngrouped, + softHang', + softHang, + softHangNoSpace', + indent, + indentAfterNewline, + indentN, + indentNonEmptyN, + indentNAfterNewline, + invert, + isMultiLine, + isEmpty, + leftPad, + lines, + linesNonEmpty, + linesSpaced, + lit, + map, + mayColumn2, + nest, + num, + newline, + leftJustify, + lineSkip, + nonEmpty, + numbered, + numberedColumn2, + numberedColumn2Header, + numberedList, + orElse, + orElses, + paragraphyText, + parenthesize, + parenthesizeCommas, + parenthesizeIf, + render, + renderUnbroken, + rightPad, + sep, + sepNonEmpty, + sepSpaced, + shown, + singleQuoted, + singleQuoted', + softbreak, + spaceIfBreak, + spaceIfNeeded, + spaced, + spacedMap, + spacesIfBreak, + string, + surroundCommas, + syntaxToColor, + table, + text, + toANSI, + toAnsiUnbroken, + toHTML, + toPlain, + toPlainUnbroken, + underline, + withSyntax, + wrap, + wrap', + wrapColumn2, + wrapString, + black, + red, + green, + yellow, + blue, + purple, + cyan, + white, + hiBlack, + hiRed, + hiGreen, + hiYellow, + hiBlue, + hiPurple, + hiCyan, + hiWhite, + bold, + border, + Width (..), + + -- * Exported for testing + delta, + Delta, + ) +where + +import Control.Monad.Identity (Identity (..), runIdentity) +import Data.Bifunctor (second) +import Data.Char (isSpace) +import Data.List (intersperse) +import qualified Data.ListLike as LL +import qualified Data.Sequence as Seq +import qualified Data.Text as Text +import Unison.Prelude +import Unison.Util.AnnotatedText (annotateMaybe) +import qualified Unison.Util.AnnotatedText as AT +import qualified Unison.Util.ColorText as CT +import Unison.Util.Monoid (intercalateMap) +import qualified Unison.Util.SyntaxText as ST +import Prelude hiding (lines, map) + +newtype Width = Width {widthToInt :: Int} + deriving (Eq, Ord, Show, Generic, Num, Bounded) + +type ColorText = CT.ColorText + +data Pretty s = Pretty {delta :: Delta, out :: F s (Pretty s)} deriving (Eq) + +instance Functor Pretty where + fmap f (Pretty d o) = Pretty d (mapLit f $ fmap (fmap f) o) + +data F s r + = Empty + | -- | A group adds a level of breaking. Layout tries not to break a group + -- unless needed to fit in available width. Breaking is done "outside in". + -- + -- (a | b) <> (c | d) will try (a <> c), then (b <> d) + -- + -- (a | b) <> group (c | d) will try (a <> c), then (b <> c), then (b <> d) + Group r + | Lit s + | Wrap (Seq r) + | OrElse r r + | Append (Seq r) + deriving (Eq, Show, Foldable, Traversable, Functor) + +isEmpty :: Eq s => IsString s => Pretty s -> Bool +isEmpty s = out s == Empty || out s == Lit "" + +mapLit :: (s -> t) -> F s r -> F t r +mapLit f (Lit s) = Lit (f s) +mapLit _ Empty = Empty +mapLit _ (Group r) = Group r +mapLit _ (Wrap s) = Wrap s +mapLit _ (OrElse r s) = OrElse r s +mapLit _ (Append s) = Append s + +lit :: (IsString s, LL.ListLike s Char) => s -> Pretty s +lit s = lit' (foldMap chDelta $ LL.toList s) s + +lit' :: Delta -> s -> Pretty s +lit' d s = Pretty d (Lit s) + +orElse :: Pretty s -> Pretty s -> Pretty s +orElse p1 p2 = Pretty (delta p1) (OrElse p1 p2) + +orElses :: [Pretty s] -> Pretty s +orElses [] = mempty +orElses ps = foldr1 orElse ps + +wrapImpl :: IsString s => [Pretty s] -> Pretty s +wrapImpl [] = mempty +wrapImpl (p : ps) = + wrap_ . Seq.fromList $ + p : fmap (\p -> (" " <> p) `orElse` (newline <> p)) ps + +wrapImplPreserveSpaces :: (LL.ListLike s Char, IsString s) => [Pretty s] -> Pretty s +wrapImplPreserveSpaces = \case + [] -> mempty + (p : ps) -> wrap_ . Seq.fromList $ p : fmap f ps + where + startsWithSpace p = case out p of + (Lit s) -> fromMaybe False (fmap (isSpaceNotNewline . fst) $ LL.uncons s) + _ -> False + f p | startsWithSpace p = p `orElse` newline + f p = p + +isSpaceNotNewline :: Char -> Bool +isSpaceNotNewline c = isSpace c && not (c == '\n') + +wrapString :: (LL.ListLike s Char, IsString s) => String -> Pretty s +wrapString s = wrap (lit $ fromString s) + +-- Wrap text, preserving whitespace (apart from at the wrap points.) +-- Used in particular for viewing/displaying doc literals. +-- Should be understood in tandem with TermParser.docNormalize. +-- See also unison-src/transcripts/doc-formatting.md. +paragraphyText :: (LL.ListLike s Char, IsString s) => Text -> Pretty s +paragraphyText = sep "\n" . fmap (wrapPreserveSpaces . text) . Text.splitOn "\n" + +wrap' :: IsString s => (s -> [Pretty s]) -> Pretty s -> Pretty s +wrap' wordify p = wrapImpl (toLeaves [p]) + where + toLeaves [] = [] + toLeaves (hd : tl) = case out hd of + Empty -> toLeaves tl + Lit s -> wordify s ++ toLeaves tl + Group _ -> hd : toLeaves tl + OrElse a _ -> toLeaves (a : tl) + Wrap _ -> hd : toLeaves tl + Append hds -> toLeaves (toList hds ++ tl) + +wrap :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s +wrap = wrap' wordify + where + wordify s0 = + let s = LL.dropWhile isSpace s0 + in if LL.null s + then [] + else case LL.break isSpace s of (word1, s) -> lit word1 : wordify s + +-- Does not insert spaces where none were present, and does not collapse +-- sequences of spaces into one. +-- It'd be a bit painful to just replace wrap with the following version, because +-- lots of OutputMessages code depends on wrap's behaviour of sometimes adding +-- extra spaces. +wrapPreserveSpaces :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s +wrapPreserveSpaces p = wrapImplPreserveSpaces (toLeaves [p]) + where + toLeaves [] = [] + toLeaves (hd : tl) = case out hd of + Empty -> toLeaves tl + Lit s -> (fmap lit $ alternations isSpaceNotNewline s) ++ toLeaves tl + Group _ -> hd : toLeaves tl + OrElse a _ -> toLeaves (a : tl) + Wrap _ -> hd : toLeaves tl + Append hds -> toLeaves (toList hds ++ tl) + +-- Cut a list every time a predicate changes. Produces a list of +-- non-empty lists. +alternations :: (LL.ListLike s c) => (c -> Bool) -> s -> [s] +alternations p s = reverse $ go True s [] + where + go _ s acc | LL.null s = acc + go w s acc = go (not w) rest acc' + where + (t, rest) = LL.span p' s + p' = if w then p else (\x -> not (p x)) + acc' = if (LL.null t) then acc else t : acc + +wrap_ :: Seq (Pretty s) -> Pretty s +wrap_ ps = Pretty (foldMap delta ps) (Wrap ps) + +group :: Pretty s -> Pretty s +group p = Pretty (delta p) (Group p) + +toANSI :: Width -> Pretty CT.ColorText -> String +toANSI avail p = CT.toANSI (render avail p) + +toAnsiUnbroken :: Pretty ColorText -> String +toAnsiUnbroken p = CT.toANSI (renderUnbroken p) + +toPlain :: Width -> Pretty CT.ColorText -> String +toPlain avail p = CT.toPlain (render avail p) + +toHTML :: String -> Width -> Pretty CT.ColorText -> String +toHTML cssPrefix avail p = CT.toHTML cssPrefix (render avail p) + +toPlainUnbroken :: Pretty ColorText -> String +toPlainUnbroken p = CT.toPlain (renderUnbroken p) + +syntaxToColor :: Pretty (ST.SyntaxText' r) -> Pretty ColorText +syntaxToColor = fmap $ annotateMaybe . fmap CT.defaultColors + +-- set the syntax, overriding any present syntax +withSyntax :: + ST.Element r -> Pretty (ST.SyntaxText' r) -> Pretty (ST.SyntaxText' r) +withSyntax e = fmap $ ST.syntax e + +renderUnbroken :: (Monoid s, IsString s) => Pretty s -> s +renderUnbroken = render maxBound + +render :: (Monoid s, IsString s) => Width -> Pretty s -> s +render availableWidth p = go mempty [Right p] + where + go _ [] = mempty + go cur (p : rest) = case p of + Right p -> + -- `p` might fit, let's try it! + if p `fits` cur + then flow p <> go (cur <> delta p) rest + else go cur (Left p : rest) -- nope, switch to breaking mode + Left p -> case out p of -- `p` requires breaking + Append ps -> go cur ((Left <$> toList ps) <> rest) + Empty -> go cur rest + Group p -> go cur (Right p : rest) + -- Note: literals can't be broken further so they're + -- added to output unconditionally + Lit l -> l <> go (cur <> delta p) rest + OrElse _ p -> go cur (Right p : rest) + Wrap ps -> go cur ((Right <$> toList ps) <> rest) + + flow p = case out p of + Append ps -> foldMap flow ps + Empty -> mempty + Group p -> flow p + Lit s -> s + OrElse p _ -> flow p + Wrap ps -> foldMap flow ps + + fits p cur = + maxCol (surgery cur <> delta p) < availableWidth + where + -- Surgically modify 'cur' to pretend it has not exceeded availableWidth. + -- This is necessary because sometimes things cannot be split and *must* + -- exceed availableWidth; in this case, we do not want to entirely "blame" + -- the new proposed (cur <> delta p) for this overflow. + -- + -- For example, when appending + -- + -- availableWidth + -- | + -- xxx | + -- yyyyyy + -- zz | + -- + -- with + -- + -- aa | + -- bb | + -- + -- we want to end up with + -- + -- xxx | + -- yyyyyy + -- zzaa| + -- bb | + -- + surgery = \case + SingleLine c -> SingleLine (min c (availableWidth - 1)) + MultiLine fc lc mc -> MultiLine fc lc (min mc (availableWidth - 1)) + +newline :: IsString s => Pretty s +newline = "\n" + +lineSkip :: IsString s => Pretty s +lineSkip = newline <> newline + +spaceIfNeeded :: Eq s => IsString s => Pretty s -> Pretty s -> Pretty s +spaceIfNeeded a b = if isEmpty a then b else a <> " " <> b + +spaceIfBreak :: IsString s => Pretty s +spaceIfBreak = "" `orElse` " " + +spacesIfBreak :: IsString s => Int -> Pretty s +spacesIfBreak n = "" `orElse` fromString (replicate n ' ') + +softbreak :: IsString s => Pretty s +softbreak = " " `orElse` newline + +spaced :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s +spaced = intercalateMap softbreak id + +spacedMap :: (Foldable f, IsString s) => (a -> Pretty s) -> f a -> Pretty s +spacedMap f as = spaced . fmap f $ toList as + +commas :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s +commas = intercalateMap ("," <> softbreak) id + +oxfordCommas :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s +oxfordCommas = oxfordCommasWith "" + +-- Like `oxfordCommas`, but attaches `end` at the end (without a space). +-- For example, `oxfordCommasWith "."` will attach a period. +oxfordCommasWith :: + (Foldable f, IsString s) => Pretty s -> f (Pretty s) -> Pretty s +oxfordCommasWith end xs = case toList xs of + [] -> "" + [x] -> group (x <> end) + [x, y] -> x <> " and " <> group (y <> end) + xs -> + intercalateMap ("," <> softbreak) id (init xs) + <> "," + <> softbreak + <> "and" + <> softbreak + <> group (last xs <> end) + +parenthesizeCommas :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s +parenthesizeCommas = surroundCommas "(" ")" + +surroundCommas :: + (Foldable f, IsString s) => + Pretty s -> + Pretty s -> + f (Pretty s) -> + Pretty s +surroundCommas start stop fs = + group $ + start + <> spaceIfBreak + <> intercalateMap ("," <> softbreak <> align) id fs + <> stop + where + align = spacesIfBreak (widthToInt $ preferredWidth start + 1) + +sepSpaced :: (Foldable f, IsString s) => Pretty s -> f (Pretty s) -> Pretty s +sepSpaced between = sep (between <> softbreak) + +sep :: (Foldable f, IsString s) => Pretty s -> f (Pretty s) -> Pretty s +sep between = intercalateMap between id + +sepNonEmpty :: (Foldable f, IsString s) => Pretty s -> f (Pretty s) -> Pretty s +sepNonEmpty between ps = sep between (nonEmpty ps) + +-- if list is too long, adds `... 22 more` to the end +excerptSep :: IsString s => Maybe Int -> Pretty s -> [Pretty s] -> Pretty s +excerptSep maxCount = + excerptSep' maxCount (\i -> group ("... " <> shown i <> " more")) + +excerptSep' :: + IsString s => + Maybe Int -> + (Int -> Pretty s) -> + Pretty s -> + [Pretty s] -> + Pretty s +excerptSep' maxCount summarize s ps = case maxCount of + Just max + | length ps > max -> + sep s (take max ps) <> summarize (length ps - max) + _ -> sep s ps + +nonEmpty :: (Foldable f, IsString s) => f (Pretty s) -> [Pretty s] +nonEmpty (toList -> l) = case l of + (out -> Empty) : t -> nonEmpty t + h : t -> h : nonEmpty t + [] -> [] + +parenthesize :: IsString s => Pretty s -> Pretty s +parenthesize p = group $ "(" <> p <> ")" + +parenthesizeIf :: IsString s => Bool -> Pretty s -> Pretty s +parenthesizeIf False s = s +parenthesizeIf True s = parenthesize s + +lines :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s +lines = intercalateMap (append newline) id + where + append p = Pretty (delta p) (Append $ Seq.singleton p) + +linesNonEmpty :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s +linesNonEmpty = lines . nonEmpty + +linesSpaced :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s +linesSpaced ps = lines (intersperse "" $ toList ps) + +prefixed :: + (Foldable f, LL.ListLike s Char, IsString s) => + Pretty s -> + Pretty s -> + f (Pretty s) -> + Pretty s +prefixed first rest = + intercalateMap newline (\b -> first <> indentAfterNewline rest b) + +bulleted :: + (Foldable f, LL.ListLike s Char, IsString s) => f (Pretty s) -> Pretty s +bulleted = prefixed "* " " " + +dashed :: + (Foldable f, LL.ListLike s Char, IsString s) => f (Pretty s) -> Pretty s +dashed = prefixed "- " " " + +commented :: + (Foldable f, LL.ListLike s Char, IsString s) => f (Pretty s) -> Pretty s +commented = prefixed "-- " "-- " + +numbered :: + (Foldable f, LL.ListLike s Char, IsString s) => + (Int -> Pretty s) -> + f (Pretty s) -> + Pretty s +numbered num ps = column2 (fmap num [1 ..] `zip` toList ps) + +numberedHeader :: + (Foldable f, LL.ListLike s Char, IsString s) => + (Maybe Int -> Pretty s) -> + f (Pretty s) -> + Pretty s +numberedHeader num ps = column2 (fmap num (Nothing : fmap Just [1 ..]) `zip` toList ps) + +-- Like `column2` but with the lines numbered. For instance: +-- +-- 1. one thing : this is a thing +-- 2. another thing : this is another thing +-- 3. and another : yet one more thing +numberedColumn2 :: + (Foldable f, LL.ListLike s Char, IsString s) => + (Int -> Pretty s) -> + f (Pretty s, Pretty s) -> + Pretty s +numberedColumn2 num ps = numbered num (align $ toList ps) + +numberedColumn2Header :: + (Foldable f, LL.ListLike s Char, IsString s) => + (Int -> Pretty s) -> + f (Pretty s, Pretty s) -> + Pretty s +numberedColumn2Header num ps = numberedHeader (maybe mempty num) (align $ toList ps) + +-- Opinionated `numbered` that uses bold numbers in front +numberedList :: Foldable f => f (Pretty ColorText) -> Pretty ColorText +numberedList = numbered (\i -> hiBlack . fromString $ show i <> ".") + +leftPad, rightPad :: IsString s => Width -> Pretty s -> Pretty s +leftPad n p = + let rem = n - preferredWidth p + in if rem > 0 then fromString (replicate (widthToInt rem) ' ') <> p else p +rightPad n p = + let rem = n - preferredWidth p + in if rem > 0 then p <> fromString (replicate (widthToInt rem) ' ') else p + +excerptColumn2Headed :: + (LL.ListLike s Char, IsString s) => + Maybe Int -> + (Pretty s, Pretty s) -> + [(Pretty s, Pretty s)] -> + Pretty s +excerptColumn2Headed max hd cols = case max of + Just max + | len > max -> + lines [column2 (hd : take max cols), "... " <> shown (len - max) <> " more"] + _ -> column2 (hd : cols) + where + len = length cols + +excerptColumn2 :: + (LL.ListLike s Char, IsString s) => + Maybe Int -> + [(Pretty s, Pretty s)] -> + Pretty s +excerptColumn2 max cols = case max of + Just max | len > max -> lines [column2 cols, "... " <> shown (len - max)] + _ -> column2 cols + where + len = length cols + +table :: (IsString s, LL.ListLike s Char) => [[Pretty s]] -> Pretty s +table rows = lines (table' rows) + +table' :: (IsString s, LL.ListLike s Char) => [[Pretty s]] -> [Pretty s] +table' [] = mempty +table' rows = case maximum (Prelude.length <$> rows) of + 1 -> + rows >>= \case + [] -> [mempty] + hd : _ -> [hd] + _ -> + let colHd = [h | (h : _) <- rows] + colTl = [t | (_ : t) <- rows] + in align (fmap (<> " ") colHd `zip` (table' colTl)) + +column2 :: + (LL.ListLike s Char, IsString s) => [(Pretty s, Pretty s)] -> Pretty s +column2 = column2sep "" + +column2Header :: + Pretty ColorText -> Pretty ColorText -> [(Pretty ColorText, Pretty ColorText)] -> Pretty ColorText +column2Header left right = column2sep " " . ((fmap CT.hiBlack left, fmap CT.hiBlack right) :) + +column2sep :: + (LL.ListLike s Char, IsString s) => Pretty s -> [(Pretty s, Pretty s)] -> Pretty s +column2sep sep rows = lines . (group <$>) . align $ [(a, indent sep b) | (a, b) <- rows] + +column2M :: + (Applicative m, LL.ListLike s Char, IsString s) => + [m (Pretty s, Pretty s)] -> + m (Pretty s) +column2M = fmap column2 . sequenceA + +mayColumn2 :: + (LL.ListLike s Char, IsString s) => + [(Pretty s, Maybe (Pretty s))] -> + Pretty s +mayColumn2 = lines . (group <$>) . ((uncurry (<>)) <$>) . align' + +column3 :: + (LL.ListLike s Char, IsString s) => + [(Pretty s, Pretty s, Pretty s)] -> + Pretty s +column3 = column3sep "" + +column3M :: + (LL.ListLike s Char, IsString s, Monad m) => + [m (Pretty s, Pretty s, Pretty s)] -> + m (Pretty s) +column3M = fmap column3 . sequence + +column3UnzippedM :: + forall m s. + (LL.ListLike s Char, IsString s, Monad m) => + Pretty s -> + [m (Pretty s)] -> + [m (Pretty s)] -> + [m (Pretty s)] -> + m (Pretty s) +column3UnzippedM bottomPadding left mid right = + let rowCount = maximum (fmap length [left, mid, right]) + pad :: [m (Pretty s)] -> [m (Pretty s)] + pad a = a ++ replicate (rowCount - length a) (pure bottomPadding) + (pleft, pmid, pright) = (pad left, pad mid, pad right) + in column3M $ zipWith3 (liftA3 (,,)) pleft pmid pright + +column2UnzippedM :: + forall m s. + (LL.ListLike s Char, IsString s, Monad m) => + Pretty s -> + [m (Pretty s)] -> + [m (Pretty s)] -> + m (Pretty s) +column2UnzippedM bottomPadding left right = + let rowCount = length left `max` length right + pad :: [m (Pretty s)] -> [m (Pretty s)] + pad a = a ++ replicate (rowCount - length a) (pure bottomPadding) + sep :: [m (Pretty s)] -> [m (Pretty s)] + sep = fmap (fmap (" " <>)) + (pleft, pright) = (pad left, sep $ pad right) + in column2M $ zipWith (liftA2 (,)) pleft pright + +column3sep :: + (LL.ListLike s Char, IsString s) => Pretty s -> [(Pretty s, Pretty s, Pretty s)] -> Pretty s +column3sep sep rows = + let bc = align [(b, sep <> c) | (_, b, c) <- rows] + abc = group <$> align [(a, sep <> bc) | ((a, _, _), bc) <- rows `zip` bc] + in lines abc + +wrapColumn2 :: + (LL.ListLike s Char, IsString s) => [(Pretty s, Pretty s)] -> Pretty s +wrapColumn2 rows = lines (align rows) + where + align rows = + let lwidth = foldl' max 0 (preferredWidth . fst <$> rows) + 2 + in [ group (rightPad lwidth l <> indentNAfterNewline lwidth (wrap r)) + | (l, r) <- rows + ] + +-- Pad with enough space on the right to make all rows the same width +leftJustify :: + (Eq s, Show s, LL.ListLike s Char, IsString s) => + [(Pretty s, a)] -> + [(Pretty s, a)] +leftJustify rows = + zip + ( fmap fst . align' $ + fmap + (\x -> (x, if isEmpty x then Nothing else Just "")) + ss + ) + as + where + (ss, as) = unzip rows + +align :: + (LL.ListLike s Char, IsString s) => [(Pretty s, Pretty s)] -> [Pretty s] +align rows = (((uncurry (<>)) <$>) . align') (second Just <$> rows) + +-- [("foo", Just "bar") +-- ,("barabaz", Nothing) +-- ,("qux","quux")] +-- +-- results in: +-- +-- [("foo ", "bar"), +-- [("barabaz", ""), +-- [("qux ", "quuxbill")] +-- +-- The first component has padding added, sufficient to align the second +-- component. The second component has whitespace added after its +-- newlines, again sufficient to line it up in a second column. +align' :: + (LL.ListLike s Char, IsString s) => + [(Pretty s, Maybe (Pretty s))] -> + [(Pretty s, Pretty s)] +align' rows = alignedRows + where + col0Width = foldl' max 0 [preferredWidth col1 | (col1, Just _) <- rows] + 1 + alignedRows = + [ case col1 of + Just s -> (rightPad col0Width col0, indentNAfterNewline col0Width s) + Nothing -> (col0, mempty) + | (col0, col1) <- rows + ] + +text :: IsString s => Text -> Pretty s +text t = fromString (Text.unpack t) + +num :: (Show n, Num n, IsString s) => n -> Pretty s +num n = fromString (show n) + +string :: IsString s => String -> Pretty s +string = fromString + +shown :: (Show a, IsString s) => a -> Pretty s +shown = fromString . show + +-- `softHang foo bar` will attempt to put the first line of `bar` right after +-- `foo` on the same line, but will behave like `hang foo bar` if there's not +-- enough horizontal space. +-- +-- Used for example to allow the `let` keyword to appear on the same line as +-- an equals sign. +-- +-- myDef x = 'let +-- y = f x +-- g y +-- +-- But if the name is too long, the `'let` is allowed to float to the next line: +-- +-- myLongDef x = +-- 'let +-- y = f x +-- g y +-- +-- To do this, we'd use `softHang "=" "'let" <> newline <> ...` +-- +softHang :: + (LL.ListLike s Char, IsString s) => + Pretty s -> + Pretty s -> + Pretty s +softHang from = softHang' from " " + +-- `softHang' by foo bar` will attempt to put `bar` right after `foo` on the same +-- line, but will behave like `hang by foo bar` if there's not enough horizontal +-- space for both `foo` and `bar`. +softHang' :: + (LL.ListLike s Char, IsString s) => + Pretty s -> + Pretty s -> + Pretty s -> + Pretty s +softHang' from by p = + group $ + (from <> " " <> group p) `orElse` (from <> "\n" <> group (indent by p)) + +softHangNoSpace' :: + (LL.ListLike s Char, IsString s) => + Pretty s -> + Pretty s -> + Pretty s -> + Pretty s +softHangNoSpace' from by p = + group $ (from <> group p) `orElse` (from <> "\n" <> group (indent by p)) + +-- Same as `hang`, except instead of indenting by two spaces, it indents by +-- the `by` argument. +hang' :: + (LL.ListLike s Char, IsString s) => + Pretty s -> + Pretty s -> + Pretty s -> + Pretty s +hang' from by p = + group $ + if isMultiLine p + then from <> "\n" <> group (indent by p) + else softHang' from by p + +-- Indents its argument by two spaces, following `from`, so that the text +-- seems to "hang" from it. +-- +-- For example, `hang "foo" ("bar" <> newline <> "baz")` results in: +-- +-- foo +-- bar +-- baz +-- +-- If the argument spans multiple lines, `hang` will always put it on the +-- next line. But if it's only a single line, `hang` will attempt to fit it +-- on the same line as `from`. +-- +-- For example, `hang "foo" "bar"`: +-- +-- foo bar +-- +hang :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s +hang from = hang' from " " + +hangUngrouped' :: + (LL.ListLike s Char, IsString s) => + Pretty s -> + Pretty s -> + Pretty s -> + Pretty s +hangUngrouped' from by p = + if isMultiLine p + then from <> "\n" <> indent by p + else (from <> " " <> p) `orElse` (from <> "\n" <> indent by p) + +hangUngrouped :: + (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s +hangUngrouped from = hangUngrouped' from " " + +nest :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s +nest = hang' "" + +indent :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s +indent by p = by <> indentAfterNewline by p + +indentN :: (LL.ListLike s Char, IsString s) => Width -> Pretty s -> Pretty s +indentN by = indent (fromString $ replicate (widthToInt by) ' ') + +indentNonEmptyN :: + (LL.ListLike s Char, IsString s) => Width -> Pretty s -> Pretty s +indentNonEmptyN _ (out -> Empty) = mempty +indentNonEmptyN by p = indentN by p + +indentNAfterNewline :: + (LL.ListLike s Char, IsString s) => Width -> Pretty s -> Pretty s +indentNAfterNewline by = + indentAfterNewline (fromString $ replicate (widthToInt by) ' ') + +indentAfterNewline :: + (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s +indentAfterNewline by = flatMap f + where + f s0 = case LL.break (== '\n') s0 of + (hd, s) -> + if LL.null s + then lit s0 + else -- use `take` and `drop` to preserve annotations or + -- or other extra info attached to the original `s` + lit (LL.take (LL.length hd) s0) <> "\n" <> by <> f (LL.drop 1 s) + +instance IsString s => IsString (Pretty s) where + fromString s = lit' (foldMap chDelta s) (fromString s) + +instance Semigroup (Pretty s) where (<>) = mappend + +instance Monoid (Pretty s) where + mempty = Pretty mempty Empty + mappend p1 p2 = Pretty (delta p1 <> delta p2) + . Append + $ case (out p1, out p2) of + (Append ps1, Append ps2) -> ps1 <> ps2 + (Append ps1, _) -> ps1 <> pure p2 + (_, Append ps2) -> pure p1 <> ps2 + (_, _) -> pure p1 <> pure p2 + +data Delta + = -- | The number of columns. + SingleLine !Width + | -- | The number of columns in the first, last, and longest lines. + MultiLine !Width !Width !Width + deriving stock (Eq, Ord, Show) + +instance Semigroup Delta where + SingleLine c <> SingleLine c2 = SingleLine (c + c2) + SingleLine c <> MultiLine fc lc mc = + let fc' = c + fc + in MultiLine fc' lc (max fc' mc) + MultiLine fc lc mc <> SingleLine c = + let lc' = lc + c + in MultiLine fc lc' (max lc' mc) + MultiLine fc lc mc <> MultiLine fc2 lc2 mc2 = + MultiLine fc lc2 (max mc (max mc2 (lc + fc2))) + +instance Monoid Delta where + mempty = SingleLine 0 + mappend = (<>) + +maxCol :: Delta -> Width +maxCol = \case + SingleLine c -> c + MultiLine _ _ c -> c + +lastCol :: Delta -> Width +lastCol = \case + SingleLine c -> c + MultiLine _ c _ -> c + +chDelta :: Char -> Delta +chDelta '\n' = MultiLine 0 0 0 +chDelta _ = SingleLine 1 + +preferredWidth :: Pretty s -> Width +preferredWidth p = lastCol (delta p) + +isMultiLine :: Pretty s -> Bool +isMultiLine p = + case delta p of + SingleLine {} -> False + MultiLine {} -> True + +black, + red, + green, + yellow, + blue, + purple, + cyan, + white, + hiBlack, + hiRed, + hiGreen, + hiYellow, + hiBlue, + hiPurple, + hiCyan, + hiWhite, + bold, + underline :: + Pretty CT.ColorText -> Pretty CT.ColorText +black = map CT.black +red = map CT.red +green = map CT.green +yellow = map CT.yellow +blue = map CT.blue +purple = map CT.purple +cyan = map CT.cyan +white = map CT.white +hiBlack = map CT.hiBlack +hiRed = map CT.hiRed +hiGreen = map CT.hiGreen +hiYellow = map CT.hiYellow +hiBlue = map CT.hiBlue +hiPurple = map CT.hiPurple +hiCyan = map CT.hiCyan +hiWhite = map CT.hiWhite +bold = map CT.bold +underline = map CT.underline + +-- invert the foreground and background colors +invert :: Pretty CT.ColorText -> Pretty CT.ColorText +invert = map CT.invert + +-- set the background color, ex: `background hiBlue`, `background yellow` +background :: (Pretty CT.ColorText -> Pretty CT.ColorText) -> Pretty CT.ColorText -> Pretty CT.ColorText +background f p = + -- hack: discover the color of `f` by calling it on a dummy string + case f (Pretty mempty (Lit "-")) of + Pretty _ (Lit (AT.AnnotatedText (toList -> [AT.Segment _ (Just c)]))) -> map (CT.background c) p + _ -> p + +plural :: + Foldable f => + f a -> + Pretty ColorText -> + Pretty ColorText +plural f p = case length f of + 0 -> mempty + 1 -> p + -- todo: consider use of plural package + _ -> + p <> case reverse (toPlainUnbroken p) of + 's' : _ -> "es" + _ -> "s" + +border :: (LL.ListLike s Char, IsString s) => Width -> Pretty s -> Pretty s +border n p = "\n" <> indentN n p <> "\n" + +callout :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s +callout header p = header <> "\n\n" <> p + +bracket :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s +bracket = indent " " + +boxForkLeft, + boxLeft, + boxRight :: + forall s. (LL.ListLike s Char, IsString s) => [Pretty s] -> [Pretty s] +boxForkLeft = boxLeft' lBoxStyle1 +boxLeft = boxLeft' lBoxStyle2 +boxRight = boxRight' rBoxStyle2 + +boxLeft', + boxRight' :: + (LL.ListLike s Char, IsString s) => + BoxStyle s -> + [Pretty s] -> + [Pretty s] +boxLeft' style = fmap runIdentity . boxLeftM' style . fmap Identity +boxRight' style = fmap runIdentity . boxRightM' style . fmap Identity + +type BoxStyle s = + ( (Pretty s, Pretty s), -- first (start, continue) + (Pretty s, Pretty s), -- middle + (Pretty s, Pretty s), -- last + (Pretty s, Pretty s) -- singleton + ) + +lBoxStyle1, lBoxStyle2, rBoxStyle2 :: IsString s => BoxStyle s +lBoxStyle1 = + ( ("โ”Œ ", "โ”‚ "), -- first + ("โ”œ ", "โ”‚ "), -- middle + ("โ”” ", " "), -- last + ("", "") -- singleton + ) +lBoxStyle2 = + ( ("โ”Œ ", " "), + ("โ”‚ ", " "), + ("โ”” ", " "), + ("", "") + ) +rBoxStyle2 = + ( (" โ”", " โ”‚"), + (" โ”‚", " โ”‚"), + (" โ”˜", " "), + (" ", " ") + ) + +boxLeftM, + boxRightM :: + forall m s. + (Monad m, LL.ListLike s Char, IsString s) => + [m (Pretty s)] -> + [m (Pretty s)] +boxLeftM = boxLeftM' lBoxStyle2 +boxRightM = boxRightM' rBoxStyle2 + +boxLeftM' :: + forall m s. + (Monad m, LL.ListLike s Char, IsString s) => + BoxStyle s -> + [m (Pretty s)] -> + [m (Pretty s)] +boxLeftM' (first, middle, last, singleton) ps = go (Seq.fromList ps) + where + go Seq.Empty = [] + go (p Seq.:<| Seq.Empty) = [decorate singleton <$> p] + go (a Seq.:<| (mid Seq.:|> b)) = + [decorate first <$> a] + ++ toList (fmap (decorate middle) <$> mid) + ++ [decorate last <$> b] + decorate (first, mid) p = first <> indentAfterNewline mid p + +-- this implementation doesn't work for multi-line inputs, +-- because i dunno how to inspect multi-line inputs + +boxRightM' :: + forall m s. + (Monad m, LL.ListLike s Char, IsString s) => + BoxStyle s -> + [m (Pretty s)] -> + [m (Pretty s)] +boxRightM' (first, middle, last, singleton) ps = go (Seq.fromList ps) + where + go :: Seq.Seq (m (Pretty s)) -> [m (Pretty s)] + go Seq.Empty = [] + go (p Seq.:<| Seq.Empty) = [decorate singleton <$> p] + go (a Seq.:<| (mid Seq.:|> b)) = + [decorate first <$> a] + ++ toList (fmap (decorate middle) <$> mid) + ++ [decorate last <$> b] + decorate (first, _mid) p = p <> first + +warnCallout, + blockedCallout, + fatalCallout, + okCallout :: + (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s +warnCallout = callout "โš ๏ธ" +fatalCallout = callout "โ—๏ธ" +okCallout = callout "โœ…" +blockedCallout = callout "๐Ÿšซ" + +backticked :: IsString s => Pretty s -> Pretty s +backticked p = group ("`" <> p <> "`") + +-- | Attach some punctuation after the closing backtick. +backticked' :: IsString s => Pretty s -> Pretty s -> Pretty s +backticked' p end = group ("`" <> p <> "`" <> end) + +singleQuoted :: IsString s => Pretty s -> Pretty s +singleQuoted p = "'" <> p <> "'" + +singleQuoted' :: IsString s => Pretty s -> Pretty s -> Pretty s +singleQuoted' p end = "'" <> p <> "'" <> end + +instance Show s => Show (Pretty s) where + show p = render 80 (metaPretty p) + +metaPretty :: Show s => Pretty s -> Pretty String +metaPretty = go (0 :: Int) + where + go prec p = case out p of + Lit s -> parenthesizeIf (prec > 0) $ "Lit" `hang` lit (show s) + Empty -> "Empty" + Group g -> parenthesizeIf (prec > 0) $ "Group" `hang` go 1 g + Wrap s -> + parenthesizeIf (prec > 0) $ + "Wrap" + `hang` surroundCommas "[" "]" (go 1 <$> s) + OrElse a b -> + parenthesizeIf (prec > 0) $ + "OrElse" `hang` spaced [go 1 a, go 1 b] + Append s -> surroundCommas "[" "]" (go 1 <$> s) + +map :: LL.ListLike s2 Char => (s -> s2) -> Pretty s -> Pretty s2 +map f p = case out p of + Append ps -> foldMap (map f) ps + Empty -> mempty + Group p -> group (map f p) + Lit s -> lit' (foldMap chDelta $ LL.toList s2) s2 where s2 = f s + OrElse p1 p2 -> orElse (map f p1) (map f p2) + Wrap p -> wrap_ (map f <$> p) + +flatMap :: (s -> Pretty s2) -> Pretty s -> Pretty s2 +flatMap f p = case out p of + Append ps -> foldMap (flatMap f) ps + Empty -> mempty + Group p -> group (flatMap f p) + Lit s -> f s + OrElse p1 p2 -> orElse (flatMap f p1) (flatMap f p2) + Wrap p -> wrap_ (flatMap f <$> p) diff --git a/parser-typechecker/src/Unison/Util/Range.hs b/lib/unison-pretty-printer/src/Unison/Util/Range.hs similarity index 100% rename from parser-typechecker/src/Unison/Util/Range.hs rename to lib/unison-pretty-printer/src/Unison/Util/Range.hs diff --git a/parser-typechecker/src/Unison/Util/SyntaxText.hs b/lib/unison-pretty-printer/src/Unison/Util/SyntaxText.hs similarity index 100% rename from parser-typechecker/src/Unison/Util/SyntaxText.hs rename to lib/unison-pretty-printer/src/Unison/Util/SyntaxText.hs diff --git a/lib/unison-pretty-printer/tests/Suite.hs b/lib/unison-pretty-printer/tests/Suite.hs new file mode 100644 index 0000000000..5fe5a76645 --- /dev/null +++ b/lib/unison-pretty-printer/tests/Suite.hs @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module Main where + +import EasyTest +import System.Environment (getArgs) +import System.IO +import System.IO.CodePage (withCP65001) +import qualified Unison.Core.Test.Name as Name +import qualified Unison.Test.ABT as ABT +import qualified Unison.Test.ANF as ANF +import qualified Unison.Test.Cache as Cache +import qualified Unison.Test.Codebase.Branch as Branch +import qualified Unison.Test.Codebase.Causal as Causal +import qualified Unison.Test.Codebase.Path as Path +import qualified Unison.Test.CodebaseInit as CodebaseInit +import qualified Unison.Test.ColorText as ColorText +import qualified Unison.Test.DataDeclaration as DataDeclaration +import qualified Unison.Test.FileParser as FileParser +import qualified Unison.Test.Lexer as Lexer +import qualified Unison.Test.MCode as MCode +import qualified Unison.Test.Range as Range +import qualified Unison.Test.Referent as Referent +import qualified Unison.Test.Term as Term +import qualified Unison.Test.TermParser as TermParser +import qualified Unison.Test.TermPrinter as TermPrinter +import qualified Unison.Test.Type as Type +import qualified Unison.Test.TypePrinter as TypePrinter +import qualified Unison.Test.Typechecker as Typechecker +import qualified Unison.Test.Typechecker.Context as Context +import qualified Unison.Test.Typechecker.TypeError as TypeError +import qualified Unison.Test.UnisonSources as UnisonSources +import qualified Unison.Test.Util.Bytes as Bytes +import qualified Unison.Test.Util.PinBoard as PinBoard +import qualified Unison.Test.Util.Pretty as Pretty +import qualified Unison.Test.Util.Relation as Relation +import qualified Unison.Test.Util.Text as Text +import qualified Unison.Test.Var as Var + +test :: Test () +test = + tests + [ Cache.test, + Lexer.test, + Term.test, + TermParser.test, + TermPrinter.test, + Type.test, + TypeError.test, + TypePrinter.test, + UnisonSources.test, + FileParser.test, + DataDeclaration.test, + Range.test, + ColorText.test, + Bytes.test, + Text.test, + Relation.test, + Path.test, + Causal.test, + Referent.test, + ABT.test, + ANF.test, + MCode.test, + Var.test, + Typechecker.test, + Context.test, + Name.test, + Pretty.test, + PinBoard.test, + CodebaseInit.test, + Branch.test + ] + +main :: IO () +main = withCP65001 do + args <- getArgs + mapM_ (`hSetEncoding` utf8) [stdout, stdin, stderr] + case args of + [] -> runOnly "" test + [prefix] -> runOnly prefix test + [seed, prefix] -> rerunOnly (read seed) prefix test diff --git a/lib/unison-pretty-printer/tests/Unison/Test/Pretty.hs b/lib/unison-pretty-printer/tests/Unison/Test/Pretty.hs new file mode 100644 index 0000000000..10e1a7755a --- /dev/null +++ b/lib/unison-pretty-printer/tests/Unison/Test/Pretty.hs @@ -0,0 +1,33 @@ +module Unison.Test.Util.Pretty + ( test, + ) +where + +import Control.Monad +import Data.String (fromString) +import EasyTest +import qualified Unison.Util.Pretty as Pretty + +test :: Test () +test = + scope "util.pretty" . tests $ + [ scope "Delta.Semigroup.<>.associative" $ do + replicateM_ 100 $ do + d1 <- randomDelta + d2 <- randomDelta + d3 <- randomDelta + expect' $ (d1 <> d2) <> d3 == d1 <> (d2 <> d3) + ok + ] + +randomDelta :: Test Pretty.Delta +randomDelta = + Pretty.delta <$> randomPretty + where + randomPretty :: Test (Pretty.Pretty String) + randomPretty = + fromString <$> randomString + + randomString :: Test String + randomString = + replicateM 3 (pick ['x', 'y', 'z', '\n']) diff --git a/parser-typechecker/tests/Unison/Test/Range.hs b/lib/unison-pretty-printer/tests/Unison/Test/Range.hs similarity index 100% rename from parser-typechecker/tests/Unison/Test/Range.hs rename to lib/unison-pretty-printer/tests/Unison/Test/Range.hs diff --git a/lib/unison-pretty-printer/unison-pretty-printer.cabal b/lib/unison-pretty-printer/unison-pretty-printer.cabal new file mode 100644 index 0000000000..08794a38c8 --- /dev/null +++ b/lib/unison-pretty-printer/unison-pretty-printer.cabal @@ -0,0 +1,150 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: unison-pretty-printer +version: 0.0.0 +homepage: https://github.com/unisonweb/unison#readme +bug-reports: https://github.com/unisonweb/unison/issues +copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors +license: MIT +license-file: LICENSE +build-type: Simple + +source-repository head + type: git + location: https://github.com/unisonweb/unison + +flag optimized + manual: True + default: True + +library + exposed-modules: + Unison.Lexer.Pos + Unison.PrettyTerminal + Unison.Util.AnnotatedText + Unison.Util.ColorText + Unison.Util.Less + Unison.Util.Pretty + Unison.Util.Range + Unison.Util.SyntaxText + other-modules: + Paths_unison_pretty_printer + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveFunctor + DeriveGeneric + DerivingStrategies + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures + build-depends: + ListLike + , ansi-terminal + , base + , containers + , extra + , mtl + , process + , terminal-size + , text + , unison-core1 + , unison-prelude + , unliftio + if flag(optimized) + ghc-options: -funbox-strict-fields -O2 + default-language: Haskell2010 + +executable prettyprintdemo + main-is: Main.hs + other-modules: + Paths_unison_pretty_printer + hs-source-dirs: + prettyprintdemo + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveFunctor + DeriveGeneric + DerivingStrategies + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures + build-depends: + base + , safe + , text + , unison-pretty-printer + if flag(optimized) + ghc-options: -funbox-strict-fields -O2 + default-language: Haskell2010 + +test-suite pretty-printer-tests + type: exitcode-stdio-1.0 + main-is: Suite.hs + other-modules: + Unison.Test.Pretty + Unison.Test.Range + Paths_unison_pretty_printer + hs-source-dirs: + tests + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveFunctor + DeriveGeneric + DerivingStrategies + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 + build-depends: + base + , unison-pretty-printer + if flag(optimized) + ghc-options: -funbox-strict-fields -O2 + default-language: Haskell2010 diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index e8dc6b26ea..aa37399e59 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -143,15 +143,6 @@ library: - generic-lens executables: - prettyprintdemo: - source-dirs: prettyprintdemo - main: Main.hs - dependencies: - - base - - safe - - text - - unison-parser-typechecker - tests: source-dirs: tests main: Suite.hs diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index b58b07fc95..83dcb283f4 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -101,7 +101,6 @@ library Unison.Hashing.V2.Type Unison.Hashing.V2.TypeEdit Unison.Lexer - Unison.Lexer.Pos Unison.NamePrinter Unison.Parser Unison.Parser.Ann @@ -112,7 +111,6 @@ library Unison.PrettyPrintEnv.Util Unison.PrettyPrintEnvDecl Unison.PrettyPrintEnvDecl.Names - Unison.PrettyTerminal Unison.PrintError Unison.Result Unison.Runtime.ANF @@ -164,9 +162,7 @@ library Unison.UnisonFile.Error Unison.UnisonFile.Names Unison.UnisonFile.Type - Unison.Util.AnnotatedText Unison.Util.Bytes - Unison.Util.ColorText Unison.Util.Convert Unison.Util.CycleTable Unison.Util.CyclicEq @@ -175,14 +171,11 @@ library Unison.Util.Exception Unison.Util.Find Unison.Util.Free - Unison.Util.Less Unison.Util.Logger Unison.Util.PinBoard Unison.Util.Pretty - Unison.Util.Range Unison.Util.Rope Unison.Util.Star3 - Unison.Util.SyntaxText Unison.Util.Text Unison.Util.TQueue Unison.Util.TransitiveClosure @@ -317,43 +310,6 @@ library ghc-options: -funbox-strict-fields -O2 default-language: Haskell2010 -executable prettyprintdemo - main-is: Main.hs - other-modules: - Paths_unison_parser_typechecker - hs-source-dirs: - prettyprintdemo - default-extensions: - ApplicativeDo - BangPatterns - BlockArguments - DeriveFunctor - DeriveGeneric - DerivingStrategies - DoAndIfThenElse - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - NamedFieldPuns - OverloadedStrings - PatternSynonyms - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications - ViewPatterns - ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures - build-depends: - base - , safe - , text - , unison-parser-typechecker - if flag(optimized) - ghc-options: -funbox-strict-fields -O2 - default-language: Haskell2010 - executable tests main-is: Suite.hs other-modules: @@ -371,7 +327,6 @@ executable tests Unison.Test.FileParser Unison.Test.Lexer Unison.Test.MCode - Unison.Test.Range Unison.Test.Referent Unison.Test.Term Unison.Test.TermParser diff --git a/stack.yaml b/stack.yaml index 9214388c91..0ad91dfa39 100644 --- a/stack.yaml +++ b/stack.yaml @@ -24,6 +24,7 @@ packages: - lib/unison-prelude - lib/unison-sqlite - lib/unison-util-relation +- lib/unison-pretty-printer #compiler-check: match-exact resolver: lts-18.13 From 0adda1a855955c09ef736ce27aedf8169e5bb57b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 9 Mar 2022 11:21:24 -0600 Subject: [PATCH 012/529] Separate pretty-printer test suite --- lib/unison-pretty-printer/tests/Suite.hs | 55 +- .../tests/Unison/Test/ColorText.hs | 0 .../unison-pretty-printer.cabal | 1 + parser-typechecker/package.yaml | 2 + parser-typechecker/src/Unison/Util/Pretty.hs | 1154 ----------------- parser-typechecker/tests/Suite.hs | 6 - .../unison-parser-typechecker.cabal | 4 +- unison-cli/package.yaml | 1 + unison-cli/unison-cli.cabal | 5 + 9 files changed, 12 insertions(+), 1216 deletions(-) rename {parser-typechecker => lib/unison-pretty-printer}/tests/Unison/Test/ColorText.hs (100%) delete mode 100644 parser-typechecker/src/Unison/Util/Pretty.hs diff --git a/lib/unison-pretty-printer/tests/Suite.hs b/lib/unison-pretty-printer/tests/Suite.hs index 5fe5a76645..d34d793dc8 100644 --- a/lib/unison-pretty-printer/tests/Suite.hs +++ b/lib/unison-pretty-printer/tests/Suite.hs @@ -8,69 +8,16 @@ import System.Environment (getArgs) import System.IO import System.IO.CodePage (withCP65001) import qualified Unison.Core.Test.Name as Name -import qualified Unison.Test.ABT as ABT -import qualified Unison.Test.ANF as ANF -import qualified Unison.Test.Cache as Cache -import qualified Unison.Test.Codebase.Branch as Branch -import qualified Unison.Test.Codebase.Causal as Causal -import qualified Unison.Test.Codebase.Path as Path -import qualified Unison.Test.CodebaseInit as CodebaseInit import qualified Unison.Test.ColorText as ColorText -import qualified Unison.Test.DataDeclaration as DataDeclaration -import qualified Unison.Test.FileParser as FileParser -import qualified Unison.Test.Lexer as Lexer -import qualified Unison.Test.MCode as MCode import qualified Unison.Test.Range as Range -import qualified Unison.Test.Referent as Referent -import qualified Unison.Test.Term as Term -import qualified Unison.Test.TermParser as TermParser -import qualified Unison.Test.TermPrinter as TermPrinter -import qualified Unison.Test.Type as Type -import qualified Unison.Test.TypePrinter as TypePrinter -import qualified Unison.Test.Typechecker as Typechecker -import qualified Unison.Test.Typechecker.Context as Context -import qualified Unison.Test.Typechecker.TypeError as TypeError -import qualified Unison.Test.UnisonSources as UnisonSources -import qualified Unison.Test.Util.Bytes as Bytes -import qualified Unison.Test.Util.PinBoard as PinBoard import qualified Unison.Test.Util.Pretty as Pretty -import qualified Unison.Test.Util.Relation as Relation -import qualified Unison.Test.Util.Text as Text -import qualified Unison.Test.Var as Var test :: Test () test = tests - [ Cache.test, - Lexer.test, - Term.test, - TermParser.test, - TermPrinter.test, - Type.test, - TypeError.test, - TypePrinter.test, - UnisonSources.test, - FileParser.test, - DataDeclaration.test, - Range.test, + [ Range.test, ColorText.test, - Bytes.test, - Text.test, - Relation.test, - Path.test, - Causal.test, - Referent.test, - ABT.test, - ANF.test, - MCode.test, - Var.test, - Typechecker.test, - Context.test, - Name.test, Pretty.test, - PinBoard.test, - CodebaseInit.test, - Branch.test ] main :: IO () diff --git a/parser-typechecker/tests/Unison/Test/ColorText.hs b/lib/unison-pretty-printer/tests/Unison/Test/ColorText.hs similarity index 100% rename from parser-typechecker/tests/Unison/Test/ColorText.hs rename to lib/unison-pretty-printer/tests/Unison/Test/ColorText.hs diff --git a/lib/unison-pretty-printer/unison-pretty-printer.cabal b/lib/unison-pretty-printer/unison-pretty-printer.cabal index 08794a38c8..f0e111fcf1 100644 --- a/lib/unison-pretty-printer/unison-pretty-printer.cabal +++ b/lib/unison-pretty-printer/unison-pretty-printer.cabal @@ -115,6 +115,7 @@ test-suite pretty-printer-tests type: exitcode-stdio-1.0 main-is: Suite.hs other-modules: + Unison.Test.ColorText Unison.Test.Pretty Unison.Test.Range Paths_unison_pretty_printer diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index aa37399e59..2f1a86bcc4 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -136,6 +136,7 @@ library: - unison-core - unison-core1 - unison-prelude + - unison-pretty-printer - unison-util - unison-util-relation - open-browser @@ -178,3 +179,4 @@ executables: - unison-prelude - unison-util - unison-util-relation + - unison-pretty-printer diff --git a/parser-typechecker/src/Unison/Util/Pretty.hs b/parser-typechecker/src/Unison/Util/Pretty.hs deleted file mode 100644 index 760af3cd63..0000000000 --- a/parser-typechecker/src/Unison/Util/Pretty.hs +++ /dev/null @@ -1,1154 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Util.Pretty - ( Pretty, - ColorText, - align, - align', - alternations, - background, - backticked, - backticked', - boxForkLeft, - boxLeft, - boxLeftM, - boxRight, - boxRightM, - bulleted, - bracket, - -- breakable - callout, - excerptSep, - excerptSep', - excerptColumn2, - excerptColumn2Headed, - warnCallout, - blockedCallout, - fatalCallout, - okCallout, - column2, - column2sep, - column2Header, - column2M, - column2UnzippedM, - column3, - column3M, - column3UnzippedM, - column3sep, - commas, - commented, - oxfordCommas, - oxfordCommasWith, - plural, - dashed, - flatMap, - group, - hang', - hang, - hangUngrouped', - hangUngrouped, - softHang', - softHang, - softHangNoSpace', - indent, - indentAfterNewline, - indentN, - indentNonEmptyN, - indentNAfterNewline, - invert, - isMultiLine, - isEmpty, - leftPad, - lines, - linesNonEmpty, - linesSpaced, - lit, - map, - mayColumn2, - nest, - num, - newline, - leftJustify, - lineSkip, - nonEmpty, - numbered, - numberedColumn2, - numberedColumn2Header, - numberedList, - orElse, - orElses, - paragraphyText, - parenthesize, - parenthesizeCommas, - parenthesizeIf, - render, - renderUnbroken, - rightPad, - sep, - sepNonEmpty, - sepSpaced, - shown, - singleQuoted, - singleQuoted', - softbreak, - spaceIfBreak, - spaceIfNeeded, - spaced, - spacedMap, - spacesIfBreak, - string, - surroundCommas, - syntaxToColor, - table, - text, - toANSI, - toAnsiUnbroken, - toHTML, - toPlain, - toPlainUnbroken, - underline, - withSyntax, - wrap, - wrap', - wrapColumn2, - wrapString, - black, - red, - green, - yellow, - blue, - purple, - cyan, - white, - hiBlack, - hiRed, - hiGreen, - hiYellow, - hiBlue, - hiPurple, - hiCyan, - hiWhite, - bold, - border, - Width (..), - - -- * Exported for testing - delta, - Delta, - ) -where - -import Control.Monad.Identity (Identity (..), runIdentity) -import Data.Bifunctor (second) -import Data.Char (isSpace) -import Data.List (intersperse) -import qualified Data.ListLike as LL -import qualified Data.Sequence as Seq -import qualified Data.Text as Text -import Unison.Prelude -import Unison.Util.AnnotatedText (annotateMaybe) -import qualified Unison.Util.AnnotatedText as AT -import qualified Unison.Util.ColorText as CT -import Unison.Util.Monoid (intercalateMap) -import qualified Unison.Util.SyntaxText as ST -import Prelude hiding (lines, map) - -newtype Width = Width {widthToInt :: Int} - deriving (Eq, Ord, Show, Generic, Num, Bounded) - -type ColorText = CT.ColorText - -data Pretty s = Pretty {delta :: Delta, out :: F s (Pretty s)} deriving (Eq) - -instance Functor Pretty where - fmap f (Pretty d o) = Pretty d (mapLit f $ fmap (fmap f) o) - -data F s r - = Empty - | -- | A group adds a level of breaking. Layout tries not to break a group - -- unless needed to fit in available width. Breaking is done "outside in". - -- - -- (a | b) <> (c | d) will try (a <> c), then (b <> d) - -- - -- (a | b) <> group (c | d) will try (a <> c), then (b <> c), then (b <> d) - Group r - | Lit s - | Wrap (Seq r) - | OrElse r r - | Append (Seq r) - deriving (Eq, Show, Foldable, Traversable, Functor) - -isEmpty :: Eq s => IsString s => Pretty s -> Bool -isEmpty s = out s == Empty || out s == Lit "" - -mapLit :: (s -> t) -> F s r -> F t r -mapLit f (Lit s) = Lit (f s) -mapLit _ Empty = Empty -mapLit _ (Group r) = Group r -mapLit _ (Wrap s) = Wrap s -mapLit _ (OrElse r s) = OrElse r s -mapLit _ (Append s) = Append s - -lit :: (IsString s, LL.ListLike s Char) => s -> Pretty s -lit s = lit' (foldMap chDelta $ LL.toList s) s - -lit' :: Delta -> s -> Pretty s -lit' d s = Pretty d (Lit s) - -orElse :: Pretty s -> Pretty s -> Pretty s -orElse p1 p2 = Pretty (delta p1) (OrElse p1 p2) - -orElses :: [Pretty s] -> Pretty s -orElses [] = mempty -orElses ps = foldr1 orElse ps - -wrapImpl :: IsString s => [Pretty s] -> Pretty s -wrapImpl [] = mempty -wrapImpl (p : ps) = - wrap_ . Seq.fromList $ - p : fmap (\p -> (" " <> p) `orElse` (newline <> p)) ps - -wrapImplPreserveSpaces :: (LL.ListLike s Char, IsString s) => [Pretty s] -> Pretty s -wrapImplPreserveSpaces = \case - [] -> mempty - (p : ps) -> wrap_ . Seq.fromList $ p : fmap f ps - where - startsWithSpace p = case out p of - (Lit s) -> fromMaybe False (fmap (isSpaceNotNewline . fst) $ LL.uncons s) - _ -> False - f p | startsWithSpace p = p `orElse` newline - f p = p - -isSpaceNotNewline :: Char -> Bool -isSpaceNotNewline c = isSpace c && not (c == '\n') - -wrapString :: (LL.ListLike s Char, IsString s) => String -> Pretty s -wrapString s = wrap (lit $ fromString s) - --- Wrap text, preserving whitespace (apart from at the wrap points.) --- Used in particular for viewing/displaying doc literals. --- Should be understood in tandem with TermParser.docNormalize. --- See also unison-src/transcripts/doc-formatting.md. -paragraphyText :: (LL.ListLike s Char, IsString s) => Text -> Pretty s -paragraphyText = sep "\n" . fmap (wrapPreserveSpaces . text) . Text.splitOn "\n" - -wrap' :: IsString s => (s -> [Pretty s]) -> Pretty s -> Pretty s -wrap' wordify p = wrapImpl (toLeaves [p]) - where - toLeaves [] = [] - toLeaves (hd : tl) = case out hd of - Empty -> toLeaves tl - Lit s -> wordify s ++ toLeaves tl - Group _ -> hd : toLeaves tl - OrElse a _ -> toLeaves (a : tl) - Wrap _ -> hd : toLeaves tl - Append hds -> toLeaves (toList hds ++ tl) - -wrap :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -wrap = wrap' wordify - where - wordify s0 = - let s = LL.dropWhile isSpace s0 - in if LL.null s - then [] - else case LL.break isSpace s of (word1, s) -> lit word1 : wordify s - --- Does not insert spaces where none were present, and does not collapse --- sequences of spaces into one. --- It'd be a bit painful to just replace wrap with the following version, because --- lots of OutputMessages code depends on wrap's behaviour of sometimes adding --- extra spaces. -wrapPreserveSpaces :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -wrapPreserveSpaces p = wrapImplPreserveSpaces (toLeaves [p]) - where - toLeaves [] = [] - toLeaves (hd : tl) = case out hd of - Empty -> toLeaves tl - Lit s -> (fmap lit $ alternations isSpaceNotNewline s) ++ toLeaves tl - Group _ -> hd : toLeaves tl - OrElse a _ -> toLeaves (a : tl) - Wrap _ -> hd : toLeaves tl - Append hds -> toLeaves (toList hds ++ tl) - --- Cut a list every time a predicate changes. Produces a list of --- non-empty lists. -alternations :: (LL.ListLike s c) => (c -> Bool) -> s -> [s] -alternations p s = reverse $ go True s [] - where - go _ s acc | LL.null s = acc - go w s acc = go (not w) rest acc' - where - (t, rest) = LL.span p' s - p' = if w then p else (\x -> not (p x)) - acc' = if (LL.null t) then acc else t : acc - -wrap_ :: Seq (Pretty s) -> Pretty s -wrap_ ps = Pretty (foldMap delta ps) (Wrap ps) - -group :: Pretty s -> Pretty s -group p = Pretty (delta p) (Group p) - -toANSI :: Width -> Pretty CT.ColorText -> String -toANSI avail p = CT.toANSI (render avail p) - -toAnsiUnbroken :: Pretty ColorText -> String -toAnsiUnbroken p = CT.toANSI (renderUnbroken p) - -toPlain :: Width -> Pretty CT.ColorText -> String -toPlain avail p = CT.toPlain (render avail p) - -toHTML :: String -> Width -> Pretty CT.ColorText -> String -toHTML cssPrefix avail p = CT.toHTML cssPrefix (render avail p) - -toPlainUnbroken :: Pretty ColorText -> String -toPlainUnbroken p = CT.toPlain (renderUnbroken p) - -syntaxToColor :: Pretty (ST.SyntaxText' r) -> Pretty ColorText -syntaxToColor = fmap $ annotateMaybe . fmap CT.defaultColors - --- set the syntax, overriding any present syntax -withSyntax :: - ST.Element r -> Pretty (ST.SyntaxText' r) -> Pretty (ST.SyntaxText' r) -withSyntax e = fmap $ ST.syntax e - -renderUnbroken :: (Monoid s, IsString s) => Pretty s -> s -renderUnbroken = render maxBound - -render :: (Monoid s, IsString s) => Width -> Pretty s -> s -render availableWidth p = go mempty [Right p] - where - go _ [] = mempty - go cur (p : rest) = case p of - Right p -> - -- `p` might fit, let's try it! - if p `fits` cur - then flow p <> go (cur <> delta p) rest - else go cur (Left p : rest) -- nope, switch to breaking mode - Left p -> case out p of -- `p` requires breaking - Append ps -> go cur ((Left <$> toList ps) <> rest) - Empty -> go cur rest - Group p -> go cur (Right p : rest) - -- Note: literals can't be broken further so they're - -- added to output unconditionally - Lit l -> l <> go (cur <> delta p) rest - OrElse _ p -> go cur (Right p : rest) - Wrap ps -> go cur ((Right <$> toList ps) <> rest) - - flow p = case out p of - Append ps -> foldMap flow ps - Empty -> mempty - Group p -> flow p - Lit s -> s - OrElse p _ -> flow p - Wrap ps -> foldMap flow ps - - fits p cur = - maxCol (surgery cur <> delta p) < availableWidth - where - -- Surgically modify 'cur' to pretend it has not exceeded availableWidth. - -- This is necessary because sometimes things cannot be split and *must* - -- exceed availableWidth; in this case, we do not want to entirely "blame" - -- the new proposed (cur <> delta p) for this overflow. - -- - -- For example, when appending - -- - -- availableWidth - -- | - -- xxx | - -- yyyyyy - -- zz | - -- - -- with - -- - -- aa | - -- bb | - -- - -- we want to end up with - -- - -- xxx | - -- yyyyyy - -- zzaa| - -- bb | - -- - surgery = \case - SingleLine c -> SingleLine (min c (availableWidth - 1)) - MultiLine fc lc mc -> MultiLine fc lc (min mc (availableWidth - 1)) - -newline :: IsString s => Pretty s -newline = "\n" - -lineSkip :: IsString s => Pretty s -lineSkip = newline <> newline - -spaceIfNeeded :: Eq s => IsString s => Pretty s -> Pretty s -> Pretty s -spaceIfNeeded a b = if isEmpty a then b else a <> " " <> b - -spaceIfBreak :: IsString s => Pretty s -spaceIfBreak = "" `orElse` " " - -spacesIfBreak :: IsString s => Int -> Pretty s -spacesIfBreak n = "" `orElse` fromString (replicate n ' ') - -softbreak :: IsString s => Pretty s -softbreak = " " `orElse` newline - -spaced :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s -spaced = intercalateMap softbreak id - -spacedMap :: (Foldable f, IsString s) => (a -> Pretty s) -> f a -> Pretty s -spacedMap f as = spaced . fmap f $ toList as - -commas :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s -commas = intercalateMap ("," <> softbreak) id - -oxfordCommas :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s -oxfordCommas = oxfordCommasWith "" - --- Like `oxfordCommas`, but attaches `end` at the end (without a space). --- For example, `oxfordCommasWith "."` will attach a period. -oxfordCommasWith :: - (Foldable f, IsString s) => Pretty s -> f (Pretty s) -> Pretty s -oxfordCommasWith end xs = case toList xs of - [] -> "" - [x] -> group (x <> end) - [x, y] -> x <> " and " <> group (y <> end) - xs -> - intercalateMap ("," <> softbreak) id (init xs) - <> "," - <> softbreak - <> "and" - <> softbreak - <> group (last xs <> end) - -parenthesizeCommas :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s -parenthesizeCommas = surroundCommas "(" ")" - -surroundCommas :: - (Foldable f, IsString s) => - Pretty s -> - Pretty s -> - f (Pretty s) -> - Pretty s -surroundCommas start stop fs = - group $ - start - <> spaceIfBreak - <> intercalateMap ("," <> softbreak <> align) id fs - <> stop - where - align = spacesIfBreak (widthToInt $ preferredWidth start + 1) - -sepSpaced :: (Foldable f, IsString s) => Pretty s -> f (Pretty s) -> Pretty s -sepSpaced between = sep (between <> softbreak) - -sep :: (Foldable f, IsString s) => Pretty s -> f (Pretty s) -> Pretty s -sep between = intercalateMap between id - -sepNonEmpty :: (Foldable f, IsString s) => Pretty s -> f (Pretty s) -> Pretty s -sepNonEmpty between ps = sep between (nonEmpty ps) - --- if list is too long, adds `... 22 more` to the end -excerptSep :: IsString s => Maybe Int -> Pretty s -> [Pretty s] -> Pretty s -excerptSep maxCount = - excerptSep' maxCount (\i -> group ("... " <> shown i <> " more")) - -excerptSep' :: - IsString s => - Maybe Int -> - (Int -> Pretty s) -> - Pretty s -> - [Pretty s] -> - Pretty s -excerptSep' maxCount summarize s ps = case maxCount of - Just max - | length ps > max -> - sep s (take max ps) <> summarize (length ps - max) - _ -> sep s ps - -nonEmpty :: (Foldable f, IsString s) => f (Pretty s) -> [Pretty s] -nonEmpty (toList -> l) = case l of - (out -> Empty) : t -> nonEmpty t - h : t -> h : nonEmpty t - [] -> [] - -parenthesize :: IsString s => Pretty s -> Pretty s -parenthesize p = group $ "(" <> p <> ")" - -parenthesizeIf :: IsString s => Bool -> Pretty s -> Pretty s -parenthesizeIf False s = s -parenthesizeIf True s = parenthesize s - -lines :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s -lines = intercalateMap (append newline) id - where - append p = Pretty (delta p) (Append $ Seq.singleton p) - -linesNonEmpty :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s -linesNonEmpty = lines . nonEmpty - -linesSpaced :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s -linesSpaced ps = lines (intersperse "" $ toList ps) - -prefixed :: - (Foldable f, LL.ListLike s Char, IsString s) => - Pretty s -> - Pretty s -> - f (Pretty s) -> - Pretty s -prefixed first rest = - intercalateMap newline (\b -> first <> indentAfterNewline rest b) - -bulleted :: - (Foldable f, LL.ListLike s Char, IsString s) => f (Pretty s) -> Pretty s -bulleted = prefixed "* " " " - -dashed :: - (Foldable f, LL.ListLike s Char, IsString s) => f (Pretty s) -> Pretty s -dashed = prefixed "- " " " - -commented :: - (Foldable f, LL.ListLike s Char, IsString s) => f (Pretty s) -> Pretty s -commented = prefixed "-- " "-- " - -numbered :: - (Foldable f, LL.ListLike s Char, IsString s) => - (Int -> Pretty s) -> - f (Pretty s) -> - Pretty s -numbered num ps = column2 (fmap num [1 ..] `zip` toList ps) - -numberedHeader :: - (Foldable f, LL.ListLike s Char, IsString s) => - (Maybe Int -> Pretty s) -> - f (Pretty s) -> - Pretty s -numberedHeader num ps = column2 (fmap num (Nothing : fmap Just [1 ..]) `zip` toList ps) - --- Like `column2` but with the lines numbered. For instance: --- --- 1. one thing : this is a thing --- 2. another thing : this is another thing --- 3. and another : yet one more thing -numberedColumn2 :: - (Foldable f, LL.ListLike s Char, IsString s) => - (Int -> Pretty s) -> - f (Pretty s, Pretty s) -> - Pretty s -numberedColumn2 num ps = numbered num (align $ toList ps) - -numberedColumn2Header :: - (Foldable f, LL.ListLike s Char, IsString s) => - (Int -> Pretty s) -> - f (Pretty s, Pretty s) -> - Pretty s -numberedColumn2Header num ps = numberedHeader (maybe mempty num) (align $ toList ps) - --- Opinionated `numbered` that uses bold numbers in front -numberedList :: Foldable f => f (Pretty ColorText) -> Pretty ColorText -numberedList = numbered (\i -> hiBlack . fromString $ show i <> ".") - -leftPad, rightPad :: IsString s => Width -> Pretty s -> Pretty s -leftPad n p = - let rem = n - preferredWidth p - in if rem > 0 then fromString (replicate (widthToInt rem) ' ') <> p else p -rightPad n p = - let rem = n - preferredWidth p - in if rem > 0 then p <> fromString (replicate (widthToInt rem) ' ') else p - -excerptColumn2Headed :: - (LL.ListLike s Char, IsString s) => - Maybe Int -> - (Pretty s, Pretty s) -> - [(Pretty s, Pretty s)] -> - Pretty s -excerptColumn2Headed max hd cols = case max of - Just max - | len > max -> - lines [column2 (hd : take max cols), "... " <> shown (len - max) <> " more"] - _ -> column2 (hd : cols) - where - len = length cols - -excerptColumn2 :: - (LL.ListLike s Char, IsString s) => - Maybe Int -> - [(Pretty s, Pretty s)] -> - Pretty s -excerptColumn2 max cols = case max of - Just max | len > max -> lines [column2 cols, "... " <> shown (len - max)] - _ -> column2 cols - where - len = length cols - -table :: (IsString s, LL.ListLike s Char) => [[Pretty s]] -> Pretty s -table rows = lines (table' rows) - -table' :: (IsString s, LL.ListLike s Char) => [[Pretty s]] -> [Pretty s] -table' [] = mempty -table' rows = case maximum (Prelude.length <$> rows) of - 1 -> - rows >>= \case - [] -> [mempty] - hd : _ -> [hd] - _ -> - let colHd = [h | (h : _) <- rows] - colTl = [t | (_ : t) <- rows] - in align (fmap (<> " ") colHd `zip` (table' colTl)) - -column2 :: - (LL.ListLike s Char, IsString s) => [(Pretty s, Pretty s)] -> Pretty s -column2 = column2sep "" - -column2Header :: - Pretty ColorText -> Pretty ColorText -> [(Pretty ColorText, Pretty ColorText)] -> Pretty ColorText -column2Header left right = column2sep " " . ((fmap CT.hiBlack left, fmap CT.hiBlack right) :) - -column2sep :: - (LL.ListLike s Char, IsString s) => Pretty s -> [(Pretty s, Pretty s)] -> Pretty s -column2sep sep rows = lines . (group <$>) . align $ [(a, indent sep b) | (a, b) <- rows] - -column2M :: - (Applicative m, LL.ListLike s Char, IsString s) => - [m (Pretty s, Pretty s)] -> - m (Pretty s) -column2M = fmap column2 . sequenceA - -mayColumn2 :: - (LL.ListLike s Char, IsString s) => - [(Pretty s, Maybe (Pretty s))] -> - Pretty s -mayColumn2 = lines . (group <$>) . ((uncurry (<>)) <$>) . align' - -column3 :: - (LL.ListLike s Char, IsString s) => - [(Pretty s, Pretty s, Pretty s)] -> - Pretty s -column3 = column3sep "" - -column3M :: - (LL.ListLike s Char, IsString s, Monad m) => - [m (Pretty s, Pretty s, Pretty s)] -> - m (Pretty s) -column3M = fmap column3 . sequence - -column3UnzippedM :: - forall m s. - (LL.ListLike s Char, IsString s, Monad m) => - Pretty s -> - [m (Pretty s)] -> - [m (Pretty s)] -> - [m (Pretty s)] -> - m (Pretty s) -column3UnzippedM bottomPadding left mid right = - let rowCount = maximum (fmap length [left, mid, right]) - pad :: [m (Pretty s)] -> [m (Pretty s)] - pad a = a ++ replicate (rowCount - length a) (pure bottomPadding) - (pleft, pmid, pright) = (pad left, pad mid, pad right) - in column3M $ zipWith3 (liftA3 (,,)) pleft pmid pright - -column2UnzippedM :: - forall m s. - (LL.ListLike s Char, IsString s, Monad m) => - Pretty s -> - [m (Pretty s)] -> - [m (Pretty s)] -> - m (Pretty s) -column2UnzippedM bottomPadding left right = - let rowCount = length left `max` length right - pad :: [m (Pretty s)] -> [m (Pretty s)] - pad a = a ++ replicate (rowCount - length a) (pure bottomPadding) - sep :: [m (Pretty s)] -> [m (Pretty s)] - sep = fmap (fmap (" " <>)) - (pleft, pright) = (pad left, sep $ pad right) - in column2M $ zipWith (liftA2 (,)) pleft pright - -column3sep :: - (LL.ListLike s Char, IsString s) => Pretty s -> [(Pretty s, Pretty s, Pretty s)] -> Pretty s -column3sep sep rows = - let bc = align [(b, sep <> c) | (_, b, c) <- rows] - abc = group <$> align [(a, sep <> bc) | ((a, _, _), bc) <- rows `zip` bc] - in lines abc - -wrapColumn2 :: - (LL.ListLike s Char, IsString s) => [(Pretty s, Pretty s)] -> Pretty s -wrapColumn2 rows = lines (align rows) - where - align rows = - let lwidth = foldl' max 0 (preferredWidth . fst <$> rows) + 2 - in [ group (rightPad lwidth l <> indentNAfterNewline lwidth (wrap r)) - | (l, r) <- rows - ] - --- Pad with enough space on the right to make all rows the same width -leftJustify :: - (Eq s, Show s, LL.ListLike s Char, IsString s) => - [(Pretty s, a)] -> - [(Pretty s, a)] -leftJustify rows = - zip - ( fmap fst . align' $ - fmap - (\x -> (x, if isEmpty x then Nothing else Just "")) - ss - ) - as - where - (ss, as) = unzip rows - -align :: - (LL.ListLike s Char, IsString s) => [(Pretty s, Pretty s)] -> [Pretty s] -align rows = (((uncurry (<>)) <$>) . align') (second Just <$> rows) - --- [("foo", Just "bar") --- ,("barabaz", Nothing) --- ,("qux","quux")] --- --- results in: --- --- [("foo ", "bar"), --- [("barabaz", ""), --- [("qux ", "quuxbill")] --- --- The first component has padding added, sufficient to align the second --- component. The second component has whitespace added after its --- newlines, again sufficient to line it up in a second column. -align' :: - (LL.ListLike s Char, IsString s) => - [(Pretty s, Maybe (Pretty s))] -> - [(Pretty s, Pretty s)] -align' rows = alignedRows - where - col0Width = foldl' max 0 [preferredWidth col1 | (col1, Just _) <- rows] + 1 - alignedRows = - [ case col1 of - Just s -> (rightPad col0Width col0, indentNAfterNewline col0Width s) - Nothing -> (col0, mempty) - | (col0, col1) <- rows - ] - -text :: IsString s => Text -> Pretty s -text t = fromString (Text.unpack t) - -num :: (Show n, Num n, IsString s) => n -> Pretty s -num n = fromString (show n) - -string :: IsString s => String -> Pretty s -string = fromString - -shown :: (Show a, IsString s) => a -> Pretty s -shown = fromString . show - --- `softHang foo bar` will attempt to put the first line of `bar` right after --- `foo` on the same line, but will behave like `hang foo bar` if there's not --- enough horizontal space. --- --- Used for example to allow the `let` keyword to appear on the same line as --- an equals sign. --- --- myDef x = 'let --- y = f x --- g y --- --- But if the name is too long, the `'let` is allowed to float to the next line: --- --- myLongDef x = --- 'let --- y = f x --- g y --- --- To do this, we'd use `softHang "=" "'let" <> newline <> ...` --- -softHang :: - (LL.ListLike s Char, IsString s) => - Pretty s -> - Pretty s -> - Pretty s -softHang from = softHang' from " " - --- `softHang' by foo bar` will attempt to put `bar` right after `foo` on the same --- line, but will behave like `hang by foo bar` if there's not enough horizontal --- space for both `foo` and `bar`. -softHang' :: - (LL.ListLike s Char, IsString s) => - Pretty s -> - Pretty s -> - Pretty s -> - Pretty s -softHang' from by p = - group $ - (from <> " " <> group p) `orElse` (from <> "\n" <> group (indent by p)) - -softHangNoSpace' :: - (LL.ListLike s Char, IsString s) => - Pretty s -> - Pretty s -> - Pretty s -> - Pretty s -softHangNoSpace' from by p = - group $ (from <> group p) `orElse` (from <> "\n" <> group (indent by p)) - --- Same as `hang`, except instead of indenting by two spaces, it indents by --- the `by` argument. -hang' :: - (LL.ListLike s Char, IsString s) => - Pretty s -> - Pretty s -> - Pretty s -> - Pretty s -hang' from by p = - group $ - if isMultiLine p - then from <> "\n" <> group (indent by p) - else softHang' from by p - --- Indents its argument by two spaces, following `from`, so that the text --- seems to "hang" from it. --- --- For example, `hang "foo" ("bar" <> newline <> "baz")` results in: --- --- foo --- bar --- baz --- --- If the argument spans multiple lines, `hang` will always put it on the --- next line. But if it's only a single line, `hang` will attempt to fit it --- on the same line as `from`. --- --- For example, `hang "foo" "bar"`: --- --- foo bar --- -hang :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s -hang from = hang' from " " - -hangUngrouped' :: - (LL.ListLike s Char, IsString s) => - Pretty s -> - Pretty s -> - Pretty s -> - Pretty s -hangUngrouped' from by p = - if isMultiLine p - then from <> "\n" <> indent by p - else (from <> " " <> p) `orElse` (from <> "\n" <> indent by p) - -hangUngrouped :: - (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s -hangUngrouped from = hangUngrouped' from " " - -nest :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s -nest = hang' "" - -indent :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s -indent by p = by <> indentAfterNewline by p - -indentN :: (LL.ListLike s Char, IsString s) => Width -> Pretty s -> Pretty s -indentN by = indent (fromString $ replicate (widthToInt by) ' ') - -indentNonEmptyN :: - (LL.ListLike s Char, IsString s) => Width -> Pretty s -> Pretty s -indentNonEmptyN _ (out -> Empty) = mempty -indentNonEmptyN by p = indentN by p - -indentNAfterNewline :: - (LL.ListLike s Char, IsString s) => Width -> Pretty s -> Pretty s -indentNAfterNewline by = - indentAfterNewline (fromString $ replicate (widthToInt by) ' ') - -indentAfterNewline :: - (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s -indentAfterNewline by = flatMap f - where - f s0 = case LL.break (== '\n') s0 of - (hd, s) -> - if LL.null s - then lit s0 - else -- use `take` and `drop` to preserve annotations or - -- or other extra info attached to the original `s` - lit (LL.take (LL.length hd) s0) <> "\n" <> by <> f (LL.drop 1 s) - -instance IsString s => IsString (Pretty s) where - fromString s = lit' (foldMap chDelta s) (fromString s) - -instance Semigroup (Pretty s) where (<>) = mappend - -instance Monoid (Pretty s) where - mempty = Pretty mempty Empty - mappend p1 p2 = Pretty (delta p1 <> delta p2) - . Append - $ case (out p1, out p2) of - (Append ps1, Append ps2) -> ps1 <> ps2 - (Append ps1, _) -> ps1 <> pure p2 - (_, Append ps2) -> pure p1 <> ps2 - (_, _) -> pure p1 <> pure p2 - -data Delta - = -- | The number of columns. - SingleLine !Width - | -- | The number of columns in the first, last, and longest lines. - MultiLine !Width !Width !Width - deriving stock (Eq, Ord, Show) - -instance Semigroup Delta where - SingleLine c <> SingleLine c2 = SingleLine (c + c2) - SingleLine c <> MultiLine fc lc mc = - let fc' = c + fc - in MultiLine fc' lc (max fc' mc) - MultiLine fc lc mc <> SingleLine c = - let lc' = lc + c - in MultiLine fc lc' (max lc' mc) - MultiLine fc lc mc <> MultiLine fc2 lc2 mc2 = - MultiLine fc lc2 (max mc (max mc2 (lc + fc2))) - -instance Monoid Delta where - mempty = SingleLine 0 - mappend = (<>) - -maxCol :: Delta -> Width -maxCol = \case - SingleLine c -> c - MultiLine _ _ c -> c - -lastCol :: Delta -> Width -lastCol = \case - SingleLine c -> c - MultiLine _ c _ -> c - -chDelta :: Char -> Delta -chDelta '\n' = MultiLine 0 0 0 -chDelta _ = SingleLine 1 - -preferredWidth :: Pretty s -> Width -preferredWidth p = lastCol (delta p) - -isMultiLine :: Pretty s -> Bool -isMultiLine p = - case delta p of - SingleLine {} -> False - MultiLine {} -> True - -black, - red, - green, - yellow, - blue, - purple, - cyan, - white, - hiBlack, - hiRed, - hiGreen, - hiYellow, - hiBlue, - hiPurple, - hiCyan, - hiWhite, - bold, - underline :: - Pretty CT.ColorText -> Pretty CT.ColorText -black = map CT.black -red = map CT.red -green = map CT.green -yellow = map CT.yellow -blue = map CT.blue -purple = map CT.purple -cyan = map CT.cyan -white = map CT.white -hiBlack = map CT.hiBlack -hiRed = map CT.hiRed -hiGreen = map CT.hiGreen -hiYellow = map CT.hiYellow -hiBlue = map CT.hiBlue -hiPurple = map CT.hiPurple -hiCyan = map CT.hiCyan -hiWhite = map CT.hiWhite -bold = map CT.bold -underline = map CT.underline - --- invert the foreground and background colors -invert :: Pretty CT.ColorText -> Pretty CT.ColorText -invert = map CT.invert - --- set the background color, ex: `background hiBlue`, `background yellow` -background :: (Pretty CT.ColorText -> Pretty CT.ColorText) -> Pretty CT.ColorText -> Pretty CT.ColorText -background f p = - -- hack: discover the color of `f` by calling it on a dummy string - case f (Pretty mempty (Lit "-")) of - Pretty _ (Lit (AT.AnnotatedText (toList -> [AT.Segment _ (Just c)]))) -> map (CT.background c) p - _ -> p - -plural :: - Foldable f => - f a -> - Pretty ColorText -> - Pretty ColorText -plural f p = case length f of - 0 -> mempty - 1 -> p - -- todo: consider use of plural package - _ -> - p <> case reverse (toPlainUnbroken p) of - 's' : _ -> "es" - _ -> "s" - -border :: (LL.ListLike s Char, IsString s) => Width -> Pretty s -> Pretty s -border n p = "\n" <> indentN n p <> "\n" - -callout :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -> Pretty s -callout header p = header <> "\n\n" <> p - -bracket :: (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -bracket = indent " " - -boxForkLeft, - boxLeft, - boxRight :: - forall s. (LL.ListLike s Char, IsString s) => [Pretty s] -> [Pretty s] -boxForkLeft = boxLeft' lBoxStyle1 -boxLeft = boxLeft' lBoxStyle2 -boxRight = boxRight' rBoxStyle2 - -boxLeft', - boxRight' :: - (LL.ListLike s Char, IsString s) => - BoxStyle s -> - [Pretty s] -> - [Pretty s] -boxLeft' style = fmap runIdentity . boxLeftM' style . fmap Identity -boxRight' style = fmap runIdentity . boxRightM' style . fmap Identity - -type BoxStyle s = - ( (Pretty s, Pretty s), -- first (start, continue) - (Pretty s, Pretty s), -- middle - (Pretty s, Pretty s), -- last - (Pretty s, Pretty s) -- singleton - ) - -lBoxStyle1, lBoxStyle2, rBoxStyle2 :: IsString s => BoxStyle s -lBoxStyle1 = - ( ("โ”Œ ", "โ”‚ "), -- first - ("โ”œ ", "โ”‚ "), -- middle - ("โ”” ", " "), -- last - ("", "") -- singleton - ) -lBoxStyle2 = - ( ("โ”Œ ", " "), - ("โ”‚ ", " "), - ("โ”” ", " "), - ("", "") - ) -rBoxStyle2 = - ( (" โ”", " โ”‚"), - (" โ”‚", " โ”‚"), - (" โ”˜", " "), - (" ", " ") - ) - -boxLeftM, - boxRightM :: - forall m s. - (Monad m, LL.ListLike s Char, IsString s) => - [m (Pretty s)] -> - [m (Pretty s)] -boxLeftM = boxLeftM' lBoxStyle2 -boxRightM = boxRightM' rBoxStyle2 - -boxLeftM' :: - forall m s. - (Monad m, LL.ListLike s Char, IsString s) => - BoxStyle s -> - [m (Pretty s)] -> - [m (Pretty s)] -boxLeftM' (first, middle, last, singleton) ps = go (Seq.fromList ps) - where - go Seq.Empty = [] - go (p Seq.:<| Seq.Empty) = [decorate singleton <$> p] - go (a Seq.:<| (mid Seq.:|> b)) = - [decorate first <$> a] - ++ toList (fmap (decorate middle) <$> mid) - ++ [decorate last <$> b] - decorate (first, mid) p = first <> indentAfterNewline mid p - --- this implementation doesn't work for multi-line inputs, --- because i dunno how to inspect multi-line inputs - -boxRightM' :: - forall m s. - (Monad m, LL.ListLike s Char, IsString s) => - BoxStyle s -> - [m (Pretty s)] -> - [m (Pretty s)] -boxRightM' (first, middle, last, singleton) ps = go (Seq.fromList ps) - where - go :: Seq.Seq (m (Pretty s)) -> [m (Pretty s)] - go Seq.Empty = [] - go (p Seq.:<| Seq.Empty) = [decorate singleton <$> p] - go (a Seq.:<| (mid Seq.:|> b)) = - [decorate first <$> a] - ++ toList (fmap (decorate middle) <$> mid) - ++ [decorate last <$> b] - decorate (first, _mid) p = p <> first - -warnCallout, - blockedCallout, - fatalCallout, - okCallout :: - (LL.ListLike s Char, IsString s) => Pretty s -> Pretty s -warnCallout = callout "โš ๏ธ" -fatalCallout = callout "โ—๏ธ" -okCallout = callout "โœ…" -blockedCallout = callout "๐Ÿšซ" - -backticked :: IsString s => Pretty s -> Pretty s -backticked p = group ("`" <> p <> "`") - --- | Attach some punctuation after the closing backtick. -backticked' :: IsString s => Pretty s -> Pretty s -> Pretty s -backticked' p end = group ("`" <> p <> "`" <> end) - -singleQuoted :: IsString s => Pretty s -> Pretty s -singleQuoted p = "'" <> p <> "'" - -singleQuoted' :: IsString s => Pretty s -> Pretty s -> Pretty s -singleQuoted' p end = "'" <> p <> "'" <> end - -instance Show s => Show (Pretty s) where - show p = render 80 (metaPretty p) - -metaPretty :: Show s => Pretty s -> Pretty String -metaPretty = go (0 :: Int) - where - go prec p = case out p of - Lit s -> parenthesizeIf (prec > 0) $ "Lit" `hang` lit (show s) - Empty -> "Empty" - Group g -> parenthesizeIf (prec > 0) $ "Group" `hang` go 1 g - Wrap s -> - parenthesizeIf (prec > 0) $ - "Wrap" - `hang` surroundCommas "[" "]" (go 1 <$> s) - OrElse a b -> - parenthesizeIf (prec > 0) $ - "OrElse" `hang` spaced [go 1 a, go 1 b] - Append s -> surroundCommas "[" "]" (go 1 <$> s) - -map :: LL.ListLike s2 Char => (s -> s2) -> Pretty s -> Pretty s2 -map f p = case out p of - Append ps -> foldMap (map f) ps - Empty -> mempty - Group p -> group (map f p) - Lit s -> lit' (foldMap chDelta $ LL.toList s2) s2 where s2 = f s - OrElse p1 p2 -> orElse (map f p1) (map f p2) - Wrap p -> wrap_ (map f <$> p) - -flatMap :: (s -> Pretty s2) -> Pretty s -> Pretty s2 -flatMap f p = case out p of - Append ps -> foldMap (flatMap f) ps - Empty -> mempty - Group p -> group (flatMap f p) - Lit s -> f s - OrElse p1 p2 -> orElse (flatMap f p1) (flatMap f p2) - Wrap p -> wrap_ (flatMap f <$> p) diff --git a/parser-typechecker/tests/Suite.hs b/parser-typechecker/tests/Suite.hs index 5fe5a76645..ab4abe2641 100644 --- a/parser-typechecker/tests/Suite.hs +++ b/parser-typechecker/tests/Suite.hs @@ -15,12 +15,10 @@ import qualified Unison.Test.Codebase.Branch as Branch import qualified Unison.Test.Codebase.Causal as Causal import qualified Unison.Test.Codebase.Path as Path import qualified Unison.Test.CodebaseInit as CodebaseInit -import qualified Unison.Test.ColorText as ColorText import qualified Unison.Test.DataDeclaration as DataDeclaration import qualified Unison.Test.FileParser as FileParser import qualified Unison.Test.Lexer as Lexer import qualified Unison.Test.MCode as MCode -import qualified Unison.Test.Range as Range import qualified Unison.Test.Referent as Referent import qualified Unison.Test.Term as Term import qualified Unison.Test.TermParser as TermParser @@ -33,7 +31,6 @@ import qualified Unison.Test.Typechecker.TypeError as TypeError import qualified Unison.Test.UnisonSources as UnisonSources import qualified Unison.Test.Util.Bytes as Bytes import qualified Unison.Test.Util.PinBoard as PinBoard -import qualified Unison.Test.Util.Pretty as Pretty import qualified Unison.Test.Util.Relation as Relation import qualified Unison.Test.Util.Text as Text import qualified Unison.Test.Var as Var @@ -52,8 +49,6 @@ test = UnisonSources.test, FileParser.test, DataDeclaration.test, - Range.test, - ColorText.test, Bytes.test, Text.test, Relation.test, @@ -67,7 +62,6 @@ test = Typechecker.test, Context.test, Name.test, - Pretty.test, PinBoard.test, CodebaseInit.test, Branch.test diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 83dcb283f4..cef80c191a 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -173,7 +173,6 @@ library Unison.Util.Free Unison.Util.Logger Unison.Util.PinBoard - Unison.Util.Pretty Unison.Util.Rope Unison.Util.Star3 Unison.Util.Text @@ -293,6 +292,7 @@ library , unison-core , unison-core1 , unison-prelude + , unison-pretty-printer , unison-util , unison-util-relation , unliftio @@ -321,7 +321,6 @@ executable tests Unison.Test.Codebase.Causal Unison.Test.Codebase.Path Unison.Test.CodebaseInit - Unison.Test.ColorText Unison.Test.Common Unison.Test.DataDeclaration Unison.Test.FileParser @@ -397,6 +396,7 @@ executable tests , unison-core1 , unison-parser-typechecker , unison-prelude + , unison-pretty-printer , unison-util , unison-util-relation , unliftio diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 13a29159a5..9830f2da89 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -40,6 +40,7 @@ dependencies: - unison-prelude - unison-util - unison-util-relation + - unison-pretty-printer - unliftio library: diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 87a3100902..5c9a47e8e1 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -108,6 +108,7 @@ library , unison-core1 , unison-parser-typechecker , unison-prelude + , unison-pretty-printer , unison-util , unison-util-relation , unliftio @@ -185,6 +186,7 @@ executable integration-tests , unison-core1 , unison-parser-typechecker , unison-prelude + , unison-pretty-printer , unison-util , unison-util-relation , unliftio @@ -256,6 +258,7 @@ executable transcripts , unison-core1 , unison-parser-typechecker , unison-prelude + , unison-pretty-printer , unison-util , unison-util-relation , unliftio @@ -331,6 +334,7 @@ executable unison , unison-core1 , unison-parser-typechecker , unison-prelude + , unison-pretty-printer , unison-util , unison-util-relation , unliftio @@ -410,6 +414,7 @@ test-suite tests , unison-core1 , unison-parser-typechecker , unison-prelude + , unison-pretty-printer , unison-util , unison-util-relation , unliftio From f0267f1099f90c5bdf5c2c39af6f46d4e2861040 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 9 Mar 2022 11:25:29 -0600 Subject: [PATCH 013/529] Revert unexpected changes to release.yaml --- .github/workflows/release.yaml | 141 ++++++++++----------------------- 1 file changed, 40 insertions(+), 101 deletions(-) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 7a86976fef..2a1efe31ba 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -3,7 +3,7 @@ name: "release" on: push: tags: - - "test-release/*" + - "release/*" jobs: release: @@ -12,7 +12,7 @@ jobs: needs: - build_linux - build_macos - - build_windows + # - build_windows steps: - uses: actions/checkout@v2 @@ -35,45 +35,42 @@ jobs: env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} with: - files: | - /tmp/ucm/**/*.tar.gz - /tmp/ucm/**/*.zip + files: /tmp/ucm/**/*.tar.gz - # build_linux: + build_linux: - # name: "build_linux" - # runs-on: ubuntu-18.04 + name: "build_linux" + runs-on: ubuntu-18.04 - # steps: - # - uses: actions/checkout@v2 - # - name: install stack - # run: | - # curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz | tar -xz - # echo "$HOME/stack-2.5.1-linux-x86_64/" >> $GITHUB_PATH + steps: + - uses: actions/checkout@v2 + - name: install stack + run: | + curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz | tar -xz + echo "$HOME/stack-2.5.1-linux-x86_64/" >> $GITHUB_PATH - # - name: build - # run: stack --no-terminal build --flag unison-parser-typechecker:optimized + - name: build + run: stack --no-terminal build --flag unison-parser-typechecker:optimized - # - name: fetch latest codebase-ui and package with ucm - # run: | - # mkdir -p /tmp/ucm/ui - # UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison - # cp $UCM /tmp/ucm/ucm - # wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip - # unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip - # tar -c -z -f ucm-linux.tar.gz -C /tmp/ucm . - - # - name: Upload linux artifact - # uses: actions/upload-artifact@v2 - # with: - # if-no-files-found: error - # name: build-linux - # path: ucm-linux.tar.gz + - name: fetch latest codebase-ui and package with ucm + run: | + mkdir -p /tmp/ucm/ui + UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison + cp $UCM /tmp/ucm/ucm + wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip + unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip + tar -c -z -f ucm-linux.tar.gz -C /tmp/ucm . -<<<<<<< Updated upstream - build_windows: - name: "build_windows" - runs-on: windows-2019 + - name: Upload linux artifact + uses: actions/upload-artifact@v2 + with: + if-no-files-found: error + name: build-linux + path: ucm-linux.tar.gz + + build_macos: + name: "build_macos" + runs-on: macos-10.15 steps: - uses: actions/checkout@v2 @@ -82,6 +79,9 @@ jobs: curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz | tar -xz echo "$HOME/stack-2.5.1-osx-x86_64/" >> $GITHUB_PATH + - name: remove ~/.stack/setup-exe-cache on macOS + run: rm -rf ~/.stack/setup-exe-cache + - name: build run: stack --no-terminal build --flag unison-parser-typechecker:optimized @@ -92,15 +92,15 @@ jobs: cp $UCM /tmp/ucm/ucm wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip - tar -c -z -f ucm-windows.tar.gz -C /tmp/ucm . + tar -c -z -f ucm-macos.tar.gz -C /tmp/ucm . - - name: Upload windows artifact + - name: Upload macos artifact uses: actions/upload-artifact@v2 with: if-no-files-found: error - name: build-windows - path: ucm-windows.tar.gz -||||||| constructed merge base + name: build-macos + path: ucm-macos.tar.gz + # build_windows: # name: "build_windows" # runs-on: windows-2019 @@ -127,64 +127,3 @@ jobs: # if-no-files-found: error # name: build-windows # path: ucm-windows.zip -======= - # build_macos: - # name: "build_macos" - # runs-on: macos-10.15 - - # steps: - # - uses: actions/checkout@v2 - # - name: install stack - # run: | - # curl -L https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz | tar -xz - # echo "$HOME/stack-2.5.1-osx-x86_64/" >> $GITHUB_PATH - - # - name: remove ~/.stack/setup-exe-cache on macOS - # run: rm -rf ~/.stack/setup-exe-cache - - # - name: build - # run: stack --no-terminal build --flag unison-parser-typechecker:optimized - - # - name: fetch latest codebase-ui and package with ucm - # run: | - # mkdir -p /tmp/ucm/ui - # UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison - # cp $UCM /tmp/ucm/ucm - # wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip - # unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip - # tar -c -z -f ucm-macos.tar.gz -C /tmp/ucm . - - # - name: Upload macos artifact - # uses: actions/upload-artifact@v2 - # with: - # if-no-files-found: error - # name: build-macos - # path: ucm-macos.tar.gz - - build_windows: - name: "build_windows" - runs-on: windows-2019 - - steps: - - uses: actions/checkout@v2 - - name: build - run: stack --no-terminal build --flag unison-parser-typechecker:optimized - - - name: fetch latest codebase-ui and package with ucm - # Powershell - run: | - mkdir -p tmp\ui - mkdir -p release\ui - $UCM = stack exec -- where unison - cp $UCM .\release\ucm.exe - Invoke-WebRequest -Uri https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip -OutFile tmp\unisonLocal.zip - Expand-Archive -Path tmp\unisonLocal.zip -DestinationPath release\ui - Compress-Archive -Path .\release\* -DestinationPath ucm-windows.zip - - - name: Upload windows artifact - uses: actions/upload-artifact@v2 - with: - if-no-files-found: error - name: build-windows - path: ucm-windows.zip ->>>>>>> Stashed changes From bdb7aa793c761f42533810557628c79c80e9c8b3 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 9 Mar 2022 11:39:35 -0600 Subject: [PATCH 014/529] Fix pretty-printer tests --- lib/unison-pretty-printer/LICENSE | 2 +- lib/unison-pretty-printer/package.yaml | 4 ++++ lib/unison-pretty-printer/tests/Suite.hs | 3 +-- lib/unison-pretty-printer/tests/Unison/Test/ColorText.hs | 2 +- lib/unison-pretty-printer/tests/Unison/Test/Range.hs | 2 +- .../tests/Unison/Test/{ => Util}/Pretty.hs | 0 lib/unison-pretty-printer/unison-pretty-printer.cabal | 6 +++++- 7 files changed, 13 insertions(+), 6 deletions(-) rename lib/unison-pretty-printer/tests/Unison/Test/{ => Util}/Pretty.hs (100%) diff --git a/lib/unison-pretty-printer/LICENSE b/lib/unison-pretty-printer/LICENSE index c45ac9a548..2d9c5682e8 100644 --- a/lib/unison-pretty-printer/LICENSE +++ b/lib/unison-pretty-printer/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013-2021, Unison Computing, public benefit corp and contributors +Copyright (c) 2013-2022, Unison Computing, public benefit corp and contributors Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal diff --git a/lib/unison-pretty-printer/package.yaml b/lib/unison-pretty-printer/package.yaml index 8ec552f306..c2b77be01b 100644 --- a/lib/unison-pretty-printer/package.yaml +++ b/lib/unison-pretty-printer/package.yaml @@ -70,3 +70,7 @@ tests: dependencies: - base - unison-pretty-printer + - raw-strings-qq + - easytest + - containers + - code-page diff --git a/lib/unison-pretty-printer/tests/Suite.hs b/lib/unison-pretty-printer/tests/Suite.hs index d34d793dc8..017998d370 100644 --- a/lib/unison-pretty-printer/tests/Suite.hs +++ b/lib/unison-pretty-printer/tests/Suite.hs @@ -7,7 +7,6 @@ import EasyTest import System.Environment (getArgs) import System.IO import System.IO.CodePage (withCP65001) -import qualified Unison.Core.Test.Name as Name import qualified Unison.Test.ColorText as ColorText import qualified Unison.Test.Range as Range import qualified Unison.Test.Util.Pretty as Pretty @@ -17,7 +16,7 @@ test = tests [ Range.test, ColorText.test, - Pretty.test, + Pretty.test ] main :: IO () diff --git a/lib/unison-pretty-printer/tests/Unison/Test/ColorText.hs b/lib/unison-pretty-printer/tests/Unison/Test/ColorText.hs index 31a1de5d37..f34dd762cc 100644 --- a/lib/unison-pretty-printer/tests/Unison/Test/ColorText.hs +++ b/lib/unison-pretty-printer/tests/Unison/Test/ColorText.hs @@ -7,7 +7,7 @@ module Unison.Test.ColorText where import qualified Data.Map as Map import EasyTest import Text.RawString.QQ -import Unison.Lexer (Pos (..)) +import Unison.Lexer.Pos (Pos (..)) import Unison.Util.AnnotatedText ( AnnotatedExcerpt (..), condensedExcerptToText, diff --git a/lib/unison-pretty-printer/tests/Unison/Test/Range.hs b/lib/unison-pretty-printer/tests/Unison/Test/Range.hs index 91f11a07fe..92cc29c87c 100644 --- a/lib/unison-pretty-printer/tests/Unison/Test/Range.hs +++ b/lib/unison-pretty-printer/tests/Unison/Test/Range.hs @@ -1,7 +1,7 @@ module Unison.Test.Range where import EasyTest -import Unison.Lexer (Pos (..)) +import Unison.Lexer.Pos (Pos (..)) import Unison.Util.Range test :: Test () diff --git a/lib/unison-pretty-printer/tests/Unison/Test/Pretty.hs b/lib/unison-pretty-printer/tests/Unison/Test/Util/Pretty.hs similarity index 100% rename from lib/unison-pretty-printer/tests/Unison/Test/Pretty.hs rename to lib/unison-pretty-printer/tests/Unison/Test/Util/Pretty.hs diff --git a/lib/unison-pretty-printer/unison-pretty-printer.cabal b/lib/unison-pretty-printer/unison-pretty-printer.cabal index f0e111fcf1..9a6186f05a 100644 --- a/lib/unison-pretty-printer/unison-pretty-printer.cabal +++ b/lib/unison-pretty-printer/unison-pretty-printer.cabal @@ -116,8 +116,8 @@ test-suite pretty-printer-tests main-is: Suite.hs other-modules: Unison.Test.ColorText - Unison.Test.Pretty Unison.Test.Range + Unison.Test.Util.Pretty Paths_unison_pretty_printer hs-source-dirs: tests @@ -145,6 +145,10 @@ test-suite pretty-printer-tests ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 build-depends: base + , code-page + , containers + , easytest + , raw-strings-qq , unison-pretty-printer if flag(optimized) ghc-options: -funbox-strict-fields -O2 From 578573c4596d7ead6654f6786ded3bd419dfb777 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 10 Mar 2022 10:38:28 -0600 Subject: [PATCH 015/529] Fix broken windows release automation (#2976) * Fix broken commands on windows release automation --- .github/workflows/release.yaml | 58 ++++++++++++++++++---------------- 1 file changed, 30 insertions(+), 28 deletions(-) diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 2a1efe31ba..5ee1df95f3 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -12,7 +12,7 @@ jobs: needs: - build_linux - build_macos - # - build_windows + - build_windows steps: - uses: actions/checkout@v2 @@ -35,7 +35,9 @@ jobs: env: GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} with: - files: /tmp/ucm/**/*.tar.gz + files: | + /tmp/ucm/**/*.tar.gz + /tmp/ucm/**/*.zip build_linux: @@ -101,29 +103,29 @@ jobs: name: build-macos path: ucm-macos.tar.gz - # build_windows: - # name: "build_windows" - # runs-on: windows-2019 - - # steps: - # - uses: actions/checkout@v2 - # - name: build - # run: stack --no-terminal build --flag unison-parser-typechecker:optimized - - # - name: fetch latest codebase-ui and package with ucm - # # Powershell - # run: | - # mkdir -p tmp\ui - # mkdir -p release\ui - # $UCM = stack exec -- where unison - # cp $UCM .\release\ucm.exe - # Invoke-WebRequest -Uri https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip -OutFile tmp\unisonLocal.zip - # Expand-Archive -Path tmp\unisonLocal.zip -DestinationPath release\ui - # Compress-Archive -Path .\release\* -DestinationPath ucm-windows.zip - - # - name: Upload windows artifact - # uses: actions/upload-artifact@v2 - # with: - # if-no-files-found: error - # name: build-windows - # path: ucm-windows.zip + build_windows: + name: "build_windows" + runs-on: windows-2019 + + steps: + - uses: actions/checkout@v2 + - name: build + run: stack --no-terminal build --flag unison-parser-typechecker:optimized + + - name: fetch latest codebase-ui and package with ucm + # Powershell + run: | + mkdir -p tmp\ui + mkdir -p release\ui + $UCM = stack exec -- where unison + cp $UCM .\release\ucm.exe + Invoke-WebRequest -Uri https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip -OutFile tmp\unisonLocal.zip + Expand-Archive -Path tmp\unisonLocal.zip -DestinationPath release\ui + Compress-Archive -Path .\release\* -DestinationPath ucm-windows.zip + + - name: Upload windows artifact + uses: actions/upload-artifact@v2 + with: + if-no-files-found: error + name: build-windows + path: ucm-windows.zip From a20a98a61a7dae1c64dc5a8837733e42ecd351a2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Thu, 17 Mar 2022 21:49:25 -0400 Subject: [PATCH 016/529] Add update.nopatch command --- .../src/Unison/Codebase/Editor/HandleInput.hs | 142 ++++++++++-------- .../src/Unison/Codebase/Editor/Input.hs | 6 +- .../src/Unison/CommandLine/InputPatterns.hs | 54 ++++++- 3 files changed, 127 insertions(+), 75 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 10300bceaa..90fca1df04 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -377,7 +377,12 @@ loop = do ResolveTermNameI path -> "resolve.termName " <> hqs' path ResolveTypeNameI path -> "resolve.typeName " <> hqs' path AddI _selection -> "add" - UpdateI p _selection -> "update " <> opatch p + UpdateI p _selection -> + "update" <> (case p of + NoPatch -> ".nopatch" + DefaultPatch -> " " <> ps' defaultPatchPath + UsePatch p -> " " <> ps' p + ) PropagatePatchI p scope -> "patch " <> ps' p <> " " <> p' scope UndoI {} -> "undo" ApiI -> "api" @@ -1283,7 +1288,8 @@ loop = do let sr = Slurp.slurpFile uf vars Slurp.AddOp currentNames previewResponse sourceName sr uf _ -> respond NoUnisonFile - UpdateI maybePatchPath requestedNames -> handleUpdate input maybePatchPath requestedNames + UpdateI optionalPatch requestedNames -> + handleUpdate input optionalPatch requestedNames PreviewUpdateI requestedNames -> case (latestFile', uf) of (Just (sourceName, _), Just uf) -> do let vars = Set.map Name.toVar requestedNames @@ -1808,8 +1814,8 @@ handleShowDefinition outputLoc inputQuery = do Just (path, _) -> Just path -- | Handle an @update@ command. -handleUpdate :: forall m v. (Monad m, Var v) => Input -> Maybe PatchPath -> Set Name -> Action' m v () -handleUpdate input maybePatchPath requestedNames = do +handleUpdate :: forall m v. (Monad m, Var v) => Input -> OptionalPatch -> Set Name -> Action' m v () +handleUpdate input optionalPatch requestedNames = do let requestedVars = Set.map Name.toVar requestedNames use LoopState.latestTypecheckedFile >>= \case Nothing -> respond NoUnisonFile @@ -1822,7 +1828,10 @@ handleUpdate input maybePatchPath requestedNames = do let (p, seg) = Path.toAbsoluteSplit currentPath' patchPath' b <- getAt p eval . Eval $ Branch.getPatch seg (Branch.head b) - let patchPath = fromMaybe defaultPatchPath maybePatchPath + let patchPath = case optionalPatch of + NoPatch -> Nothing + DefaultPatch -> Just defaultPatchPath + UsePatch p -> Just p slurpCheckNames <- slurpResultNames let currentPathNames = slurpCheckNames let sr = Slurp.slurpFile uf requestedVars Slurp.UpdateOp slurpCheckNames @@ -1871,82 +1880,82 @@ handleUpdate input maybePatchPath requestedNames = do | (oldTypeRef, _) <- Map.elems typeEdits, (n, r) <- Names.constructorsForType oldTypeRef currentPathNames ] - - ye'ol'Patch <- getPatchAt patchPath - -- If `uf` updates a -> a', we want to replace all (a0 -> a) in patch - -- with (a0 -> a') in patch'. - -- So for all (a0 -> a) in patch, for all (a -> a') in `uf`, - -- we must know the type of a0, a, a'. - let -- we need: - -- all of the `old` references from the `new` edits, - -- plus all of the `old` references for edits from patch we're replacing - collectOldForTyping :: [(Reference, Reference)] -> Patch -> Set Reference - collectOldForTyping new old = foldl' f mempty (new ++ fromOld) - where - f acc (r, _r') = Set.insert r acc - newLHS = Set.fromList . fmap fst $ new - fromOld :: [(Reference, Reference)] - fromOld = - [ (r, r') | (r, TermEdit.Replace r' _) <- R.toList . Patch._termEdits $ old, Set.member r' newLHS - ] - neededTypes = collectOldForTyping (toList termEdits) ye'ol'Patch - - allTypes :: Map Reference (Type v Ann) <- - fmap Map.fromList . for (toList neededTypes) $ \r -> - (r,) . fromMaybe (Type.builtin External "unknown type") - <$> (eval . LoadTypeOfTerm) r - - let typing r1 r2 = case (Map.lookup r1 allTypes, Map.lookup r2 hashTerms) of - (Just t1, Just t2) - | Typechecker.isEqual t1 t2 -> TermEdit.Same - | Typechecker.isSubtype t1 t2 -> TermEdit.Subtype - | otherwise -> TermEdit.Different - e -> - error $ - "compiler bug: typing map not constructed properly\n" - <> "typing " - <> show r1 - <> " " - <> show r2 - <> " : " - <> show e - - let updatePatch :: Patch -> Patch - updatePatch p = foldl' step2 p' termEdits - where - p' = foldl' step1 p typeEdits - step1 p (r, r') = Patch.updateType r (TypeEdit.Replace r') p - step2 p (r, r') = Patch.updateTerm typing r (TermEdit.Replace r' (typing r r')) p - (p, seg) = Path.toAbsoluteSplit currentPath' patchPath - updatePatches :: Branch0 m -> m (Branch0 m) - updatePatches = Branch.modifyPatches seg updatePatch + patchOps <- for patchPath $ \patchPath -> do + ye'ol'Patch <- getPatchAt patchPath + -- If `uf` updates a -> a', we want to replace all (a0 -> a) in patch + -- with (a0 -> a') in patch'. + -- So for all (a0 -> a) in patch, for all (a -> a') in `uf`, + -- we must know the type of a0, a, a'. + let -- we need: + -- all of the `old` references from the `new` edits, + -- plus all of the `old` references for edits from patch we're replacing + collectOldForTyping :: [(Reference, Reference)] -> Patch -> Set Reference + collectOldForTyping new old = foldl' f mempty (new ++ fromOld) + where + f acc (r, _r') = Set.insert r acc + newLHS = Set.fromList . fmap fst $ new + fromOld :: [(Reference, Reference)] + fromOld = + [ (r, r') | (r, TermEdit.Replace r' _) <- R.toList . Patch._termEdits $ old, Set.member r' newLHS + ] + neededTypes = collectOldForTyping (toList termEdits) ye'ol'Patch + + allTypes :: Map Reference (Type v Ann) <- + fmap Map.fromList . for (toList neededTypes) $ \r -> + (r,) . fromMaybe (Type.builtin External "unknown type") + <$> (eval . LoadTypeOfTerm) r + + let typing r1 r2 = case (Map.lookup r1 allTypes, Map.lookup r2 hashTerms) of + (Just t1, Just t2) + | Typechecker.isEqual t1 t2 -> TermEdit.Same + | Typechecker.isSubtype t1 t2 -> TermEdit.Subtype + | otherwise -> TermEdit.Different + e -> + error $ + "compiler bug: typing map not constructed properly\n" + <> "typing " + <> show r1 + <> " " + <> show r2 + <> " : " + <> show e + + updatePatch :: Patch -> Patch + updatePatch p = foldl' step2 p' termEdits + where + p' = foldl' step1 p typeEdits + step1 p (r, r') = Patch.updateType r (TypeEdit.Replace r') p + step2 p (r, r') = Patch.updateTerm typing r (TermEdit.Replace r' (typing r r')) p + (p, seg) = Path.toAbsoluteSplit currentPath' patchPath + updatePatches :: Branch0 m -> m (Branch0 m) + updatePatches = Branch.modifyPatches seg updatePatch + pure (updatePatch ye'ol'Patch, updatePatches, p) when (Slurp.hasAddsOrUpdates sr) $ do -- take a look at the `updates` from the SlurpResult -- and make a patch diff to record a replacement from the old to new references stepManyAtMNoSync Branch.CompressHistory - [ ( Path.unabsolute currentPath', + ([ ( Path.unabsolute currentPath', pure . doSlurpUpdates typeEdits termEdits termDeprecations ), ( Path.unabsolute currentPath', pure . doSlurpAdds addsAndUpdates uf - ), - (Path.unabsolute p, updatePatches) - ] + )] ++ case patchOps of + Nothing -> [] + Just (_, update, p) -> [(Path.unabsolute p, update)]) eval . AddDefsToCodebase . filterBySlurpResult sr $ uf ppe <- prettyPrintEnvDecl =<< displayNames uf respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr -- propagatePatch prints TodoOutput - void $ propagatePatchNoSync (updatePatch ye'ol'Patch) currentPath' + for_ patchOps $ \case + (updatedPatch, _, _) -> void $ propagatePatchNoSync updatedPatch currentPath' addDefaultMetadata addsAndUpdates - let patchString :: Text - patchString = - patchPath - & Path.unsplit' - & Path.resolve @_ @_ @Path.Absolute currentPath' - & tShow - syncRoot ("update " <> patchString) + syncRoot $ case patchPath of + Nothing -> "update.nopatch" + Just p -> p & Path.unsplit' + & Path.resolve @_ @_ @Path.Absolute currentPath' + & tShow -- Add default metadata to all added types and terms in a slurp component. -- @@ -1955,6 +1964,7 @@ addDefaultMetadata :: (Monad m, Var v) => SlurpComponent v -> Action m (Either E addDefaultMetadata adds = when (not (SC.isEmpty adds)) do currentPath' <- use LoopState.currentPath + let addedVs = Set.toList $ SC.types adds <> SC.terms adds addedNs = traverse (Path.hqSplitFromName' . Name.unsafeFromVar) addedVs case addedNs of diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index de373bfcb8..b8dd6a5894 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -10,6 +10,7 @@ module Unison.Codebase.Editor.Input HashOrHQSplit', Insistence (..), PullMode (..), + OptionalPatch (..), ) where @@ -42,6 +43,9 @@ type SourceName = Text -- "foo.u" or "buffer 7" type PatchPath = Path.Split' +data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath + deriving (Eq, Ord, Show) + type BranchId = Either ShortBranchHash Path' type AbsBranchId = Either ShortBranchHash Path.Absolute @@ -116,7 +120,7 @@ data Input LoadI (Maybe FilePath) | AddI (Set Name) | PreviewAddI (Set Name) - | UpdateI (Maybe PatchPath) (Set Name) + | UpdateI OptionalPatch (Set Name) | PreviewUpdateI (Set Name) | TodoI (Maybe PatchPath) Path' | PropagatePatchI PatchPath Path' diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 906d61209f..2dc62edc2e 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -187,16 +187,48 @@ previewAdd = ) $ \ws -> pure $ Input.PreviewAddI (Set.fromList $ map Name.unsafeFromString ws) +updateNoPatch :: InputPattern +updateNoPatch = + InputPattern + "update.nopatch" + ["un"] + [(ZeroPlus, noCompletions)] + ( P.wrap + ( makeExample' updateNoPatch + <> "works like" + <> P.group (makeExample' update <> ",") + <> "except it doesn't add a patch entry for any updates. " + <> "Use this when you want to make changes to definitions without " + <> "pushing those changes to dependents beyond your codebase. " + <> "An example is when updating docs, or when updating a term you " + <> "just added." + ) + <> P.wrapColumn2 + [ ( makeExample' updateNoPatch, + "updates all definitions in the .u file." + ), + ( makeExample updateNoPatch ["foo", "bar"], + "updates `foo`, `bar`, and their dependents from the .u file." + ) + ] + ) + ( \case + ws -> do + pure $ + Input.UpdateI + Input.NoPatch + (Set.fromList $ map Name.unsafeFromString ws) + ) + update :: InputPattern update = InputPattern "update" [] - [ (Optional, patchArg), - (ZeroPlus, noCompletions) - ] + [(Optional, patchArg), (ZeroPlus, noCompletions)] ( P.wrap - ( makeExample' update <> "works like" + ( makeExample' update + <> "works like" <> P.group (makeExample' add <> ",") <> "except that if a definition in the file has the same name as an" <> "existing definition, the name gets updated to point to the new" @@ -221,9 +253,14 @@ update = ) ( \case patchStr : ws -> do - patch <- first fromString $ Path.parseSplit' Path.definitionNameSegment patchStr - pure $ Input.UpdateI (Just patch) (Set.fromList $ map Name.unsafeFromString ws) - [] -> Right $ Input.UpdateI Nothing mempty + patch <- + first fromString $ + Path.parseSplit' Path.definitionNameSegment patchStr + pure $ + Input.UpdateI + (Input.UsePatch patch) + (Set.fromList $ map Name.unsafeFromString ws) + [] -> Right $ Input.UpdateI Input.DefaultPatch mempty ) previewUpdate :: InputPattern @@ -385,7 +422,7 @@ findShallow :: InputPattern findShallow = InputPattern "list" - ["ls"] + ["ls", "dir"] [(Optional, namespaceArg)] ( P.wrapColumn2 [ ("`list`", "lists definitions and namespaces at the current level of the current namespace."), @@ -1878,6 +1915,7 @@ validInputs = previewAdd, update, previewUpdate, + updateNoPatch, delete, forkLocal, mergeLocal, From 863d9898565df0ac5e76673d6562ed08330fed1f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Sat, 19 Mar 2022 12:54:28 -0600 Subject: [PATCH 017/529] Use a split for fzf to show previous work. (tput doesn't seem to work on windows terminal) (#2984) * Use a split for fzf to show previous work. * Handle most errors by just silently returning empty results. --- .../src/Unison/CommandLine/FuzzySelect.hs | 45 ++++++++----------- 1 file changed, 19 insertions(+), 26 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/FuzzySelect.hs b/unison-cli/src/Unison/CommandLine/FuzzySelect.hs index 70413fc601..7800480487 100644 --- a/unison-cli/src/Unison/CommandLine/FuzzySelect.hs +++ b/unison-cli/src/Unison/CommandLine/FuzzySelect.hs @@ -14,12 +14,11 @@ import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Text.IO as Text import GHC.IO.Handle (hDuplicateTo) -import System.Exit (ExitCode (ExitFailure, ExitSuccess)) import System.IO (BufferMode (NoBuffering), hPutStrLn, stderr) import Unison.Prelude -import UnliftIO (handleAny) +import qualified UnliftIO import UnliftIO.Directory (findExecutable) -import UnliftIO.Exception (bracket, bracket_) +import UnliftIO.Exception (bracket) import UnliftIO.IO (hGetBuffering, hSetBuffering, stdin) import qualified UnliftIO.Process as Proc @@ -47,24 +46,19 @@ optsToArgs opts = -- This allows us to prepend each line with a number, and use that number to determine -- which values from the input list were selected. [ "--with-nth", - "2.." + "2..", + -- Use only half the screen (it's nice to see what you were working on when searching) + "--height=50%", + -- But if 50% of the screen is too small, ensure show at least 10 results. + "--min-height=10" ] --- | Run the given IO block within a fresh terminal screen, clean it up and restore the --- previous screen after the block is finished. -withTempScreen :: IO a -> IO a -withTempScreen = - bracket_ - (Proc.callCommand "tput smcup") -- Stash existing screen, create a new one - (Proc.callCommand "tput rmcup") -- Delete the temporary screen, restore the original. - -- | Allows prompting the user to interactively fuzzy-select a result from a list of options, currently shells out to `fzf` under the hood. -- If fzf is missing, or an error (other than ctrl-c) occurred, returns Nothing. fuzzySelect :: forall a. Options -> (a -> Text) -> [a] -> IO (Maybe [a]) fuzzySelect opts intoSearchText choices = - handleAny handleException + UnliftIO.handleAny handleException . handleError - . withTempScreen . restoreBuffering . runExceptT $ do @@ -88,17 +82,16 @@ fuzzySelect opts intoSearchText choices = -- Generally no-buffering is helpful for highly interactive processes. hSetBuffering stdin NoBuffering hSetBuffering stdin' NoBuffering - -- Dump the search terms into fzf's stdin - liftIO $ traverse (Text.hPutStrLn stdin') searchTexts - -- Wire up the interactive terminal to fzf now that the inputs have been loaded. - liftIO $ hDuplicateTo stdin stdin' - exitCode <- Proc.waitForProcess procHandle - case exitCode of - ExitSuccess -> pure () - -- Thrown on ctrl-c in fzf - ExitFailure 130 -> pure () -- output handle will be empty and no results will be returned. - ExitFailure _ -> throwError "Oops, something went wrong. No input selected." - selections <- Text.lines <$> liftIO (Text.hGetContents stdout') + result <- liftIO . UnliftIO.tryAny $ do + -- Dump the search terms into fzf's stdin + traverse (Text.hPutStrLn stdin') searchTexts + -- Wire up the interactive terminal to fzf now that the inputs have been loaded. + hDuplicateTo stdin stdin' + void $ Proc.waitForProcess procHandle + Text.lines <$> liftIO (Text.hGetContents stdout') + -- Ignore any errors from fzf, or from trying to write to pipes which may have been + -- closed by a ctrl-c, just treat it as an empty selection. + let selections = fromRight [] result -- Since we prefixed every search term with its number earlier, we know each result -- is prefixed with a number, we need to parse it and use it to select the matching -- value from our input list. @@ -109,7 +102,7 @@ fuzzySelect opts intoSearchText choices = pure $ mapMaybe (\(n, a) -> if n `Set.member` selectedNumbers then Just a else Nothing) numberedChoices where handleException :: SomeException -> IO (Maybe [a]) - handleException _ = hPutStrLn stderr "Oops, something went wrong. No input selected." *> pure Nothing + handleException err = traceShowM err *> hPutStrLn stderr "Oops, something went wrong. No input selected." *> pure Nothing handleError :: IO (Either Text [a]) -> IO (Maybe [a]) handleError m = m >>= \case From 9fc61ff292dd5d8d518cb3380a8104876c79cb92 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Mon, 21 Mar 2022 13:29:37 -0400 Subject: [PATCH 018/529] Avoid redundant floating due to signatures Due to a missing case in the floating logic, definitions like: f : ... f x y z = ... were being turned into: f : ... f = g x y z = ... g Because the compiler thought the lambda needed to be floated out of the signature ascription, as the original `f` is the same as: f = (x y z -> ...) : ... This is obviously not necessary, as the signature will be erased anyway, and just results in extra indirection. --- parser-typechecker/src/Unison/Runtime/ANF.hs | 4 ++++ unison-src/transcripts/fix2053.output.md | 15 +++++++-------- 2 files changed, 11 insertions(+), 8 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index 85dbb65e16..b566d72e7a 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -317,6 +317,10 @@ floater :: (Term v a -> FloatM v a (Term v a)) -> Term v a -> Maybe (FloatM v a (Term v a)) +floater top rec tm0@(Ann' tm ty) = + (fmap . fmap) (\tm -> ann a tm ty) (floater top rec tm) + where + a = ABT.annotation tm0 floater top rec (LetRecNamed' vbs e) = Just $ letFloater rec vbs e >>= \case diff --git a/unison-src/transcripts/fix2053.output.md b/unison-src/transcripts/fix2053.output.md index 5bdd86dbc4..d311f85f82 100644 --- a/unison-src/transcripts/fix2053.output.md +++ b/unison-src/transcripts/fix2053.output.md @@ -1,13 +1,12 @@ ```ucm .> display List.map - f a -> - go f i as acc = - match List.at i as with - None -> acc - Some a -> - use Nat + - go f (i + 1) as (acc :+ f a) - go f 0 a [] + go f i as acc = + match List.at i as with + None -> acc + Some a -> + use Nat + + go f (i + 1) as (acc :+ f a) + f a -> go f 0 a [] ``` From 46e5c910cea87ca770a38892c81d32fdf538b1b4 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Mon, 21 Mar 2022 15:26:22 -0400 Subject: [PATCH 019/529] Some serialization related tweaks 1. Allow for serializing `Code` with builtin foreign references to binary, using a mapping to the builtin name used. This is useful for parsing the binary and emitting scheme within unison. 2. Fixed an encoding error where variable indexing was wrong. The context maintained for serialization is stored backwards, but simultaneous bindings of multiple variables were being pushed on in order, which resulted in reversing the order of variables in some cases. --- .../src/Unison/Runtime/ANF/Serialize.hs | 118 ++++++++++++------ .../src/Unison/Runtime/Builtin.hs | 13 +- .../src/Unison/Runtime/Interface.hs | 2 +- .../src/Unison/Runtime/Machine.hs | 8 +- .../transcripts-using-base/hashing.output.md | 4 +- 5 files changed, 100 insertions(+), 45 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs index d20e9365cb..29f5510b9c 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs @@ -16,6 +16,7 @@ import Data.Functor ((<&>)) import Data.Map as Map (Map, fromList, lookup) import qualified Data.Sequence as Seq import Data.Serialize.Put (runPutLazy) +import Data.Text (Text) import Data.Word (Word16, Word64) import GHC.Stack import Unison.ABT.Normalized (Term (..)) @@ -23,6 +24,7 @@ import Unison.Reference (Reference) import Unison.Runtime.ANF as ANF hiding (Tag) import Unison.Runtime.Exception import Unison.Runtime.Serialize +import qualified Unison.Util.EnumContainers as EC import qualified Unison.Util.Text as Util.Text import Unison.Var (Type (ANFBlank), Var (..)) import Prelude hiding (getChar, putChar) @@ -47,6 +49,7 @@ data FnTag | FConT | FReqT | FPrimT + | FForeignT data MtTag = MIntT @@ -106,6 +109,7 @@ instance Tag FnTag where FConT -> 3 FReqT -> 4 FPrimT -> 5 + FForeignT -> 6 word2tag = \case 0 -> pure FVarT @@ -114,6 +118,7 @@ instance Tag FnTag where 3 -> pure FConT 4 -> pure FReqT 5 -> pure FPrimT + 6 -> pure FForeignT n -> unknownTag "FnTag" n instance Tag MtTag where @@ -244,9 +249,14 @@ getCCs = 1 -> BX _ -> exn "getCCs: bad calling convention" -putGroup :: MonadPut m => Var v => SuperGroup v -> m () -putGroup (Rec bs e) = - putLength n *> traverse_ (putComb ctx) cs *> putComb ctx e +putGroup :: + MonadPut m => + Var v => + EC.EnumMap FOp Text -> + SuperGroup v -> + m () +putGroup fops (Rec bs e) = + putLength n *> traverse_ (putComb fops ctx) cs *> putComb fops ctx e where n = length ctx (ctx, cs) = unzip bs @@ -259,9 +269,15 @@ getGroup = do cs <- replicateM l (getComb vs n) Rec (zip vs cs) <$> getComb vs n -putComb :: MonadPut m => Var v => [v] -> SuperNormal v -> m () -putComb ctx (Lambda ccs (TAbss us e)) = - putCCs ccs *> putNormal (us ++ ctx) e +putComb :: + MonadPut m => + Var v => + EC.EnumMap FOp Text -> + [v] -> + SuperNormal v -> + m () +putComb fops ctx (Lambda ccs (TAbss us e)) = + putCCs ccs *> putNormal fops (reverse us ++ ctx) e getFresh :: Var v => Word64 -> v getFresh n = freshenId n $ typed ANFBlank @@ -273,29 +289,35 @@ getComb ctx frsh0 = do frsh = frsh0 + fromIntegral (length ccs) Lambda ccs . TAbss us <$> getNormal (us ++ ctx) frsh -putNormal :: MonadPut m => Var v => [v] -> ANormal v -> m () -putNormal ctx tm = case tm of +putNormal :: + MonadPut m => + Var v => + EC.EnumMap FOp Text -> + [v] -> + ANormal v -> + m () +putNormal fops ctx tm = case tm of TVar v -> putTag VarT *> putVar ctx v TFrc v -> putTag ForceT *> putVar ctx v - TApp f as -> putTag AppT *> putFunc ctx f *> putArgs ctx as + TApp f as -> putTag AppT *> putFunc fops ctx f *> putArgs ctx as THnd rs h e -> - putTag HandleT *> putRefs rs *> putVar ctx h *> putNormal ctx e + putTag HandleT *> putRefs rs *> putVar ctx h *> putNormal fops ctx e TShift r v e -> - putTag ShiftT *> putReference r *> putNormal (v : ctx) e - TMatch v bs -> putTag MatchT *> putVar ctx v *> putBranches ctx bs + putTag ShiftT *> putReference r *> putNormal fops (v : ctx) e + TMatch v bs -> putTag MatchT *> putVar ctx v *> putBranches fops ctx bs TLit l -> putTag LitT *> putLit l TName v (Left r) as e -> putTag NameRefT *> putReference r *> putArgs ctx as - *> putNormal (v : ctx) e + *> putNormal fops (v : ctx) e TName v (Right u) as e -> putTag NameVarT *> putVar ctx u *> putArgs ctx as - *> putNormal (v : ctx) e + *> putNormal fops (v : ctx) e TLets Direct us ccs l e -> - putTag LetDirT *> putCCs ccs *> putNormal ctx l - *> putNormal (us ++ ctx) e + putTag LetDirT *> putCCs ccs *> putNormal fops ctx l + *> putNormal fops (reverse us ++ ctx) e TLets (Indirect w) us ccs l e -> - putTag LetIndT *> putWord16be w *> putCCs ccs *> putNormal ctx l - *> putNormal (us ++ ctx) e + putTag LetIndT *> putWord16be w *> putCCs ccs *> putNormal fops ctx l + *> putNormal fops (reverse us ++ ctx) e _ -> exn "putNormal: malformed term" getNormal :: MonadGet m => Var v => [v] -> Word64 -> m (ANormal v) @@ -343,15 +365,24 @@ getNormal ctx frsh0 = <$> getNormal ctx frsh0 <*> getNormal (us ++ ctx) frsh -putFunc :: MonadPut m => Var v => [v] -> Func v -> m () -putFunc ctx f = case f of +putFunc :: + MonadPut m => + Var v => + EC.EnumMap FOp Text -> + [v] -> + Func v -> + m () +putFunc fops ctx f = case f of FVar v -> putTag FVarT *> putVar ctx v FComb r -> putTag FCombT *> putReference r FCont v -> putTag FContT *> putVar ctx v FCon r c -> putTag FConT *> putReference r *> putCTag c FReq r c -> putTag FReqT *> putReference r *> putCTag c FPrim (Left p) -> putTag FPrimT *> putPOp p - FPrim _ -> exn "putFunc: can't serialize foreign func" + FPrim (Right f) + | Just nm <- EC.lookup f fops -> + putTag FForeignT *> putText nm + | otherwise -> exn $ "putFUnc: unknown FOp: " ++ show f getFunc :: MonadGet m => Var v => [v] -> m (Func v) getFunc ctx = @@ -362,6 +393,7 @@ getFunc ctx = FConT -> FCon <$> getReference <*> getCTag FReqT -> FReq <$> getReference <*> getCTag FPrimT -> FPrim . Left <$> getPOp + FForeignT -> exn "getFunc: can't deserialize a foreign func" putPOp :: MonadPut m => POp -> m () putPOp op @@ -535,31 +567,37 @@ putRefs rs = putFoldable putReference rs getRefs :: MonadGet m => m [Reference] getRefs = getList getReference -putBranches :: MonadPut m => Var v => [v] -> Branched (ANormal v) -> m () -putBranches ctx bs = case bs of +putBranches :: + MonadPut m => + Var v => + EC.EnumMap FOp Text -> + [v] -> + Branched (ANormal v) -> + m () +putBranches fops ctx bs = case bs of MatchEmpty -> putTag MEmptyT MatchIntegral m df -> do putTag MIntT - putEnumMap putWord64be (putNormal ctx) m - putMaybe df $ putNormal ctx + putEnumMap putWord64be (putNormal fops ctx) m + putMaybe df $ putNormal fops ctx MatchText m df -> do putTag MTextT - putMap (putText . Util.Text.toText) (putNormal ctx) m - putMaybe df $ putNormal ctx + putMap (putText . Util.Text.toText) (putNormal fops ctx) m + putMaybe df $ putNormal fops ctx MatchRequest m (TAbs v df) -> do putTag MReqT - putMap putReference (putEnumMap putCTag (putCase ctx)) m - putNormal (v : ctx) df + putMap putReference (putEnumMap putCTag (putCase fops ctx)) m + putNormal fops (v : ctx) df where MatchData r m df -> do putTag MDataT putReference r - putEnumMap putCTag (putCase ctx) m - putMaybe df $ putNormal ctx + putEnumMap putCTag (putCase fops ctx) m + putMaybe df $ putNormal fops ctx MatchSum m -> do putTag MSumT - putEnumMap putWord64be (putCase ctx) m + putEnumMap putWord64be (putCase fops ctx) m _ -> exn "putBranches: malformed intermediate term" getBranches :: @@ -588,8 +626,15 @@ getBranches ctx frsh0 = <*> getMaybe (getNormal ctx frsh0) MSumT -> MatchSum <$> getEnumMap getWord64be (getCase ctx frsh0) -putCase :: MonadPut m => Var v => [v] -> ([Mem], ANormal v) -> m () -putCase ctx (ccs, (TAbss us e)) = putCCs ccs *> putNormal (us ++ ctx) e +putCase :: + MonadPut m => + Var v => + EC.EnumMap FOp Text -> + [v] -> + ([Mem], ANormal v) -> + m () +putCase fops ctx (ccs, (TAbss us e)) = + putCCs ccs *> putNormal fops (us ++ ctx) e getCase :: MonadGet m => Var v => [v] -> Word64 -> m ([Mem], ANormal v) getCase ctx frsh0 = do @@ -684,8 +729,9 @@ deserializeGroup bs = runGetS (getVersion *> getGroup) bs 1 -> pure () n -> fail $ "deserializeGroup: unknown version: " ++ show n -serializeGroup :: Var v => SuperGroup v -> ByteString -serializeGroup sg = runPutS (putVersion *> putGroup sg) +serializeGroup :: + Var v => EC.EnumMap FOp Text -> SuperGroup v -> ByteString +serializeGroup fops sg = runPutS (putVersion *> putGroup fops sg) where putVersion = putWord32be 1 diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 56993f3802..08cb6c43f2 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -1683,7 +1683,7 @@ builtinLookup = ++ foreignWrappers type FDecl v = - State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 ForeignFunc) + State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) -- Data type to determine whether a builtin should be tracked for -- sandboxing. Untracked means that it can be freely used, and Tracked @@ -1700,7 +1700,7 @@ declareForeign :: FDecl Symbol () declareForeign sand name op func = modify $ \(w, cs, fs) -> - (w + 1, (name, (sand, uncurry Lambda (op w))) : cs, mapInsert w func fs) + (w + 1, (name, (sand, uncurry Lambda (op w))) : cs, mapInsert w (name, func) fs) mkForeignIOF :: (ForeignConvention a, ForeignConvention r) => @@ -2086,7 +2086,7 @@ declareForeigns = do declareForeign Untracked "Code.serialize" boxDirect . mkForeign $ \(sg :: SuperGroup Symbol) -> - pure . Bytes.fromArray $ serializeGroup sg + pure . Bytes.fromArray $ serializeGroup builtinForeignNames sg declareForeign Untracked "Code.deserialize" boxToEBoxBox . mkForeign $ pure . deserializeGroup @Symbol . Bytes.toArray @@ -2205,7 +2205,7 @@ typeReferences = zip rs [1 ..] ++ [DerivedId i | (_, i, _) <- Ty.builtinEffectDecls] foreignDeclResults :: - (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 ForeignFunc) + (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) foreignDeclResults = execState declareForeigns (0, [], mempty) foreignWrappers :: [(Data.Text.Text, (Sandbox, SuperNormal Symbol))] @@ -2232,7 +2232,10 @@ builtinTypeBackref = mapFromList $ swap <$> typeReferences swap (x, y) = (y, x) builtinForeigns :: EnumMap Word64 ForeignFunc -builtinForeigns | (_, _, m) <- foreignDeclResults = m +builtinForeigns | (_, _, m) <- foreignDeclResults = snd <$> m + +builtinForeignNames :: EnumMap Word64 Data.Text.Text +builtinForeignNames | (_, _, m) <- foreignDeclResults = fst <$> m -- Bootstrapping for sandbox check. The eventual map will be one with -- associations `r -> s` where `s` is all the 'sensitive' base diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index 8c8b9054f3..57a4c2ee1c 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -566,7 +566,7 @@ putStoredCache (SCache cs crs trs ftm fty int rtm rty sbs) = do putEnumMap putNat putReference trs putNat ftm putNat fty - putMap putReference putGroup int + putMap putReference (putGroup mempty) int putMap putReference putNat rtm putMap putReference putNat rty putMap putReference (putFoldable putReference) sbs diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index 5f31c4d246..9f8d1271b4 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -288,7 +288,13 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LKUP i) = do m <- readTVarIO (intermed env) ustk <- bump ustk bstk <- case M.lookup link m of - Nothing -> bstk <$ poke ustk 0 + Nothing + | Just w <- M.lookup link builtinTermNumbering, + Just sn <- EC.lookup w numberedTermLookup -> do + poke ustk 1 + bstk <- bump bstk + bstk <$ pokeBi bstk (ANF.Rec [] sn) + | otherwise -> bstk <$ poke ustk 0 Just sg -> do poke ustk 1 bstk <- bump bstk diff --git a/unison-src/transcripts-using-base/hashing.output.md b/unison-src/transcripts-using-base/hashing.output.md index 4c3920422f..368227031b 100644 --- a/unison-src/transcripts-using-base/hashing.output.md +++ b/unison-src/transcripts-using-base/hashing.output.md @@ -106,11 +106,11 @@ ex5 = crypto.hmac Sha2_256 mysecret f |> hex 25 | > ex4 โงฉ - "1e014deb2a1ef1dc3c8765a6f7ebf7184ccaeaecbc2b5428030befd7085139db" + "a52c81c976ff4fe9c809d9896d6dc32775c6272bb100555c507b72f20ace4b39" 26 | > ex5 โงฉ - "c729f5ed4b2a89dc33ae06cd0b925174c990328c736123bc220e6fe8b42d3d53" + "b9f05335381fc8eecba3bfa6e82a4dc23fdab95a04f24b97d14785f0f15f56b4" ``` And here's the full API: From 60d3fea6172674911088640849b17110704a1f58 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 22 Mar 2022 10:54:41 -0600 Subject: [PATCH 020/529] Pass ucm version through to command layer --- .../src/Unison/Runtime/Interface.hs | 90 +++++++++---------- .../src/Unison/Codebase/Editor/Command.hs | 5 ++ .../Unison/Codebase/Editor/HandleCommand.hs | 6 +- .../src/Unison/Codebase/TranscriptParser.hs | 14 +-- unison-cli/src/Unison/CommandLine/Main.hs | 6 +- unison-cli/src/Unison/CommandLine/Welcome.hs | 10 +-- unison-cli/unison/Main.hs | 32 +++---- unison-cli/unison/Version.hs | 31 ++++--- 8 files changed, 105 insertions(+), 89 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index 8c8b9054f3..1e0ffc2739 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -42,7 +42,7 @@ import Data.Set as Set (\\), ) import qualified Data.Set as Set -import Data.Text (Text, isPrefixOf, pack) +import Data.Text (Text, isPrefixOf) import Data.Traversable (for) import Data.Word (Word64) import GHC.Stack (HasCallStack) @@ -337,9 +337,9 @@ prepareEvaluation ppe tm ctx = do $ Map.fromList bs, mn <- Tm.substs (Map.toList $ Tm.ref () . fst <$> hcs) mn0, rmn <- RF.DerivedId $ Hashing.hashClosedTerm mn = - (rmn, (rmn, mn) : Map.elems hcs) + (rmn, (rmn, mn) : Map.elems hcs) | rmn <- RF.DerivedId $ Hashing.hashClosedTerm tm = - (rmn, [(rmn, tm)]) + (rmn, [(rmn, tm)]) (rgrp, rbkr) = intermediateTerms ppe ctx rtms @@ -407,50 +407,50 @@ executeMainComb init cc = bugMsg :: PrettyPrintEnv -> Text -> Term Symbol -> Pretty ColorText bugMsg ppe name tm | name == "blank expression" = - P.callout icon . P.lines $ - [ P.wrap - ( "I encountered a" <> P.red (P.text name) - <> "with the following name/message:" - ), - "", - P.indentN 2 $ pretty ppe tm, - "", - sorryMsg - ] + P.callout icon . P.lines $ + [ P.wrap + ( "I encountered a" <> P.red (P.text name) + <> "with the following name/message:" + ), + "", + P.indentN 2 $ pretty ppe tm, + "", + sorryMsg + ] | "pattern match failure" `isPrefixOf` name = - P.callout icon . P.lines $ - [ P.wrap - ( "I've encountered a" <> P.red (P.text name) - <> "while scrutinizing:" - ), - "", - P.indentN 2 $ pretty ppe tm, - "", - "This happens when calling a function that doesn't handle all \ - \possible inputs", - sorryMsg - ] + P.callout icon . P.lines $ + [ P.wrap + ( "I've encountered a" <> P.red (P.text name) + <> "while scrutinizing:" + ), + "", + P.indentN 2 $ pretty ppe tm, + "", + "This happens when calling a function that doesn't handle all \ + \possible inputs", + sorryMsg + ] | name == "builtin.raise" = - P.callout icon . P.lines $ - [ P.wrap ("The program halted with an unhandled exception:"), - "", - P.indentN 2 $ pretty ppe tm - ] + P.callout icon . P.lines $ + [ P.wrap ("The program halted with an unhandled exception:"), + "", + P.indentN 2 $ pretty ppe tm + ] | name == "builtin.bug", RF.TupleTerm' [Tm.Text' msg, x] <- tm, "pattern match failure" `isPrefixOf` msg = - P.callout icon . P.lines $ - [ P.wrap - ( "I've encountered a" <> P.red (P.text msg) - <> "while scrutinizing:" - ), - "", - P.indentN 2 $ pretty ppe x, - "", - "This happens when calling a function that doesn't handle all \ - \possible inputs", - sorryMsg - ] + P.callout icon . P.lines $ + [ P.wrap + ( "I've encountered a" <> P.red (P.text msg) + <> "while scrutinizing:" + ), + "", + P.indentN 2 $ pretty ppe x, + "", + "This happens when calling a function that doesn't handle all \ + \possible inputs", + sorryMsg + ] bugMsg ppe name tm = P.callout icon . P.lines $ [ P.wrap @@ -495,7 +495,7 @@ data RuntimeHost = Standalone | UCM -startRuntime :: RuntimeHost -> String -> IO (Runtime Symbol) +startRuntime :: RuntimeHost -> Text -> IO (Runtime Symbol) startRuntime runtimeHost version = do ctxVar <- newIORef =<< baseContext (activeThreads, cleanupThreads) <- case runtimeHost of @@ -528,7 +528,7 @@ startRuntime runtimeHost version = do Just w <- Map.lookup rf <$> readTVarIO (refTm cc) sto <- standalone cc w BL.writeFile path . runPutL $ do - serialize $ pack version + serialize $ version serialize $ RF.showShort 8 rf putNat w putStoredCache sto, @@ -616,7 +616,7 @@ traceNeeded init src = fmap (`withoutKeys` ks) $ go mempty init go acc w | hasKey w acc = pure acc | Just co <- EC.lookup w src = - foldlM go (mapInsert w co acc) (foldMap combDeps co) + foldlM go (mapInsert w co acc) (foldMap combDeps co) | otherwise = die $ "traceNeeded: unknown combinator: " ++ show w buildSCache :: diff --git a/unison-cli/src/Unison/Codebase/Editor/Command.hs b/unison-cli/src/Unison/Codebase/Editor/Command.hs index c4b1825f51..48d3fa6c04 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Command.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Command.hs @@ -13,6 +13,7 @@ module Unison.Codebase.Editor.Command EvalResult, commandName, lookupEvalResult, + UCMVersion, ) where @@ -94,6 +95,8 @@ type TypecheckingResult v = (Seq (Note v Ann)) (Either Names (UF.TypecheckedUnisonFile v Ann)) +type UCMVersion = Text + data Command m -- Command monad @@ -266,6 +269,7 @@ data -- Ideally we will eventually remove the Command type entirely and won't need -- this anymore. CmdUnliftIO :: Command m i v (UnliftIO (Free (Command m i v))) + UCMVersion :: Command m i v UCMVersion instance MonadIO m => MonadIO (Free (Command m i v)) where liftIO io = Free.eval $ Eval (liftIO io) @@ -344,3 +348,4 @@ commandName = \case MakeStandalone {} -> "MakeStandalone" FuzzySelect {} -> "FuzzySelect" CmdUnliftIO {} -> "UnliftIO" + UCMVersion {} -> "UCMVersion" diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs index 9a146b294b..3b233d6e55 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs @@ -23,7 +23,7 @@ import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Branch.Merge as Branch import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo -import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UseCache) +import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UCMVersion, UseCache) import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output (PrintMessage)) import qualified Unison.Codebase.Path as Path import Unison.Codebase.Runtime (Runtime) @@ -94,10 +94,11 @@ commandLine :: (SourceName -> IO LoadSourceResult) -> Codebase IO Symbol Ann -> Maybe Server.BaseUrl -> + UCMVersion -> (Int -> IO gen) -> Free (Command IO i Symbol) a -> IO a -commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSource codebase serverBaseUrl rngGen free = do +commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSource codebase serverBaseUrl ucmVersion rngGen free = do rndSeed <- STM.newTVarIO 0 flip runReaderT rndSeed . Free.fold go $ free where @@ -232,6 +233,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour -- in-scope. UnliftIO.UnliftIO toIO -> toIO . Free.fold go pure runF + UCMVersion -> pure ucmVersion watchCache :: Reference.Id -> IO (Maybe (Term Symbol ())) watchCache h = do diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 9ef320f254..cdf9b9c746 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -38,7 +38,7 @@ import qualified Text.Megaparsec as P import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.Editor.Command (LoadSourceResult (..)) +import Unison.Codebase.Editor.Command (LoadSourceResult (..), UCMVersion) import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState @@ -145,22 +145,22 @@ type TranscriptRunner = withTranscriptRunner :: forall m r. UnliftIO.MonadUnliftIO m => - String -> + UCMVersion -> Maybe FilePath -> (TranscriptRunner -> m r) -> m r -withTranscriptRunner version configFile action = do +withTranscriptRunner ucmVersion configFile action = do withRuntime $ \runtime -> withConfig $ \config -> do action $ \transcriptName transcriptSrc (codebaseDir, codebase) -> do let parsed = parse transcriptName transcriptSrc result <- for parsed $ \stanzas -> do - liftIO $ run codebaseDir stanzas codebase runtime config + liftIO $ run codebaseDir stanzas codebase runtime config ucmVersion pure $ join @(Either TranscriptError) result where withRuntime :: ((Runtime.Runtime Symbol -> m a) -> m a) withRuntime action = UnliftIO.bracket - (liftIO $ RTI.startRuntime RTI.UCM version) + (liftIO $ RTI.startRuntime RTI.UCM ucmVersion) (liftIO . Runtime.terminate) action withConfig :: forall a. ((Maybe Config -> m a) -> m a) @@ -182,8 +182,9 @@ run :: Codebase IO Symbol Ann -> Runtime.Runtime Symbol -> Maybe Config -> + UCMVersion -> IO (Either TranscriptError Text) -run dir stanzas codebase runtime config = UnliftIO.try $ do +run dir stanzas codebase runtime config ucmVersion = UnliftIO.try $ do let initialPath = Path.absoluteEmpty putPrettyLn $ P.lines @@ -389,6 +390,7 @@ run dir stanzas codebase runtime config = UnliftIO.try $ do loadPreviousUnisonBlock codebase Nothing + ucmVersion rng free case o of diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 6729508635..2e83abe8a6 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -26,7 +26,7 @@ import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.Editor.Command (LoadSourceResult (..)) +import Unison.Codebase.Editor.Command (LoadSourceResult (..), UCMVersion) import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState @@ -110,8 +110,9 @@ main :: Runtime.Runtime Symbol -> Codebase IO Symbol Ann -> Maybe Server.BaseUrl -> + UCMVersion -> IO () -main dir welcome initialPath (config, cancelConfig) initialInputs runtime codebase serverBaseUrl = do +main dir welcome initialPath (config, cancelConfig) initialInputs runtime codebase serverBaseUrl ucmVersion = do root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase eventQueue <- Q.newIO welcomeEvents <- Welcome.run codebase welcome @@ -203,6 +204,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba loadSourceFile codebase serverBaseUrl + ucmVersion (const Random.getSystemDRG) free UnliftIO.race waitForInterrupt (try handleCommand) >>= \case diff --git a/unison-cli/src/Unison/CommandLine/Welcome.hs b/unison-cli/src/Unison/CommandLine/Welcome.hs index feba81a405..4f3447071f 100644 --- a/unison-cli/src/Unison/CommandLine/Welcome.hs +++ b/unison-cli/src/Unison/CommandLine/Welcome.hs @@ -21,7 +21,7 @@ data Welcome = Welcome { onboarding :: Onboarding, -- Onboarding States downloadBase :: DownloadBase, watchDir :: FilePath, - unisonVersion :: String + unisonVersion :: Text } data DownloadBase @@ -44,7 +44,7 @@ data Onboarding | Finished | PreviouslyOnboarded -welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> String -> Welcome +welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> Text -> Welcome welcome initStatus downloadBase filePath unisonVersion = Welcome (Init initStatus) downloadBase filePath unisonVersion @@ -98,7 +98,7 @@ determineFirstStep downloadBase codebase = do case downloadBase of DownloadBase ns | isEmptyCodebase -> - pure $ DownloadingBase ns + pure $ DownloadingBase ns _ -> pure PreviouslyOnboarded @@ -141,14 +141,14 @@ downloading path = ) ] -header :: String -> P.Pretty P.ColorText +header :: Text -> P.Pretty P.ColorText header version = asciiartUnison <> P.newline <> P.newline <> P.linesSpaced [ P.wrap "๐Ÿ‘‹ Welcome to Unison!", - P.wrap ("You are running version: " <> P.bold (P.string version)) + P.wrap ("You are running version: " <> P.bold (P.text version)) ] authorSuggestion :: P.Pretty P.ColorText diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index 7e381e02f0..998b8f3e2e 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -29,6 +29,7 @@ import Data.Configurator.Types (Config) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text +import qualified Data.Text.IO as Text import qualified GHC.Conc import System.Directory (canonicalizePath, getCurrentDirectory, removeDirectoryRecursive) import System.Environment (getProgName, withArgs) @@ -74,7 +75,7 @@ main = withCP65001 do progName <- getProgName -- hSetBuffering stdout NoBuffering -- cool - (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName Version.gitDescribeWithDate + (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName (Text.unpack Version.gitDescribeWithDate) let GlobalOptions {codebasePathOption = mCodePathOption} = globalOptions let mcodepath = fmap codebasePathOptionToPath mCodePathOption @@ -85,7 +86,7 @@ main = withCP65001 do Exit.die "Your .unisonConfig could not be loaded. Check that it's correct!" case command of PrintVersion -> - putStrLn $ progName ++ " version: " ++ Version.gitDescribeWithDate + Text.putStrLn $ Text.pack progName <> " version: " <> Version.gitDescribeWithDate Init -> do PT.putPrettyLn $ P.callout @@ -107,14 +108,14 @@ main = withCP65001 do Run (RunFromFile file mainName) args | not (isDotU file) -> PT.putPrettyLn $ P.callout "โš ๏ธ" "Files must have a .u extension." | otherwise -> do - e <- safeReadUtf8 file - case e of - Left _ -> PT.putPrettyLn $ P.callout "โš ๏ธ" "I couldn't find that file or it is for some reason unreadable." - Right contents -> do - getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do - rt <- RTI.startRuntime RTI.Standalone Version.gitDescribeWithDate - let fileEvent = Input.UnisonFileChanged (Text.pack file) contents - launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes + e <- safeReadUtf8 file + case e of + Left _ -> PT.putPrettyLn $ P.callout "โš ๏ธ" "I couldn't find that file or it is for some reason unreadable." + Right contents -> do + getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do + rt <- RTI.startRuntime RTI.Standalone Version.gitDescribeWithDate + let fileEvent = Input.UnisonFileChanged (Text.pack file) contents + launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes Run (RunFromPipe mainName) args -> do e <- safeReadUtf8StdIn case e of @@ -159,7 +160,7 @@ main = withCP65001 do | not vmatch -> mismatchMsg | otherwise -> withArgs args $ RTI.runStandalone sto w where - vmatch = v == Text.pack Version.gitDescribeWithDate + vmatch = v == Version.gitDescribeWithDate ws s = P.wrap (P.text s) ifile | 'c' : 'u' : '.' : rest <- reverse file = reverse rest @@ -175,7 +176,7 @@ main = withCP65001 do P.indentN 4 $ P.text v, "", "Your version", - P.indentN 4 $ P.string Version.gitDescribeWithDate, + P.indentN 4 $ P.text Version.gitDescribeWithDate, "", P.wrap $ "The program was compiled from hash " @@ -364,8 +365,8 @@ launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase initR CreatedCodebase {} -> NewlyCreatedCodebase _ -> PreviouslyCreatedCodebase - (gitRef, _date) = Version.gitDescribe - welcome = Welcome.welcome isNewCodebase downloadBase dir gitRef + (ucmVersion, _date) = Version.gitDescribe + welcome = Welcome.welcome isNewCodebase downloadBase dir ucmVersion in CommandLine.main dir welcome @@ -375,6 +376,7 @@ launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase initR runtime codebase serverBaseUrl + ucmVersion isMarkdown :: String -> Bool isMarkdown md = case FP.takeExtension md of @@ -396,7 +398,7 @@ getConfigFilePath mcodepath = (FP. ".unisonConfig") <$> Codebase.getCodebaseD defaultBaseLib :: Maybe ReadRemoteNamespace defaultBaseLib = rightMay $ - runParser VP.defaultBaseLib "version" (Text.pack gitRef) + runParser VP.defaultBaseLib "version" gitRef where (gitRef, _date) = Version.gitDescribe diff --git a/unison-cli/unison/Version.hs b/unison-cli/unison/Version.hs index 1498a6a6df..e933f6d947 100644 --- a/unison-cli/unison/Version.hs +++ b/unison-cli/unison/Version.hs @@ -3,7 +3,9 @@ module Version where +import Data.Bifunctor import Data.Text +import qualified Data.Text as Text import Language.Haskell.TH (Exp (TupE), runIO) import Language.Haskell.TH.Syntax (Exp (LitE), Lit (StringL)) import Shellmet @@ -11,15 +13,15 @@ import Shellmet -- | A formatted descriptor of when and against which commit this unison executable was built -- E.g. latest-149-g5cef8f851 (built on 2021-10-04) -- release/M2i (built on 2021-10-05) -gitDescribeWithDate :: String +gitDescribeWithDate :: Text gitDescribeWithDate = let formatDate d = " (built on " <> d <> ")" (gitRef, date) = gitDescribe in gitRef <> formatDate date -type CommitDate = String +type CommitDate = Text -type GitRef = String +type GitRef = Text -- | Uses Template Haskell to embed a git descriptor of the commit -- which was used to build the executable. @@ -27,14 +29,15 @@ type GitRef = String -- release/M2i (built on 2021-10-05) gitDescribe :: (GitRef, CommitDate) gitDescribe = - $( runIO $ do - -- Outputs date of current commit; E.g. 2021-08-06 - let getDate = "git" $| ["show", "-s", "--format=%cs"] - date <- getDate $? pure "" - -- Fetches a unique tag-name to represent the current commit. - -- Uses human-readable names whenever possible. - -- Marks version with a `'` suffix if building on a dirty worktree. - let getTag = "git" $| ["describe", "--tags", "--always", "--dirty='"] - tag <- getTag $? pure "unknown" - pure (TupE [Just . LitE . StringL . unpack $ tag, Just . LitE . StringL . unpack $ date]) - ) + bimap Text.pack Text.pack $ + $( runIO $ do + -- Outputs date of current commit; E.g. 2021-08-06 + let getDate = "git" $| ["show", "-s", "--format=%cs"] + date <- getDate $? pure "" + -- Fetches a unique tag-name to represent the current commit. + -- Uses human-readable names whenever possible. + -- Marks version with a `'` suffix if building on a dirty worktree. + let getTag = "git" $| ["describe", "--tags", "--always", "--dirty='"] + tag <- getTag $? pure "unknown" + pure (TupE [Just . LitE . StringL . unpack $ tag, Just . LitE . StringL . unpack $ date]) + ) From 1b575f26c4742a6cb0b4ed73346f37f4d15f8dd7 Mon Sep 17 00:00:00 2001 From: Jens Petersen Date: Wed, 23 Mar 2022 11:49:31 +0800 Subject: [PATCH 021/529] stack.yaml: update to final lts-18.28 snapshot --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 0ad91dfa39..61f92528d4 100644 --- a/stack.yaml +++ b/stack.yaml @@ -27,7 +27,7 @@ packages: - lib/unison-pretty-printer #compiler-check: match-exact -resolver: lts-18.13 +resolver: lts-18.28 extra-deps: - github: unisonweb/configurator From da9c50d2f19c2d4f1b054d2067939864e8ecd1ef Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 24 Mar 2022 10:46:07 -0600 Subject: [PATCH 022/529] Add ReaderT to Action and wrap Action in its own monad --- .../src/Unison/Codebase/Editor/HandleInput.hs | 8 ++--- .../Codebase/Editor/HandleInput/LoopState.hs | 29 +++++++++++++++++-- .../src/Unison/Codebase/TranscriptParser.hs | 3 +- unison-cli/src/Unison/CommandLine/Main.hs | 3 +- 4 files changed, 32 insertions(+), 11 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 90fca1df04..276ad09bd6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -45,7 +45,7 @@ import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..)) import Unison.Codebase.Editor.Command as Command import Unison.Codebase.Editor.DisplayObject import qualified Unison.Codebase.Editor.Git as Git -import Unison.Codebase.Editor.HandleInput.LoopState (Action, Action', MonadCommand (..), eval) +import Unison.Codebase.Editor.HandleInput.LoopState (Action, Action', MonadCommand (..), eval, liftF) import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState import qualified Unison.Codebase.Editor.HandleInput.NamespaceDependencies as NamespaceDependencies import Unison.Codebase.Editor.Input @@ -1628,7 +1628,7 @@ loop = do doRemoveReplacement from patchPath False ShowDefinitionByPrefixI {} -> notImplemented UpdateBuiltinsI -> notImplemented - QuitI -> MaybeT $ pure Nothing + QuitI -> empty GistI input -> handleGist input where notImplemented = eval $ Notify NotImplemented @@ -2243,7 +2243,7 @@ propagatePatchNoSync patch scopePath = do stepAtMNoSync' Branch.CompressHistory ( Path.unabsolute scopePath, - lift . lift . Propagate.propagateAndApply nroot patch + liftF . Propagate.propagateAndApply nroot patch ) -- Returns True if the operation changed the namespace, False otherwise. @@ -2260,7 +2260,7 @@ propagatePatch inputDescription patch scopePath = do Branch.CompressHistory (inputDescription <> " (applying patch)") ( Path.unabsolute scopePath, - lift . lift . Propagate.propagateAndApply nroot patch + liftF . Propagate.propagateAndApply nroot patch ) -- | Create the args needed for showTodoOutput and call it diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs index 1c2cc64d44..431662e37d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs @@ -5,8 +5,9 @@ module Unison.Codebase.Editor.HandleInput.LoopState where import Control.Lens -import Control.Monad.Except (ExceptT) -import Control.Monad.State (StateT) +import Control.Monad.Except +import Control.Monad.Reader +import Control.Monad.State import Data.Configurator () import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel @@ -24,7 +25,23 @@ import qualified Unison.Util.Free as Free type F m i v = Free (Command m i v) -type Action m i v = MaybeT (StateT (LoopState m v) (F m i v)) +data Env = Env + +newtype Action m i v a = Action {unAction :: MaybeT (ReaderT Env (StateT (LoopState m v) (F m i v))) a} + deriving newtype (Functor, Applicative, Alternative, Monad, MonadIO, MonadState (LoopState m v), MonadReader Env) + -- We should likely remove this MonadFail instance since it's really hard to debug, + -- but it's currently in use. + deriving newtype (MonadFail) + +runAction :: Env -> LoopState m v -> Action m i v a -> (F m i v (Maybe a, LoopState m v)) +runAction env state (Action m) = + m + & runMaybeT + & flip runReaderT env + & flip runStateT state + +liftF :: F m i v a -> Action m i v a +liftF = Action . lift . lift . lift -- | A typeclass representing monads which can evaluate 'Command's. class Monad n => MonadCommand n m v i | n -> m v i where @@ -42,6 +59,12 @@ instance MonadCommand n m i v => MonadCommand (MaybeT n) m i v where instance MonadCommand n m i v => MonadCommand (ExceptT e n) m i v where eval = lift . eval +instance MonadCommand n m i v => MonadCommand (ReaderT r n) m i v where + eval = lift . eval + +instance MonadCommand (Action m i v) m i v where + eval = Action . eval + type NumberedArgs = [String] data LoopState m v = LoopState diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 9ef320f254..39e981ec8d 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -21,7 +21,6 @@ where import Control.Concurrent.STM (atomically) import Control.Error (rightMay) import Control.Lens (view) -import Control.Monad.State (runStateT) import qualified Crypto.Random as Random import qualified Data.Char as Char import qualified Data.Configurator as Configurator @@ -376,7 +375,7 @@ run dir stanzas codebase runtime config = UnliftIO.try $ do loop state = do writeIORef pathRef (view LoopState.currentPath state) - let free = runStateT (runMaybeT HandleInput.loop) state + let free = LoopState.runAction LoopState.Env state $ HandleInput.loop rng i = pure $ Random.drgNewSeed (Random.seedFromInteger (fromIntegral i)) (o, state') <- HandleCommand.commandLine diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 6729508635..a189edb19c 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -13,7 +13,6 @@ import Control.Concurrent.STM (atomically) import Control.Error (rightMay) import Control.Exception (catch, finally) import Control.Lens (view) -import Control.Monad.State (runStateT) import qualified Crypto.Random as Random import Data.Configurator.Types (Config) import Data.IORef @@ -188,7 +187,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba let loop :: LoopState.LoopState IO Symbol -> IO () loop state = do writeIORef pathRef (view LoopState.currentPath state) - let free = runStateT (runMaybeT HandleInput.loop) state + let free = LoopState.runAction LoopState.Env state HandleInput.loop let handleCommand = HandleCommand.commandLine config From eea51284d1b1a82dfa0a5d648057255ecca474dc Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 24 Mar 2022 11:54:12 -0600 Subject: [PATCH 023/529] Add ability to hide ucm commands until we're ready to release them. --- .../src/Unison/CommandLine/InputPattern.hs | 4 + .../src/Unison/CommandLine/InputPatterns.hs | 265 ++++++++++++------ 2 files changed, 180 insertions(+), 89 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPattern.hs b/unison-cli/src/Unison/CommandLine/InputPattern.hs index f8a7f65162..098d47666f 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -23,9 +23,13 @@ data IsOptional | OnePlus -- 1 or more, at the end deriving (Show, Eq) +data Visibility = Hidden | Visible + deriving (Show, Eq, Ord) + data InputPattern = InputPattern { patternName :: String, aliases :: [String], + visibility :: Visibility, -- Allow hiding certain commands when debugging or work-in-progress argTypes :: [(IsOptional, ArgumentType)], help :: P.Pretty CT.ColorText, parse :: [String] -> Either (P.Pretty CT.ColorText) Input diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 2dc62edc2e..22ccb871df 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -87,6 +87,7 @@ mergeBuiltins = InputPattern "builtins.merge" [] + I.Visible [] "Adds the builtins to `builtins.` in the current namespace (excluding `io` and misc)." (const . pure $ Input.MergeBuiltinsI) @@ -96,6 +97,7 @@ mergeIOBuiltins = InputPattern "builtins.mergeio" [] + I.Visible [] "Adds all the builtins to `builtins.` in the current namespace, including `io` and misc." (const . pure $ Input.MergeIOBuiltinsI) @@ -105,6 +107,7 @@ updateBuiltins = InputPattern "builtins.update" [] + I.Visible [] ( "Adds all the builtins that are missing from this namespace, " <> "and deprecate the ones that don't exist in this version of Unison." @@ -116,6 +119,7 @@ todo = InputPattern "todo" [] + I.Visible [(Optional, patchArg), (Optional, namespaceArg)] ( P.wrapColumn2 [ ( makeExample' todo, @@ -147,6 +151,7 @@ load = InputPattern "load" [] + I.Visible [(Optional, noCompletions)] ( P.wrapColumn2 [ ( makeExample' load, @@ -168,6 +173,7 @@ add = InputPattern "add" [] + I.Visible [(ZeroPlus, noCompletions)] ( "`add` adds to the codebase all the definitions from the most recently " <> "typechecked file." @@ -179,6 +185,7 @@ previewAdd = InputPattern "add.preview" [] + I.Visible [(ZeroPlus, noCompletions)] ( "`add.preview` previews additions to the codebase from the most recently " <> "typechecked file. This command only displays cached typechecking " @@ -192,6 +199,7 @@ updateNoPatch = InputPattern "update.nopatch" ["un"] + I.Visible [(ZeroPlus, noCompletions)] ( P.wrap ( makeExample' updateNoPatch @@ -225,6 +233,7 @@ update = InputPattern "update" [] + I.Visible [(Optional, patchArg), (ZeroPlus, noCompletions)] ( P.wrap ( makeExample' update @@ -268,6 +277,7 @@ previewUpdate = InputPattern "update.preview" [] + I.Visible [(ZeroPlus, noCompletions)] ( "`update.preview` previews updates to the codebase from the most " <> "recently typechecked file. This command only displays cached " @@ -281,6 +291,7 @@ patch = InputPattern "patch" [] + I.Visible [(Required, patchArg), (Optional, namespaceArg)] ( P.wrap $ makeExample' patch @@ -307,6 +318,7 @@ view = InputPattern "view" [] + I.Visible [(ZeroPlus, definitionQueryArg)] ( P.lines [ "`view foo` prints the definition of `foo`.", @@ -322,6 +334,7 @@ display = InputPattern "display" [] + I.Visible [(ZeroPlus, definitionQueryArg)] ( P.lines [ "`display foo` prints a rendered version of the term `foo`.", @@ -336,6 +349,7 @@ displayTo = InputPattern "display.to" [] + I.Visible [(Required, noCompletions), (ZeroPlus, definitionQueryArg)] ( P.wrap $ makeExample displayTo ["", "foo"] @@ -352,6 +366,7 @@ docs = InputPattern "docs" [] + I.Visible [(ZeroPlus, definitionQueryArg)] ( P.lines [ "`docs foo` shows documentation for the definition `foo`.", @@ -365,6 +380,7 @@ api = InputPattern "api" [] + I.Visible [] "`api` provides details about the API." (const $ pure Input.ApiI) @@ -374,6 +390,7 @@ ui = InputPattern "ui" [] + I.Visible [] "`ui` opens the Codebase UI in the default browser." (const $ pure Input.UiI) @@ -383,6 +400,7 @@ undo = InputPattern "undo" [] + I.Visible [] "`undo` reverts the most recent change to the codebase." (const $ pure Input.UndoI) @@ -392,6 +410,7 @@ viewByPrefix = InputPattern "view.recursive" [] + I.Visible [(OnePlus, definitionQueryArg)] "`view.recursive Foo` prints the definitions of `Foo` and `Foo.blah`." ( fmap (Input.ShowDefinitionByPrefixI Input.ConsoleLocation) @@ -403,6 +422,7 @@ find = InputPattern "find" [] + I.Visible [(ZeroPlus, fuzzyDefinitionQueryArg)] ( P.wrapColumn2 [ ("`find`", "lists all definitions in the current namespace."), @@ -423,6 +443,7 @@ findShallow = InputPattern "list" ["ls", "dir"] + I.Visible [(Optional, namespaceArg)] ( P.wrapColumn2 [ ("`list`", "lists definitions and namespaces at the current level of the current namespace."), @@ -443,6 +464,7 @@ findVerbose = InputPattern "find.verbose" ["list.verbose", "ls.verbose"] + I.Visible [(ZeroPlus, fuzzyDefinitionQueryArg)] ( "`find.verbose` searches for definitions like `find`, but includes hashes " <> "and aliases in the results." @@ -454,6 +476,7 @@ findPatch = InputPattern "find.patch" ["list.patch", "ls.patch"] + I.Visible [] ( P.wrapColumn2 [("`find.patch`", "lists all patches in the current namespace.")] @@ -465,6 +488,7 @@ renameTerm = InputPattern "move.term" ["rename.term"] + I.Visible [ (Required, exactDefinitionTermQueryArg), (Required, newNameArg) ] @@ -485,6 +509,7 @@ renameType = InputPattern "move.type" ["rename.type"] + I.Visible [ (Required, exactDefinitionTypeQueryArg), (Required, newNameArg) ] @@ -505,6 +530,7 @@ delete = InputPattern "delete" [] + I.Visible [(OnePlus, definitionQueryArg)] "`delete foo` removes the term or type name `foo` from the namespace." ( \case @@ -522,6 +548,7 @@ deleteTerm = InputPattern "delete.term" [] + I.Visible [(OnePlus, exactDefinitionTermQueryArg)] "`delete.term foo` removes the term name `foo` from the namespace." ( \case @@ -539,6 +566,7 @@ deleteType = InputPattern "delete.type" [] + I.Visible [(OnePlus, exactDefinitionTypeQueryArg)] "`delete.type foo` removes the type name `foo` from the namespace." ( \case @@ -562,6 +590,7 @@ deleteReplacement isTerm = InputPattern commandName [] + I.Visible [(Required, if isTerm then exactDefinitionTermQueryArg else exactDefinitionTypeQueryArg), (Optional, patchArg)] ( P.string $ commandName @@ -626,6 +655,7 @@ aliasTerm = InputPattern "alias.term" [] + I.Visible [(Required, exactDefinitionTermQueryArg), (Required, newNameArg)] "`alias.term foo bar` introduces `bar` with the same definition as `foo`." ( \case @@ -644,6 +674,7 @@ aliasType = InputPattern "alias.type" [] + I.Visible [(Required, exactDefinitionTypeQueryArg), (Required, newNameArg)] "`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`." ( \case @@ -662,6 +693,7 @@ aliasMany = InputPattern "alias.many" ["copy"] + I.Visible [(Required, definitionQueryArg), (OnePlus, exactDefinitionOrPathArg)] ( P.group . P.lines $ [ P.wrap $ @@ -685,6 +717,7 @@ up = InputPattern "up" [] + I.Visible [] (P.wrapColumn2 [(makeExample up [], "move current path up one level")]) ( \case @@ -697,6 +730,7 @@ cd = InputPattern "namespace" ["cd", "j"] + I.Visible [(Required, namespaceArg)] ( P.lines [ "Moves your perspective to a different namespace.", @@ -732,6 +766,7 @@ back = InputPattern "back" ["popd"] + I.Visible [] ( P.wrapColumn2 [ ( makeExample back [], @@ -749,6 +784,7 @@ deleteNamespace = InputPattern "delete.namespace" [] + I.Visible [(Required, namespaceArg)] "`delete.namespace ` deletes the namespace `foo`" (deleteNamespaceParser (I.help deleteNamespace) Input.Try) @@ -758,6 +794,7 @@ deleteNamespaceForce = InputPattern "delete.namespace.force" [] + I.Visible [(Required, namespaceArg)] ( "`delete.namespace.force ` deletes the namespace `foo`," <> "deletion will proceed even if other code depends on definitions in foo." @@ -782,6 +819,7 @@ deletePatch = InputPattern "delete.patch" [] + I.Visible [(Required, patchArg)] "`delete.patch ` deletes the patch `foo`" ( \case @@ -808,6 +846,7 @@ copyPatch = InputPattern "copy.patch" [] + I.Visible [(Required, patchArg), (Required, newNameArg)] "`copy.patch foo bar` copies the patch `foo` to `bar`." ( \case @@ -820,6 +859,7 @@ renamePatch = InputPattern "move.patch" ["rename.patch"] + I.Visible [(Required, patchArg), (Required, newNameArg)] "`move.patch foo bar` renames the patch `foo` to `bar`." ( \case @@ -832,6 +872,7 @@ renameBranch = InputPattern "move.namespace" ["rename.namespace"] + I.Visible [(Required, namespaceArg), (Required, newNameArg)] "`move.namespace foo bar` renames the path `bar` to `foo`." ( \case @@ -850,6 +891,7 @@ history = InputPattern "history" [] + I.Visible [(Optional, namespaceArg)] ( P.wrapColumn2 [ (makeExample history [], "Shows the history of the current path."), @@ -873,6 +915,7 @@ forkLocal = InputPattern "fork" ["copy.namespace"] + I.Visible [ (Required, namespaceArg), (Required, newNameArg) ] @@ -890,6 +933,7 @@ resetRoot = InputPattern "reset-root" [] + I.Visible [(Required, namespaceArg)] ( P.wrapColumn2 [ ( makeExample resetRoot [".foo"], @@ -930,6 +974,7 @@ pullImpl name verbosity pullMode addendum = do InputPattern name [] + I.Visible [(Optional, gitUrlArg), (Optional, namespaceArg)] ( P.lines [ P.wrap @@ -975,6 +1020,7 @@ pullExhaustive = InputPattern "debug.pull-exhaustive" [] + I.Visible [(Required, gitUrlArg), (Optional, namespaceArg)] ( P.lines [ P.wrap $ @@ -1003,6 +1049,7 @@ push = InputPattern "push" [] + I.Visible [(Required, gitUrlArg), (Optional, namespaceArg)] ( P.lines [ P.wrap @@ -1043,6 +1090,7 @@ pushCreate = InputPattern "push.create" [] + I.Visible [(Required, gitUrlArg), (Optional, namespaceArg)] ( P.lines [ P.wrap @@ -1083,6 +1131,7 @@ pushExhaustive = InputPattern "debug.push-exhaustive" [] + I.Visible [(Required, gitUrlArg), (Optional, namespaceArg)] ( P.lines [ P.wrap $ @@ -1110,6 +1159,7 @@ createPullRequest = InputPattern "pull-request.create" ["pr.create"] + I.Visible [(Required, gitUrlArg), (Required, gitUrlArg), (Optional, namespaceArg)] ( P.group $ P.lines @@ -1139,6 +1189,7 @@ loadPullRequest = InputPattern "pull-request.load" ["pr.load"] + I.Visible [(Required, gitUrlArg), (Required, gitUrlArg), (Optional, namespaceArg)] ( P.lines [ P.wrap $ @@ -1220,6 +1271,7 @@ squashMerge = InputPattern "merge.squash" ["squash"] + I.Visible [(Required, namespaceArg), (Required, namespaceArg)] ( P.wrap $ makeExample squashMerge ["src", "dest"] @@ -1241,6 +1293,7 @@ mergeLocal = InputPattern "merge" [] + I.Visible [ (Required, namespaceArg), (Optional, namespaceArg) ] @@ -1265,6 +1318,7 @@ diffNamespace = InputPattern "diff.namespace" [] + I.Visible [(Required, namespaceArg), (Optional, namespaceArg)] ( P.column2 [ ( "`diff.namespace before after`", @@ -1293,6 +1347,7 @@ previewMergeLocal = InputPattern "merge.preview" [] + I.Visible [(Required, namespaceArg), (Optional, namespaceArg)] ( P.column2 [ ( "`merge.preview src`", @@ -1327,6 +1382,7 @@ replaceEdit f = self InputPattern "replace" [] + I.Visible [ (Required, definitionQueryArg), (Required, definitionQueryArg), (Optional, patchArg) @@ -1360,6 +1416,7 @@ viewReflog = InputPattern "reflog" [] + I.Visible [] "`reflog` lists the changes that have affected the root namespace" ( \case @@ -1374,6 +1431,7 @@ edit = InputPattern "edit" [] + I.Visible [(OnePlus, definitionQueryArg)] ( P.lines [ "`edit foo` prepends the definition of `foo` to the top of the most " @@ -1398,6 +1456,7 @@ helpTopics = InputPattern "help-topics" ["help-topic"] + I.Visible [(Optional, topicNameArg)] ("`help-topics` lists all topics and `help-topics ` shows an explanation of that topic.") ( \case @@ -1542,6 +1601,7 @@ help = InputPattern "help" ["?"] + I.Visible [(Optional, commandNameArg)] "`help` shows general help and `help ` shows help for one command." ( \case @@ -1550,7 +1610,7 @@ help = intercalateMap "\n\n" showPatternHelp - (sortOn I.patternName validInputs) + visibleInputs [isHelp -> Just msg] -> Left msg [cmd] -> case Map.lookup cmd commandsByName of Nothing -> Left . warn $ "I don't know of that command. Try `help`." @@ -1559,9 +1619,10 @@ help = ) where commandsByName = - Map.fromList - [ (n, i) | i <- validInputs, n <- I.patternName i : I.aliases i - ] + Map.fromList $ do + input@I.InputPattern {I.patternName, I.aliases} <- validInputs + name <- patternName : aliases + pure (name, input) isHelp s = Map.lookup s helpTopicsMap quit :: InputPattern @@ -1569,6 +1630,7 @@ quit = InputPattern "quit" ["exit", ":q"] + I.Visible [] "Exits the Unison command line interface." ( \case @@ -1581,6 +1643,7 @@ viewPatch = InputPattern "view.patch" [] + I.Visible [(Required, patchArg)] ( P.wrapColumn2 [ ( makeExample' viewPatch, @@ -1604,6 +1667,7 @@ link = InputPattern "link" [] + I.Visible [(Required, definitionQueryArg), (OnePlus, definitionQueryArg)] ( fromString $ concat @@ -1629,6 +1693,7 @@ links = InputPattern "links" [] + I.Visible [(Required, definitionQueryArg), (Optional, definitionQueryArg)] ( P.column2 [ (makeExample links ["defn"], "shows all outgoing links from `defn`."), @@ -1650,6 +1715,7 @@ unlink = InputPattern "unlink" ["delete.link"] + I.Visible [(Required, definitionQueryArg), (OnePlus, definitionQueryArg)] ( fromString $ concat @@ -1674,6 +1740,7 @@ names = InputPattern "names" [] + I.Visible [(Required, definitionQueryArg)] "`names foo` shows the hash and all known names for `foo`." ( \case @@ -1691,6 +1758,7 @@ dependents = InputPattern "dependents" [] + I.Visible [] "List the named dependents of the specified definition." ( \case @@ -1701,6 +1769,7 @@ dependencies = InputPattern "dependencies" [] + I.Visible [] "List the dependencies of the specified definition." ( \case @@ -1713,6 +1782,7 @@ namespaceDependencies = InputPattern "namespace.dependencies" [] + I.Visible [(Optional, namespaceArg)] "List the external dependencies of the specified namespace." ( \case @@ -1728,6 +1798,7 @@ debugNumberedArgs = InputPattern "debug.numberedArgs" [] + I.Visible [] "Dump the contents of the numbered args state." (const $ Right Input.DebugNumberedArgsI) @@ -1737,6 +1808,7 @@ debugFileHashes = InputPattern "debug.file" [] + I.Visible [] "View details about the most recent succesfully typechecked file." (const $ Right Input.DebugTypecheckedUnisonFileI) @@ -1746,6 +1818,7 @@ debugDumpNamespace = InputPattern "debug.dump-namespace" [] + I.Visible [(Required, noCompletions)] "Dump the namespace to a text file" (const $ Right Input.DebugDumpNamespacesI) @@ -1755,6 +1828,7 @@ debugDumpNamespaceSimple = InputPattern "debug.dump-namespace-simple" [] + I.Visible [(Required, noCompletions)] "Dump the namespace to a text file" (const $ Right Input.DebugDumpNamespaceSimpleI) @@ -1764,6 +1838,7 @@ debugClearWatchCache = InputPattern "debug.clear-cache" [] + I.Visible [(Required, noCompletions)] "Clear the watch expression cache" (const $ Right Input.DebugClearWatchI) @@ -1773,6 +1848,7 @@ test = InputPattern "test" [] + I.Visible [] "`test` runs unit tests for the current branch." (const $ pure $ Input.TestI True True) @@ -1782,6 +1858,7 @@ docsToHtml = InputPattern "docs.to-html" [] + I.Visible [] ( P.wrapColumn2 [ ( "`docs.to-html .path.to.namespace ~/path/to/file/output`", @@ -1802,6 +1879,7 @@ execute = InputPattern "run" [] + I.Visible [(Required, exactDefinitionTermQueryArg), (ZeroPlus, noCompletions)] ( P.wrapColumn2 [ ( "`run mymain args...`", @@ -1823,6 +1901,7 @@ ioTest = InputPattern "io.test" [] + I.Visible [] ( P.wrapColumn2 [ ( "`io.test mytest`", @@ -1841,6 +1920,7 @@ makeStandalone = InputPattern "compile" ["compile.output"] + I.Visible [(Required, exactDefinitionTermQueryArg), (Required, noCompletions)] ( P.wrapColumn2 [ ( "`compile main file`", @@ -1861,6 +1941,7 @@ createAuthor = InputPattern "create.author" [] + I.Visible [(Required, noCompletions), (Required, noCompletions)] ( makeExample createAuthor ["alicecoder", "\"Alice McGee\""] <> "creates" @@ -1888,6 +1969,7 @@ gist = InputPattern "push.gist" ["gist"] + I.Visible [(Required, gitUrlArg)] ( P.lines [ "Publish the current namespace.", @@ -1908,93 +1990,98 @@ gist = validInputs :: [InputPattern] validInputs = - [ help, - helpTopics, - load, - add, - previewAdd, - update, - previewUpdate, - updateNoPatch, - delete, - forkLocal, - mergeLocal, - squashMerge, - previewMergeLocal, - diffNamespace, - names, - push, - pushCreate, - pull, - pullWithoutHistory, - pullSilent, - pushExhaustive, - pullExhaustive, - createPullRequest, - loadPullRequest, - cd, - up, - back, - deleteNamespace, - deleteNamespaceForce, - renameBranch, - deletePatch, - renamePatch, - copyPatch, - find, - findShallow, - findVerbose, - view, - display, - displayTo, - api, - ui, - docs, - docsToHtml, - findPatch, - viewPatch, - undo, - history, - edit, - renameTerm, - deleteTerm, - aliasTerm, - renameType, - deleteType, - aliasType, - aliasMany, - todo, - patch, - link, - unlink, - links, - createAuthor, - replace, - deleteTermReplacement, - deleteTypeReplacement, - test, - ioTest, - execute, - viewReflog, - resetRoot, - quit, - updateBuiltins, - makeStandalone, - mergeBuiltins, - mergeIOBuiltins, - dependents, - dependencies, - namespaceDependencies, - debugNumberedArgs, - debugFileHashes, - debugDumpNamespace, - debugDumpNamespaceSimple, - debugClearWatchCache, - gist - ] + sortOn + I.patternName + [ help, + helpTopics, + load, + add, + previewAdd, + update, + previewUpdate, + updateNoPatch, + delete, + forkLocal, + mergeLocal, + squashMerge, + previewMergeLocal, + diffNamespace, + names, + push, + pushCreate, + pull, + pullWithoutHistory, + pullSilent, + pushExhaustive, + pullExhaustive, + createPullRequest, + loadPullRequest, + cd, + up, + back, + deleteNamespace, + deleteNamespaceForce, + renameBranch, + deletePatch, + renamePatch, + copyPatch, + find, + findShallow, + findVerbose, + view, + display, + displayTo, + api, + ui, + docs, + docsToHtml, + findPatch, + viewPatch, + undo, + history, + edit, + renameTerm, + deleteTerm, + aliasTerm, + renameType, + deleteType, + aliasType, + aliasMany, + todo, + patch, + link, + unlink, + links, + createAuthor, + replace, + deleteTermReplacement, + deleteTypeReplacement, + test, + ioTest, + execute, + viewReflog, + resetRoot, + quit, + updateBuiltins, + makeStandalone, + mergeBuiltins, + mergeIOBuiltins, + dependents, + dependencies, + namespaceDependencies, + debugNumberedArgs, + debugFileHashes, + debugDumpNamespace, + debugDumpNamespaceSimple, + debugClearWatchCache, + gist + ] + +visibleInputs :: [InputPattern] +visibleInputs = filter ((== I.Visible) . I.visibility) validInputs commandNames :: [String] -commandNames = validInputs >>= \i -> I.patternName i : I.aliases i +commandNames = visibleInputs >>= \i -> I.patternName i : I.aliases i commandNameArg :: ArgumentType commandNameArg = From da1275346bdc8611d767b3b4adb60ef65e2d8dac Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 24 Mar 2022 15:26:48 -0400 Subject: [PATCH 024/529] Standardize context handling in ANF serialization --- .../src/Unison/Runtime/ANF/Serialize.hs | 29 +++++++++++-------- 1 file changed, 17 insertions(+), 12 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs index 29f5510b9c..0a196d8491 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs @@ -214,6 +214,9 @@ deindex (v : vs) n | n == 0 = v | otherwise = deindex vs (n - 1) +pushCtx :: [v] -> [v] -> [v] +pushCtx us vs = reverse us ++ vs + putIndex :: MonadPut m => Word64 -> m () putIndex = serialize . VarInt @@ -258,16 +261,18 @@ putGroup :: putGroup fops (Rec bs e) = putLength n *> traverse_ (putComb fops ctx) cs *> putComb fops ctx e where - n = length ctx - (ctx, cs) = unzip bs + n = length us + (us, cs) = unzip bs + ctx = pushCtx us [] getGroup :: MonadGet m => Var v => m (SuperGroup v) getGroup = do l <- getLength let n = fromIntegral l vs = getFresh <$> take l [0 ..] - cs <- replicateM l (getComb vs n) - Rec (zip vs cs) <$> getComb vs n + ctx = pushCtx vs [] + cs <- replicateM l (getComb ctx n) + Rec (zip ctx cs) <$> getComb ctx n putComb :: MonadPut m => @@ -277,7 +282,7 @@ putComb :: SuperNormal v -> m () putComb fops ctx (Lambda ccs (TAbss us e)) = - putCCs ccs *> putNormal fops (reverse us ++ ctx) e + putCCs ccs *> putNormal fops (pushCtx us ctx) e getFresh :: Var v => Word64 -> v getFresh n = freshenId n $ typed ANFBlank @@ -287,7 +292,7 @@ getComb ctx frsh0 = do ccs <- getCCs let us = zipWith (\_ -> getFresh) ccs [frsh0 ..] frsh = frsh0 + fromIntegral (length ccs) - Lambda ccs . TAbss us <$> getNormal (us ++ ctx) frsh + Lambda ccs . TAbss us <$> getNormal (pushCtx us ctx) frsh putNormal :: MonadPut m => @@ -314,10 +319,10 @@ putNormal fops ctx tm = case tm of *> putNormal fops (v : ctx) e TLets Direct us ccs l e -> putTag LetDirT *> putCCs ccs *> putNormal fops ctx l - *> putNormal fops (reverse us ++ ctx) e + *> putNormal fops (pushCtx us ctx) e TLets (Indirect w) us ccs l e -> putTag LetIndT *> putWord16be w *> putCCs ccs *> putNormal fops ctx l - *> putNormal fops (reverse us ++ ctx) e + *> putNormal fops (pushCtx us ctx) e _ -> exn "putNormal: malformed term" getNormal :: MonadGet m => Var v => [v] -> Word64 -> m (ANormal v) @@ -354,7 +359,7 @@ getNormal ctx frsh0 = us = getFresh <$> take l [frsh0 ..] TLets Direct us ccs <$> getNormal ctx frsh0 - <*> getNormal (us ++ ctx) frsh + <*> getNormal (pushCtx us ctx) frsh LetIndT -> do w <- getWord16be ccs <- getCCs @@ -363,7 +368,7 @@ getNormal ctx frsh0 = us = getFresh <$> take l [frsh0 ..] TLets (Indirect w) us ccs <$> getNormal ctx frsh0 - <*> getNormal (us ++ ctx) frsh + <*> getNormal (pushCtx us ctx) frsh putFunc :: MonadPut m => @@ -634,7 +639,7 @@ putCase :: ([Mem], ANormal v) -> m () putCase fops ctx (ccs, (TAbss us e)) = - putCCs ccs *> putNormal fops (us ++ ctx) e + putCCs ccs *> putNormal fops (pushCtx us ctx) e getCase :: MonadGet m => Var v => [v] -> Word64 -> m ([Mem], ANormal v) getCase ctx frsh0 = do @@ -642,7 +647,7 @@ getCase ctx frsh0 = do let l = length ccs frsh = frsh0 + fromIntegral l us = getFresh <$> take l [frsh0 ..] - (,) ccs . TAbss us <$> getNormal (us ++ ctx) frsh + (,) ccs . TAbss us <$> getNormal (pushCtx us ctx) frsh putCTag :: MonadPut m => CTag -> m () putCTag c = serialize (VarInt $ fromEnum c) From f752ff7abcd647741275695c11d407b218744a30 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Sun, 27 Mar 2022 16:52:42 -0500 Subject: [PATCH 025/529] Switch to self-contained namespace model --- .../src/Unison/Codebase/Editor/HandleInput.hs | 24 ++++++++++--------- .../src/Unison/Codebase/Editor/Input.hs | 2 +- .../src/Unison/CommandLine/InputPatterns.hs | 19 +++++++++++---- 3 files changed, 28 insertions(+), 17 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 90fca1df04..977af3a904 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -234,7 +234,7 @@ loop = do L.Hash sh -> Just (HQ.HashOnly sh) _ -> Nothing hqs = Set.fromList . mapMaybe (getHQ . L.payload) $ tokens - let parseNames = Backend.getCurrentParseNames (Backend.AllNames currentPath'') root' + let parseNames = Backend.getCurrentParseNames (Backend.Within currentPath'') root' LoopState.latestFile .= Just (Text.unpack sourceName, False) LoopState.latestTypecheckedFile .= Nothing Result notes r <- eval $ Typecheck ambient parseNames sourceName lexed @@ -441,7 +441,7 @@ loop = do HistoryI {} -> wat TestI {} -> wat LinksI {} -> wat - SearchByNameI {} -> wat + FindI {} -> wat FindShallowI {} -> wat FindPatchI {} -> wat ShowDefinitionI {} -> wat @@ -1100,7 +1100,7 @@ loop = do p | last p == '.' -> p ++ s p -> p ++ "." ++ s pathArgStr = show pathArg - SearchByNameI isVerbose _showAll ws -> do + FindI isVerbose global ws -> do let prettyPrintNames = basicPrettyPrintNames unlessError do results <- case ws of @@ -1131,7 +1131,9 @@ loop = do -- name query (map HQ.unsafeFromString -> qs) -> do - let ns = basicPrettyPrintNames + ns <- lift $ + if not global then basicParseNames + else fst <$> basicNames' Backend.AllNames let srs = searchBranchScored ns fuzzyNameDistance qs pure $ uniqueBy SR.toReferent srs lift do @@ -1400,7 +1402,7 @@ loop = do IOTestI main -> do -- todo - allow this to run tests from scratch file, using addRunMain testType <- eval RuntimeTest - parseNames <- (`NamesWithHistory.NamesWithHistory` mempty) <$> basicPrettyPrintNamesA + parseNames <- (`NamesWithHistory.NamesWithHistory` mempty) <$> basicParseNames ppe <- suffixifiedPPE parseNames -- use suffixed names for resolving the argument to display let oks results = @@ -2537,7 +2539,7 @@ getMetadataFromName name = do getPPE = do currentPath' <- use LoopState.currentPath sbhLength <- eval BranchHashLength - Backend.basicSuffixifiedNames sbhLength <$> use LoopState.root <*> pure (Backend.AllNames $ Path.unabsolute currentPath') + Backend.basicSuffixifiedNames sbhLength <$> use LoopState.root <*> pure (Backend.Within $ Path.unabsolute currentPath') -- | Get the set of terms related to a hash-qualified name. getHQTerms :: HQ.HashQualified Name -> Action' m v (Set Referent) @@ -3116,7 +3118,7 @@ findHistoricalHQs lexedHQs0 = do pure rawHistoricalNames basicPrettyPrintNamesA :: Functor m => Action' m v Names -basicPrettyPrintNamesA = snd <$> basicNames' +basicPrettyPrintNamesA = snd <$> basicNames' Backend.AllNames makeShadowedPrintNamesFromHQ :: Monad m => Set (HQ.HashQualified Name) -> Names -> Action' m v NamesWithHistory makeShadowedPrintNamesFromHQ lexedHQs shadowing = do @@ -3131,7 +3133,7 @@ makeShadowedPrintNamesFromHQ lexedHQs shadowing = do (NamesWithHistory basicNames (fixupNamesRelative curPath rawHistoricalNames)) basicParseNames, slurpResultNames :: Functor m => Action' m v Names -basicParseNames = fst <$> basicNames' +basicParseNames = fst <$> basicNames' Backend.Within -- we check the file against everything in the current path slurpResultNames = currentPathNames @@ -3142,11 +3144,11 @@ currentPathNames = do pure $ Branch.toNames (Branch.head currentBranch') -- implementation detail of basicParseNames and basicPrettyPrintNames -basicNames' :: (Functor m) => Action m i v (Names, Names) -basicNames' = do +basicNames' :: (Functor m) => (Path -> Backend.NameScoping) -> Action m i v (Names, Names) +basicNames' nameScoping = do root' <- use LoopState.root currentPath' <- use LoopState.currentPath - pure $ Backend.basicNames' root' (Backend.AllNames $ Path.unabsolute currentPath') + pure $ Backend.basicNames' root' (nameScoping $ Path.unabsolute currentPath') data AddRunMainResult v = NoTermWithThatName diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index b8dd6a5894..d82e2b63f4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -155,7 +155,7 @@ data Input | -- Display docs for provided terms. If list is empty, prompt a fuzzy search. DocsI [Path.HQSplit'] | -- other - SearchByNameI Bool Bool [String] -- SearchByName isVerbose showAll query + FindI Bool Bool [String] -- SearchByName isVerbose global query | FindShallowI Path' | FindPatchI | -- Show provided definitions. If list is empty, prompt a fuzzy search. diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 2dc62edc2e..91b3b5622a 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -399,9 +399,15 @@ viewByPrefix = ) find :: InputPattern -find = +find = find' "find" False + +findGlobal :: InputPattern +findGlobal = find' "find.global" True + +find' :: String -> Bool -> InputPattern +find' cmd global = InputPattern - "find" + cmd [] [(ZeroPlus, fuzzyDefinitionQueryArg)] ( P.wrapColumn2 @@ -413,10 +419,13 @@ find = ( "`find foo bar`", "lists all definitions with a name similar to 'foo' or 'bar' in the " <> "current namespace." + ), + ( "find.global foo", + "lists all definitions with a name similar to 'foo' in any namespace" ) ] ) - (pure . Input.SearchByNameI False False) + (pure . Input.FindI False global) findShallow :: InputPattern findShallow = @@ -442,12 +451,12 @@ findVerbose :: InputPattern findVerbose = InputPattern "find.verbose" - ["list.verbose", "ls.verbose"] + [] [(ZeroPlus, fuzzyDefinitionQueryArg)] ( "`find.verbose` searches for definitions like `find`, but includes hashes " <> "and aliases in the results." ) - (pure . Input.SearchByNameI True False) + (pure . Input.FindI True False) findPatch :: InputPattern findPatch = From 9cb116a80ba61e9732d60db346e44daa1117c3a8 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Sun, 27 Mar 2022 16:59:40 -0500 Subject: [PATCH 026/529] Add find.global command. Tweak output messages to suggest it on no results. --- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 1 + unison-cli/src/Unison/CommandLine/OutputMessages.hs | 12 +++++++++--- 2 files changed, 10 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 91b3b5622a..7b7312a586 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1951,6 +1951,7 @@ validInputs = renamePatch, copyPatch, find, + findGlobal, findShallow, findVerbose, view, diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index da396ec032..9997e31e5a 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2528,9 +2528,15 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = noResults :: Pretty noResults = P.callout "๐Ÿ˜ถ" $ - P.wrap $ - "No results. Check your spelling, or try using tab completion " - <> "to supply command arguments." + P.lines + [ P.wrap $ + "No results. Check your spelling, or try using tab completion " + <> "to supply command arguments.", + "", + P.wrap $ + IP.makeExample IP.findGlobal [] + <> "can be used to search outside the current namespace." + ] listOfDefinitions' :: Var v => From 34c4f4675774ac58635f33acc59af0db50603815 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Mon, 28 Mar 2022 12:08:52 -0500 Subject: [PATCH 027/529] dependents command now correctly shows local dependents didn't bother with dependents.global --- .../src/Unison/Codebase/Editor/HandleInput.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 977af3a904..b28b0c7911 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -159,11 +159,11 @@ prettyPrintEnvDecl :: MonadCommand n m i v => NamesWithHistory -> n PPE.PrettyPr prettyPrintEnvDecl ns = eval CodebaseHashLength <&> (`PPE.fromNamesDecl` ns) -- | Get a pretty print env decl for the current names at the current path. -currentPrettyPrintEnvDecl :: Action' m v PPE.PrettyPrintEnvDecl -currentPrettyPrintEnvDecl = do +currentPrettyPrintEnvDecl :: (Path -> Backend.NameScoping) -> Action' m v PPE.PrettyPrintEnvDecl +currentPrettyPrintEnvDecl scoping = do root' <- use LoopState.root currentPath' <- Path.unabsolute <$> use LoopState.currentPath - prettyPrintEnvDecl (Backend.getCurrentPrettyNames (Backend.AllNames currentPath') root') + prettyPrintEnvDecl (Backend.getCurrentPrettyNames (scoping currentPath') root') loop :: forall m. MonadUnliftIO m => Action m (Either Event Input) Symbol () loop = do @@ -535,7 +535,7 @@ loop = do diffHelper (Branch.head root') (Branch.head root'') >>= respondNumbered . uncurry ShowDiffAfterDeleteDefinitions else do - ppeDecl <- currentPrettyPrintEnvDecl + ppeDecl <- currentPrettyPrintEnvDecl Backend.Within respondNumbered $ CantDeleteDefinitions ppeDecl endangerments in case input of ApiI -> eval API @@ -760,11 +760,11 @@ loop = do then doDelete b0 else case insistence of Force -> do - ppeDecl <- currentPrettyPrintEnvDecl + ppeDecl <- currentPrettyPrintEnvDecl Backend.Within doDelete b0 respondNumbered $ DeletedDespiteDependents ppeDecl endangerments Try -> do - ppeDecl <- currentPrettyPrintEnvDecl + ppeDecl <- currentPrettyPrintEnvDecl Backend.Within respondNumbered $ CantDeleteNamespace ppeDecl endangerments where doDelete b0 = do @@ -1560,7 +1560,7 @@ loop = do Nothing -> respond $ BranchEmpty (Right (Path.absoluteToPath' path)) Just b -> do externalDependencies <- NamespaceDependencies.namespaceDependencies (Branch.head b) - ppe <- PPE.unsuffixifiedPPE <$> currentPrettyPrintEnvDecl + ppe <- PPE.unsuffixifiedPPE <$> currentPrettyPrintEnvDecl Backend.Within respond $ ListNamespaceDependencies ppe path externalDependencies DebugNumberedArgsI -> use LoopState.numberedArgs >>= respond . DumpNumberedArgs DebugTypecheckedUnisonFileI -> case uf of @@ -1656,7 +1656,7 @@ handleDependents hq = do in LD.fold tp tm ld -- Use an unsuffixified PPE here, so we display full names (relative to the current path), rather than the shortest possible -- unambiguous name. - ppe <- PPE.unsuffixifiedPPE <$> currentPrettyPrintEnvDecl + ppe <- PPE.unsuffixifiedPPE <$> currentPrettyPrintEnvDecl Backend.Within let results :: [(Reference, Maybe Name)] results = -- Currently we only retain dependents that are named in the current namespace (hence `mapMaybe`). In the future, we could From 4a5a56c48ce800f0b01b0fdb9e3c09f09a05e27c Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Mon, 28 Mar 2022 12:39:15 -0500 Subject: [PATCH 028/529] Sort dependents output by name, not by hash! And put name in first column, rather than hash. --- .../src/Unison/CommandLine/OutputMessages.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 9997e31e5a..344b7a3314 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1438,20 +1438,23 @@ notifyUser dir o = case o of P.lines [ "Dependents of " <> prettyLd <> ":", "", - P.indentN 2 (P.numberedColumn2Header num pairs) + P.indentN 2 (P.numberedColumn2Header num pairs), + "", + tip $ "Try " <> IP.makeExample IP.view ["1"] <> " to see the source of any numbered item in the above list." ] where prettyLd = P.syntaxToColor (prettyLabeledDependency hqLength ld) num n = P.hiBlack $ P.shown n <> "." - header = (P.hiBlack "Reference", P.hiBlack "Name") - pairs = header : map pair results + header = (P.hiBlack "Name", P.hiBlack "Reference") + pairs = header : map pair (List.sortOn (fmap (Name.convert :: Name -> HQ.HashQualified Name) . snd) results) pair :: (Reference, Maybe Name) -> (Pretty, Pretty) pair (reference, maybeName) = - ( prettyShortHash (SH.take hqLength (Reference.toShortHash reference)), - case maybeName of + ( case maybeName of Nothing -> "" - Just name -> prettyName name + Just name -> prettyName name, + prettyShortHash (SH.take hqLength (Reference.toShortHash reference)) ) + -- this definition is identical to the previous one, apart from the word -- "Dependencies", but undecided about whether or how to refactor ListDependencies hqLength ld names missing -> From fc296793ba8f2146b3582a157fa873b377b448be Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 29 Mar 2022 13:59:44 -0400 Subject: [PATCH 029/529] Save information for decompiling non-closed definitions Previously in cases like: let f x = ... g y = ... f ... ... we would not save decompilation information for `g`, because it wouldn't be possible to guarantee that the output of decompilation actually made sense (for instance, if `g` is decompiled, it will not mention `f`. However, this seems to block some useful documentation, even in cases where it doesn't seem like such intermediate definitions would need to be decompiled. So, it seems like a better trade-off to just allow decompilation, and accept that some output might be difficult to understand. Such output can be avoided when writing documentation. --- parser-typechecker/src/Unison/Runtime/ANF.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index b566d72e7a..077eb208c4 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -332,7 +332,7 @@ floater _ rec (Let1Named' v b e) | Just (vs0, _, vs1, bd) <- unLamsAnnot b = Just $ rec bd - >>= lamFloater (null $ ABT.freeVars b) b (Just v) a (vs0 ++ vs1) + >>= lamFloater True b (Just v) a (vs0 ++ vs1) >>= \lv -> rec $ ABT.renames (Map.singleton v lv) e where a = ABT.annotation b @@ -340,7 +340,7 @@ floater top rec tm@(LamsNamed' vs bd) | top = Just $ lam' a vs <$> rec bd | otherwise = Just $ do bd <- rec bd - lv <- lamFloater (null $ ABT.freeVars tm) tm Nothing a vs bd + lv <- lamFloater True tm Nothing a vs bd pure $ var a lv where a = ABT.annotation tm From f1a7bc210c8c148dbd511ac04f55baadf1399ea0 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 30 Mar 2022 13:19:48 -0600 Subject: [PATCH 030/529] Authenticate UCM with Codebase Servers. (#3000) * The auth.login command is hidden until it's officially supported. --- lib/unison-prelude/src/Unison/Debug.hs | 19 +- lib/unison-prelude/src/Unison/Prelude.hs | 20 ++- .../src/Unison/Runtime/Interface.hs | 90 +++++----- stack.yaml | 2 + unison-cli/package.yaml | 12 ++ unison-cli/src/Unison/Auth/CredentialFile.hs | 47 +++++ .../src/Unison/Auth/CredentialManager.hs | 44 +++++ unison-cli/src/Unison/Auth/Discovery.hs | 24 +++ unison-cli/src/Unison/Auth/HTTPClient.hs | 35 ++++ unison-cli/src/Unison/Auth/OAuth.hs | 138 ++++++++++++++ unison-cli/src/Unison/Auth/Tokens.hs | 44 +++++ unison-cli/src/Unison/Auth/Types.hs | 168 ++++++++++++++++++ .../src/Unison/Codebase/Editor/Command.hs | 5 + .../Unison/Codebase/Editor/HandleCommand.hs | 6 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 68 +++---- .../Codebase/Editor/HandleInput/AuthLogin.hs | 22 +++ .../Codebase/Editor/HandleInput/LoopState.hs | 17 +- .../src/Unison/Codebase/Editor/Input.hs | 3 + .../src/Unison/Codebase/Editor/Output.hs | 9 + .../src/Unison/Codebase/TranscriptParser.hs | 21 ++- .../src/Unison/CommandLine/InputPatterns.hs | 34 +++- unison-cli/src/Unison/CommandLine/Main.hs | 17 +- .../src/Unison/CommandLine/OutputMessages.hs | 56 +++++- unison-cli/src/Unison/CommandLine/Welcome.hs | 10 +- unison-cli/src/Unison/Util/HTTP.hs | 19 ++ unison-cli/unison-cli.cabal | 63 +++++++ unison-cli/unison/Main.hs | 51 ++++-- unison-cli/unison/Version.hs | 31 ++-- 28 files changed, 940 insertions(+), 135 deletions(-) create mode 100644 unison-cli/src/Unison/Auth/CredentialFile.hs create mode 100644 unison-cli/src/Unison/Auth/CredentialManager.hs create mode 100644 unison-cli/src/Unison/Auth/Discovery.hs create mode 100644 unison-cli/src/Unison/Auth/HTTPClient.hs create mode 100644 unison-cli/src/Unison/Auth/OAuth.hs create mode 100644 unison-cli/src/Unison/Auth/Tokens.hs create mode 100644 unison-cli/src/Unison/Auth/Types.hs create mode 100644 unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs create mode 100644 unison-cli/src/Unison/Util/HTTP.hs diff --git a/lib/unison-prelude/src/Unison/Debug.hs b/lib/unison-prelude/src/Unison/Debug.hs index af6864914b..fe42dceccf 100644 --- a/lib/unison-prelude/src/Unison/Debug.hs +++ b/lib/unison-prelude/src/Unison/Debug.hs @@ -1,6 +1,14 @@ {-# LANGUAGE OverloadedStrings #-} -module Unison.Debug (debug, debugM, whenDebug, debugLog, debugLogM, DebugFlag (..)) where +module Unison.Debug + ( debug, + debugM, + whenDebug, + debugLog, + debugLogM, + DebugFlag (..), + ) +where import Control.Applicative (empty) import Control.Monad (when) @@ -15,10 +23,11 @@ data DebugFlag = Git | Sqlite | Codebase + | Auth deriving (Eq, Ord, Show, Bounded, Enum) debugFlags :: Set DebugFlag -debugFlags = pTraceShowId $ case pTraceShowId $ (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of +debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of Nothing -> Set.empty -- Enable all debugging flags for bare UNISON_DEBUG declarations like: -- UNISON_DEBUG= ucm @@ -29,6 +38,7 @@ debugFlags = pTraceShowId $ case pTraceShowId $ (unsafePerformIO (lookupEnv "UNI "GIT" -> pure Git "SQLITE" -> pure Sqlite "CODEBASE" -> pure Codebase + "AUTH" -> pure Auth _ -> empty {-# NOINLINE debugFlags #-} @@ -44,6 +54,10 @@ debugCodebase :: Bool debugCodebase = Codebase `Set.member` debugFlags {-# NOINLINE debugCodebase #-} +debugAuth :: Bool +debugAuth = Auth `Set.member` debugFlags +{-# NOINLINE debugAuth #-} + -- | Use for trace-style selective debugging. -- E.g. 1 + (debug Git "The second number" 2) -- @@ -87,3 +101,4 @@ shouldDebug = \case Git -> debugGit Sqlite -> debugSqlite Codebase -> debugCodebase + Auth -> debugAuth diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index f13e8e13b9..504bdb7dc7 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -10,6 +10,9 @@ module Unison.Prelude -- * @Maybe@ control flow onNothing, + whenNothing, + eitherToMaybe, + maybeToEither, -- * @Either@ control flow whenLeft, @@ -33,6 +36,7 @@ import Data.ByteString as X (ByteString) import Data.Coerce as X (Coercible, coerce) import Data.Either as X import Data.Either.Combinators as X (mapLeft, maybeToRight) +import Data.Either.Extra (eitherToMaybe, maybeToEither) import Data.Foldable as X (asum, fold, foldl', for_, toList, traverse_) import Data.Function as X ((&)) import Data.Functor as X @@ -59,9 +63,17 @@ import qualified System.IO as IO import Text.Read as X (readMaybe) import qualified UnliftIO +-- | E.g. +-- +-- @@ +-- onNothing (throwIO MissingPerson) $ mayThing +-- @@ onNothing :: Applicative m => m a -> Maybe a -> m a -onNothing x = - maybe x pure +onNothing m may = maybe m pure may + +-- | E.g. @maybePerson `whenNothing` throwIO MissingPerson@ +whenNothing :: Applicative m => Maybe a -> m a -> m a +whenNothing may m = maybe m pure may whenLeft :: Applicative m => Either a b -> (a -> m b) -> m b whenLeft = \case @@ -77,10 +89,10 @@ throwExceptTWith f action = Left e -> liftIO . UnliftIO.throwIO $ e Right a -> pure a -throwEitherM :: (MonadIO m, Exception e) => m (Either e a) -> m a +throwEitherM :: forall e m a. (MonadIO m, Exception e) => m (Either e a) -> m a throwEitherM = throwEitherMWith id -throwEitherMWith :: (MonadIO m, Exception e') => (e -> e') -> m (Either e a) -> m a +throwEitherMWith :: forall e e' m a. (MonadIO m, Exception e') => (e -> e') -> m (Either e a) -> m a throwEitherMWith f action = throwExceptT . withExceptT f $ (ExceptT action) tShow :: Show a => a -> Text diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index 57a4c2ee1c..9dc6730fe7 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -42,7 +42,7 @@ import Data.Set as Set (\\), ) import qualified Data.Set as Set -import Data.Text (Text, isPrefixOf, pack) +import Data.Text (Text, isPrefixOf) import Data.Traversable (for) import Data.Word (Word64) import GHC.Stack (HasCallStack) @@ -337,9 +337,9 @@ prepareEvaluation ppe tm ctx = do $ Map.fromList bs, mn <- Tm.substs (Map.toList $ Tm.ref () . fst <$> hcs) mn0, rmn <- RF.DerivedId $ Hashing.hashClosedTerm mn = - (rmn, (rmn, mn) : Map.elems hcs) + (rmn, (rmn, mn) : Map.elems hcs) | rmn <- RF.DerivedId $ Hashing.hashClosedTerm tm = - (rmn, [(rmn, tm)]) + (rmn, [(rmn, tm)]) (rgrp, rbkr) = intermediateTerms ppe ctx rtms @@ -407,50 +407,50 @@ executeMainComb init cc = bugMsg :: PrettyPrintEnv -> Text -> Term Symbol -> Pretty ColorText bugMsg ppe name tm | name == "blank expression" = - P.callout icon . P.lines $ - [ P.wrap - ( "I encountered a" <> P.red (P.text name) - <> "with the following name/message:" - ), - "", - P.indentN 2 $ pretty ppe tm, - "", - sorryMsg - ] + P.callout icon . P.lines $ + [ P.wrap + ( "I encountered a" <> P.red (P.text name) + <> "with the following name/message:" + ), + "", + P.indentN 2 $ pretty ppe tm, + "", + sorryMsg + ] | "pattern match failure" `isPrefixOf` name = - P.callout icon . P.lines $ - [ P.wrap - ( "I've encountered a" <> P.red (P.text name) - <> "while scrutinizing:" - ), - "", - P.indentN 2 $ pretty ppe tm, - "", - "This happens when calling a function that doesn't handle all \ - \possible inputs", - sorryMsg - ] + P.callout icon . P.lines $ + [ P.wrap + ( "I've encountered a" <> P.red (P.text name) + <> "while scrutinizing:" + ), + "", + P.indentN 2 $ pretty ppe tm, + "", + "This happens when calling a function that doesn't handle all \ + \possible inputs", + sorryMsg + ] | name == "builtin.raise" = - P.callout icon . P.lines $ - [ P.wrap ("The program halted with an unhandled exception:"), - "", - P.indentN 2 $ pretty ppe tm - ] + P.callout icon . P.lines $ + [ P.wrap ("The program halted with an unhandled exception:"), + "", + P.indentN 2 $ pretty ppe tm + ] | name == "builtin.bug", RF.TupleTerm' [Tm.Text' msg, x] <- tm, "pattern match failure" `isPrefixOf` msg = - P.callout icon . P.lines $ - [ P.wrap - ( "I've encountered a" <> P.red (P.text msg) - <> "while scrutinizing:" - ), - "", - P.indentN 2 $ pretty ppe x, - "", - "This happens when calling a function that doesn't handle all \ - \possible inputs", - sorryMsg - ] + P.callout icon . P.lines $ + [ P.wrap + ( "I've encountered a" <> P.red (P.text msg) + <> "while scrutinizing:" + ), + "", + P.indentN 2 $ pretty ppe x, + "", + "This happens when calling a function that doesn't handle all \ + \possible inputs", + sorryMsg + ] bugMsg ppe name tm = P.callout icon . P.lines $ [ P.wrap @@ -495,7 +495,7 @@ data RuntimeHost = Standalone | UCM -startRuntime :: RuntimeHost -> String -> IO (Runtime Symbol) +startRuntime :: RuntimeHost -> Text -> IO (Runtime Symbol) startRuntime runtimeHost version = do ctxVar <- newIORef =<< baseContext (activeThreads, cleanupThreads) <- case runtimeHost of @@ -528,7 +528,7 @@ startRuntime runtimeHost version = do Just w <- Map.lookup rf <$> readTVarIO (refTm cc) sto <- standalone cc w BL.writeFile path . runPutL $ do - serialize $ pack version + serialize $ version serialize $ RF.showShort 8 rf putNat w putStoredCache sto, @@ -616,7 +616,7 @@ traceNeeded init src = fmap (`withoutKeys` ks) $ go mempty init go acc w | hasKey w acc = pure acc | Just co <- EC.lookup w src = - foldlM go (mapInsert w co acc) (foldMap combDeps co) + foldlM go (mapInsert w co acc) (foldMap combDeps co) | otherwise = die $ "traceNeeded: unknown combinator: " ++ show w buildSCache :: diff --git a/stack.yaml b/stack.yaml index 0ad91dfa39..36b9aef23e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -47,6 +47,8 @@ extra-deps: - NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 # not in lts-18.13 - recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 +- lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 +- http-client-0.7.11 ghc-options: # All packages diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 9830f2da89..8ab028b788 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -42,6 +42,18 @@ dependencies: - unison-util-relation - unison-pretty-printer - unliftio + - network-uri + - aeson + - http-client >= 0.7.6 + - http-client-tls + - http-types + - warp + - wai + - memory + - time + - lock-file + - jwt + library: source-dirs: src diff --git a/unison-cli/src/Unison/Auth/CredentialFile.hs b/unison-cli/src/Unison/Auth/CredentialFile.hs new file mode 100644 index 0000000000..4437258a0d --- /dev/null +++ b/unison-cli/src/Unison/Auth/CredentialFile.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE NumericUnderscores #-} + +module Unison.Auth.CredentialFile (atomicallyModifyCredentialsFile) where + +import qualified Data.Aeson as Aeson +import qualified Data.Text as Text +import System.FilePath (takeDirectory, ()) +import System.IO.LockFile +import Unison.Auth.Types +import Unison.Prelude +import qualified UnliftIO +import UnliftIO.Directory + +lockfileConfig :: LockingParameters +lockfileConfig = + LockingParameters + { retryToAcquireLock = NumberOfTimes 3, + sleepBetweenRetries = sleepTimeMicros + } + where + sleepTimeMicros = 100_000 -- 100ms + +getCredentialJSONFilePath :: MonadIO m => m FilePath +getCredentialJSONFilePath = do + unisonDataDir <- getXdgDirectory XdgData "unisonlanguage" + pure (unisonDataDir "credentials.json") + +-- | Atomically update the credential storage file. +-- Creates an empty file automatically if one doesn't exist. +atomicallyModifyCredentialsFile :: MonadIO m => (Credentials -> Credentials) -> m Credentials +atomicallyModifyCredentialsFile f = liftIO $ do + credentialJSONPath <- getCredentialJSONFilePath + doesFileExist credentialJSONPath >>= \case + True -> pure () + False -> do + createDirectoryIfMissing True $ takeDirectory credentialJSONPath + Aeson.encodeFile credentialJSONPath emptyCredentials + + withLockFile lockfileConfig (withLockExt credentialJSONPath) $ do + credentials <- + Aeson.eitherDecodeFileStrict credentialJSONPath >>= \case + Left err -> UnliftIO.throwIO $ CredentialParseFailure credentialJSONPath (Text.pack err) + Right creds -> pure creds + let newCredentials = f credentials + when (newCredentials /= credentials) $ do + Aeson.encodeFile credentialJSONPath $ newCredentials + pure newCredentials diff --git a/unison-cli/src/Unison/Auth/CredentialManager.hs b/unison-cli/src/Unison/Auth/CredentialManager.hs new file mode 100644 index 0000000000..2fe907c508 --- /dev/null +++ b/unison-cli/src/Unison/Auth/CredentialManager.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE DeriveAnyClass #-} + +module Unison.Auth.CredentialManager + ( saveTokens, + CredentialManager, + newCredentialManager, + getTokens, + ) +where + +import Unison.Auth.CredentialFile +import Unison.Auth.Types +import Unison.Prelude +import qualified UnliftIO + +-- | A 'CredentialManager' knows how to load, save, and cache credentials. +-- It's thread-safe and safe for use across multiple UCM clients. +-- Note: Currently the in-memory cache is _not_ updated if a different UCM updates +-- the credentials file, however this shouldn't pose any problems, since auth will still +-- be refreshed if we encounter any auth failures on requests. +newtype CredentialManager = CredentialManager (UnliftIO.MVar Credentials) + +-- | Saves credentials to the active profile. +saveTokens :: UnliftIO.MonadUnliftIO m => CredentialManager -> Host -> Tokens -> m () +saveTokens credManager aud tokens = do + void . modifyCredentials credManager $ setActiveTokens aud tokens + +-- | Atomically update the credential storage file, and update the in-memory cache. +modifyCredentials :: UnliftIO.MonadUnliftIO m => CredentialManager -> (Credentials -> Credentials) -> m Credentials +modifyCredentials (CredentialManager credsVar) f = do + UnliftIO.modifyMVar credsVar $ \_ -> do + newCreds <- atomicallyModifyCredentialsFile f + pure (newCreds, newCreds) + +getTokens :: MonadIO m => CredentialManager -> Host -> m (Either CredentialFailure Tokens) +getTokens (CredentialManager credsVar) aud = do + creds <- UnliftIO.readMVar credsVar + pure $ getActiveTokens aud creds + +newCredentialManager :: MonadIO m => m CredentialManager +newCredentialManager = do + credentials <- atomicallyModifyCredentialsFile id + credentialsVar <- UnliftIO.newMVar credentials + pure (CredentialManager credentialsVar) diff --git a/unison-cli/src/Unison/Auth/Discovery.hs b/unison-cli/src/Unison/Auth/Discovery.hs new file mode 100644 index 0000000000..c81a7eee36 --- /dev/null +++ b/unison-cli/src/Unison/Auth/Discovery.hs @@ -0,0 +1,24 @@ +module Unison.Auth.Discovery where + +import qualified Data.Aeson as Aeson +import qualified Data.Text as Text +import qualified Network.HTTP.Client as HTTP +import Network.URI +import qualified Network.URI as URI +import Unison.Auth.Types +import Unison.Prelude +import qualified UnliftIO + +discoveryURI :: Host -> Either CredentialFailure URI +discoveryURI (Host host) = + maybeToEither (InvalidHost (Host host)) (URI.parseURI ("https://" <> Text.unpack host)) <&> \host -> + host {uriPath = "/.well-known/openid-configuration"} + +discoveryForHost :: MonadIO m => HTTP.Manager -> Host -> m (Either CredentialFailure DiscoveryDoc) +discoveryForHost httpClient host = liftIO . UnliftIO.try @_ @CredentialFailure $ do + uri <- UnliftIO.fromEither $ discoveryURI host + req <- HTTP.requestFromURI uri + resp <- HTTP.httpLbs req httpClient + case Aeson.eitherDecode (HTTP.responseBody $ resp) of + Left err -> UnliftIO.throwIO $ InvalidDiscoveryDocument uri (Text.pack err) + Right doc -> pure doc diff --git a/unison-cli/src/Unison/Auth/HTTPClient.hs b/unison-cli/src/Unison/Auth/HTTPClient.hs new file mode 100644 index 0000000000..cf9a401449 --- /dev/null +++ b/unison-cli/src/Unison/Auth/HTTPClient.hs @@ -0,0 +1,35 @@ +module Unison.Auth.HTTPClient where + +import qualified Data.Text.Encoding as Text +import Network.HTTP.Client (Request) +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.TLS as HTTP +import Unison.Auth.CredentialManager (CredentialManager) +import Unison.Auth.Tokens (TokenProvider, newTokenProvider) +import Unison.Auth.Types +import Unison.Codebase.Editor.Command (UCMVersion) +import Unison.Prelude +import qualified Unison.Util.HTTP as HTTP + +-- | Returns a new http manager which applies the appropriate Authorization header to +-- any hosts our UCM is authenticated with. +newAuthorizedHTTPClient :: MonadIO m => CredentialManager -> UCMVersion -> m HTTP.Manager +newAuthorizedHTTPClient credsMan ucmVersion = liftIO $ do + let tokenProvider = newTokenProvider credsMan + let managerSettings = + HTTP.tlsManagerSettings + & HTTP.addRequestMiddleware (authMiddleware tokenProvider) + & HTTP.setUserAgent (HTTP.ucmUserAgent ucmVersion) + HTTP.newTlsManagerWith managerSettings + +-- | Adds Bearer tokens to requests according to their host. +-- If a CredentialFailure occurs (failure to refresh a token), auth is simply omitted, +-- and the request is likely to trigger a 401 response which the caller can detect and initiate a re-auth. +-- +-- If a host isn't associated with any credentials auth is omitted. +authMiddleware :: TokenProvider -> (Request -> IO Request) +authMiddleware tokenProvider req = do + result <- tokenProvider (Host . Text.decodeUtf8 $ HTTP.host req) + case result of + Right token -> pure $ HTTP.applyBearerAuth (Text.encodeUtf8 token) req + Left _ -> pure req diff --git a/unison-cli/src/Unison/Auth/OAuth.hs b/unison-cli/src/Unison/Auth/OAuth.hs new file mode 100644 index 0000000000..cc46ceeebd --- /dev/null +++ b/unison-cli/src/Unison/Auth/OAuth.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE RecordWildCards #-} + +module Unison.Auth.OAuth (authenticateHost) where + +import qualified Crypto.Hash as Crypto +import Crypto.Random (getRandomBytes) +import qualified Data.Aeson as Aeson +import qualified Data.ByteArray.Encoding as BE +import qualified Data.ByteString.Char8 as BSC +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Network.HTTP.Client (urlEncodedBody) +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.TLS as HTTP +import Network.HTTP.Types +import Network.URI +import Network.Wai +import qualified Network.Wai as Wai +import qualified Network.Wai.Handler.Warp as Warp +import Unison.Auth.CredentialManager (CredentialManager, saveTokens) +import Unison.Auth.Discovery (discoveryForHost) +import Unison.Auth.Types +import Unison.Codebase.Editor.HandleInput.LoopState (MonadCommand, respond) +import qualified Unison.Codebase.Editor.Output as Output +import Unison.Debug +import Unison.Prelude +import qualified UnliftIO +import qualified Web.Browser as Web + +ucmOAuthClientID :: ByteString +ucmOAuthClientID = "ucm" + +-- | A server in the format expected for a Wai Application +-- This is a temporary server which is spun up only until we get a code back from the +-- auth server. +authTransferServer :: (Code -> IO Response) -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived +authTransferServer callback req respond = + case (requestMethod req, pathInfo req, getCodeQuery req) of + ("GET", ["redirect"], Just code) -> do + callback code >>= respond + _ -> respond (responseLBS status404 [] "Not Found") + where + getCodeQuery req = do + code <- join $ Prelude.lookup "code" (queryString req) + pure $ Text.decodeUtf8 code + +-- | Direct the user through an authentication flow with the given server and store the +-- credentials in the provided credential manager. +authenticateHost :: forall m n i v. (UnliftIO.MonadUnliftIO m, MonadCommand m n i v) => CredentialManager -> Host -> m (Either CredentialFailure ()) +authenticateHost credsManager host = UnliftIO.try @_ @CredentialFailure $ do + httpClient <- liftIO HTTP.getGlobalManager + doc@(DiscoveryDoc {authorizationEndpoint, tokenEndpoint}) <- throwCredFailure $ discoveryForHost httpClient host + debugM Auth "Discovery Doc" doc + authResultVar <- UnliftIO.newEmptyMVar @_ @(Either CredentialFailure Tokens) + -- The redirect_uri depends on the port, so we need to spin up the server first, but + -- we can't spin up the server without the code-handler which depends on the redirect_uri. + -- So, annoyingly we just embed an MVar which will be filled as soon as the server boots up, + -- and it all works out fine. + redirectURIVar <- UnliftIO.newEmptyMVar + (verifier, challenge, state) <- generateParams + let codeHandler code = do + redirectURI <- UnliftIO.readMVar redirectURIVar + result <- exchangeCode httpClient tokenEndpoint code verifier redirectURI + UnliftIO.putMVar authResultVar result + case result of + Left err -> do + debugM Auth "Auth Error" err + pure $ Wai.responseLBS internalServerError500 [] "Something went wrong, please try again." + Right _ -> + pure $ Wai.responseLBS ok200 [] "Authorization successful. You may close this page and return to UCM." + toIO <- UnliftIO.askRunInIO + liftIO . Warp.withApplication (pure $ authTransferServer codeHandler) $ \port -> toIO $ do + let redirectURI = "http://localhost:" <> show port <> "/redirect" + UnliftIO.putMVar redirectURIVar redirectURI + let authorizationKickoff = authURI authorizationEndpoint redirectURI state challenge + void . liftIO $ Web.openBrowser (show authorizationKickoff) + respond . Output.InitiateAuthFlow $ authorizationKickoff + tokens <- throwCredFailure $ UnliftIO.readMVar authResultVar + saveTokens credsManager host tokens + where + throwCredFailure :: m (Either CredentialFailure a) -> m a + throwCredFailure = throwEitherM + +-- | Construct an authorization URL from the parameters required. +authURI :: URI -> String -> OAuthState -> PKCEChallenge -> URI +authURI authEndpoint redirectURI state challenge = + authEndpoint + & addQueryParam "state" state + & addQueryParam "redirect_uri" (BSC.pack redirectURI) + & addQueryParam "response_type" "code" + & addQueryParam "scope" "openid" + & addQueryParam "client_id" ucmOAuthClientID + & addQueryParam "code_challenge" challenge + & addQueryParam "code_challenge_method" "S256" + +-- | Exchange an authorization code for tokens. +exchangeCode :: + MonadIO m => + HTTP.Manager -> + URI -> + Code -> + PKCEVerifier -> + String -> + m (Either CredentialFailure Tokens) +exchangeCode httpClient tokenEndpoint code verifier redirectURI = liftIO $ do + req <- HTTP.requestFromURI tokenEndpoint + let addFormData = + urlEncodedBody + [ ("code", Text.encodeUtf8 code), + ("code_verifier", verifier), + ("grant_type", "authorization_code"), + ("redirect_uri", BSC.pack redirectURI), + ("client_id", ucmOAuthClientID) + ] + let fullReq = addFormData $ req {HTTP.method = "POST", HTTP.requestHeaders = [("Accept", "application/json")]} + resp <- HTTP.httpLbs fullReq httpClient + case HTTP.responseStatus resp of + status + | status < status300 -> do + let respBytes = HTTP.responseBody resp + pure $ case Aeson.eitherDecode @Tokens respBytes of + Left err -> Left (InvalidTokenResponse tokenEndpoint (Text.pack err)) + Right a -> Right a + | otherwise -> pure $ Left (InvalidTokenResponse tokenEndpoint $ "Received " <> tShow status <> " response from token endpoint") + +addQueryParam :: ByteString -> ByteString -> URI -> URI +addQueryParam key val uri = + let existingQuery = parseQuery $ BSC.pack (uriQuery uri) + newParam = (key, Just val) + in uri {uriQuery = BSC.unpack $ renderQuery True (existingQuery <> [newParam])} + +generateParams :: MonadIO m => m (PKCEVerifier, PKCEChallenge, OAuthState) +generateParams = liftIO $ do + verifier <- BE.convertToBase @ByteString BE.Base64URLUnpadded <$> getRandomBytes 50 + let digest = Crypto.hashWith Crypto.SHA256 verifier + let challenge = BE.convertToBase BE.Base64URLUnpadded digest + state <- BE.convertToBase @ByteString BE.Base64URLUnpadded <$> getRandomBytes 12 + pure (verifier, challenge, state) diff --git a/unison-cli/src/Unison/Auth/Tokens.hs b/unison-cli/src/Unison/Auth/Tokens.hs new file mode 100644 index 0000000000..5504934084 --- /dev/null +++ b/unison-cli/src/Unison/Auth/Tokens.hs @@ -0,0 +1,44 @@ +module Unison.Auth.Tokens where + +import qualified Data.Text as Text +import Data.Time.Clock.POSIX (getPOSIXTime) +import Unison.Auth.CredentialManager +import Unison.Auth.Types +import Unison.CommandLine.InputPattern (patternName) +import qualified Unison.CommandLine.InputPatterns as IP +import Unison.Prelude +import qualified UnliftIO +import UnliftIO.Exception +import Web.JWT +import qualified Web.JWT as JWT + +-- | Checks whether a JWT access token is expired. +isExpired :: MonadIO m => AccessToken -> m Bool +isExpired accessToken = liftIO do + jwt <- JWT.decode accessToken `whenNothing` (throwIO $ InvalidJWT "Failed to decode JWT") + now <- getPOSIXTime + expDate <- JWT.exp (claims jwt) `whenNothing` (throwIO $ InvalidJWT "Missing exp claim on JWT") + let expiry = JWT.secondsSinceEpoch expDate + pure (now >= expiry) + +-- | Given a 'Host', provide a valid 'AccessToken' for the associated host. +-- The TokenProvider may automatically refresh access tokens if we have a refresh token. +type TokenProvider = Host -> IO (Either CredentialFailure AccessToken) + +-- | Creates a 'TokenProvider' using the given 'CredentialManager' +newTokenProvider :: CredentialManager -> TokenProvider +newTokenProvider manager host = UnliftIO.try @_ @CredentialFailure $ do + tokens@(Tokens {accessToken}) <- throwEitherM $ getTokens manager host + expired <- isExpired accessToken + if expired + then do + newTokens@(Tokens {accessToken = newAccessToken}) <- throwEitherM $ refreshTokens manager host tokens + saveTokens manager host newTokens + pure $ newAccessToken + else pure accessToken + +-- | Don't yet support automatically refreshing tokens. +refreshTokens :: MonadIO m => CredentialManager -> Host -> Tokens -> m (Either CredentialFailure Tokens) +refreshTokens _manager _host _tokens = + -- Refreshing tokens is currently unsupported. + pure (Left (RefreshFailure . Text.pack $ "Unable to refresh authentication, please run " <> patternName IP.authLogin <> " and try again.")) diff --git a/unison-cli/src/Unison/Auth/Types.hs b/unison-cli/src/Unison/Auth/Types.hs new file mode 100644 index 0000000000..5afd50a5cf --- /dev/null +++ b/unison-cli/src/Unison/Auth/Types.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} + +module Unison.Auth.Types + ( DiscoveryDoc (..), + Tokens (..), + Credentials (..), + Code, + AccessToken, + RefreshToken, + IDToken, + OAuthState, + PKCEVerifier, + PKCEChallenge, + ProfileName, + CredentialFailure (..), + Host (..), + getActiveTokens, + setActiveTokens, + emptyCredentials, + ) +where + +import Control.Lens hiding ((.=)) +import Data.Aeson (FromJSON (..), FromJSONKey, KeyValue ((.=)), ToJSON (..), ToJSONKey, (.:), (.:?)) +import qualified Data.Aeson as Aeson +import qualified Data.Map as Map +import qualified Data.Text as Text +import Data.Time (NominalDiffTime) +import Network.URI +import qualified Network.URI as URI +import Unison.Prelude + +defaultProfileName :: ProfileName +defaultProfileName = "default" + +data CredentialFailure + = ReauthRequired Host + | CredentialParseFailure FilePath Text + | InvalidDiscoveryDocument URI Text + | InvalidJWT Text + | RefreshFailure Text + | InvalidTokenResponse URI Text + | InvalidHost Host + deriving stock (Show, Eq) + deriving anyclass (Exception) + +type Code = Text + +type OAuthState = ByteString + +type PKCEVerifier = ByteString + +type PKCEChallenge = ByteString + +type AccessToken = Text + +type RefreshToken = Text + +type IDToken = Text + +type TokenType = Text + +newtype Scopes = Scopes [Text] + deriving stock (Show, Eq, Ord) + +instance ToJSON Scopes where + toJSON (Scopes scopes) = Aeson.String $ Text.unwords scopes + +instance FromJSON Scopes where + parseJSON = Aeson.withText "Scopes" $ \txt -> do + pure . Scopes $ Text.words txt + +data DiscoveryDoc = DiscoveryDoc + { issuer :: URI, + authorizationEndpoint :: URI, + tokenEndpoint :: URI, + userInfoEndpoint :: URI + } + deriving (Show) + +data Tokens = Tokens + { accessToken :: AccessToken, + idToken :: Maybe IDToken, + refreshToken :: Maybe RefreshToken, + tokenType :: TokenType, + expiresIn :: NominalDiffTime, + scopes :: Scopes + } + deriving (Eq, Show) + +instance Aeson.FromJSON Tokens where + parseJSON = + Aeson.withObject "Tokens" $ \obj -> do + accessToken <- obj .: "access_token" + idToken <- obj .:? "id_token" + refreshToken <- obj .: "refresh_token" + tokenType <- obj .: "token_type" + expiresIn <- obj .: "expires_in" + scopes <- obj .: "scope" + pure (Tokens {..}) + +instance Aeson.ToJSON Tokens where + toJSON (Tokens accessToken idToken refreshToken tokenType expiresIn scopes) = + Aeson.object + [ "access_token" .= accessToken, + "id_token" .= idToken, + "refresh_token" .= refreshToken, + "token_type" .= tokenType, + "expires_in" .= expiresIn, + "scope" .= scopes + ] + +newtype URIParam = URIParam URI + +instance Aeson.FromJSON URIParam where + parseJSON = Aeson.withText "URI" $ \txt -> + maybe (fail "Invalid URI") (pure . URIParam) $ URI.parseURI (Text.unpack txt) + +instance Aeson.FromJSON DiscoveryDoc where + parseJSON = Aeson.withObject "Discovery Document" $ \obj -> do + URIParam issuer <- obj .: "issuer" + URIParam authorizationEndpoint <- obj .: "authorization_endpoint" + URIParam tokenEndpoint <- obj .: "token_endpoint" + URIParam userInfoEndpoint <- obj .: "userinfo_endpoint" + pure (DiscoveryDoc {..}) + +type ProfileName = Text + +-- | The hostname of a server we may authenticate with, +-- e.g. @Host "enlil.unison-lang.org"@ +newtype Host = Host Text + deriving stock (Eq, Ord, Show) + deriving newtype (ToJSON, FromJSON, ToJSONKey, FromJSONKey) + +data Credentials = Credentials + { credentials :: Map ProfileName (Map Host Tokens), + activeProfile :: ProfileName + } + deriving (Eq) + +emptyCredentials :: Credentials +emptyCredentials = Credentials mempty defaultProfileName + +getActiveTokens :: Host -> Credentials -> Either CredentialFailure Tokens +getActiveTokens host (Credentials {credentials, activeProfile}) = + maybeToEither (ReauthRequired host) $ + credentials ^? ix activeProfile . ix host + +setActiveTokens :: Host -> Tokens -> Credentials -> Credentials +setActiveTokens host tokens creds@(Credentials {credentials, activeProfile}) = + let newCredMap = + credentials + & at activeProfile . non Map.empty . at host .~ Just tokens + in creds {credentials = newCredMap} + +instance Aeson.ToJSON Credentials where + toJSON (Credentials credMap activeProfile) = + Aeson.object + [ "credentials" .= credMap, + "active_profile" .= activeProfile + ] + +instance Aeson.FromJSON Credentials where + parseJSON = Aeson.withObject "Credentials" $ \obj -> do + credentials <- obj .: "credentials" + activeProfile <- obj .: "active_profile" + pure Credentials {..} diff --git a/unison-cli/src/Unison/Codebase/Editor/Command.hs b/unison-cli/src/Unison/Codebase/Editor/Command.hs index c4b1825f51..48d3fa6c04 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Command.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Command.hs @@ -13,6 +13,7 @@ module Unison.Codebase.Editor.Command EvalResult, commandName, lookupEvalResult, + UCMVersion, ) where @@ -94,6 +95,8 @@ type TypecheckingResult v = (Seq (Note v Ann)) (Either Names (UF.TypecheckedUnisonFile v Ann)) +type UCMVersion = Text + data Command m -- Command monad @@ -266,6 +269,7 @@ data -- Ideally we will eventually remove the Command type entirely and won't need -- this anymore. CmdUnliftIO :: Command m i v (UnliftIO (Free (Command m i v))) + UCMVersion :: Command m i v UCMVersion instance MonadIO m => MonadIO (Free (Command m i v)) where liftIO io = Free.eval $ Eval (liftIO io) @@ -344,3 +348,4 @@ commandName = \case MakeStandalone {} -> "MakeStandalone" FuzzySelect {} -> "FuzzySelect" CmdUnliftIO {} -> "UnliftIO" + UCMVersion {} -> "UCMVersion" diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs index 9a146b294b..3b233d6e55 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs @@ -23,7 +23,7 @@ import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Branch.Merge as Branch import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo -import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UseCache) +import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UCMVersion, UseCache) import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output (PrintMessage)) import qualified Unison.Codebase.Path as Path import Unison.Codebase.Runtime (Runtime) @@ -94,10 +94,11 @@ commandLine :: (SourceName -> IO LoadSourceResult) -> Codebase IO Symbol Ann -> Maybe Server.BaseUrl -> + UCMVersion -> (Int -> IO gen) -> Free (Command IO i Symbol) a -> IO a -commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSource codebase serverBaseUrl rngGen free = do +commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSource codebase serverBaseUrl ucmVersion rngGen free = do rndSeed <- STM.newTVarIO 0 flip runReaderT rndSeed . Free.fold go $ free where @@ -232,6 +233,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour -- in-scope. UnliftIO.UnliftIO toIO -> toIO . Free.fold go pure runF + UCMVersion -> pure ucmVersion watchCache :: Reference.Id -> IO (Maybe (Term Symbol ())) watchCache h = do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 276ad09bd6..d405d47e97 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -15,7 +15,6 @@ import Control.Monad.State (StateT) import qualified Control.Monad.State as State import Data.Bifunctor (first, second) import Data.Configurator () -import Data.Either.Extra (eitherToMaybe) import qualified Data.Foldable as Foldable import qualified Data.List as List import Data.List.Extra (nubOrd) @@ -30,6 +29,7 @@ import Data.Tuple.Extra (uncurry3) import qualified Text.Megaparsec as P import U.Util.Timing (unsafeTime) import qualified Unison.ABT as ABT +import Unison.Auth.Types (Host (Host)) import qualified Unison.Builtin as Builtin import qualified Unison.Builtin.Decls as DD import qualified Unison.Builtin.Terms as Builtin @@ -45,7 +45,8 @@ import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..)) import Unison.Codebase.Editor.Command as Command import Unison.Codebase.Editor.DisplayObject import qualified Unison.Codebase.Editor.Git as Git -import Unison.Codebase.Editor.HandleInput.LoopState (Action, Action', MonadCommand (..), eval, liftF) +import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin) +import Unison.Codebase.Editor.HandleInput.LoopState (Action, Action', MonadCommand (..), eval, liftF, respond, respondNumbered) import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState import qualified Unison.Codebase.Editor.HandleInput.NamespaceDependencies as NamespaceDependencies import Unison.Codebase.Editor.Input @@ -378,11 +379,12 @@ loop = do ResolveTypeNameI path -> "resolve.typeName " <> hqs' path AddI _selection -> "add" UpdateI p _selection -> - "update" <> (case p of - NoPatch -> ".nopatch" - DefaultPatch -> " " <> ps' defaultPatchPath - UsePatch p -> " " <> ps' p - ) + "update" + <> ( case p of + NoPatch -> ".nopatch" + DefaultPatch -> " " <> ps' defaultPatchPath + UsePatch p -> " " <> ps' p + ) PropagatePatchI p scope -> "patch " <> ps' p <> " " <> p' scope UndoI {} -> "undo" ApiI -> "api" @@ -458,6 +460,7 @@ loop = do DeprecateTermI {} -> undefined DeprecateTypeI {} -> undefined GistI {} -> wat + AuthLoginI {} -> wat RemoveTermReplacementI src p -> "delete.term-replacement" <> HQ.toText src <> " " <> opatch p RemoveTypeReplacementI src p -> @@ -1630,6 +1633,14 @@ loop = do UpdateBuiltinsI -> notImplemented QuitI -> empty GistI input -> handleGist input + AuthLoginI mayCodebaseServer -> do + case mayCodebaseServer of + Nothing -> authLogin Nothing + Just codeServer -> do + mayHost <- eval $ ConfigLookup ("CodeServers." <> codeServer) + case mayHost of + Nothing -> respond (UnknownCodeServer codeServer) + Just host -> authLogin (Just $ Host host) where notImplemented = eval $ Notify NotImplemented success = respond Success @@ -1829,9 +1840,9 @@ handleUpdate input optionalPatch requestedNames = do b <- getAt p eval . Eval $ Branch.getPatch seg (Branch.head b) let patchPath = case optionalPatch of - NoPatch -> Nothing - DefaultPatch -> Just defaultPatchPath - UsePatch p -> Just p + NoPatch -> Nothing + DefaultPatch -> Just defaultPatchPath + UsePatch p -> Just p slurpCheckNames <- slurpResultNames let currentPathNames = slurpCheckNames let sr = Slurp.slurpFile uf requestedVars Slurp.UpdateOp slurpCheckNames @@ -1936,14 +1947,17 @@ handleUpdate input optionalPatch requestedNames = do -- and make a patch diff to record a replacement from the old to new references stepManyAtMNoSync Branch.CompressHistory - ([ ( Path.unabsolute currentPath', - pure . doSlurpUpdates typeEdits termEdits termDeprecations - ), - ( Path.unabsolute currentPath', - pure . doSlurpAdds addsAndUpdates uf - )] ++ case patchOps of - Nothing -> [] - Just (_, update, p) -> [(Path.unabsolute p, update)]) + ( [ ( Path.unabsolute currentPath', + pure . doSlurpUpdates typeEdits termEdits termDeprecations + ), + ( Path.unabsolute currentPath', + pure . doSlurpAdds addsAndUpdates uf + ) + ] + ++ case patchOps of + Nothing -> [] + Just (_, update, p) -> [(Path.unabsolute p, update)] + ) eval . AddDefsToCodebase . filterBySlurpResult sr $ uf ppe <- prettyPrintEnvDecl =<< displayNames uf respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr @@ -1952,10 +1966,11 @@ handleUpdate input optionalPatch requestedNames = do (updatedPatch, _, _) -> void $ propagatePatchNoSync updatedPatch currentPath' addDefaultMetadata addsAndUpdates syncRoot $ case patchPath of - Nothing -> "update.nopatch" - Just p -> p & Path.unsplit' - & Path.resolve @_ @_ @Path.Absolute currentPath' - & tShow + Nothing -> "update.nopatch" + Just p -> + p & Path.unsplit' + & Path.resolve @_ @_ @Path.Absolute currentPath' + & tShow -- Add default metadata to all added types and terms in a slurp component. -- @@ -2444,15 +2459,6 @@ handleBackendError = \case Backend.MissingSignatureForTerm r -> respond $ TermMissingType r -respond :: MonadCommand n m i v => Output v -> n () -respond output = eval $ Notify output - -respondNumbered :: NumberedOutput v -> Action m i v () -respondNumbered output = do - args <- eval $ NotifyNumbered output - unless (null args) $ - LoopState.numberedArgs .= toList args - unlessError :: ExceptT (Output v) (Action' m v) () -> Action' m v () unlessError ma = runExceptT ma >>= either respond pure diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs new file mode 100644 index 0000000000..27032e72d0 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE RecordWildCards #-} + +module Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin) where + +import Control.Monad.Reader +import Unison.Auth.OAuth +import Unison.Auth.Types (Host (..)) +import Unison.Codebase.Editor.HandleInput.LoopState +import Unison.Codebase.Editor.Output (Output (CredentialFailureMsg, Success)) +import Unison.Prelude +import qualified UnliftIO + +defaultShareHost :: Host +defaultShareHost = Host "enlil.unison-lang.org" + +authLogin :: UnliftIO.MonadUnliftIO m => Maybe Host -> Action m i v () +authLogin mayHost = do + let host = fromMaybe defaultShareHost mayHost + credsMan <- asks credentialManager + (Action . lift . lift . lift $ authenticateHost credsMan host) >>= \case + Left err -> respond (CredentialFailureMsg err) + Right () -> respond Success diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs index 431662e37d..67ce4d5461 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs @@ -11,11 +11,14 @@ import Control.Monad.State import Data.Configurator () import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel +import qualified Network.HTTP.Client as HTTP +import Unison.Auth.CredentialManager (CredentialManager) import Unison.Codebase.Branch ( Branch (..), ) import Unison.Codebase.Editor.Command import Unison.Codebase.Editor.Input +import Unison.Codebase.Editor.Output import qualified Unison.Codebase.Path as Path import Unison.Parser.Ann (Ann (..)) import Unison.Prelude @@ -26,6 +29,9 @@ import qualified Unison.Util.Free as Free type F m i v = Free (Command m i v) data Env = Env + { authHTTPClient :: HTTP.Manager, + credentialManager :: CredentialManager + } newtype Action m i v a = Action {unAction :: MaybeT (ReaderT Env (StateT (LoopState m v) (F m i v))) a} deriving newtype (Functor, Applicative, Alternative, Monad, MonadIO, MonadState (LoopState m v), MonadReader Env) @@ -65,8 +71,6 @@ instance MonadCommand n m i v => MonadCommand (ReaderT r n) m i v where instance MonadCommand (Action m i v) m i v where eval = Action . eval -type NumberedArgs = [String] - data LoopState m v = LoopState { _root :: Branch m, _lastSavedRoot :: Branch m, @@ -103,3 +107,12 @@ currentPath = currentPathStack . to Nel.head loopState0 :: Branch m -> Path.Absolute -> LoopState m v loopState0 b p = LoopState b b (pure p) Nothing Nothing Nothing [] + +respond :: MonadCommand n m i v => Output v -> n () +respond output = eval $ Notify output + +respondNumbered :: NumberedOutput v -> Action m i v () +respondNumbered output = do + args <- eval $ NotifyNumbered output + unless (null args) $ + numberedArgs .= toList args diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index b8dd6a5894..b6f65544ea 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -43,6 +43,8 @@ type SourceName = Text -- "foo.u" or "buffer 7" type PatchPath = Path.Split' +type CodebaseServerName = Text + data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath deriving (Eq, Ord, Show) @@ -180,6 +182,7 @@ data Input | UiI | DocsToHtmlI Path' FilePath | GistI GistInput + | AuthLoginI (Maybe CodebaseServerName) deriving (Eq, Show) -- | @"gist repo"@ pushes the contents of the current namespace to @repo@. diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 58c8a66b32..b4c5782c3a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -19,6 +19,8 @@ where import Data.List.NonEmpty (NonEmpty) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) +import Network.URI (URI) +import Unison.Auth.Types (CredentialFailure) import Unison.Codebase (GetRootBranchError) import qualified Unison.Codebase.Branch as Branch import Unison.Codebase.Editor.DisplayObject (DisplayObject) @@ -248,6 +250,10 @@ data Output v RefusedToPush PushBehavior | -- | @GistCreated repo hash@ means causal @hash@ was just published to @repo@. GistCreated Int WriteRepo Branch.Hash + | -- | Directs the user to URI to begin an authorization flow. + InitiateAuthFlow URI + | UnknownCodeServer Text + | CredentialFailureMsg CredentialFailure data ReflogEntry = ReflogEntry {hash :: ShortBranchHash, reason :: Text} deriving (Show) @@ -370,6 +376,9 @@ isFailure o = case o of NamespaceEmpty {} -> True RefusedToPush {} -> True GistCreated {} -> False + InitiateAuthFlow {} -> False + UnknownCodeServer {} -> True + CredentialFailureMsg {} -> True isNumberedFailure :: NumberedOutput v -> Bool isNumberedFailure = \case diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 39e981ec8d..86f3d79cd0 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -37,7 +37,7 @@ import qualified Text.Megaparsec as P import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.Editor.Command (LoadSourceResult (..)) +import Unison.Codebase.Editor.Command (LoadSourceResult (..), UCMVersion) import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState @@ -144,22 +144,22 @@ type TranscriptRunner = withTranscriptRunner :: forall m r. UnliftIO.MonadUnliftIO m => - String -> + UCMVersion -> Maybe FilePath -> (TranscriptRunner -> m r) -> m r -withTranscriptRunner version configFile action = do +withTranscriptRunner ucmVersion configFile action = do withRuntime $ \runtime -> withConfig $ \config -> do action $ \transcriptName transcriptSrc (codebaseDir, codebase) -> do let parsed = parse transcriptName transcriptSrc result <- for parsed $ \stanzas -> do - liftIO $ run codebaseDir stanzas codebase runtime config + liftIO $ run codebaseDir stanzas codebase runtime config ucmVersion pure $ join @(Either TranscriptError) result where withRuntime :: ((Runtime.Runtime Symbol -> m a) -> m a) withRuntime action = UnliftIO.bracket - (liftIO $ RTI.startRuntime RTI.UCM version) + (liftIO $ RTI.startRuntime RTI.UCM ucmVersion) (liftIO . Runtime.terminate) action withConfig :: forall a. ((Maybe Config -> m a) -> m a) @@ -181,8 +181,9 @@ run :: Codebase IO Symbol Ann -> Runtime.Runtime Symbol -> Maybe Config -> + UCMVersion -> IO (Either TranscriptError Text) -run dir stanzas codebase runtime config = UnliftIO.try $ do +run dir stanzas codebase runtime config ucmVersion = UnliftIO.try $ do let initialPath = Path.absoluteEmpty putPrettyLn $ P.lines @@ -375,7 +376,12 @@ run dir stanzas codebase runtime config = UnliftIO.try $ do loop state = do writeIORef pathRef (view LoopState.currentPath state) - let free = LoopState.runAction LoopState.Env state $ HandleInput.loop + let env = + LoopState.Env + { LoopState.authHTTPClient = error "Error: No access to authorized requests from transcripts.", + LoopState.credentialManager = error "Error: No access to credentials from transcripts." + } + let free = LoopState.runAction env state $ HandleInput.loop rng i = pure $ Random.drgNewSeed (Random.seedFromInteger (fromIntegral i)) (o, state') <- HandleCommand.commandLine @@ -388,6 +394,7 @@ run dir stanzas codebase runtime config = UnliftIO.try $ do loadPreviousUnisonBlock codebase Nothing + ucmVersion rng free case o of diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 22ccb871df..343dd83511 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1451,6 +1451,14 @@ topicNameArg = globTargets = mempty } +codebaseServerNameArg :: ArgumentType +codebaseServerNameArg = + ArgumentType + { typeName = "codebase-server", + suggestions = \q _ _ _ -> pure (exactComplete q $ Map.keys helpTopicsMap), + globTargets = mempty + } + helpTopics :: InputPattern helpTopics = InputPattern @@ -1988,6 +1996,29 @@ gist = _ -> Left (showPatternHelp gist) ) +authLogin :: InputPattern +authLogin = + InputPattern + "auth.login" + [] + I.Hidden + [(Optional, noCompletions)] + ( P.lines + [ P.wrap "Obtain an authentication session with Unison Share or a specified codeserver host.", + makeExample authLogin [] + <> "authenticates ucm with Unison Share.", + makeExample authLogin ["mycodeserver"] + <> "authenticates ucm with the host configured at" + <> P.backticked "CodeServers.mycodeserver" + <> "in your .unisonConfig" + ] + ) + ( \case + [] -> Right $ Input.AuthLoginI Nothing + [codebaseServerName] -> Right . Input.AuthLoginI $ Just (Text.pack codebaseServerName) + _ -> Left (showPatternHelp authLogin) + ) + validInputs :: [InputPattern] validInputs = sortOn @@ -2074,7 +2105,8 @@ validInputs = debugDumpNamespace, debugDumpNamespaceSimple, debugClearWatchCache, - gist + gist, + authLogin ] visibleInputs :: [InputPattern] diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index a189edb19c..07048792c7 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -21,11 +21,13 @@ import qualified Data.Text as Text import qualified System.Console.Haskeline as Line import System.IO (hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) +import Unison.Auth.CredentialManager (newCredentialManager) +import qualified Unison.Auth.HTTPClient as HTTP import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.Editor.Command (LoadSourceResult (..)) +import Unison.Codebase.Editor.Command (LoadSourceResult (..), UCMVersion) import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState @@ -109,8 +111,9 @@ main :: Runtime.Runtime Symbol -> Codebase IO Symbol Ann -> Maybe Server.BaseUrl -> + UCMVersion -> IO () -main dir welcome initialPath (config, cancelConfig) initialInputs runtime codebase serverBaseUrl = do +main dir welcome initialPath (config, cancelConfig) initialInputs runtime codebase serverBaseUrl ucmVersion = do root <- fromMaybe Branch.empty . rightMay <$> Codebase.getRootBranch codebase eventQueue <- Q.newIO welcomeEvents <- Welcome.run codebase welcome @@ -187,7 +190,14 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba let loop :: LoopState.LoopState IO Symbol -> IO () loop state = do writeIORef pathRef (view LoopState.currentPath state) - let free = LoopState.runAction LoopState.Env state HandleInput.loop + credMan <- newCredentialManager + authorizedHTTPClient <- HTTP.newAuthorizedHTTPClient credMan ucmVersion + let env = + LoopState.Env + { LoopState.authHTTPClient = authorizedHTTPClient, + LoopState.credentialManager = credMan + } + let free = LoopState.runAction env state HandleInput.loop let handleCommand = HandleCommand.commandLine config @@ -202,6 +212,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba loadSourceFile codebase serverBaseUrl + ucmVersion (const Random.getSystemDRG) free UnliftIO.race waitForInterrupt (try handleCommand) >>= \case diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index da396ec032..9dee91d25e 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -24,6 +24,7 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Text as Text import Data.Tuple (swap) import Data.Tuple.Extra (dupe, uncurry3) +import Network.URI (URI) import System.Directory ( canonicalizePath, doesFileExist, @@ -32,6 +33,7 @@ import System.Directory import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) import qualified U.Util.Monoid as Monoid import qualified Unison.ABT as ABT +import qualified Unison.Auth.Types as Auth import qualified Unison.Builtin.Decls as DD import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch @@ -500,6 +502,9 @@ showListEdits patch ppe = "-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTypeName) ) +prettyURI :: URI -> Pretty +prettyURI = P.bold . P.blue . P.shown + prettyRemoteNamespace :: ReadRemoteNamespace -> Pretty @@ -1529,6 +1534,50 @@ notifyUser dir o = case o of where remoteNamespace = (RemoteRepo.writeToRead repo, Just (SBH.fromHash hqLength hash), Path.empty) + InitiateAuthFlow authURI -> do + pure $ + P.wrap $ + "Please navigate to " <> prettyURI authURI <> " to authorize UCM with the codebase server." + UnknownCodeServer codeServerName -> do + pure $ + P.lines + [ P.wrap $ "No host configured for code server " <> P.red (P.text codeServerName) <> ".", + "You can configure code server hosts in your .unisonConfig file." + ] + CredentialFailureMsg err -> pure $ case err of + Auth.ReauthRequired (Auth.Host host) -> + P.lines + [ "Authentication for host " <> P.red (P.text host) <> " is required.", + "Run " <> IP.makeExample IP.help [IP.patternName IP.authLogin] + <> " to learn how." + ] + Auth.CredentialParseFailure fp txt -> + P.lines + [ "Failed to parse the credentials file at " <> prettyFilePath fp <> ", with error: " <> P.text txt <> ".", + "You can attempt to fix the issue, or may simply delete the credentials file and run " <> IP.makeExample IP.authLogin [] <> "." + ] + Auth.InvalidDiscoveryDocument uri txt -> + P.lines + [ "Failed to parse the discover document from " <> prettyURI uri <> ", with error: " <> P.text txt <> "." + ] + Auth.InvalidJWT txt -> + P.lines + [ "Failed to validate JWT from authentication server: " <> P.text txt + ] + Auth.RefreshFailure txt -> + P.lines + [ "Failed to refresh access token with authentication server: " <> P.text txt + ] + Auth.InvalidTokenResponse uri txt -> + P.lines + [ "Failed to parse token response from authentication server: " <> prettyURI uri, + "The error was: " <> P.text txt + ] + Auth.InvalidHost (Auth.Host host) -> + P.lines + [ "Failed to parse a URI from the hostname: " <> P.text host <> ".", + "Host names should NOT include a schema or path." + ] where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" @@ -1559,6 +1608,10 @@ notifyUser dir o = case o of -- ns targets = P.oxfordCommas $ -- map (fromString . Names.renderNameTarget) (toList targets) +prettyFilePath :: FilePath -> Pretty +prettyFilePath fp = + P.blue (P.string fp) + prettyPath' :: Path.Path' -> Pretty prettyPath' p' = if Path.isCurrentPath p' @@ -1673,8 +1726,7 @@ displayDefinitions :: Map Reference.Reference (DisplayObject (Type v a1) (Term v a1)) -> IO Pretty displayDefinitions _outputLoc _ppe types terms - | Map.null types && Map.null terms = - pure $ P.callout "๐Ÿ˜ถ" "No results to display." + | Map.null types && Map.null terms = pure $ P.callout "๐Ÿ˜ถ" "No results to display." displayDefinitions outputLoc ppe types terms = maybe displayOnly scratchAndDisplay outputLoc where diff --git a/unison-cli/src/Unison/CommandLine/Welcome.hs b/unison-cli/src/Unison/CommandLine/Welcome.hs index feba81a405..4f3447071f 100644 --- a/unison-cli/src/Unison/CommandLine/Welcome.hs +++ b/unison-cli/src/Unison/CommandLine/Welcome.hs @@ -21,7 +21,7 @@ data Welcome = Welcome { onboarding :: Onboarding, -- Onboarding States downloadBase :: DownloadBase, watchDir :: FilePath, - unisonVersion :: String + unisonVersion :: Text } data DownloadBase @@ -44,7 +44,7 @@ data Onboarding | Finished | PreviouslyOnboarded -welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> String -> Welcome +welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> Text -> Welcome welcome initStatus downloadBase filePath unisonVersion = Welcome (Init initStatus) downloadBase filePath unisonVersion @@ -98,7 +98,7 @@ determineFirstStep downloadBase codebase = do case downloadBase of DownloadBase ns | isEmptyCodebase -> - pure $ DownloadingBase ns + pure $ DownloadingBase ns _ -> pure PreviouslyOnboarded @@ -141,14 +141,14 @@ downloading path = ) ] -header :: String -> P.Pretty P.ColorText +header :: Text -> P.Pretty P.ColorText header version = asciiartUnison <> P.newline <> P.newline <> P.linesSpaced [ P.wrap "๐Ÿ‘‹ Welcome to Unison!", - P.wrap ("You are running version: " <> P.bold (P.string version)) + P.wrap ("You are running version: " <> P.bold (P.text version)) ] authorSuggestion :: P.Pretty P.ColorText diff --git a/unison-cli/src/Unison/Util/HTTP.hs b/unison-cli/src/Unison/Util/HTTP.hs new file mode 100644 index 0000000000..940d681f43 --- /dev/null +++ b/unison-cli/src/Unison/Util/HTTP.hs @@ -0,0 +1,19 @@ +module Unison.Util.HTTP (addRequestMiddleware, setUserAgent, ucmUserAgent) where + +import qualified Data.Text.Encoding as Text +import qualified Network.HTTP.Client as HTTP +import Unison.Codebase.Editor.Command (UCMVersion) +import Unison.Prelude + +addRequestMiddleware :: (HTTP.Request -> IO HTTP.Request) -> HTTP.ManagerSettings -> HTTP.ManagerSettings +addRequestMiddleware f man = + man {HTTP.managerModifyRequest = (HTTP.managerModifyRequest man) >=> f} + +ucmUserAgent :: UCMVersion -> Text +ucmUserAgent ucmVersion = "UCM/" <> ucmVersion + +setUserAgent :: Text -> HTTP.ManagerSettings -> HTTP.ManagerSettings +setUserAgent userAgent = + let addUserAgent req = do + pure $ req {HTTP.requestHeaders = ("User-Agent", Text.encodeUtf8 userAgent) : HTTP.requestHeaders req} + in addRequestMiddleware addUserAgent diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 5c9a47e8e1..7e16081d4c 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -24,10 +24,18 @@ flag optimized library exposed-modules: Compat + Unison.Auth.CredentialFile + Unison.Auth.CredentialManager + Unison.Auth.Discovery + Unison.Auth.HTTPClient + Unison.Auth.OAuth + Unison.Auth.Tokens + Unison.Auth.Types Unison.Codebase.Editor.AuthorInfo Unison.Codebase.Editor.Command Unison.Codebase.Editor.HandleCommand Unison.Codebase.Editor.HandleInput + Unison.Codebase.Editor.HandleInput.AuthLogin Unison.Codebase.Editor.HandleInput.LoopState Unison.Codebase.Editor.HandleInput.NamespaceDependencies Unison.Codebase.Editor.Input @@ -51,6 +59,7 @@ library Unison.CommandLine.Main Unison.CommandLine.OutputMessages Unison.CommandLine.Welcome + Unison.Util.HTTP other-modules: Paths_unison_cli hs-source-dirs: @@ -81,6 +90,7 @@ library ghc-options: -Wall build-depends: ListLike + , aeson , async , base , bytestring @@ -92,9 +102,16 @@ library , extra , filepath , haskeline + , http-client >=0.7.6 + , http-client-tls + , http-types + , jwt , lens + , lock-file , megaparsec >=5.0.0 && <7.0.0 + , memory , mtl + , network-uri , nonempty-containers , open-browser , random >=1.2.0 @@ -103,6 +120,7 @@ library , stm , text , these + , time , transformers , unison-codebase-sqlite , unison-core1 @@ -112,6 +130,8 @@ library , unison-util , unison-util-relation , unliftio + , wai + , warp if flag(optimized) ghc-options: -O2 -funbox-strict-fields if !os(windows) @@ -154,6 +174,7 @@ executable integration-tests unison build-depends: ListLike + , aeson , async , base , bytestring @@ -167,9 +188,16 @@ executable integration-tests , extra , filepath , haskeline + , http-client >=0.7.6 + , http-client-tls + , http-types + , jwt , lens + , lock-file , megaparsec >=5.0.0 && <7.0.0 + , memory , mtl + , network-uri , nonempty-containers , open-browser , process @@ -190,6 +218,8 @@ executable integration-tests , unison-util , unison-util-relation , unliftio + , wai + , warp if flag(optimized) ghc-options: -O2 -funbox-strict-fields default-language: Haskell2010 @@ -226,6 +256,7 @@ executable transcripts ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -v0 build-depends: ListLike + , aeson , async , base , bytestring @@ -239,9 +270,16 @@ executable transcripts , extra , filepath , haskeline + , http-client >=0.7.6 + , http-client-tls + , http-types + , jwt , lens + , lock-file , megaparsec >=5.0.0 && <7.0.0 + , memory , mtl + , network-uri , nonempty-containers , open-browser , process @@ -252,6 +290,7 @@ executable transcripts , stm , text , these + , time , transformers , unison-cli , unison-codebase-sqlite @@ -262,6 +301,8 @@ executable transcripts , unison-util , unison-util-relation , unliftio + , wai + , warp if flag(optimized) ghc-options: -O2 -funbox-strict-fields default-language: Haskell2010 @@ -301,6 +342,7 @@ executable unison ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-I0 -optP-Wno-nonportable-include-path build-depends: ListLike + , aeson , async , base , bytestring @@ -313,9 +355,16 @@ executable unison , extra , filepath , haskeline + , http-client >=0.7.6 + , http-client-tls + , http-types + , jwt , lens + , lock-file , megaparsec >=5.0.0 && <7.0.0 + , memory , mtl + , network-uri , nonempty-containers , open-browser , optparse-applicative >=0.16.1.0 @@ -328,6 +377,7 @@ executable unison , temporary , text , these + , time , transformers , unison-cli , unison-codebase-sqlite @@ -338,6 +388,8 @@ executable unison , unison-util , unison-util-relation , unliftio + , wai + , warp if flag(optimized) ghc-options: -O2 -funbox-strict-fields default-language: Haskell2010 @@ -381,6 +433,7 @@ test-suite tests ghc-options: -Wall build-depends: ListLike + , aeson , async , base , bytestring @@ -395,9 +448,16 @@ test-suite tests , filepath , haskeline , here + , http-client >=0.7.6 + , http-client-tls + , http-types + , jwt , lens + , lock-file , megaparsec >=5.0.0 && <7.0.0 + , memory , mtl + , network-uri , nonempty-containers , open-browser , random >=1.2.0 @@ -408,6 +468,7 @@ test-suite tests , temporary , text , these + , time , transformers , unison-cli , unison-codebase-sqlite @@ -418,6 +479,8 @@ test-suite tests , unison-util , unison-util-relation , unliftio + , wai + , warp if flag(optimized) ghc-options: -O2 -funbox-strict-fields default-language: Haskell2010 diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index 7e381e02f0..713c6d9c6b 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -21,7 +21,7 @@ import ArgParse parseCLIArgs, ) import Compat (defaultInterruptHandler, withInterruptHandler) -import Control.Concurrent (newEmptyMVar, takeMVar) +import Control.Concurrent (forkIO, newEmptyMVar, takeMVar) import Control.Error.Safe (rightMay) import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BL @@ -29,7 +29,11 @@ import Data.Configurator.Types (Config) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.IO as Text import qualified GHC.Conc +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.TLS as HTTP import System.Directory (canonicalizePath, getCurrentDirectory, removeDirectoryRecursive) import System.Environment (getProgName, withArgs) import qualified System.Exit as Exit @@ -71,10 +75,10 @@ main :: IO () main = withCP65001 do interruptHandler <- defaultInterruptHandler withInterruptHandler interruptHandler $ do + forkIO initHTTPClient progName <- getProgName -- hSetBuffering stdout NoBuffering -- cool - - (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName Version.gitDescribeWithDate + (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName (Text.unpack Version.gitDescribeWithDate) let GlobalOptions {codebasePathOption = mCodePathOption} = globalOptions let mcodepath = fmap codebasePathOptionToPath mCodePathOption @@ -85,7 +89,7 @@ main = withCP65001 do Exit.die "Your .unisonConfig could not be loaded. Check that it's correct!" case command of PrintVersion -> - putStrLn $ progName ++ " version: " ++ Version.gitDescribeWithDate + Text.putStrLn $ Text.pack progName <> " version: " <> Version.gitDescribeWithDate Init -> do PT.putPrettyLn $ P.callout @@ -107,14 +111,14 @@ main = withCP65001 do Run (RunFromFile file mainName) args | not (isDotU file) -> PT.putPrettyLn $ P.callout "โš ๏ธ" "Files must have a .u extension." | otherwise -> do - e <- safeReadUtf8 file - case e of - Left _ -> PT.putPrettyLn $ P.callout "โš ๏ธ" "I couldn't find that file or it is for some reason unreadable." - Right contents -> do - getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do - rt <- RTI.startRuntime RTI.Standalone Version.gitDescribeWithDate - let fileEvent = Input.UnisonFileChanged (Text.pack file) contents - launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes + e <- safeReadUtf8 file + case e of + Left _ -> PT.putPrettyLn $ P.callout "โš ๏ธ" "I couldn't find that file or it is for some reason unreadable." + Right contents -> do + getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do + rt <- RTI.startRuntime RTI.Standalone Version.gitDescribeWithDate + let fileEvent = Input.UnisonFileChanged (Text.pack file) contents + launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes Run (RunFromPipe mainName) args -> do e <- safeReadUtf8StdIn case e of @@ -159,7 +163,7 @@ main = withCP65001 do | not vmatch -> mismatchMsg | otherwise -> withArgs args $ RTI.runStandalone sto w where - vmatch = v == Text.pack Version.gitDescribeWithDate + vmatch = v == Version.gitDescribeWithDate ws s = P.wrap (P.text s) ifile | 'c' : 'u' : '.' : rest <- reverse file = reverse rest @@ -175,7 +179,7 @@ main = withCP65001 do P.indentN 4 $ P.text v, "", "Your version", - P.indentN 4 $ P.string Version.gitDescribeWithDate, + P.indentN 4 $ P.text Version.gitDescribeWithDate, "", P.wrap $ "The program was compiled from hash " @@ -221,6 +225,18 @@ main = withCP65001 do PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..." launch currentDir config runtime theCodebase [] (Just baseUrl) downloadBase initRes +-- | Set user agent and configure TLS on global http client. +-- Note that the authorized http client is distinct from the global http client. +initHTTPClient :: IO () +initHTTPClient = do + let (ucmVersion, _date) = Version.gitDescribe + let userAgent = Text.encodeUtf8 $ "UCM/" <> ucmVersion + let addUserAgent req = do + pure $ req {HTTP.requestHeaders = ("User-Agent", userAgent) : HTTP.requestHeaders req} + let managerSettings = HTTP.tlsManagerSettings {HTTP.managerModifyRequest = addUserAgent} + manager <- HTTP.newTlsManagerWith managerSettings + HTTP.setGlobalManager manager + prepareTranscriptDir :: ShouldForkCodebase -> Maybe CodebasePathOption -> IO FilePath prepareTranscriptDir shouldFork mCodePathOption = do tmp <- Temp.getCanonicalTemporaryDirectory >>= (`Temp.createTempDirectory` "transcript") @@ -364,8 +380,8 @@ launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase initR CreatedCodebase {} -> NewlyCreatedCodebase _ -> PreviouslyCreatedCodebase - (gitRef, _date) = Version.gitDescribe - welcome = Welcome.welcome isNewCodebase downloadBase dir gitRef + (ucmVersion, _date) = Version.gitDescribe + welcome = Welcome.welcome isNewCodebase downloadBase dir ucmVersion in CommandLine.main dir welcome @@ -375,6 +391,7 @@ launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase initR runtime codebase serverBaseUrl + ucmVersion isMarkdown :: String -> Bool isMarkdown md = case FP.takeExtension md of @@ -396,7 +413,7 @@ getConfigFilePath mcodepath = (FP. ".unisonConfig") <$> Codebase.getCodebaseD defaultBaseLib :: Maybe ReadRemoteNamespace defaultBaseLib = rightMay $ - runParser VP.defaultBaseLib "version" (Text.pack gitRef) + runParser VP.defaultBaseLib "version" gitRef where (gitRef, _date) = Version.gitDescribe diff --git a/unison-cli/unison/Version.hs b/unison-cli/unison/Version.hs index 1498a6a6df..e933f6d947 100644 --- a/unison-cli/unison/Version.hs +++ b/unison-cli/unison/Version.hs @@ -3,7 +3,9 @@ module Version where +import Data.Bifunctor import Data.Text +import qualified Data.Text as Text import Language.Haskell.TH (Exp (TupE), runIO) import Language.Haskell.TH.Syntax (Exp (LitE), Lit (StringL)) import Shellmet @@ -11,15 +13,15 @@ import Shellmet -- | A formatted descriptor of when and against which commit this unison executable was built -- E.g. latest-149-g5cef8f851 (built on 2021-10-04) -- release/M2i (built on 2021-10-05) -gitDescribeWithDate :: String +gitDescribeWithDate :: Text gitDescribeWithDate = let formatDate d = " (built on " <> d <> ")" (gitRef, date) = gitDescribe in gitRef <> formatDate date -type CommitDate = String +type CommitDate = Text -type GitRef = String +type GitRef = Text -- | Uses Template Haskell to embed a git descriptor of the commit -- which was used to build the executable. @@ -27,14 +29,15 @@ type GitRef = String -- release/M2i (built on 2021-10-05) gitDescribe :: (GitRef, CommitDate) gitDescribe = - $( runIO $ do - -- Outputs date of current commit; E.g. 2021-08-06 - let getDate = "git" $| ["show", "-s", "--format=%cs"] - date <- getDate $? pure "" - -- Fetches a unique tag-name to represent the current commit. - -- Uses human-readable names whenever possible. - -- Marks version with a `'` suffix if building on a dirty worktree. - let getTag = "git" $| ["describe", "--tags", "--always", "--dirty='"] - tag <- getTag $? pure "unknown" - pure (TupE [Just . LitE . StringL . unpack $ tag, Just . LitE . StringL . unpack $ date]) - ) + bimap Text.pack Text.pack $ + $( runIO $ do + -- Outputs date of current commit; E.g. 2021-08-06 + let getDate = "git" $| ["show", "-s", "--format=%cs"] + date <- getDate $? pure "" + -- Fetches a unique tag-name to represent the current commit. + -- Uses human-readable names whenever possible. + -- Marks version with a `'` suffix if building on a dirty worktree. + let getTag = "git" $| ["describe", "--tags", "--always", "--dirty='"] + tag <- getTag $? pure "unknown" + pure (TupE [Just . LitE . StringL . unpack $ tag, Just . LitE . StringL . unpack $ date]) + ) From ca1509a7b75ed0742e056f920d98cd765fe0d380 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Wed, 30 Mar 2022 17:21:32 -0400 Subject: [PATCH 031/529] Fix a bug when renaming variables during ANF translation When a binding like: let v = u arose during the translation, the ANF could would simply rename v to u. However, it was only doing it in the 'body' portion of the code, not an associated context. --- parser-typechecker/src/Unison/Runtime/ANF.hs | 21 +++++++- unison-src/transcripts/anf-tests.md | 33 +++++++++++++ unison-src/transcripts/anf-tests.output.md | 51 ++++++++++++++++++++ 3 files changed, 104 insertions(+), 1 deletion(-) create mode 100644 unison-src/transcripts/anf-tests.md create mode 100644 unison-src/transcripts/anf-tests.output.md diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index 077eb208c4..1bce3ff774 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -1116,6 +1116,23 @@ fls, tru :: Var v => ANormal v fls = TCon Ty.booleanRef 0 [] tru = TCon Ty.booleanRef 1 [] +renameCtx :: Var v => v -> v -> Ctx v -> (Ctx v, Bool) +renameCtx v u (d, ctx) | (ctx, b) <- rn [] ctx = ((d, ctx), b) + where + swap w | w == v = u | otherwise = w + + rn acc [] = (reverse acc, False) + rn acc (ST d vs ccs b : es) + | any (== v) vs = (reverse acc ++ e : es, True) + | otherwise = rn (e : acc) es + where + e = ST d vs ccs $ ABTN.rename v u b + rn acc (LZ w f as : es) + | w == v = (reverse acc ++ e : es, True) + | otherwise = rn (e : acc) es + where + e = LZ w (swap <$> f) (swap <$> as) + anfBlock :: Var v => Term v a -> ANFM v (Ctx v, DNormal v) anfBlock (Var' v) = pure (mempty, pure $ TVar v) anfBlock (If' c t f) = do @@ -1270,7 +1287,9 @@ anfBlock (Let1Named' v b e) = anfBlock b >>= \case (bctx, (Direct, TVar u)) -> do (ectx, ce) <- anfBlock e - pure (bctx <> ectx, ABTN.rename v u <$> ce) + (ectx, shaded) <- pure $ renameCtx v u ectx + ce <- pure $ if shaded then ce else ABTN.rename v u <$> ce + pure (bctx <> ectx, ce) (bctx, (d0, cb)) -> bindLocal [v] $ do (ectx, ce) <- anfBlock e d <- bindDirection d0 diff --git a/unison-src/transcripts/anf-tests.md b/unison-src/transcripts/anf-tests.md new file mode 100644 index 0000000000..4e77e7406d --- /dev/null +++ b/unison-src/transcripts/anf-tests.md @@ -0,0 +1,33 @@ + +```ucm:hide +.> builtins.merge +``` + +This tests a variable related bug in the ANF compiler. + +The nested let would get flattened out, resulting in: + + bar = result + +which would be handled by renaming. However, the _context_ portion of +the rest of the code was not being renamed correctly, so `bar` would +remain in the definition of `baz`. + +```unison +foo _ = + id x = x + bar = let + Debug.watch "hello" "hello" + result = 5 + Debug.watch "goodbye" "goodbye" + result + baz = id bar + baz + +> !foo +``` + +```ucm +.> add +``` + diff --git a/unison-src/transcripts/anf-tests.output.md b/unison-src/transcripts/anf-tests.output.md new file mode 100644 index 0000000000..9fe04e0a1f --- /dev/null +++ b/unison-src/transcripts/anf-tests.output.md @@ -0,0 +1,51 @@ + +This tests a variable related bug in the ANF compiler. + +The nested let would get flattened out, resulting in: + + bar = result + +which would be handled by renaming. However, the _context_ portion of +the rest of the code was not being renamed correctly, so `bar` would +remain in the definition of `baz`. + +```unison +foo _ = + id x = x + bar = let + Debug.watch "hello" "hello" + result = 5 + Debug.watch "goodbye" "goodbye" + result + baz = id bar + baz + +> !foo +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + foo : โˆ€ _. _ -> Nat + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 11 | > !foo + โงฉ + 5 + +``` +```ucm +.> add + + โŸ I've added these definitions: + + foo : โˆ€ _. _ -> Nat + +``` From de015ba062088ba926cdfbf24ae6f886124fbc78 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Wed, 30 Mar 2022 17:26:49 -0400 Subject: [PATCH 032/529] Document renameCtx --- parser-typechecker/src/Unison/Runtime/ANF.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index 1bce3ff774..5d5046337a 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -1116,6 +1116,11 @@ fls, tru :: Var v => ANormal v fls = TCon Ty.booleanRef 0 [] tru = TCon Ty.booleanRef 1 [] +-- Helper function for renaming a variable arising from a +-- let v = u +-- binding during ANF translation. Renames a variable in a +-- context, and returns an indication of whether the varible +-- was shadowed by one of the context bindings. renameCtx :: Var v => v -> v -> Ctx v -> (Ctx v, Bool) renameCtx v u (d, ctx) | (ctx, b) <- rn [] ctx = ((d, ctx), b) where From 4a0c5367a743bfefd2899dcd7b602744f6a3ee48 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 30 Mar 2022 16:17:57 -0600 Subject: [PATCH 033/529] Correctly print errors which occur during transcripts Also set exit code 1 when transcripts fail. --- unison-cli/package.yaml | 1 + unison-cli/transcripts/Transcripts.hs | 3 + unison-cli/unison-cli.cabal | 5 ++ unison-cli/unison/Main.hs | 97 ++++++++++++++------------- 4 files changed, 58 insertions(+), 48 deletions(-) diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 8ab028b788..0abd6d0f6b 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -53,6 +53,7 @@ dependencies: - time - lock-file - jwt + - either library: diff --git a/unison-cli/transcripts/Transcripts.hs b/unison-cli/transcripts/Transcripts.hs index 28bb3c3f2c..0590dc47d4 100644 --- a/unison-cli/transcripts/Transcripts.hs +++ b/unison-cli/transcripts/Transcripts.hs @@ -8,6 +8,7 @@ module Main (main) where import Data.Bifunctor (second) import Data.List import qualified Data.Text as Text +import qualified Data.Text.IO as Text import EasyTest import System.Directory import System.Environment (getArgs) @@ -47,6 +48,8 @@ testBuilder dir prelude transcript = scope transcript $ do crash $ "Error parsing " <> filePath <> ": " <> Text.unpack msg TranscriptRunFailure errOutput -> do io $ writeUtf8 outputFile errOutput + io $ Text.putStrLn errOutput + crash $ "Failure in " <> filePath (filePath, Right out) -> do let outputFile = outputFileForTranscript filePath io $ writeUtf8 outputFile out diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 7e16081d4c..7264cb123c 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -98,6 +98,7 @@ library , containers >=0.6.3 , cryptonite , directory + , either , errors , extra , filepath @@ -184,6 +185,7 @@ executable integration-tests , cryptonite , directory , easytest + , either , errors , extra , filepath @@ -266,6 +268,7 @@ executable transcripts , cryptonite , directory , easytest + , either , errors , extra , filepath @@ -351,6 +354,7 @@ executable unison , containers >=0.6.3 , cryptonite , directory + , either , errors , extra , filepath @@ -443,6 +447,7 @@ test-suite tests , cryptonite , directory , easytest + , either , errors , extra , filepath diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index 713c6d9c6b..f8f0b5bdda 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -26,8 +26,8 @@ import Control.Error.Safe (rightMay) import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BL import Data.Configurator.Types (Config) +import Data.Either.Validation (Validation (..)) import Data.List.NonEmpty (NonEmpty) -import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.IO as Text @@ -70,6 +70,7 @@ import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P import UnliftIO.Directory (getHomeDirectory) import qualified Version +import Data.Bifunctor main :: IO () main = withCP65001 do @@ -262,20 +263,19 @@ runTranscripts' :: String -> Maybe FilePath -> FilePath -> - NonEmpty String -> + NonEmpty MarkdownFile -> IO Bool -runTranscripts' progName mcodepath transcriptDir args = do +runTranscripts' progName mcodepath transcriptDir markdownFiles = do currentDir <- getCurrentDirectory - let (markdownFiles, invalidArgs) = NonEmpty.partition isMarkdown args configFilePath <- getConfigFilePath mcodepath -- We don't need to create a codebase through `getCodebaseOrExit` as we've already done so previously. - getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) \(_, codebasePath, theCodebase) -> do + and <$> getCodebaseOrExit (Just (DontCreateCodebaseWhenMissing transcriptDir)) \(_, codebasePath, theCodebase) -> do TR.withTranscriptRunner Version.gitDescribeWithDate (Just configFilePath) $ \runTranscript -> do - for_ markdownFiles $ \fileName -> do + for markdownFiles $ \(MarkdownFile fileName) -> do transcriptSrc <- readUtf8 fileName result <- runTranscript fileName transcriptSrc (codebasePath, theCodebase) let outputFile = FP.replaceExtension (currentDir FP. fileName) ".output.md" - output <- case result of + (output, succeeded) <- case result of Left err -> case err of TR.TranscriptParseError err -> do PT.putPrettyLn $ @@ -287,7 +287,7 @@ runTranscripts' progName mcodepath transcriptDir args = do P.indentN 2 $ P.text err ] ) - pure err + pure (err, False) TR.TranscriptRunFailure err -> do PT.putPrettyLn $ P.callout @@ -305,24 +305,12 @@ runTranscripts' progName mcodepath transcriptDir args = do <> "to do more work with it." ] ) - pure err + pure (err, False) Right mdOut -> do - pure mdOut + pure (mdOut, True) writeUtf8 outputFile output putStrLn $ "๐Ÿ’พ Wrote " <> outputFile - - when (not . null $ invalidArgs) $ do - PT.putPrettyLn $ - P.callout - "โ“" - ( P.lines - [ P.indentN 2 "Transcripts must have an .md or .markdown extension.", - P.indentN 2 "Skipping the following invalid files:", - "", - P.bulleted $ fmap (P.bold . P.string . (<> "\n")) invalidArgs - ] - ) - pure True + pure succeeded runTranscripts :: UsageRenderer -> @@ -332,32 +320,43 @@ runTranscripts :: NonEmpty String -> IO () runTranscripts renderUsageInfo shouldFork shouldSaveTempCodebase mCodePathOption args = do + markdownFiles <- case traverse (first (pure @[]) . markdownFile) args of + Failure invalidArgs -> do + PT.putPrettyLn $ + P.callout + "โ“" + ( P.lines + [ P.indentN 2 "Transcripts must have an .md or .markdown extension.", + "", + P.bulleted $ fmap (P.bold . P.string . (<> "\n")) invalidArgs + ] + ) + putStrLn (renderUsageInfo $ Just "transcript") + Exit.exitWith (Exit.ExitFailure 1) + Success markdownFiles -> pure markdownFiles progName <- getProgName transcriptDir <- prepareTranscriptDir shouldFork mCodePathOption completed <- - runTranscripts' progName (Just transcriptDir) transcriptDir args + runTranscripts' progName (Just transcriptDir) transcriptDir markdownFiles case shouldSaveTempCodebase of DontSaveCodebase -> removeDirectoryRecursive transcriptDir SaveCodebase -> - if completed - then - PT.putPrettyLn $ - P.callout - "๐ŸŒธ" - ( P.lines - [ "I've finished running the transcript(s) in this codebase:", - "", - P.indentN 2 (P.string transcriptDir), - "", - P.wrap $ - "You can run" - <> P.backticked (P.string progName <> " --codebase " <> P.string transcriptDir) - <> "to do more work with it." - ] - ) - else do - putStrLn (renderUsageInfo $ Just "transcript") - Exit.exitWith (Exit.ExitFailure 1) + when completed $ do + PT.putPrettyLn $ + P.callout + "๐ŸŒธ" + ( P.lines + [ "I've finished running the transcript(s) in this codebase:", + "", + P.indentN 2 (P.string transcriptDir), + "", + P.wrap $ + "You can run" + <> P.backticked (P.string progName <> " --codebase " <> P.string transcriptDir) + <> "to do more work with it." + ] + ) + when (not completed) $ Exit.exitWith (Exit.ExitFailure 1) initialPath :: Path.Absolute initialPath = Path.absoluteEmpty @@ -393,11 +392,13 @@ launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase initR serverBaseUrl ucmVersion -isMarkdown :: String -> Bool -isMarkdown md = case FP.takeExtension md of - ".md" -> True - ".markdown" -> True - _ -> False +newtype MarkdownFile = MarkdownFile FilePath + +markdownFile :: FilePath -> Validation FilePath MarkdownFile +markdownFile md = case FP.takeExtension md of + ".md" -> Success $ MarkdownFile md + ".markdown" -> Success $ MarkdownFile md + _ -> Failure md isDotU :: String -> Bool isDotU file = FP.takeExtension file == ".u" From aa69d40f606862562080c23c643e92c9cd6c4063 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 30 Mar 2022 16:29:13 -0600 Subject: [PATCH 034/529] Assert that transcripts in /errors/ should fail. --- unison-cli/transcripts/Transcripts.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/unison-cli/transcripts/Transcripts.hs b/unison-cli/transcripts/Transcripts.hs index 0590dc47d4..7f4b2e3380 100644 --- a/unison-cli/transcripts/Transcripts.hs +++ b/unison-cli/transcripts/Transcripts.hs @@ -32,8 +32,8 @@ data TestConfig = TestConfig type TestBuilder = FilePath -> [String] -> String -> Test () testBuilder :: - FilePath -> [String] -> String -> Test () -testBuilder dir prelude transcript = scope transcript $ do + Bool -> FilePath -> [String] -> String -> Test () +testBuilder expectFailure dir prelude transcript = scope transcript $ do outputs <- io . withTemporaryUcmCodebase SC.init "transcript" $ \(codebasePath, codebase) -> do withTranscriptRunner "TODO: pass version here" Nothing $ \runTranscript -> do for files $ \filePath -> do @@ -45,14 +45,15 @@ testBuilder dir prelude transcript = scope transcript $ do let outputFile = outputFileForTranscript filePath case err of TranscriptParseError msg -> do - crash $ "Error parsing " <> filePath <> ": " <> Text.unpack msg + when (not expectFailure) . crash $ "Error parsing " <> filePath <> ": " <> Text.unpack msg TranscriptRunFailure errOutput -> do io $ writeUtf8 outputFile errOutput io $ Text.putStrLn errOutput - crash $ "Failure in " <> filePath + when (not expectFailure) . crash $ "Failure in " <> filePath (filePath, Right out) -> do let outputFile = outputFileForTranscript filePath io $ writeUtf8 outputFile out + when expectFailure $ crash "Expected a failure, but transcript was successful." ok where files = fmap (dir ) (prelude ++ [transcript]) @@ -109,11 +110,11 @@ cleanup = do test :: TestConfig -> Test () test config = do - buildTests config testBuilder $ + buildTests config (testBuilder False) $ "unison-src" "transcripts" - buildTests config testBuilder $ + buildTests config (testBuilder False) $ "unison-src" "transcripts-using-base" - buildTests config testBuilder $ + buildTests config (testBuilder True) $ "unison-src" "transcripts" "errors" cleanup From 18c15b881de5877bbb00c0e706a16c2e64f7c4ee Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 30 Mar 2022 17:18:08 -0600 Subject: [PATCH 035/529] Hide builtins.merge, builtins.mergeio --- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 343dd83511..da2605a06d 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -87,7 +87,7 @@ mergeBuiltins = InputPattern "builtins.merge" [] - I.Visible + I.Hidden [] "Adds the builtins to `builtins.` in the current namespace (excluding `io` and misc)." (const . pure $ Input.MergeBuiltinsI) @@ -97,7 +97,7 @@ mergeIOBuiltins = InputPattern "builtins.mergeio" [] - I.Visible + I.Hidden [] "Adds all the builtins to `builtins.` in the current namespace, including `io` and misc." (const . pure $ Input.MergeIOBuiltinsI) From 48e1653b3e6e6c8ba77f04d5212b098e316687d7 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 31 Mar 2022 13:20:33 -0400 Subject: [PATCH 036/529] improve query logging and top-level exception printing --- .../U/Codebase/Sqlite/Operations.hs | 1 - .../src/Unison/Sqlite/Connection.hs | 106 +++++++++--------- .../src/Unison/Sqlite/Connection/Internal.hs | 17 +++ .../src/Unison/Sqlite/Exception.hs | 17 ++- lib/unison-sqlite/unison-sqlite.cabal | 1 + unison-cli/package.yaml | 1 + .../src/Unison/Codebase/TranscriptParser.hs | 4 - unison-cli/src/Unison/CommandLine/Main.hs | 12 +- unison-cli/unison-cli.cabal | 5 + 9 files changed, 91 insertions(+), 73 deletions(-) create mode 100644 lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 07c6bad879..ca772d23a8 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -226,7 +226,6 @@ data Error = DecodeError DecodeError ByteString ErrString deriving stock (Show) deriving anyclass (SqliteExceptionReason) --- instance Exception Error -- FIXME this came from trunk newtype NeedTypeForBuiltinMetadata = NeedTypeForBuiltinMetadata Text diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index 1a9a58d7e1..afd126e691 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -65,27 +65,15 @@ where import Data.Bifunctor (bimap) import qualified Database.SQLite.Simple as Sqlite import qualified Database.SQLite.Simple.FromField as Sqlite -import qualified Database.SQLite3.Direct as Sqlite (Database (..)) import Debug.RecoverRTTI (anythingToString) -import Unison.Debug (debugLogM, debugM) import qualified Unison.Debug as Debug import Unison.Prelude +import Unison.Sqlite.Connection.Internal (Connection (..)) import Unison.Sqlite.Exception import Unison.Sqlite.Sql import UnliftIO (MonadUnliftIO, withRunInIO) import UnliftIO.Exception --- | A /non-thread safe/ connection to a SQLite database. -data Connection = Connection - { name :: String, - file :: FilePath, - conn :: Sqlite.Connection - } - -instance Show Connection where - show (Connection name file (Sqlite.Connection (Sqlite.Database conn))) = - "Connection " ++ show name ++ " " ++ show file ++ " " ++ show conn - -- | Perform an action with a connection to a SQLite database. -- -- Note: the connection is created with @PRAGMA foreign_keys = ON@ automatically, to work around the fact that SQLite @@ -124,13 +112,33 @@ closeConnection (Connection _ _ conn) = -- 2. Always ignore exceptions thrown by `close` (Mitchell prefers this one) Sqlite.close conn +-- An internal type, for making prettier debug logs + +data Query = Query + { sql :: Sql, + params :: Maybe String, + result :: Maybe String + } + +instance Show Query where + show Query {sql, params, result} = + concat + [ "Query { sql = ", + show sql, + maybe "" (\p -> ", params = " ++ show p) params, + maybe "" (\r -> ", results = " ++ show r) result, + " }" + ] + +logQuery :: Sql -> Maybe a -> Maybe b -> IO () +logQuery sql params result = + Debug.debugM Debug.Sqlite "SQL query" (Query sql (anythingToString <$> params) (anythingToString <$> result)) + -- Without results, with parameters execute :: Sqlite.ToRow a => Connection -> Sql -> a -> IO () execute conn@(Connection _ _ conn0) s params = do - debugM Debug.Sqlite "query" s - debugM Debug.Sqlite "params" (anythingToString params) - debugLogM Debug.Sqlite "----------" + logQuery s (Just params) Nothing Sqlite.execute conn0 (coerce s) params `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException SqliteQueryExceptionInfo @@ -142,9 +150,7 @@ execute conn@(Connection _ _ conn0) s params = do executeMany :: Sqlite.ToRow a => Connection -> Sql -> [a] -> IO () executeMany conn@(Connection _ _ conn0) s params = do - debugM Debug.Sqlite "query" s - debugM Debug.Sqlite "params" (anythingToString params) - debugLogM Debug.Sqlite "----------" + logQuery s (Just params) Nothing Sqlite.executeMany conn0 (coerce s) params `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException SqliteQueryExceptionInfo @@ -158,8 +164,7 @@ executeMany conn@(Connection _ _ conn0) s params = do execute_ :: Connection -> Sql -> IO () execute_ conn@(Connection _ _ conn0) s = do - debugM Debug.Sqlite "query" s - debugLogM Debug.Sqlite "----------" + logQuery s Nothing Nothing Sqlite.execute_ conn0 (coerce s) `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException SqliteQueryExceptionInfo @@ -172,23 +177,19 @@ execute_ conn@(Connection _ _ conn0) s = do -- With results, with parameters, without checks queryListRow :: (Sqlite.FromRow b, Sqlite.ToRow a) => Connection -> Sql -> a -> IO [b] -queryListRow conn@(Connection _ _ conn0) s params = - doQueryListRow `catch` \(exception :: Sqlite.SQLError) -> - throwSqliteQueryException - SqliteQueryExceptionInfo - { connection = conn, - exception = SomeSqliteExceptionReason exception, - params = Just params, - sql = s - } - where - doQueryListRow = do - debugM Debug.Sqlite "query" s - debugM Debug.Sqlite "params" (anythingToString params) - result <- Sqlite.query conn0 (coerce s) params - debugM Debug.Sqlite "result" (anythingToString result) - debugLogM Debug.Sqlite "----------" - pure result +queryListRow conn@(Connection _ _ conn0) s params = do + result <- + Sqlite.query conn0 (coerce s) params + `catch` \(exception :: Sqlite.SQLError) -> + throwSqliteQueryException + SqliteQueryExceptionInfo + { connection = conn, + exception = SomeSqliteExceptionReason exception, + params = Just params, + sql = s + } + logQuery s (Just params) (Just result) + pure result queryListCol :: forall a b. (Sqlite.FromField b, Sqlite.ToRow a) => Connection -> Sql -> a -> IO [b] queryListCol conn s params = @@ -308,22 +309,19 @@ queryOneColCheck conn s params check = -- With results, without parameters, without checks queryListRow_ :: Sqlite.FromRow a => Connection -> Sql -> IO [a] -queryListRow_ conn@(Connection _ _ conn0) s = - doQueryListRow_ `catch` \(exception :: Sqlite.SQLError) -> - throwSqliteQueryException - SqliteQueryExceptionInfo - { connection = conn, - exception = SomeSqliteExceptionReason exception, - params = Nothing, - sql = s - } - where - doQueryListRow_ = do - debugM Debug.Sqlite "query" s - result <- Sqlite.query_ conn0 (coerce s) - debugM Debug.Sqlite "result" (anythingToString result) - debugLogM Debug.Sqlite "----------" - pure result +queryListRow_ conn@(Connection _ _ conn0) s = do + result <- + Sqlite.query_ conn0 (coerce s) + `catch` \(exception :: Sqlite.SQLError) -> + throwSqliteQueryException + SqliteQueryExceptionInfo + { connection = conn, + exception = SomeSqliteExceptionReason exception, + params = Nothing, + sql = s + } + logQuery s Nothing (Just result) + pure result queryListCol_ :: forall a. Sqlite.FromField a => Connection -> Sql -> IO [a] queryListCol_ conn s = diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs new file mode 100644 index 0000000000..9471c70e9a --- /dev/null +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs @@ -0,0 +1,17 @@ +module Unison.Sqlite.Connection.Internal + ( Connection (..), + ) +where + +import qualified Database.SQLite.Simple as Sqlite + +-- | A /non-thread safe/ connection to a SQLite database. +data Connection = Connection + { name :: String, + file :: FilePath, + conn :: Sqlite.Connection + } + +instance Show Connection where + show (Connection name file _conn) = + "Connection { name = " ++ show name ++ ", file = " ++ show file ++ " }" diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs b/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs index 46768236fa..931cb24f5f 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE ImplicitParams #-} + -- | Sqlite exception utils. module Unison.Sqlite.Exception ( -- * @SomeSqliteException@ @@ -24,7 +26,9 @@ import Data.Typeable (cast) import Data.Void (Void) import qualified Database.SQLite.Simple as Sqlite import Debug.RecoverRTTI (anythingToString) +import GHC.Stack (currentCallStack) import Unison.Prelude +import Unison.Sqlite.Connection.Internal (Connection) import Unison.Sqlite.Sql import UnliftIO.Exception @@ -110,7 +114,8 @@ data SqliteQueryException = SqliteQueryException -- | The inner exception. It is intentionally not 'SomeException', so that calling code cannot accidentally -- 'throwIO' domain-specific exception types, but must instead use a @*Check@ query variant. exception :: SomeSqliteExceptionReason, - connection :: String, + callStack :: [String], + connection :: Connection, threadId :: ThreadId } deriving stock (Show) @@ -128,22 +133,24 @@ isSqliteBusyException SqliteQueryException {exception = SomeSqliteExceptionReaso Just (Sqlite.SQLError Sqlite.ErrorBusy _ _) -> True _ -> False -data SqliteQueryExceptionInfo params connection = SqliteQueryExceptionInfo - { connection :: connection, +data SqliteQueryExceptionInfo params = SqliteQueryExceptionInfo + { connection :: Connection, sql :: Sql, params :: Maybe params, exception :: SomeSqliteExceptionReason } -throwSqliteQueryException :: Show connection => SqliteQueryExceptionInfo params connection -> IO a +throwSqliteQueryException :: SqliteQueryExceptionInfo params -> IO a throwSqliteQueryException SqliteQueryExceptionInfo {connection, exception, params, sql} = do threadId <- myThreadId + callStack <- currentCallStack throwIO SqliteQueryException { sql, params = maybe "" anythingToString params, exception, - connection = show connection, + callStack, + connection, threadId } diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 159ea91d81..0d7820ebba 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -19,6 +19,7 @@ library exposed-modules: Unison.Sqlite Unison.Sqlite.Connection + Unison.Sqlite.Connection.Internal Unison.Sqlite.DB Unison.Sqlite.Transaction other-modules: diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 9830f2da89..c3fb5b89a6 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -30,6 +30,7 @@ dependencies: - mtl - transformers - open-browser + - pretty-simple - random >= 1.2.0 - regex-tdfa - stm diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 78d652d6e7..f347810f3a 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -19,7 +19,6 @@ module Unison.Codebase.TranscriptParser where import Control.Concurrent.STM (atomically) -import Control.Error (rightMay) import Control.Lens (view) import qualified Crypto.Random as Random import qualified Data.Char as Char @@ -58,9 +57,6 @@ import qualified Unison.Runtime.Interface as RTI import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P import qualified Unison.Util.TQueue as Q -import qualified Unison.Codebase.Editor.Output as Output -import Control.Lens (view) -import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified UnliftIO import Prelude hiding (readFile, writeFile) diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 0abcb268ff..ede6e5dfc6 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -10,7 +10,6 @@ where import Compat (withInterruptHandler) import qualified Control.Concurrent.Async as Async import Control.Concurrent.STM (atomically) -import Control.Error (rightMay) import Control.Exception (catch, finally) import Control.Lens (view) import qualified Crypto.Random as Random @@ -18,9 +17,11 @@ import Data.Configurator.Types (Config) import Data.IORef import qualified Data.Map as Map import qualified Data.Text as Text +import qualified Data.Text.Lazy.IO as Text.Lazy import qualified System.Console.Haskeline as Line import System.IO (hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) +import Text.Pretty.Simple (pShow) import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Unison.Codebase.Branch (Branch) @@ -46,13 +47,6 @@ import qualified Unison.Server.CodebaseServer as Server import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P import qualified Unison.Util.TQueue as Q -import qualified Unison.CommandLine.Welcome as Welcome -import Control.Lens (view) -import UnliftIO (catchSyncOrAsync, throwIO, withException) -import System.IO (hPutStrLn, stderr) -import Unison.Codebase.Editor.Output (Output) -import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState -import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified UnliftIO getUserInput :: @@ -234,7 +228,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba `finally` cleanup where printException :: SomeException -> IO () - printException e = hPutStrLn stderr ("Encountered Exception: " <> show (e :: SomeException)) + printException e = Text.Lazy.hPutStrLn stderr ("Encountered exception:\n" <> pShow e) -- | Installs a posix interrupt handler for catching SIGINT. -- This replaces GHC's default sigint handler which throws a UserInterrupt async exception diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 5c9a47e8e1..9ab5d7c655 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -97,6 +97,7 @@ library , mtl , nonempty-containers , open-browser + , pretty-simple , random >=1.2.0 , regex-tdfa , semialign @@ -172,6 +173,7 @@ executable integration-tests , mtl , nonempty-containers , open-browser + , pretty-simple , process , random >=1.2.0 , regex-tdfa @@ -244,6 +246,7 @@ executable transcripts , mtl , nonempty-containers , open-browser + , pretty-simple , process , random >=1.2.0 , regex-tdfa @@ -319,6 +322,7 @@ executable unison , nonempty-containers , open-browser , optparse-applicative >=0.16.1.0 + , pretty-simple , random >=1.2.0 , regex-tdfa , semialign @@ -400,6 +404,7 @@ test-suite tests , mtl , nonempty-containers , open-browser + , pretty-simple , random >=1.2.0 , regex-tdfa , semialign From 1c429116998862dda4f601743ad5188c82acaebd Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 31 Mar 2022 12:31:19 -0600 Subject: [PATCH 037/529] Multiple tries for building dependencies on windows. --- .github/workflows/ci.yaml | 16 +++++++++++++++- 1 file changed, 15 insertions(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index d5df9e60f5..5c85227b8b 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -100,7 +100,21 @@ jobs: # Build deps, then build local code. Splitting it into two steps just allows us to see how much time each step # takes. - name: build dependencies - run: stack --no-terminal build --fast --only-dependencies + # Run up to 5 times in a row before giving up. + # It's very unlikely that our build-dependencies step will fail on most builds, + # so if it fails its almost certainly due to a race condition on the Windows + # file-system API that stack runs into. Since any successful packages are + # cached within a single build, it should get further along on each re-start + # and should hopefully finish! + run: | + tries=1 + if [[ ${{matrix.os}} = "windows-"* ]]; then + tries=5 + fi + + for (( i = 0; i < $tries; i++ )); do + stack --no-terminal build --fast --only-dependencies && break; + done - name: build run: stack --no-terminal build --fast --no-run-tests --test From 95aabd60450163fe7bc955f0aca6669cb2cbfa43 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 31 Mar 2022 14:37:31 -0400 Subject: [PATCH 038/529] fix a couple regressions in term/decl queries --- .../U/Codebase/Sqlite/Operations.hs | 65 +++++++-------- .../U/Codebase/Sqlite/Queries.hs | 79 ++++++++++++++----- 2 files changed, 89 insertions(+), 55 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index ca772d23a8..e048808ede 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -289,8 +289,9 @@ loadRootCausalHash :: DB m => m CausalHash loadRootCausalHash = loadCausalHashById =<< Q.loadNamespaceRoot loadMaybeRootCausalHash :: DB m => m (Maybe CausalHash) -loadMaybeRootCausalHash = runMaybeT $ - loadCausalHashById =<< MaybeT Q.loadMaybeNamespaceRoot +loadMaybeRootCausalHash = + runMaybeT $ + loadCausalHashById =<< MaybeT Q.loadMaybeNamespaceRoot -- * Reference transformations @@ -456,13 +457,9 @@ componentByObjectId id = do loadTermComponent :: DB m => H.Hash -> MaybeT m [(C.Term Symbol, C.Term.Type Symbol)] loadTermComponent h = do - MaybeT (anyHashToMaybeObjectId h) - -- retrieve and deserialize the blob - >>= (\oid -> Q.expectTermObjectById oid decodeTermFormat) - >>= \case - S.Term.Term (S.Term.LocallyIndexedComponent elements) -> - lift . traverse (uncurry3 s2cTermWithType) $ - Foldable.toList elements + oid <- MaybeT (anyHashToMaybeObjectId h) + S.Term.Term (S.Term.LocallyIndexedComponent elements) <- MaybeT (Q.loadTermObjectById oid decodeTermFormat) + lift . traverse (uncurry3 s2cTermWithType) $ Foldable.toList elements saveTermComponent :: DB m => H.Hash -> [(C.Term Symbol, C.Term.Type Symbol)] -> m Db.ObjectId saveTermComponent h terms = do @@ -614,27 +611,27 @@ c2xTerm saveText saveDefn tm tp = pure (ids, void tm, void <$> tp) loadTermWithTypeByReference :: DB m => C.Reference.Id -> MaybeT m (C.Term Symbol, C.Term.Type Symbol) -loadTermWithTypeByReference (C.Reference.Id h i) = - MaybeT (primaryHashToMaybeObjectId h) - -- retrieve and deserialize the blob - >>= (\oId -> Q.expectTermObjectById oId (decodeTermElementWithType i)) - >>= uncurry3 s2cTermWithType +loadTermWithTypeByReference (C.Reference.Id h i) = do + oid <- MaybeT (primaryHashToMaybeObjectId h) + -- retrieve and deserialize the blob + (localIds, term, typ) <- MaybeT (Q.loadTermObjectById oid (decodeTermElementWithType i)) + s2cTermWithType localIds term typ loadTermByReference :: DB m => C.Reference.Id -> MaybeT m (C.Term Symbol) loadTermByReference r@(C.Reference.Id h i) = do when debug . traceM $ "loadTermByReference " ++ show r - MaybeT (primaryHashToMaybeObjectId h) - -- retrieve and deserialize the blob - >>= (\oid -> lift (Q.expectTermObjectById oid (decodeTermElementDiscardingType i))) - >>= uncurry s2cTerm + oid <- MaybeT (primaryHashToMaybeObjectId h) + -- retrieve and deserialize the blob + (localIds, term) <- MaybeT (Q.loadTermObjectById oid (decodeTermElementDiscardingType i)) + s2cTerm localIds term loadTypeOfTermByTermReference :: DB m => C.Reference.Id -> MaybeT m (C.Term.Type Symbol) loadTypeOfTermByTermReference id@(C.Reference.Id h i) = do when debug . traceM $ "loadTypeOfTermByTermReference " ++ show id - MaybeT (primaryHashToMaybeObjectId h) - -- retrieve and deserialize the blob - >>= (\oid -> lift (Q.expectTermObjectById oid (decodeTermElementDiscardingTerm i))) - >>= uncurry s2cTypeOfTerm + oid <- MaybeT (primaryHashToMaybeObjectId h) + -- retrieve and deserialize the blob + (localIds, typ) <- MaybeT (Q.loadTermObjectById oid (decodeTermElementDiscardingTerm i)) + s2cTypeOfTerm localIds typ s2cTermWithType :: DB m => LocalIds -> S.Term.Term -> S.Term.Type -> m (C.Term Symbol, C.Term.Type Symbol) s2cTermWithType ids tm tp = do @@ -733,11 +730,10 @@ listWatches k = Q.loadWatchesByWatchKind k >>= traverse h2cReferenceId -- | returns Nothing if the expression isn't cached. loadWatch :: DB m => WatchKind -> C.Reference.Id -> MaybeT m (C.Term Symbol) -loadWatch k r = - C.Reference.idH Q.saveHashHash r - >>= (\r' -> MaybeT (Q.loadWatch k r' (getFromBytesOr (ErrWatch k r) S.getWatchResultFormat))) - >>= \case - S.Term.WatchResult wlids t -> w2cTerm wlids t +loadWatch k r = do + r' <- C.Reference.idH Q.saveHashHash r + S.Term.WatchResult wlids t <- MaybeT (Q.loadWatch k r' (getFromBytesOr (ErrWatch k r) S.getWatchResultFormat)) + w2cTerm wlids t saveWatch :: DB m => WatchKind -> C.Reference.Id -> C.Term Symbol -> m () saveWatch w r t = do @@ -761,11 +757,9 @@ w2cTerm ids tm = do loadDeclComponent :: DB m => H.Hash -> MaybeT m [C.Decl Symbol] loadDeclComponent h = do - MaybeT (anyHashToMaybeObjectId h) - >>= (\oid -> Q.expectDeclObjectById oid decodeDeclFormat) - >>= \case - S.Decl.Decl (S.Decl.LocallyIndexedComponent elements) -> - lift . traverse (uncurry s2cDecl) $ Foldable.toList elements + oid <- MaybeT (anyHashToMaybeObjectId h) + S.Decl.Decl (S.Decl.LocallyIndexedComponent elements) <- MaybeT (Q.loadDeclObjectById oid decodeDeclFormat) + lift . traverse (uncurry s2cDecl) $ Foldable.toList elements saveDeclComponent :: DB m => H.Hash -> [C.Decl Symbol] -> m Db.ObjectId saveDeclComponent h decls = do @@ -830,10 +824,9 @@ s2cDecl ids (C.Decl.DataDeclaration dt m b ct) = do loadDeclByReference :: DB m => C.Reference.Id -> MaybeT m (C.Decl Symbol) loadDeclByReference r@(C.Reference.Id h i) = do when debug . traceM $ "loadDeclByReference " ++ show r - -- retrieve the blob - MaybeT (primaryHashToMaybeObjectId h) - >>= (\oid -> Q.expectDeclObjectById oid (decodeDeclElement i)) - >>= uncurry s2cDecl + oid <- MaybeT (primaryHashToMaybeObjectId h) + (localIds, decl) <- MaybeT (Q.loadDeclObjectById oid (decodeDeclElement i)) + s2cDecl localIds decl -- TODO rename expectDeclById expectDeclByReference :: DB m => C.Reference.Id -> m (C.Decl Symbol) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index d827a6a872..70908e9555 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -52,8 +52,12 @@ module U.Codebase.Sqlite.Queries loadObjectWithTypeById, loadObjectWithHashIdAndTypeById, expectDeclObjectById, + loadDeclObjectById, expectNamespaceObjectById, + loadNamespaceObjectById, expectPatchObjectById, + loadPatchObjectById, + loadTermObjectById, expectTermObjectById, updateObjectBlob, -- unused @@ -147,7 +151,6 @@ import Data.Tuple.Only (Only (..)) import U.Codebase.HashTags (BranchHash (..), CausalHash (..)) import U.Codebase.Reference (Reference' (..)) import qualified U.Codebase.Reference as C.Reference -import qualified UnliftIO import U.Codebase.Sqlite.DbId ( BranchHashId (..), BranchObjectId (..), @@ -158,7 +161,7 @@ import U.Codebase.Sqlite.DbId SchemaVersion, TextId, ) -import U.Codebase.Sqlite.ObjectType (ObjectType(DeclComponent, Namespace, Patch, TermComponent)) +import U.Codebase.Sqlite.ObjectType (ObjectType (DeclComponent, Namespace, Patch, TermComponent)) import qualified U.Codebase.Sqlite.Reference as Reference import qualified U.Codebase.Sqlite.Referent as Referent import U.Codebase.WatchKind (WatchKind) @@ -186,7 +189,8 @@ vacuumInto dest = do schemaVersion :: DB m => m SchemaVersion schemaVersion = queryOneCol_ sql - where sql = "SELECT version from schema_version;" + where + sql = "SELECT version from schema_version;" setSchemaVersion :: DB m => SchemaVersion -> m () setSchemaVersion schemaVersion = execute sql (Only schemaVersion) @@ -317,32 +321,63 @@ loadObjectWithTypeById oId = queryOneRow sql (Only oId) SELECT type_id, bytes FROM object WHERE id = ? |] +loadObjectOfTypeById :: + (DB m, SqliteExceptionReason e) => + ObjectId -> + ObjectType -> + (ByteString -> Either e a) -> + m (Maybe a) +loadObjectOfTypeById oid ty = + queryMaybeColCheck loadObjectOfTypeByIdSql (oid, ty) + expectObjectOfTypeById :: (DB m, SqliteExceptionReason e) => ObjectId -> ObjectType -> (ByteString -> Either e a) -> m a expectObjectOfTypeById oid ty = - queryOneColCheck - [here| - SELECT bytes - FROM object - WHERE id = ? - AND type_id = ? - |] - (oid, ty) + queryOneColCheck loadObjectOfTypeByIdSql (oid, ty) + +loadObjectOfTypeByIdSql :: Sql +loadObjectOfTypeByIdSql = + [here| + SELECT bytes + FROM object + WHERE id = ? + AND type_id = ? + |] + +-- | Load a decl component object. +loadDeclObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) +loadDeclObjectById oid = + loadObjectOfTypeById oid DeclComponent -- | Expect a decl component object. expectDeclObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a expectDeclObjectById oid = expectObjectOfTypeById oid DeclComponent +-- | Load a namespace object. +loadNamespaceObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) +loadNamespaceObjectById oid = + loadObjectOfTypeById oid Namespace + -- | Expect a namespace object. expectNamespaceObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a expectNamespaceObjectById oid = expectObjectOfTypeById oid Namespace +-- | Load a patch object. +loadPatchObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) +loadPatchObjectById oid = + loadObjectOfTypeById oid Patch + -- | Expect a patch object. expectPatchObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a expectPatchObjectById oid = expectObjectOfTypeById oid Patch +-- | Load a term component object. +loadTermObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) +loadTermObjectById oid = + loadObjectOfTypeById oid TermComponent + -- | Expect a term component object. expectTermObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a expectTermObjectById oid = @@ -846,7 +881,8 @@ removeHashObjectsByHashingVersion hashVersion = before :: DB m => CausalHashId -> CausalHashId -> m Bool before chId1 chId2 = queryOneCol sql (chId2, chId1) - where sql = fromString $ "SELECT EXISTS (" ++ ancestorSql ++ " WHERE ancestor.id = ?)" + where + sql = fromString $ "SELECT EXISTS (" ++ ancestorSql ++ " WHERE ancestor.id = ?)" -- the `Connection` arguments come second to fit the shape of Exception.bracket + uncurry curry lca :: CausalHashId -> CausalHashId -> Connection -> Connection -> IO (Maybe CausalHashId) @@ -859,17 +895,22 @@ lca x y cx cy = (Just (Only px), Just (Only py)) -> let seenX' = Set.insert px seenX seenY' = Set.insert py seenY - in if Set.member px seenY' then pure (Just px) - else if Set.member py seenX' then pure (Just py) - else loop2 seenX' seenY' + in if Set.member px seenY' + then pure (Just px) + else + if Set.member py seenX' + then pure (Just py) + else loop2 seenX' seenY' (Nothing, Nothing) -> pure Nothing (Just (Only px), Nothing) -> loop1 nextX seenY px (Nothing, Just (Only py)) -> loop1 nextY seenX py loop1 getNext matches v = - if Set.member v matches then pure (Just v) - else getNext >>= \case - Just (Only v) -> loop1 getNext matches v - Nothing -> pure Nothing + if Set.member v matches + then pure (Just v) + else + getNext >>= \case + Just (Only v) -> loop1 getNext matches v + Nothing -> pure Nothing loop2 (Set.singleton x) (Set.singleton y) where sql = fromString ancestorSql From 1895dff8f8fcdb5460c03a1d522dcc8e22654494 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 31 Mar 2022 12:39:24 -0600 Subject: [PATCH 039/529] Use bash, not power-shell for simplicity sake --- .github/workflows/ci.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 5c85227b8b..c2cb6822a0 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -100,6 +100,7 @@ jobs: # Build deps, then build local code. Splitting it into two steps just allows us to see how much time each step # takes. - name: build dependencies + shell: bash # Run up to 5 times in a row before giving up. # It's very unlikely that our build-dependencies step will fail on most builds, # so if it fails its almost certainly due to a race condition on the Windows From 18bb2ea0bdb2351b6a84db110aefa1b6431b7145 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 31 Mar 2022 14:39:47 -0400 Subject: [PATCH 040/529] delete extensions from file --- .../codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 15 --------------- codebase2/codebase-sqlite/package.yaml | 4 ++++ .../codebase-sqlite/unison-codebase-sqlite.cabal | 4 ++++ 3 files changed, 8 insertions(+), 15 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 70908e9555..d5731428e0 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -1,18 +1,3 @@ -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-orphans #-} module U.Codebase.Sqlite.Queries diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index e2f9689b9a..3ffaed340a 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -42,6 +42,7 @@ default-extensions: - DeriveFunctor - DeriveGeneric - DerivingStrategies + - DerivingVia - DoAndIfThenElse - FlexibleContexts - FlexibleInstances @@ -53,10 +54,13 @@ default-extensions: - NamedFieldPuns - OverloadedStrings - PatternSynonyms + - QuasiQuotes - RankNTypes - ScopedTypeVariables + - StandaloneDeriving - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies + - TypeOperators - ViewPatterns diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index e363d8e841..b6f82f8121 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -53,6 +53,7 @@ library DeriveFunctor DeriveGeneric DerivingStrategies + DerivingVia DoAndIfThenElse FlexibleContexts FlexibleInstances @@ -64,12 +65,15 @@ library NamedFieldPuns OverloadedStrings PatternSynonyms + QuasiQuotes RankNTypes ScopedTypeVariables + StandaloneDeriving TupleSections TypeApplications TypeFamilies TypeFamilyDependencies + TypeOperators ViewPatterns build-depends: Only From e0c851d10bc69019d34c2a0dcb6a4cf07f335eb5 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 31 Mar 2022 14:41:42 -0400 Subject: [PATCH 041/529] Use a faster copy function in `arrayToChunk` --- parser-typechecker/src/Unison/Util/Bytes.hs | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/Util/Bytes.hs b/parser-typechecker/src/Unison/Util/Bytes.hs index c2db34d8f4..c13e835183 100644 --- a/parser-typechecker/src/Unison/Util/Bytes.hs +++ b/parser-typechecker/src/Unison/Util/Bytes.hs @@ -55,6 +55,7 @@ module Unison.Util.Bytes ) where +import Basement.Block.Mutable (Block (Block)) import qualified Codec.Compression.GZip as GZip import qualified Codec.Compression.Zlib as Zlib import Control.DeepSeq (NFData (..)) @@ -65,7 +66,10 @@ import qualified Data.ByteArray.Encoding as BE import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as LB import Data.Char -import Data.Primitive.ByteArray (copyByteArrayToPtr) +import Data.Primitive.ByteArray + ( ByteArray (ByteArray), + copyByteArrayToPtr, + ) import Data.Primitive.Ptr (copyPtrToMutableByteArray) import qualified Data.Text as Text import qualified Data.Vector.Primitive as V @@ -348,7 +352,11 @@ chunkToArray bs = BA.allocAndFreeze (V.length bs) $ \ptr -> arrayFromChunk = chunkToArray arrayToChunk, chunkFromArray :: BA.ByteArrayAccess b => b -> Chunk -arrayToChunk bs = V.generate (BA.length bs) (BA.index bs) +arrayToChunk bs = case BA.convert bs :: Block Word8 of + Block bs -> V.Vector 0 n (ByteArray bs) + where + n = BA.length bs +{-# INLINE arrayToChunk #-} chunkFromArray = arrayToChunk fromBase16 :: Bytes -> Either Text.Text Bytes From 81b5f81403ee161b07eee57d860d9ac93de9e7ca Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 31 Mar 2022 16:24:33 -0400 Subject: [PATCH 042/529] rename a bunch of database things for consistency --- .../U/Codebase/Sqlite/Operations.hs | 249 ++++++--------- .../U/Codebase/Sqlite/Queries.hs | 297 ++++++++++-------- .../U/Codebase/Sqlite/Sync22.hs | 14 +- .../src/Unison/Codebase/SqliteCodebase.hs | 18 +- .../Migrations/MigrateSchema1To2.hs | 20 +- .../Migrations/MigrateSchema1To2/DbHelpers.hs | 19 +- 6 files changed, 294 insertions(+), 323 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index e048808ede..c2d2a923b4 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -1,21 +1,9 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ViewPatterns #-} - module U.Codebase.Sqlite.Operations ( -- * branches saveRootBranch, - loadMaybeRootCausalHash, loadRootCausalHash, - loadRootCausal, + expectRootCausalHash, + expectRootCausal, saveBranch, loadCausalBranchByCausalHash, @@ -36,16 +24,11 @@ module U.Codebase.Sqlite.Operations -- * patches savePatch, - loadPatchById, + expectPatch, -- * test for stuff in codebase objectExistsForHash, - -- * dubiously exported stuff involving database ids - loadHashByObjectId, - primaryHashToMaybeObjectId, - primaryHashToMaybePatchObjectId, - -- * watch expression cache saveWatch, loadWatch, @@ -77,8 +60,8 @@ module U.Codebase.Sqlite.Operations termsMentioningType, -- * low-level stuff - loadDbBranchByObjectId, - loadDbPatchById, + expectDbBranch, + expectDbPatch, saveBranchObject, saveDbPatch, @@ -239,59 +222,25 @@ getFromBytesOr e get bs = case runGetS get bs of -- * Database lookups -loadTextById :: DB m => Db.TextId -> m Text -loadTextById = Q.loadTextById - --- | look up an existing object by its primary hash -primaryHashToExistingObjectId :: DB m => H.Hash -> m Db.ObjectId -primaryHashToExistingObjectId h = do - hashId <- Q.expectHashIdByHash h - Q.expectObjectIdForPrimaryHashId hashId - -primaryHashToMaybeObjectId :: DB m => H.Hash -> m (Maybe Db.ObjectId) -primaryHashToMaybeObjectId h = do - Q.loadHashIdByHash h >>= \case - Just hashId -> Q.maybeObjectIdForPrimaryHashId hashId - Nothing -> pure Nothing - -anyHashToMaybeObjectId :: DB m => H.Hash -> m (Maybe Db.ObjectId) -anyHashToMaybeObjectId h = do - (Q.loadHashId . H.toBase32Hex) h >>= \case - Just hashId -> Q.maybeObjectIdForAnyHashId hashId - Nothing -> pure Nothing - -primaryHashToMaybePatchObjectId :: DB m => PatchHash -> m (Maybe Db.PatchObjectId) -primaryHashToMaybePatchObjectId = - (fmap . fmap) Db.PatchObjectId . primaryHashToMaybeObjectId . unPatchHash - objectExistsForHash :: DB m => H.Hash -> m Bool objectExistsForHash h = isJust <$> runMaybeT do id <- MaybeT . Q.loadHashId . H.toBase32Hex $ h - MaybeT $ Q.maybeObjectIdForAnyHashId id - -loadHashByObjectId :: DB m => Db.ObjectId -> m H.Hash -loadHashByObjectId = fmap H.fromBase32Hex . Q.loadPrimaryHashByObjectId + MaybeT $ Q.loadObjectIdForAnyHashId id -loadHashByHashId :: DB m => Db.HashId -> m H.Hash -loadHashByHashId = fmap H.fromBase32Hex . Q.loadHashById - -loadCausalHashById :: DB m => Db.CausalHashId -> m CausalHash -loadCausalHashById = fmap (CausalHash . H.fromBase32Hex) . Q.loadHashById . Db.unCausalHashId - -loadValueHashByCausalHashId :: DB m => Db.CausalHashId -> m BranchHash -loadValueHashByCausalHashId = loadValueHashById <=< Q.loadCausalValueHashId +expectValueHashByCausalHashId :: DB m => Db.CausalHashId -> m BranchHash +expectValueHashByCausalHashId = loadValueHashById <=< Q.expectCausalValueHashId where loadValueHashById :: DB m => Db.BranchHashId -> m BranchHash - loadValueHashById = fmap (BranchHash . H.fromBase32Hex) . Q.loadHashById . Db.unBranchHashId + loadValueHashById = fmap BranchHash . Q.expectHash . Db.unBranchHashId -loadRootCausalHash :: DB m => m CausalHash -loadRootCausalHash = loadCausalHashById =<< Q.loadNamespaceRoot +expectRootCausalHash :: DB m => m CausalHash +expectRootCausalHash = Q.expectCausalHash =<< Q.expectNamespaceRoot -loadMaybeRootCausalHash :: DB m => m (Maybe CausalHash) -loadMaybeRootCausalHash = +loadRootCausalHash :: DB m => m (Maybe CausalHash) +loadRootCausalHash = runMaybeT $ - loadCausalHashById =<< MaybeT Q.loadMaybeNamespaceRoot + Q.expectCausalHash =<< MaybeT Q.loadNamespaceRoot -- * Reference transformations @@ -301,37 +250,37 @@ loadMaybeRootCausalHash = -- (by virtue of dependencies being stored before dependents), but does -- not assume a builtin reference would. c2sReference :: DB m => C.Reference -> m S.Reference -c2sReference = bitraverse Q.saveText primaryHashToExistingObjectId +c2sReference = bitraverse Q.saveText Q.expectObjectIdForPrimaryHash s2cReference :: DB m => S.Reference -> m C.Reference -s2cReference = bitraverse loadTextById loadHashByObjectId +s2cReference = bitraverse Q.expectText Q.expectPrimaryHashByObjectId c2sReferenceId :: DB m => C.Reference.Id -> m S.Reference.Id -c2sReferenceId = C.Reference.idH primaryHashToExistingObjectId +c2sReferenceId = C.Reference.idH Q.expectObjectIdForPrimaryHash s2cReferenceId :: DB m => S.Reference.Id -> m C.Reference.Id -s2cReferenceId = C.Reference.idH loadHashByObjectId +s2cReferenceId = C.Reference.idH Q.expectPrimaryHashByObjectId h2cReferenceId :: DB m => S.Reference.IdH -> m C.Reference.Id -h2cReferenceId = C.Reference.idH loadHashByHashId +h2cReferenceId = C.Reference.idH Q.expectHash h2cReference :: DB m => S.ReferenceH -> m C.Reference -h2cReference = bitraverse loadTextById loadHashByHashId +h2cReference = bitraverse Q.expectText Q.expectHash c2hReference :: DB m => C.Reference -> MaybeT m S.ReferenceH -c2hReference = bitraverse (MaybeT . Q.loadText) (MaybeT . Q.loadHashIdByHash) +c2hReference = bitraverse (MaybeT . Q.loadTextId) (MaybeT . Q.loadHashIdByHash) s2cReferent :: DB m => S.Referent -> m C.Referent s2cReferent = bitraverse s2cReference s2cReference s2cReferentId :: DB m => S.Referent.Id -> m C.Referent.Id -s2cReferentId = bitraverse loadHashByObjectId loadHashByObjectId +s2cReferentId = bitraverse Q.expectPrimaryHashByObjectId Q.expectPrimaryHashByObjectId c2sReferent :: DB m => C.Referent -> m S.Referent c2sReferent = bitraverse c2sReference c2sReference c2sReferentId :: DB m => C.Referent.Id -> m S.Referent.Id -c2sReferentId = bitraverse primaryHashToExistingObjectId primaryHashToExistingObjectId +c2sReferentId = bitraverse Q.expectObjectIdForPrimaryHash Q.expectObjectIdForPrimaryHash h2cReferent :: DB m => S.ReferentH -> m C.Referent h2cReferent = bitraverse h2cReference h2cReference @@ -431,13 +380,13 @@ getCycleLen h = do when debug $ traceM $ "\ngetCycleLen " ++ (Text.unpack . Base32Hex.toText $ H.toBase32Hex h) runMaybeT do -- actually want Nothing in case of non term/decl component hash - oid <- MaybeT (anyHashToMaybeObjectId h) + oid <- MaybeT (Q.loadObjectIdForAnyHash h) -- todo: decodeComponentLengthOnly is unintentionally a hack that relies on -- the fact the two things that references can refer to (term and decl -- components) have the same basic serialized structure: first a format -- byte that is always 0 for now, followed by a framed array representing -- the strongly-connected component. :grimace: - Q.loadObjectById oid decodeComponentLengthOnly + Q.expectObject oid decodeComponentLengthOnly -- | Get the 'C.DeclType.DeclType' of a 'C.Reference.Id'. -- TODO rename to expectDeclTypeById @@ -448,7 +397,7 @@ getDeclTypeById = componentByObjectId :: DB m => Db.ObjectId -> m [S.Reference.Id] componentByObjectId id = do when debug . traceM $ "Operations.componentByObjectId " ++ show id - len <- Q.loadObjectById id decodeComponentLengthOnly + len <- Q.expectObject id decodeComponentLengthOnly pure [C.Reference.Id id i | i <- [0 .. len - 1]] -- * Codebase operations @@ -457,8 +406,8 @@ componentByObjectId id = do loadTermComponent :: DB m => H.Hash -> MaybeT m [(C.Term Symbol, C.Term.Type Symbol)] loadTermComponent h = do - oid <- MaybeT (anyHashToMaybeObjectId h) - S.Term.Term (S.Term.LocallyIndexedComponent elements) <- MaybeT (Q.loadTermObjectById oid decodeTermFormat) + oid <- MaybeT (Q.loadObjectIdForAnyHash h) + S.Term.Term (S.Term.LocallyIndexedComponent elements) <- MaybeT (Q.loadTermObject oid decodeTermFormat) lift . traverse (uncurry3 s2cTermWithType) $ Foldable.toList elements saveTermComponent :: DB m => H.Hash -> [(C.Term Symbol, C.Term.Type Symbol)] -> m Db.ObjectId @@ -612,40 +561,40 @@ c2xTerm saveText saveDefn tm tp = loadTermWithTypeByReference :: DB m => C.Reference.Id -> MaybeT m (C.Term Symbol, C.Term.Type Symbol) loadTermWithTypeByReference (C.Reference.Id h i) = do - oid <- MaybeT (primaryHashToMaybeObjectId h) + oid <- MaybeT (Q.loadObjectIdForPrimaryHash h) -- retrieve and deserialize the blob - (localIds, term, typ) <- MaybeT (Q.loadTermObjectById oid (decodeTermElementWithType i)) + (localIds, term, typ) <- MaybeT (Q.loadTermObject oid (decodeTermElementWithType i)) s2cTermWithType localIds term typ loadTermByReference :: DB m => C.Reference.Id -> MaybeT m (C.Term Symbol) loadTermByReference r@(C.Reference.Id h i) = do when debug . traceM $ "loadTermByReference " ++ show r - oid <- MaybeT (primaryHashToMaybeObjectId h) + oid <- MaybeT (Q.loadObjectIdForPrimaryHash h) -- retrieve and deserialize the blob - (localIds, term) <- MaybeT (Q.loadTermObjectById oid (decodeTermElementDiscardingType i)) + (localIds, term) <- MaybeT (Q.loadTermObject oid (decodeTermElementDiscardingType i)) s2cTerm localIds term loadTypeOfTermByTermReference :: DB m => C.Reference.Id -> MaybeT m (C.Term.Type Symbol) loadTypeOfTermByTermReference id@(C.Reference.Id h i) = do when debug . traceM $ "loadTypeOfTermByTermReference " ++ show id - oid <- MaybeT (primaryHashToMaybeObjectId h) + oid <- MaybeT (Q.loadObjectIdForPrimaryHash h) -- retrieve and deserialize the blob - (localIds, typ) <- MaybeT (Q.loadTermObjectById oid (decodeTermElementDiscardingTerm i)) + (localIds, typ) <- MaybeT (Q.loadTermObject oid (decodeTermElementDiscardingTerm i)) s2cTypeOfTerm localIds typ s2cTermWithType :: DB m => LocalIds -> S.Term.Term -> S.Term.Type -> m (C.Term Symbol, C.Term.Type Symbol) s2cTermWithType ids tm tp = do - (substText, substHash) <- localIdsToLookups loadTextById loadHashByObjectId ids + (substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids pure (x2cTerm substText substHash tm, x2cTType substText substHash tp) s2cTerm :: DB m => LocalIds -> S.Term.Term -> m (C.Term Symbol) s2cTerm ids tm = do - (substText, substHash) <- localIdsToLookups loadTextById loadHashByObjectId ids + (substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids pure $ x2cTerm substText substHash tm s2cTypeOfTerm :: DB m => LocalIds -> S.Term.Type -> m (C.Term.Type Symbol) s2cTypeOfTerm ids tp = do - (substText, substHash) <- localIdsToLookups loadTextById loadHashByObjectId ids + (substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids pure $ x2cTType substText substHash tp -- | implementation detail of {s,w}2c*Term* & s2cDecl @@ -659,7 +608,7 @@ localIdsToLookups loadText loadHash localIds = do localIdsToTypeRefLookup :: DB m => LocalIds -> m (S.Decl.TypeRef -> C.Decl.TypeRef) localIdsToTypeRefLookup localIds = do - (substText, substHash) <- localIdsToLookups loadTextById loadHashByObjectId localIds + (substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId localIds pure $ bimap substText (fmap substHash) -- | implementation detail of {s,w}2c*Term* @@ -721,7 +670,7 @@ lookup_ stateLens writerLens mk t = do Just t' -> pure t' c2sTerm :: DB m => C.Term Symbol -> C.Term.Type Symbol -> m (LocalIds, S.Term.Term, S.Term.Type) -c2sTerm tm tp = c2xTerm Q.saveText primaryHashToExistingObjectId tm (Just tp) <&> \(w, tm, Just tp) -> (w, tm, tp) +c2sTerm tm tp = c2xTerm Q.saveText Q.expectObjectIdForPrimaryHash tm (Just tp) <&> \(w, tm, Just tp) -> (w, tm, tp) -- *** Watch expressions @@ -750,21 +699,21 @@ c2wTerm tm = c2xTerm Q.saveText Q.saveHashHash tm Nothing <&> \(w, tm, _) -> (w, w2cTerm :: DB m => WatchLocalIds -> S.Term.Term -> m (C.Term Symbol) w2cTerm ids tm = do - (substText, substHash) <- localIdsToLookups loadTextById loadHashByHashId ids + (substText, substHash) <- localIdsToLookups Q.expectText Q.expectHash ids pure $ x2cTerm substText substHash tm -- ** Saving & loading type decls loadDeclComponent :: DB m => H.Hash -> MaybeT m [C.Decl Symbol] loadDeclComponent h = do - oid <- MaybeT (anyHashToMaybeObjectId h) - S.Decl.Decl (S.Decl.LocallyIndexedComponent elements) <- MaybeT (Q.loadDeclObjectById oid decodeDeclFormat) + oid <- MaybeT (Q.loadObjectIdForAnyHash h) + S.Decl.Decl (S.Decl.LocallyIndexedComponent elements) <- MaybeT (Q.loadDeclObject oid decodeDeclFormat) lift . traverse (uncurry s2cDecl) $ Foldable.toList elements saveDeclComponent :: DB m => H.Hash -> [C.Decl Symbol] -> m Db.ObjectId saveDeclComponent h decls = do when debug . traceM $ "Operations.saveDeclComponent " ++ show h - sDeclElements <- traverse (c2sDecl Q.saveText primaryHashToExistingObjectId) decls + sDeclElements <- traverse (c2sDecl Q.saveText Q.expectObjectIdForPrimaryHash) decls hashId <- Q.saveHashHash h let li = S.Decl.LocallyIndexedComponent $ Vector.fromList sDeclElements bytes = S.putBytes S.putDeclFormat $ S.Decl.Decl li @@ -824,17 +773,16 @@ s2cDecl ids (C.Decl.DataDeclaration dt m b ct) = do loadDeclByReference :: DB m => C.Reference.Id -> MaybeT m (C.Decl Symbol) loadDeclByReference r@(C.Reference.Id h i) = do when debug . traceM $ "loadDeclByReference " ++ show r - oid <- MaybeT (primaryHashToMaybeObjectId h) - (localIds, decl) <- MaybeT (Q.loadDeclObjectById oid (decodeDeclElement i)) + oid <- MaybeT (Q.loadObjectIdForPrimaryHash h) + (localIds, decl) <- MaybeT (Q.loadDeclObject oid (decodeDeclElement i)) s2cDecl localIds decl --- TODO rename expectDeclById expectDeclByReference :: DB m => C.Reference.Id -> m (C.Decl Symbol) expectDeclByReference r@(C.Reference.Id h i) = do when debug . traceM $ "expectDeclByReference " ++ show r -- retrieve the blob - primaryHashToExistingObjectId h - >>= (\oid -> Q.expectDeclObjectById oid (decodeDeclElement i)) + Q.expectObjectIdForPrimaryHash h + >>= (\oid -> Q.expectDeclObject oid (decodeDeclElement i)) >>= uncurry s2cDecl -- * Branch transformation @@ -850,7 +798,7 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = loadMetadataType :: DB m => S.Reference -> m C.Reference loadMetadataType = \case C.ReferenceBuiltin tId -> - Q.loadTextByIdCheck (Left . NeedTypeForBuiltinMetadata) tId + Q.expectTextCheck tId (Left . NeedTypeForBuiltinMetadata) C.ReferenceDerived id -> typeReferenceForTerm id >>= h2cReference @@ -858,7 +806,7 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = doTerms :: DB m => Map Db.TextId (Map S.Referent S.DbMetadataSet) -> m (Map C.Branch.NameSegment (Map C.Referent (m C.Branch.MdValues))) doTerms = Map.bitraverse - (fmap C.Branch.NameSegment . loadTextById) + (fmap C.Branch.NameSegment . Q.expectText) ( Map.bitraverse s2cReferent \case S.MetadataSet.Inline rs -> pure $ C.Branch.MdValues <$> loadTypesForMetadata rs @@ -866,22 +814,22 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = doTypes :: DB m => Map Db.TextId (Map S.Reference S.DbMetadataSet) -> m (Map C.Branch.NameSegment (Map C.Reference (m C.Branch.MdValues))) doTypes = Map.bitraverse - (fmap C.Branch.NameSegment . loadTextById) + (fmap C.Branch.NameSegment . Q.expectText) ( Map.bitraverse s2cReference \case S.MetadataSet.Inline rs -> pure $ C.Branch.MdValues <$> loadTypesForMetadata rs ) doPatches :: DB m => Map Db.TextId Db.PatchObjectId -> m (Map C.Branch.NameSegment (PatchHash, m C.Branch.Patch)) - doPatches = Map.bitraverse (fmap C.Branch.NameSegment . loadTextById) \patchId -> do - h <- PatchHash <$> (loadHashByObjectId . Db.unPatchObjectId) patchId - pure (h, loadPatchById patchId) + doPatches = Map.bitraverse (fmap C.Branch.NameSegment . Q.expectText) \patchId -> do + h <- PatchHash <$> (Q.expectPrimaryHashByObjectId . Db.unPatchObjectId) patchId + pure (h, expectPatch patchId) doChildren :: DB m => Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) -> m (Map C.Branch.NameSegment (C.Causal m CausalHash BranchHash (C.Branch.Branch m))) - doChildren = Map.bitraverse (fmap C.Branch.NameSegment . loadTextById) \(boId, chId) -> - C.Causal <$> loadCausalHashById chId - <*> loadValueHashByCausalHashId chId + doChildren = Map.bitraverse (fmap C.Branch.NameSegment . Q.expectText) \(boId, chId) -> + C.Causal <$> Q.expectCausalHash chId + <*> expectValueHashByCausalHashId chId <*> headParents chId - <*> pure (loadBranchByObjectId boId) + <*> pure (expectBranch boId) where headParents :: DB m => Db.CausalHashId -> m (Map CausalHash (m (C.Causal m CausalHash BranchHash (C.Branch.Branch m)))) headParents chId = do @@ -889,18 +837,18 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = fmap Map.fromList $ traverse pairParent parentsChIds pairParent :: DB m => Db.CausalHashId -> m (CausalHash, m (C.Causal m CausalHash BranchHash (C.Branch.Branch m))) pairParent chId = do - h <- loadCausalHashById chId + h <- Q.expectCausalHash chId pure (h, loadCausal chId) loadCausal :: DB m => Db.CausalHashId -> m (C.Causal m CausalHash BranchHash (C.Branch.Branch m)) loadCausal chId = do - C.Causal <$> loadCausalHashById chId - <*> loadValueHashByCausalHashId chId + C.Causal <$> Q.expectCausalHash chId + <*> expectValueHashByCausalHashId chId <*> headParents chId <*> pure (loadValue chId) loadValue :: DB m => Db.CausalHashId -> m (C.Branch.Branch m) loadValue chId = do boId <- Q.expectBranchObjectIdByCausalHashId chId - loadBranchByObjectId boId + expectBranch boId saveRootBranch :: DB m => C.Branch.Causal m -> m (Db.BranchObjectId, Db.CausalHashId) saveRootBranch c = do @@ -993,7 +941,7 @@ saveBranch (C.Causal hc he parents me) = do savePatchObjectId :: DB m => (PatchHash, m C.Branch.Patch) -> m Db.PatchObjectId savePatchObjectId (h, mp) = do - primaryHashToMaybePatchObjectId h >>= \case + Q.loadPatchObjectIdForPrimaryHash h >>= \case Just patchOID -> pure patchOID Nothing -> do patch <- mp @@ -1006,33 +954,32 @@ saveBranchObject id@(Db.unBranchHashId -> hashId) li lBranch = do oId <- Q.saveObject hashId OT.Namespace bytes pure $ Db.BranchObjectId oId -loadRootCausal :: DB m => m (C.Branch.Causal m) -loadRootCausal = Q.loadNamespaceRoot >>= loadCausalByCausalHashId +expectRootCausal :: DB m => m (C.Branch.Causal m) +expectRootCausal = Q.expectNamespaceRoot >>= expectCausalByCausalHashId loadCausalBranchByCausalHash :: DB m => CausalHash -> m (Maybe (C.Branch.Causal m)) loadCausalBranchByCausalHash hc = do Q.loadCausalHashIdByCausalHash hc >>= \case - Just chId -> Just <$> loadCausalByCausalHashId chId + Just chId -> Just <$> expectCausalByCausalHashId chId Nothing -> pure Nothing -loadCausalByCausalHashId :: DB m => Db.CausalHashId -> m (C.Branch.Causal m) -loadCausalByCausalHashId id = do - hc <- loadCausalHashById id - hb <- loadValueHashByCausalHashId id +expectCausalByCausalHashId :: DB m => Db.CausalHashId -> m (C.Branch.Causal m) +expectCausalByCausalHashId id = do + hc <- Q.expectCausalHash id + hb <- expectValueHashByCausalHashId id parentHashIds <- Q.loadCausalParents id loadParents <- for parentHashIds \hId -> do - h <- loadCausalHashById hId - pure (h, loadCausalByCausalHashId hId) - pure $ C.Causal hc hb (Map.fromList loadParents) (loadBranchByCausalHashId id) + h <- Q.expectCausalHash hId + pure (h, expectCausalByCausalHashId hId) + pure $ C.Causal hc hb (Map.fromList loadParents) (expectBranchByCausalHashId id) --- TODO rename expect -loadBranchByCausalHashId :: DB m => Db.CausalHashId -> m (C.Branch.Branch m) -loadBranchByCausalHashId id = do +expectBranchByCausalHashId :: DB m => Db.CausalHashId -> m (C.Branch.Branch m) +expectBranchByCausalHashId id = do boId <- Q.expectBranchObjectIdByCausalHashId id - loadBranchByObjectId boId + expectBranch boId -loadDbBranchByObjectId :: DB m => Db.BranchObjectId -> m S.DbBranch -loadDbBranchByObjectId id = +expectDbBranch :: DB m => Db.BranchObjectId -> m S.DbBranch +expectDbBranch id = deserializeBranchObject id >>= \case S.BranchFormat.Full li f -> pure (S.BranchFormat.localToDbBranch li f) S.BranchFormat.Diff r li d -> doDiff r [S.BranchFormat.localToDbDiff li d] @@ -1040,7 +987,7 @@ loadDbBranchByObjectId id = deserializeBranchObject :: DB m => Db.BranchObjectId -> m S.BranchFormat deserializeBranchObject id = do when debug $ traceM $ "deserializeBranchObject " ++ show id - Q.expectNamespaceObjectById (Db.unBranchObjectId id) (getFromBytesOr (ErrBranch id) S.getBranchFormat) + Q.expectNamespaceObject (Db.unBranchObjectId id) (getFromBytesOr (ErrBranch id) S.getBranchFormat) doDiff :: DB m => Db.BranchObjectId -> [S.Branch.Diff] -> m S.DbBranch doDiff ref ds = @@ -1137,18 +1084,18 @@ loadDbBranchByObjectId id = let (Set.fromList -> adds, Set.fromList -> removes) = S.BranchDiff.addsRemoves md' in Just . S.MetadataSet.Inline $ (Set.union adds $ Set.difference md removes) -loadBranchByObjectId :: DB m => Db.BranchObjectId -> m (C.Branch.Branch m) -loadBranchByObjectId id = - loadDbBranchByObjectId id >>= s2cBranch +expectBranch :: DB m => Db.BranchObjectId -> m (C.Branch.Branch m) +expectBranch id = + expectDbBranch id >>= s2cBranch -- * Patch transformation -loadPatchById :: DB m => Db.PatchObjectId -> m C.Branch.Patch -loadPatchById patchId = - loadDbPatchById patchId >>= s2cPatch +expectPatch :: DB m => Db.PatchObjectId -> m C.Branch.Patch +expectPatch patchId = + expectDbPatch patchId >>= s2cPatch -loadDbPatchById :: DB m => Db.PatchObjectId -> m S.Patch -loadDbPatchById patchId = +expectDbPatch :: DB m => Db.PatchObjectId -> m S.Patch +expectDbPatch patchId = deserializePatchObject patchId >>= \case S.Patch.Format.Full li p -> pure (S.Patch.Format.localPatchToPatch li p) S.Patch.Format.Diff ref li d -> doDiff ref [S.Patch.Format.localPatchDiffToPatchDiff li d] @@ -1179,14 +1126,14 @@ s2cPatch (S.Patch termEdits typeEdits) = deserializePatchObject :: DB m => Db.PatchObjectId -> m S.PatchFormat deserializePatchObject id = do when debug $ traceM $ "Operations.deserializePatchObject " ++ show id - Q.expectPatchObjectById (Db.unPatchObjectId id) (getFromBytesOr (ErrPatch id) S.getPatchFormat) + Q.expectPatchObject (Db.unPatchObjectId id) (getFromBytesOr (ErrPatch id) S.getPatchFormat) lca :: DB m => CausalHash -> CausalHash -> Connection -> Connection -> m (Maybe CausalHash) lca h1 h2 c1 c2 = runMaybeT do chId1 <- MaybeT $ Q.loadCausalHashIdByCausalHash h1 chId2 <- MaybeT $ Q.loadCausalHashIdByCausalHash h2 chId3 <- MaybeT . liftIO $ Q.lca chId1 chId2 c1 c2 - Q.loadCausalHash chId3 + Q.expectCausalHash chId3 before :: DB m => CausalHash -> CausalHash -> m (Maybe Bool) before h1 h2 = runMaybeT do @@ -1243,12 +1190,12 @@ componentReferencesByPrefix ot b32prefix pos = do termReferencesByPrefix :: DB m => Text -> Maybe Word64 -> m [C.Reference.Id] termReferencesByPrefix t w = componentReferencesByPrefix OT.TermComponent t w - >>= traverse (C.Reference.idH loadHashByObjectId) + >>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId) declReferencesByPrefix :: DB m => Text -> Maybe Word64 -> m [C.Reference.Id] declReferencesByPrefix t w = componentReferencesByPrefix OT.DeclComponent t w - >>= traverse (C.Reference.idH loadHashByObjectId) + >>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId) termReferentsByPrefix :: DB m => Text -> Maybe Word64 -> m [C.Referent.Id] termReferentsByPrefix b32prefix pos = @@ -1269,7 +1216,7 @@ declReferentsByPrefix b32prefix pos cid = do loadConstructors :: DB m => Maybe Word64 -> S.Reference.Id -> m (H.Hash, C.Reference.Pos, C.DeclType, [ConstructorId]) loadConstructors cid rid@(C.Reference.Id oId pos) = do (dt, ctorCount) <- getDeclCtorCount rid - h <- loadHashByObjectId oId + h <- Q.expectPrimaryHashByObjectId oId let test :: ConstructorId -> Bool test = maybe (const True) (==) cid cids = [cid | cid <- [0 :: ConstructorId .. ctorCount - 1], test cid] @@ -1277,20 +1224,20 @@ declReferentsByPrefix b32prefix pos cid = do getDeclCtorCount :: DB m => S.Reference.Id -> m (C.Decl.DeclType, ConstructorId) getDeclCtorCount id@(C.Reference.Id r i) = do when debug $ traceM $ "getDeclCtorCount " ++ show id - (_localIds, decl) <- Q.expectDeclObjectById r (decodeDeclElement i) + (_localIds, decl) <- Q.expectDeclObject r (decodeDeclElement i) pure (C.Decl.declType decl, fromIntegral $ length (C.Decl.constructorTypes decl)) branchHashesByPrefix :: DB m => ShortBranchHash -> m (Set BranchHash) branchHashesByPrefix (ShortBranchHash b32prefix) = do hashIds <- Q.namespaceHashIdByBase32Prefix b32prefix - b32s <- traverse (Q.loadHashById . Db.unBranchHashId) hashIds - pure $ Set.fromList . fmap BranchHash . fmap H.fromBase32Hex $ b32s + hashes <- traverse (Q.expectHash . Db.unBranchHashId) hashIds + pure $ Set.fromList . map BranchHash $ hashes causalHashesByPrefix :: DB m => ShortBranchHash -> m (Set CausalHash) causalHashesByPrefix (ShortBranchHash b32prefix) = do hashIds <- Q.causalHashIdByBase32Prefix b32prefix - b32s <- traverse (Q.loadHashById . Db.unCausalHashId) hashIds - pure $ Set.fromList . fmap CausalHash . fmap H.fromBase32Hex $ b32s + hashes <- traverse (Q.expectHash . Db.unCausalHashId) hashIds + pure $ Set.fromList . map CausalHash $ hashes -- | returns a list of known definitions referencing `r` dependents :: DB m => C.Reference -> m (Set C.Reference.Id) @@ -1303,7 +1250,7 @@ dependents r = do -- | returns a list of known definitions referencing `h` dependentsOfComponent :: DB m => H.Hash -> m (Set C.Reference.Id) dependentsOfComponent h = do - oId <- primaryHashToExistingObjectId h + oId <- Q.expectObjectIdForPrimaryHash h sIds :: [S.Reference.Id] <- Q.getDependentsForDependencyComponent oId cIds <- traverse s2cReferenceId sIds pure $ Set.fromList cIds @@ -1315,5 +1262,3 @@ derivedDependencies cid = do sids <- Q.getDependencyIdsForDependent sid cids <- traverse s2cReferenceId sids pure $ Set.fromList cids - --- lca :: (forall he e. [Causal m CausalHash he e] -> m (Maybe BranchHash)), diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index d5731428e0..f0b0594834 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -1,55 +1,64 @@ {-# OPTIONS_GHC -Wno-orphans #-} +-- | Some naming conventions used in this module: +-- +-- * @32@: the base32 representation of a hash +-- * @expect@: retrieve something that's known to exist +-- * @load@: retrieve something that's not known to exist (so the return type is a Maybe, or another container that +-- could be empty) +-- * @save@: idempotent (on conflict do nothing) insert, and return the id of the thing (usually) module U.Codebase.Sqlite.Queries ( -- * text table saveText, - loadText, + loadTextId, + expectTextId, expectText, - loadTextById, - loadTextByIdCheck, + expectTextCheck, -- * hash table saveHash, saveHashHash, loadHashId, - loadHashById, - loadHashHashById, + expectHash, + expectHash32, loadHashIdByHash, expectHashIdByHash, saveCausalHash, - loadCausalHash, + expectCausalHash, saveBranchHash, -- * hash_object table saveHashObject, - hashIdsForObject, + expectHashIdsForObject, hashIdWithVersionForObject, + loadObjectIdForPrimaryHashId, expectObjectIdForPrimaryHashId, + loadObjectIdForPrimaryHash, + expectObjectIdForPrimaryHash, + loadPatchObjectIdForPrimaryHash, + loadObjectIdForAnyHash, + loadObjectIdForAnyHashId, expectObjectIdForAnyHashId, - maybeObjectIdForPrimaryHashId, - maybeObjectIdForAnyHashId, recordObjectRehash, -- * object table saveObject, - loadObjectById, - loadPrimaryHashByObjectId, - loadObjectWithTypeById, - loadObjectWithHashIdAndTypeById, - expectDeclObjectById, - loadDeclObjectById, - expectNamespaceObjectById, - loadNamespaceObjectById, - expectPatchObjectById, - loadPatchObjectById, - loadTermObjectById, - expectTermObjectById, - updateObjectBlob, -- unused + expectObject, + expectPrimaryHashByObjectId, + expectObjectWithHashIdAndType, + expectDeclObject, + loadDeclObject, + expectNamespaceObject, + loadNamespaceObject, + expectPatchObject, + loadPatchObject, + loadTermObject, + expectTermObject, -- * namespace_root table - loadMaybeNamespaceRoot, - setNamespaceRoot, loadNamespaceRoot, + setNamespaceRoot, + expectNamespaceRoot, -- * causals @@ -57,7 +66,7 @@ module U.Codebase.Sqlite.Queries saveCausal, isCausalHash, loadCausalHashIdByCausalHash, - loadCausalValueHashId, + expectCausalValueHashId, loadCausalByCausalHash, loadBranchObjectIdByCausalHashId, expectBranchObjectIdByCausalHashId, @@ -133,7 +142,7 @@ import Data.String (fromString) import Data.String.Here.Uninterpolated (here, hereFile) import Data.Text (Text) import Data.Tuple.Only (Only (..)) -import U.Codebase.HashTags (BranchHash (..), CausalHash (..)) +import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) import U.Codebase.Reference (Reference' (..)) import qualified U.Codebase.Reference as C.Reference import U.Codebase.Sqlite.DbId @@ -143,6 +152,7 @@ import U.Codebase.Sqlite.DbId HashId (..), HashVersion, ObjectId (..), + PatchObjectId (..), SchemaVersion, TextId, ) @@ -230,44 +240,41 @@ loadCausalHashIdByCausalHash ch = runMaybeT do loadCausalByCausalHash :: DB m => CausalHash -> m (Maybe (CausalHashId, BranchHashId)) loadCausalByCausalHash ch = runMaybeT do hId <- MaybeT $ loadHashIdByHash (unCausalHash ch) - bhId <- MaybeT $ loadMaybeCausalValueHashId hId + bhId <- MaybeT $ loadCausalValueHashId hId pure (CausalHashId hId, bhId) expectHashIdByHash :: DB m => Hash -> m HashId expectHashIdByHash = expectHashId . Hash.toBase32Hex --- FIXME rename to expectHashHashById -loadHashHashById :: DB m => HashId -> m Hash -loadHashHashById h = Hash.fromBase32Hex <$> loadHashById h +expectHash :: DB m => HashId -> m Hash +expectHash h = Hash.fromBase32Hex <$> expectHash32 h --- FIXME rename to expectHashById -loadHashById :: DB m => HashId -> m Base32Hex -loadHashById h = queryOneCol sql (Only h) +expectHash32 :: DB m => HashId -> m Base32Hex +expectHash32 h = queryOneCol sql (Only h) where sql = [here|ย SELECT base32 FROM hash WHERE id = ? |] saveText :: DB m => Text -> m TextId -saveText t = execute sql (Only t) >> expectText t +saveText t = execute sql (Only t) >> expectTextId t where sql = [here| INSERT INTO text (text) VALUES (?) ON CONFLICT DO NOTHING|] -loadText :: DB m => Text -> m (Maybe TextId) -loadText t = queryMaybeCol loadTextSql (Only t) +loadTextId :: DB m => Text -> m (Maybe TextId) +loadTextId t = queryMaybeCol loadTextIdSql (Only t) -expectText :: DB m => Text -> m TextId -expectText t = queryOneCol loadTextSql (Only t) +expectTextId :: DB m => Text -> m TextId +expectTextId t = queryOneCol loadTextIdSql (Only t) -loadTextSql :: Sql -loadTextSql = +loadTextIdSql :: Sql +loadTextIdSql = [here| SELECT id FROM text WHERE text = ? |] --- FIXME rename to expectTextById -loadTextById :: DB m => TextId -> m Text -loadTextById h = queryOneCol loadTextByIdSql (Only h) +expectText :: DB m => TextId -> m Text +expectText h = queryOneCol loadTextSql (Only h) -loadTextByIdCheck :: (DB m, SqliteExceptionReason e) => (Text -> Either e a) -> TextId -> m a -loadTextByIdCheck check h = queryOneColCheck loadTextByIdSql (Only h) check +expectTextCheck :: (DB m, SqliteExceptionReason e) => TextId -> (Text -> Either e a) -> m a +expectTextCheck h = queryOneColCheck loadTextSql (Only h) -loadTextByIdSql :: Sql -loadTextByIdSql = +loadTextSql :: Sql +loadTextSql = [here|ย SELECT text FROM text WHERE id = ? |] saveHashObject :: DB m => HashId -> ObjectId -> HashVersion -> m () @@ -290,37 +297,29 @@ saveObject h t blob = do ON CONFLICT DO NOTHING |] --- FIXME rename to expectObjectById -loadObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a -loadObjectById oId check = do +expectObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectObject oId check = do result <- queryOneColCheck sql (Only oId) check pure result where sql = [here| SELECT bytes FROM object WHERE id = ? |] --- FIXME rename to expectObjectWithTypeById -loadObjectWithTypeById :: DB m => ObjectId -> m (ObjectType, ByteString) -loadObjectWithTypeById oId = queryOneRow sql (Only oId) - where sql = [here| - SELECT type_id, bytes FROM object WHERE id = ? - |] - -loadObjectOfTypeById :: +loadObjectOfType :: (DB m, SqliteExceptionReason e) => ObjectId -> ObjectType -> (ByteString -> Either e a) -> m (Maybe a) -loadObjectOfTypeById oid ty = - queryMaybeColCheck loadObjectOfTypeByIdSql (oid, ty) +loadObjectOfType oid ty = + queryMaybeColCheck loadObjectOfTypeSql (oid, ty) -expectObjectOfTypeById :: (DB m, SqliteExceptionReason e) => ObjectId -> ObjectType -> (ByteString -> Either e a) -> m a -expectObjectOfTypeById oid ty = - queryOneColCheck loadObjectOfTypeByIdSql (oid, ty) +expectObjectOfType :: (DB m, SqliteExceptionReason e) => ObjectId -> ObjectType -> (ByteString -> Either e a) -> m a +expectObjectOfType oid ty = + queryOneColCheck loadObjectOfTypeSql (oid, ty) -loadObjectOfTypeByIdSql :: Sql -loadObjectOfTypeByIdSql = +loadObjectOfTypeSql :: Sql +loadObjectOfTypeSql = [here| SELECT bytes FROM object @@ -329,86 +328,117 @@ loadObjectOfTypeByIdSql = |] -- | Load a decl component object. -loadDeclObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) -loadDeclObjectById oid = - loadObjectOfTypeById oid DeclComponent +loadDeclObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) +loadDeclObject oid = + loadObjectOfType oid DeclComponent -- | Expect a decl component object. -expectDeclObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a -expectDeclObjectById oid = - expectObjectOfTypeById oid DeclComponent +expectDeclObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectDeclObject oid = + expectObjectOfType oid DeclComponent -- | Load a namespace object. -loadNamespaceObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) -loadNamespaceObjectById oid = - loadObjectOfTypeById oid Namespace +loadNamespaceObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) +loadNamespaceObject oid = + loadObjectOfType oid Namespace -- | Expect a namespace object. -expectNamespaceObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a -expectNamespaceObjectById oid = - expectObjectOfTypeById oid Namespace +expectNamespaceObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectNamespaceObject oid = + expectObjectOfType oid Namespace -- | Load a patch object. -loadPatchObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) -loadPatchObjectById oid = - loadObjectOfTypeById oid Patch +loadPatchObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) +loadPatchObject oid = + loadObjectOfType oid Patch -- | Expect a patch object. -expectPatchObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a -expectPatchObjectById oid = - expectObjectOfTypeById oid Patch +expectPatchObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectPatchObject oid = + expectObjectOfType oid Patch -- | Load a term component object. -loadTermObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) -loadTermObjectById oid = - loadObjectOfTypeById oid TermComponent +loadTermObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) +loadTermObject oid = + loadObjectOfType oid TermComponent -- | Expect a term component object. -expectTermObjectById :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a -expectTermObjectById oid = - expectObjectOfTypeById oid TermComponent +expectTermObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectTermObject oid = + expectObjectOfType oid TermComponent --- | FIXME rename to expectObjectWithHashIdAndTypeById -loadObjectWithHashIdAndTypeById :: DB m => ObjectId -> m (HashId, ObjectType, ByteString) -loadObjectWithHashIdAndTypeById oId = queryOneRow sql (Only oId) +expectObjectWithHashIdAndType :: DB m => ObjectId -> m (HashId, ObjectType, ByteString) +expectObjectWithHashIdAndType oId = queryOneRow sql (Only oId) where sql = [here| SELECT primary_hash_id, type_id, bytes FROM object WHERE id = ? |] --- |Not all hashes have corresponding objects; e.g., hashes of term types +loadObjectIdForPrimaryHashId :: DB m => HashId -> m (Maybe ObjectId) +loadObjectIdForPrimaryHashId h = + queryMaybeCol loadObjectIdForPrimaryHashIdSql (Only h) + +-- | Not all hashes have corresponding objects; e.g., hashes of term types expectObjectIdForPrimaryHashId :: DB m => HashId -> m ObjectId expectObjectIdForPrimaryHashId h = - queryOneCol maybeObjectIdForPrimaryHashIdSql (Only h) + queryOneCol loadObjectIdForPrimaryHashIdSql (Only h) + +loadObjectIdForPrimaryHashIdSql :: Sql +loadObjectIdForPrimaryHashIdSql = + [here| + SELECT id + FROM object + WHERE primary_hash_id = ? + |] + +loadObjectIdForPrimaryHash :: DB m => Hash -> m (Maybe ObjectId) +loadObjectIdForPrimaryHash h = + loadHashIdByHash h >>= \case + Nothing -> pure Nothing + Just hashId -> loadObjectIdForPrimaryHashId hashId + +expectObjectIdForPrimaryHash :: DB m => Hash -> m ObjectId +expectObjectIdForPrimaryHash h = do + hashId <- expectHashIdByHash h + expectObjectIdForPrimaryHashId hashId -maybeObjectIdForPrimaryHashId :: DB m => HashId -> m (Maybe ObjectId) -maybeObjectIdForPrimaryHashId h = queryMaybeCol maybeObjectIdForPrimaryHashIdSql (Only h) +-- FIXME this doesn't check that the object is actually a patch +loadPatchObjectIdForPrimaryHash :: DB m => PatchHash -> m (Maybe PatchObjectId) +loadPatchObjectIdForPrimaryHash = + (fmap . fmap) PatchObjectId . loadObjectIdForPrimaryHash . unPatchHash -maybeObjectIdForPrimaryHashIdSql :: Sql -maybeObjectIdForPrimaryHashIdSql = - [here| SELECT id FROM object WHERE primary_hash_id = ? |] +loadObjectIdForAnyHash :: DB m => Hash -> m (Maybe ObjectId) +loadObjectIdForAnyHash h = + loadHashIdByHash h >>= \case + Nothing -> pure Nothing + Just hashId -> loadObjectIdForAnyHashId hashId + +loadObjectIdForAnyHashId :: DB m => HashId -> m (Maybe ObjectId) +loadObjectIdForAnyHashId h = + queryMaybeCol loadObjectIdForAnyHashIdSql (Only h) expectObjectIdForAnyHashId :: DB m => HashId -> m ObjectId expectObjectIdForAnyHashId h = - queryOneCol maybeObjectIdForAnyHashIdSql (Only h) - -maybeObjectIdForAnyHashId :: DB m => HashId -> m (Maybe ObjectId) -maybeObjectIdForAnyHashId h = queryMaybeCol maybeObjectIdForAnyHashIdSql (Only h) + queryOneCol loadObjectIdForAnyHashIdSql (Only h) -maybeObjectIdForAnyHashIdSql :: Sql -maybeObjectIdForAnyHashIdSql = +loadObjectIdForAnyHashIdSql :: Sql +loadObjectIdForAnyHashIdSql = [here| SELECT object_id FROM hash_object WHERE hash_id = ? |] --- |All objects have corresponding hashes. -loadPrimaryHashByObjectId :: DB m => ObjectId -> m Base32Hex -loadPrimaryHashByObjectId oId = queryOneCol sql (Only oId) +-- | All objects have corresponding hashes. +expectPrimaryHashByObjectId :: DB m => ObjectId -> m Hash +expectPrimaryHashByObjectId = + fmap Hash.fromBase32Hex . expectPrimaryHash32ByObjectId + +expectPrimaryHash32ByObjectId :: DB m => ObjectId -> m Base32Hex +expectPrimaryHash32ByObjectId oId = queryOneCol sql (Only oId) where sql = [here| SELECT hash.base32 FROM hash INNER JOIN object ON object.primary_hash_id = hash.id WHERE object.id = ? |] -hashIdsForObject :: DB m => ObjectId -> m (NonEmpty HashId) -hashIdsForObject oId = do +expectHashIdsForObject :: DB m => ObjectId -> m (NonEmpty HashId) +expectHashIdsForObject oId = do primaryHashId <- queryOneCol sql1 (Only oId) hashIds <- queryListCol sql2 (Only oId) pure $ primaryHashId Nel.:| filter (/= primaryHashId) hashIds @@ -434,11 +464,6 @@ recordObjectRehash old new = WHERE object_id = ? |] -updateObjectBlob :: DB m => ObjectId -> ByteString -> m () -updateObjectBlob oId bs = execute sql (oId, bs) where sql = [here| - UPDATE object SET bytes = ? WHERE id = ? -|] - -- |Maybe we would generalize this to something other than NamespaceHash if we -- end up wanting to store other kinds of Causals here too. saveCausal :: DB m => CausalHashId -> BranchHashId -> m () @@ -465,20 +490,19 @@ saveCausal self value = execute sql (self, value) where sql = [here| -- SELECT MAX(gc_generation) FROM causal; -- |] --- FIXME rename to expectCausalValueHashId -loadCausalValueHashId :: DB m => CausalHashId -> m BranchHashId -loadCausalValueHashId (CausalHashId id) = - queryOneCol loadMaybeCausalValueHashIdSql (Only id) +expectCausalValueHashId :: DB m => CausalHashId -> m BranchHashId +expectCausalValueHashId (CausalHashId id) = + queryOneCol loadCausalValueHashIdSql (Only id) -loadCausalHash :: DB m => CausalHashId -> m CausalHash -loadCausalHash (CausalHashId id) = CausalHash <$> loadHashHashById id +expectCausalHash :: DB m => CausalHashId -> m CausalHash +expectCausalHash (CausalHashId id) = CausalHash <$> expectHash id -loadMaybeCausalValueHashId :: DB m => HashId -> m (Maybe BranchHashId) -loadMaybeCausalValueHashId id = - queryMaybeCol loadMaybeCausalValueHashIdSql (Only id) +loadCausalValueHashId :: DB m => HashId -> m (Maybe BranchHashId) +loadCausalValueHashId id = + queryMaybeCol loadCausalValueHashIdSql (Only id) -loadMaybeCausalValueHashIdSql :: Sql -loadMaybeCausalValueHashIdSql = +loadCausalValueHashIdSql :: Sql +loadCausalValueHashIdSql = [here| SELECT value_hash_id FROM causal WHERE self_hash_id = ? |] isCausalHash :: DB m => HashId -> m Bool @@ -512,17 +536,20 @@ loadCausalParents h = queryListCol sql (Only h) where sql = [here| SELECT parent_id FROM causal_parent WHERE causal_id = ? |] -loadNamespaceRoot :: DB m => m CausalHashId -loadNamespaceRoot = - queryOneCol_ loadMaybeNamespaceRootSql +expectNamespaceRoot :: DB m => m CausalHashId +expectNamespaceRoot = + queryOneCol_ loadNamespaceRootSql -loadMaybeNamespaceRoot :: DB m => m (Maybe CausalHashId) -loadMaybeNamespaceRoot = - queryMaybeCol_ loadMaybeNamespaceRootSql +loadNamespaceRoot :: DB m => m (Maybe CausalHashId) +loadNamespaceRoot = + queryMaybeCol_ loadNamespaceRootSql -loadMaybeNamespaceRootSql :: Sql -loadMaybeNamespaceRootSql = - "SELECT causal_id FROM namespace_root" +loadNamespaceRootSql :: Sql +loadNamespaceRootSql = + [here| + SELECT causal_id + FROM namespace_root + |] setNamespaceRoot :: forall m. DB m => CausalHashId -> m () setNamespaceRoot id = diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs index ea58e89c73..246b944181 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs @@ -112,8 +112,8 @@ trySync tCache hCache oCache cCache = \case Just {} -> pure Sync.PreviouslyDone Nothing -> do result <- runValidateT @(Set Entity) @m @() do - bhId <- runSrc $ Q.loadCausalValueHashId chId - mayBoId <- runSrc . Q.maybeObjectIdForAnyHashId $ unBranchHashId bhId + bhId <- runSrc $ Q.expectCausalValueHashId chId + mayBoId <- runSrc . Q.loadObjectIdForAnyHashId $ unBranchHashId bhId traverse_ syncLocalObjectId mayBoId parents' :: [CausalHashId] <- findParents' chId @@ -133,7 +133,7 @@ trySync tCache hCache oCache cCache = \case isSyncedObject oId >>= \case Just {} -> pure Sync.PreviouslyDone Nothing -> do - (hId, objType, bytes) <- runSrc $ Q.loadObjectWithHashIdAndTypeById oId + (hId, objType, bytes) <- runSrc $ Q.expectObjectWithHashIdAndType oId hId' <- syncHashLiteral hId result <- runValidateT @(Set Entity) @m @ObjectId case objType of OT.TermComponent -> do @@ -315,14 +315,14 @@ trySync tCache hCache oCache cCache = \case syncTextLiteral :: TextId -> m TextId syncTextLiteral = Cache.apply tCache \tId -> do - t <- runSrc $ Q.loadTextById tId + t <- runSrc $ Q.expectText tId tId' <- runDest $ Q.saveText t when debug $ traceM $ "Source " ++ show tId ++ " is Dest " ++ show tId' ++ " (" ++ show t ++ ")" pure tId' syncHashLiteral :: HashId -> m HashId syncHashLiteral = Cache.apply hCache \hId -> do - b32hex <- runSrc $ Q.loadHashById hId + b32hex <- runSrc $ Q.expectHash32 hId hId' <- runDest $ Q.saveHash b32hex when debug $ traceM $ "Source " ++ show hId ++ " is Dest " ++ show hId' ++ " (" ++ show b32hex ++ ")" pure hId' @@ -390,10 +390,10 @@ trySync tCache hCache oCache cCache = \case isSyncedObject :: ObjectId -> m (Maybe ObjectId) isSyncedObject = Cache.applyDefined oCache \oId -> do - hIds <- toList <$> runSrc (Q.hashIdsForObject oId) + hIds <- toList <$> runSrc (Q.expectHashIdsForObject oId) hIds' <- traverse syncHashLiteral hIds ( nubOrd . catMaybes - <$> traverse (runDest . Q.maybeObjectIdForAnyHashId) hIds' + <$> traverse (runDest . Q.loadObjectIdForAnyHashId) hIds' ) >>= \case [oId'] -> do diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 3db50a2384..cad64cbf82 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -497,7 +497,7 @@ sqliteCodebase debugName root localOrRemote action = do if v == v' then pure b else do - newRootHash <- Sqlite.runDB conn Ops.loadRootCausalHash + newRootHash <- Sqlite.runDB conn Ops.expectRootCausalHash if Branch.headHash b == Cv.branchHash2to1 newRootHash then pure b else do @@ -508,14 +508,14 @@ sqliteCodebase debugName root localOrRemote action = do b <- Sqlite.runDB conn . fmap (Branch.transform (Sqlite.runDB conn)) - $ Cv.causalbranch2to1 getDeclType =<< Ops.loadRootCausal + $ Cv.causalbranch2to1 getDeclType =<< Ops.expectRootCausal v <- Sqlite.Transaction.runTransaction conn Sqlite.getDataVersion atomically (writeTVar rootBranchCache (Just (v, b))) pure b getRootBranchExists :: MonadIO m => m Bool getRootBranchExists = - isJust <$> Sqlite.runDB conn (Ops.loadMaybeRootCausalHash) + isJust <$> Sqlite.runDB conn (Ops.loadRootCausalHash) putRootBranch :: MonadUnliftIO m => TVar (Maybe (Sqlite.DataVersion, Branch m)) -> Branch m -> m () putRootBranch rootBranchCache branch1 = @@ -587,8 +587,8 @@ sqliteCodebase debugName root localOrRemote action = do getPatch :: MonadIO m => Branch.EditHash -> m (Maybe Patch) getPatch h = Sqlite.runDB conn . runMaybeT $ - MaybeT (Ops.primaryHashToMaybePatchObjectId (Cv.patchHash1to2 h)) - >>= Ops.loadPatchById + MaybeT (Q.loadPatchObjectIdForPrimaryHash (Cv.patchHash1to2 h)) + >>= Ops.expectPatch <&> Cv.patch2to1 putPatch :: MonadUnliftIO m => Branch.EditHash -> Patch -> m () @@ -704,7 +704,7 @@ sqliteCodebase debugName root localOrRemote action = do Monoid.fromMaybe <$> runDB' conn do refs <- do Ops.componentReferencesByPrefix ot prefix cycle - >>= traverse (C.Reference.idH Ops.loadHashByObjectId) + >>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId) >>= pure . Set.fromList pure $ Set.map Cv.referenceid2to1 refs @@ -809,11 +809,11 @@ sqliteCodebase debugName root localOrRemote action = do -- well one or the other. :zany_face: the thinking being that they wouldn't hash-collide termExists', declExists' :: MonadIO m => Hash -> ReaderT Connection m Bool -termExists' = fmap isJust . Ops.primaryHashToMaybeObjectId . Cv.hash1to2 +termExists' = fmap isJust . Q.loadObjectIdForPrimaryHash . Cv.hash1to2 declExists' = termExists' patchExists' :: MonadIO m => Branch.EditHash -> ReaderT Connection m Bool -patchExists' h = fmap isJust $ Ops.primaryHashToMaybePatchObjectId (Cv.patchHash1to2 h) +patchExists' h = fmap isJust $ Q.loadPatchObjectIdForPrimaryHash (Cv.patchHash1to2 h) putBranch' :: MonadIO m => Branch m -> ReaderT Connection m () putBranch' branch1 = @@ -1123,7 +1123,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift case codebaseStatus of ExistingCodebase -> do -- the call to runDB "handles" the possible DB error by bombing - maybeOldRootHash <- fmap Cv.branchHash2to1 <$> Sqlite.runDB destConn Ops.loadMaybeRootCausalHash + maybeOldRootHash <- fmap Cv.branchHash2to1 <$> Sqlite.runDB destConn Ops.loadRootCausalHash case maybeOldRootHash of Nothing -> Sqlite.runDB destConn $ do setRepoRoot newBranchHash diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index da5290be15..a4844e466c 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -124,7 +124,7 @@ migrateSchema1To2 conn codebase = liftIO $ putStrLn $ "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." liftIO $ putStrLn $ "Updating Namespace Root..." - rootCausalHashId <- Q.loadNamespaceRoot + rootCausalHashId <- Q.expectNamespaceRoot numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] v2EmptyBranchHashInfo <- saveV2EmptyBranch watches <- @@ -234,12 +234,12 @@ migrateCausal :: MonadIO m => Sqlite.Connection -> CausalHashId -> StateT Migrat migrateCausal conn oldCausalHashId = fmap (either id id) . runExceptT $ do whenM (Map.member oldCausalHashId <$> use (field @"causalMapping")) (throwE Sync.PreviouslyDone) - oldBranchHashId <- Sqlite.runDB conn $ Q.loadCausalValueHashId oldCausalHashId + oldBranchHashId <- Sqlite.runDB conn $ Q.expectCausalValueHashId oldCausalHashId oldCausalParentHashIds <- Sqlite.runDB conn $ Q.loadCausalParents oldCausalHashId maybeOldBranchObjId <- Sqlite.runDB conn $ - Q.maybeObjectIdForAnyHashId (unBranchHashId oldBranchHashId) + Q.loadObjectIdForAnyHashId (unBranchHashId oldBranchHashId) migratedObjIds <- gets objLookup -- If the branch for this causal hasn't been migrated, migrate it first. let unmigratedBranch = @@ -299,9 +299,9 @@ migrateBranch :: MonadIO m => Sqlite.Connection -> ObjectId -> StateT MigrationS migrateBranch conn oldObjectId = fmap (either id id) . runExceptT $ do whenM (Map.member oldObjectId <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone) - oldBranch <- Sqlite.runDB conn (Ops.loadDbBranchByObjectId (BranchObjectId oldObjectId)) - oldHash <- fmap Cv.hash2to1 . Sqlite.runDB conn $ Ops.loadHashByObjectId oldObjectId - oldBranchWithHashes <- Sqlite.runDB conn (traverseOf S.branchHashes_ (fmap Cv.hash2to1 . Ops.loadHashByObjectId) oldBranch) + oldBranch <- Sqlite.runDB conn (Ops.expectDbBranch (BranchObjectId oldObjectId)) + oldHash <- fmap Cv.hash2to1 . Sqlite.runDB conn $ Q.expectPrimaryHashByObjectId oldObjectId + oldBranchWithHashes <- Sqlite.runDB conn (traverseOf S.branchHashes_ (fmap Cv.hash2to1 . Q.expectPrimaryHashByObjectId) oldBranch) migratedRefs <- gets referenceMapping migratedObjects <- gets objLookup migratedCausals <- gets causalMapping @@ -379,14 +379,14 @@ migratePatch :: migratePatch conn oldObjectId = fmap (either id id) . runExceptT $ do whenM (Map.member (unPatchObjectId oldObjectId) <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone) - oldHash <- fmap Cv.hash2to1 . Sqlite.runDB conn $ Ops.loadHashByObjectId (unPatchObjectId oldObjectId) - oldPatch <- Sqlite.runDB conn (Ops.loadDbPatchById oldObjectId) + oldHash <- fmap Cv.hash2to1 . Sqlite.runDB conn $ Q.expectPrimaryHashByObjectId (unPatchObjectId oldObjectId) + oldPatch <- Sqlite.runDB conn (Ops.expectDbPatch oldObjectId) let hydrateHashes :: forall m. Sqlite.DB m => HashId -> m Hash hydrateHashes hashId = do - Cv.hash2to1 <$> Q.loadHashHashById hashId + Cv.hash2to1 <$> Q.expectHash hashId let hydrateObjectIds :: forall m. Sqlite.DB m => ObjectId -> m Hash hydrateObjectIds objId = do - Cv.hash2to1 <$> Ops.loadHashByObjectId objId + Cv.hash2to1 <$> Q.expectPrimaryHashByObjectId objId oldPatchWithHashes :: S.Patch' TextId Hash Hash <- Sqlite.runDB conn do diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs index 96b882c162..351f500c71 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs @@ -20,7 +20,6 @@ import qualified U.Codebase.Sqlite.Patch.TypeEdit as S.TypeEdit import qualified U.Codebase.Sqlite.Queries as Q import qualified U.Codebase.Sqlite.Reference as S import qualified U.Codebase.Sqlite.Referent as S -import qualified U.Util.Hash import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import Unison.Hash (Hash) import Unison.Hashing.V2.Branch (NameSegment (..)) @@ -93,7 +92,7 @@ s2hMetadataSet = \case s2hNameSegment :: DB m => Db.TextId -> m NameSegment s2hNameSegment = - fmap NameSegment . Q.loadTextById + fmap NameSegment . Q.expectText s2hReferent :: DB m => S.Referent -> m Hashing.Referent s2hReferent = \case @@ -107,13 +106,13 @@ s2hReferentH = \case s2hReference :: DB m => S.Reference -> m Hashing.Reference s2hReference = \case - S.ReferenceBuiltin t -> Hashing.Reference.Builtin <$> Q.loadTextById t + S.ReferenceBuiltin t -> Hashing.Reference.Builtin <$> Q.expectText t S.Reference.Derived h i -> Hashing.Reference.Derived <$> objectIdToPrimaryHash h <*> pure i s2hReferenceH :: DB m => S.ReferenceH -> m Hashing.Reference s2hReferenceH = \case - S.ReferenceBuiltin t -> Hashing.Reference.Builtin <$> Q.loadTextById t - S.Reference.Derived h i -> Hashing.Reference.Derived <$> loadHashHashById h <*> pure i + S.ReferenceBuiltin t -> Hashing.Reference.Builtin <$> Q.expectText t + S.Reference.Derived h i -> Hashing.Reference.Derived <$> expectHash h <*> pure i s2hTermEdit :: DB m => S.TermEdit -> m Hashing.TermEdit s2hTermEdit = \case @@ -129,12 +128,12 @@ s2hTypeEdit = \case causalHashIdToHash :: DB m => Db.CausalHashId -> m Hash causalHashIdToHash = - fmap Cv.hash2to1 . Q.loadHashHashById . Db.unCausalHashId + fmap Cv.hash2to1 . Q.expectHash . Db.unCausalHashId objectIdToPrimaryHash :: DB m => Db.ObjectId -> m Hash objectIdToPrimaryHash = - fmap (Cv.hash2to1 . U.Util.Hash.fromBase32Hex) . Q.loadPrimaryHashByObjectId + fmap Cv.hash2to1 . Q.expectPrimaryHashByObjectId -loadHashHashById :: DB m => Db.HashId -> m Hash -loadHashHashById = - fmap Cv.hash2to1 . Q.loadHashHashById +expectHash :: DB m => Db.HashId -> m Hash +expectHash = + fmap Cv.hash2to1 . Q.expectHash From 92e9e37f61e6a9b6cfe77740968aef5c0d5353e6 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 31 Mar 2022 16:26:09 -0400 Subject: [PATCH 043/529] use explicit deriving strategies where it's ambiguous --- .../src/Unison/Util/Pretty.hs | 3 +- parser-typechecker/package.yaml | 46 ++++++++++--------- .../src/Unison/Codebase/Path.hs | 4 +- parser-typechecker/src/Unison/Runtime/ANF.hs | 8 +++- parser-typechecker/src/Unison/Util/Bytes.hs | 4 +- .../src/Unison/Util/EnumContainers.hs | 23 +++++----- parser-typechecker/src/Unison/Util/Text.hs | 4 +- .../unison-parser-typechecker.cabal | 4 ++ 8 files changed, 57 insertions(+), 39 deletions(-) diff --git a/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs b/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs index 760af3cd63..886b5003d5 100644 --- a/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs +++ b/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs @@ -158,7 +158,8 @@ import qualified Unison.Util.SyntaxText as ST import Prelude hiding (lines, map) newtype Width = Width {widthToInt :: Int} - deriving (Eq, Ord, Show, Generic, Num, Bounded) + deriving stock (Eq, Ord, Show, Generic) + deriving newtype (Num, Bounded) type ColorText = CT.ColorText diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 2f1a86bcc4..433342c5f6 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -2,28 +2,6 @@ name: unison-parser-typechecker github: unisonweb/unison copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors -default-extensions: - - ApplicativeDo - - BangPatterns - - BlockArguments - - DeriveFunctor - - DeriveGeneric - - DerivingStrategies - - DoAndIfThenElse - - FlexibleContexts - - FlexibleInstances - - GeneralizedNewtypeDeriving - - LambdaCase - - MultiParamTypeClasses - - NamedFieldPuns - - OverloadedStrings - - PatternSynonyms - - RankNTypes - - ScopedTypeVariables - - TupleSections - - TypeApplications - - ViewPatterns - ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures flags: @@ -180,3 +158,27 @@ executables: - unison-util - unison-util-relation - unison-pretty-printer + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - TupleSections + - TypeApplications + - ViewPatterns diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index 4a8d66c22a..df76ea0426 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -84,7 +84,9 @@ import Unison.Prelude hiding (empty, toList) import Unison.Util.Monoid (intercalateMap) -- `Foo.Bar.baz` becomes ["Foo", "Bar", "baz"] -newtype Path = Path {toSeq :: Seq NameSegment} deriving (Eq, Ord, Semigroup, Monoid) +newtype Path = Path {toSeq :: Seq NameSegment} + deriving stock (Eq, Ord) + deriving newtype (Semigroup, Monoid) newtype Absolute = Absolute {unabsolute :: Path} deriving (Eq, Ord) diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index 5d5046337a..30fb45f36a 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -477,9 +477,13 @@ data ANormalF v e -- Types representing components that will go into the runtime tag of -- a data type value. RTags correspond to references, while CTags -- correspond to constructors. -newtype RTag = RTag Word64 deriving (Eq, Ord, Show, Read, EC.EnumKey) +newtype RTag = RTag Word64 + deriving stock (Eq, Ord, Show, Read) + deriving newtype (EC.EnumKey) -newtype CTag = CTag Word16 deriving (Eq, Ord, Show, Read, EC.EnumKey) +newtype CTag = CTag Word16 + deriving stock (Eq, Ord, Show, Read) + deriving newtype (EC.EnumKey) class Tag t where rawTag :: t -> Word64 diff --git a/parser-typechecker/src/Unison/Util/Bytes.hs b/parser-typechecker/src/Unison/Util/Bytes.hs index c2db34d8f4..2bfc2ff74f 100644 --- a/parser-typechecker/src/Unison/Util/Bytes.hs +++ b/parser-typechecker/src/Unison/Util/Bytes.hs @@ -83,7 +83,9 @@ import Prelude hiding (drop, take) type Chunk = V.Vector Word8 -- Bytes type represented as a rope of ByteStrings -newtype Bytes = Bytes {underlying :: R.Rope Chunk} deriving (Semigroup, Monoid, Eq, Ord) +newtype Bytes = Bytes {underlying :: R.Rope Chunk} + deriving stock (Eq, Ord) + deriving newtype (Semigroup, Monoid) instance R.Sized Chunk where size = V.length diff --git a/parser-typechecker/src/Unison/Util/EnumContainers.hs b/parser-typechecker/src/Unison/Util/EnumContainers.hs index 4872cf9a28..51def1b043 100644 --- a/parser-typechecker/src/Unison/Util/EnumContainers.hs +++ b/parser-typechecker/src/Unison/Util/EnumContainers.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module Unison.Util.EnumContainers ( EnumMap, EnumSet, @@ -49,25 +46,29 @@ instance EnumKey Word16 where intToKey i = fromIntegral i newtype EnumMap k a = EM (IM.IntMap a) - deriving - ( Monoid, - Semigroup, - Functor, + deriving stock + ( Functor, Foldable, Traversable, Show, Eq, Ord ) + deriving newtype + ( Monoid, + Semigroup + ) newtype EnumSet k = ES IS.IntSet - deriving - ( Monoid, - Semigroup, - Show, + deriving stock + ( Show, Eq, Ord ) + deriving newtype + ( Monoid, + Semigroup + ) mapFromList :: EnumKey k => [(k, a)] -> EnumMap k a mapFromList = EM . IM.fromList . fmap (first keyToInt) diff --git a/parser-typechecker/src/Unison/Util/Text.hs b/parser-typechecker/src/Unison/Util/Text.hs index 2106e322b4..18dd0541de 100644 --- a/parser-typechecker/src/Unison/Util/Text.hs +++ b/parser-typechecker/src/Unison/Util/Text.hs @@ -14,7 +14,9 @@ import qualified Unison.Util.Rope as R import Prelude hiding (drop, replicate, take) -- Text type represented as a `Rope` of chunks -newtype Text = Text (R.Rope Chunk) deriving (Eq, Ord, Semigroup, Monoid) +newtype Text = Text (R.Rope Chunk) + deriving stock (Eq, Ord) + deriving newtype (Semigroup, Monoid) data Chunk = Chunk {-# UNPACK #-} !Int {-# UNPACK #-} !T.Text diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index cef80c191a..eb7c346e27 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -188,7 +188,9 @@ library BlockArguments DeriveFunctor DeriveGeneric + DeriveTraversable DerivingStrategies + DerivingVia DoAndIfThenElse FlexibleContexts FlexibleInstances @@ -352,7 +354,9 @@ executable tests BlockArguments DeriveFunctor DeriveGeneric + DeriveTraversable DerivingStrategies + DerivingVia DoAndIfThenElse FlexibleContexts FlexibleInstances From 1eaebf370985f75b94e98dac4fd85d442eade731 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 31 Mar 2022 15:16:16 -0600 Subject: [PATCH 044/529] Commit stack.yaml.lock as is recommended. https://docs.haskellstack.org/en/stable/lock_files --- .gitignore | 1 - stack.yaml.lock | 126 ++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 126 insertions(+), 1 deletion(-) create mode 100644 stack.yaml.lock diff --git a/.gitignore b/.gitignore index 02aff877fd..6ef1f50473 100644 --- a/.gitignore +++ b/.gitignore @@ -6,7 +6,6 @@ scratch.u # Stack .stack-work -stack.yaml.lock # Cabal dist-newstyle diff --git a/stack.yaml.lock b/stack.yaml.lock new file mode 100644 index 0000000000..a052f7bd63 --- /dev/null +++ b/stack.yaml.lock @@ -0,0 +1,126 @@ +# This file was autogenerated by Stack. +# You should not edit this file by hand. +# For more information, please see the documentation at: +# https://docs.haskellstack.org/en/stable/lock_files + +packages: +- completed: + size: 15989 + url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz + name: configurator + version: 0.3.0.0 + sha256: d4fd87fb7bfc5d8e9fbc3e4ee7302c6b1500cdc00fdb9b659d0f4849b6ebe2d5 + pantry-tree: + size: 955 + sha256: 90547cd983fd15ebdc803e057d3ef8735fe93a75e29a00f8a74eadc13ee0f6e9 + original: + url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz +- completed: + size: 75098 + url: https://github.com/unisonweb/haskeline/archive/2944b11d19ee034c48276edc991736105c9d6143.tar.gz + name: haskeline + version: 0.7.5.0 + sha256: 6d44207a4e94a16bc99d13dccbbb79bf676190c0476436b03235eeeaf6c72f9d + pantry-tree: + size: 3717 + sha256: 878c7fb5801ec7418761a49b529ca3fdab274f22707c7d2759f2b3a2df06c3ea + original: + url: https://github.com/unisonweb/haskeline/archive/2944b11d19ee034c48276edc991736105c9d6143.tar.gz +- completed: + size: 92490 + url: https://github.com/unisonweb/megaparsec/archive/c4463124c578e8d1074c04518779b5ce5957af6b.tar.gz + name: megaparsec + version: 6.5.0 + sha256: 94f9573735fefda868371ff735a6b1f52bea22b9e52289abeb8114c99bbf8832 + pantry-tree: + size: 2635 + sha256: 7d3f8b23c862d878b4adce628caaf7bc337f0ac10b2556e1cdf0913c28a45929 + original: + url: https://github.com/unisonweb/megaparsec/archive/c4463124c578e8d1074c04518779b5ce5957af6b.tar.gz +- completed: + size: 10460 + url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz + name: shellmet + version: 0.0.4.0 + sha256: 6e642163070a217cc3363bdbefde571ff6c1878f4fc3d92e9c910db7fa88eaf2 + pantry-tree: + size: 654 + sha256: 05a169a7a6b68100630e885054dc1821d31cd06571b0317ec90c75ac2c41aeb7 + original: + url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz +- completed: + hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 + pantry-tree: + size: 364 + sha256: a33838b7b1c54f6ac3e1b436b25674948713a4189658e4d82e639b9a689bc90d + original: + hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 +- completed: + hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 + pantry-tree: + size: 476 + sha256: a03f60a1250c9d0daaf208ba58ccf24e05e0807f2e3dc7892fad3f2f3a196f7f + original: + hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 +- completed: + hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 + pantry-tree: + size: 3455 + sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350 + original: + hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 +- completed: + hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 + pantry-tree: + size: 212 + sha256: 876e5a679244143e2a7e74357427c7522a8d61f68a4cc3ae265fe4960b75a2e2 + original: + hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 +- completed: + hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 + pantry-tree: + size: 542 + sha256: 0e6c6d4f89083c8385de5adc4f36ad01b2b0ff45261b47f7d90d919969c8b5ed + original: + hackage: fuzzyfind-3.0.0 +- completed: + hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 + pantry-tree: + size: 713 + sha256: 8e049bd12ce2bd470909578f2ee8eb80b89d5ff88860afa30e29dd4eafecfa3e + original: + hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 +- completed: + hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 + pantry-tree: + size: 363 + sha256: d33d603a2f0d1a220ff0d5e7edb6273def89120e6bb958c2d836cae89e788334 + original: + hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 +- completed: + hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 + pantry-tree: + size: 2410 + sha256: d87d84c3f760c1b2540f74e4a301cd4e8294df891e8e4262e8bdd313bc8e0bfd + original: + hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 +- completed: + hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 + pantry-tree: + size: 718 + sha256: 3634593ce191e82793ea0e060598ab3cf67f2ef2fe1d65345dc9335ad529d25f + original: + hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 +- completed: + hackage: http-client-0.7.11@sha256:3f59ac8ffe2a3768846cdda040a0d1df2a413960529ba61c839861c948871967,5756 + pantry-tree: + size: 2547 + sha256: 8372e84e9c710097f4f80f2016ca15a5a0cd7884b8ac5ce70f26b3110f4401bd + original: + hackage: http-client-0.7.11 +snapshots: +- completed: + size: 590100 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml + sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 + original: lts-18.28 From ef3282b38134cb730e8e641bb6bbdeb668b12def Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 1 Apr 2022 11:03:26 -0400 Subject: [PATCH 045/529] simplify throwing decoding error ceremony a bit --- .../U/Codebase/Sqlite/Operations.hs | 97 +++++++------------ .../U/Codebase/Sqlite/Queries.hs | 1 - .../src/Unison/Codebase/SqliteCodebase.hs | 6 +- 3 files changed, 39 insertions(+), 65 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index c2d2a923b4..1c269cfb0c 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -17,7 +17,7 @@ module U.Codebase.Sqlite.Operations saveDeclComponent, loadDeclComponent, loadDeclByReference, - getDeclTypeById, + expectDeclTypeById, -- * terms/decls getCycleLen, @@ -65,10 +65,6 @@ module U.Codebase.Sqlite.Operations saveBranchObject, saveDbPatch, - -- * Error types - Error (..), - DecodeError (..), - -- * somewhat unexpectedly unused definitions c2sReferenceId, c2sReferentId, @@ -84,38 +80,23 @@ where import Control.Lens (Lens') import qualified Control.Lens as Lens -import Control.Monad (join, unless, when, (<=<)) -import Control.Monad.Except (MonadIO (liftIO)) import qualified Control.Monad.Extra as Monad import Control.Monad.State (MonadState, evalStateT) -import Control.Monad.Trans (MonadTrans (lift)) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) import Control.Monad.Writer (MonadWriter, runWriterT) import qualified Control.Monad.Writer as Writer import Data.Bifunctor (Bifunctor (bimap)) import Data.Bitraversable (Bitraversable (bitraverse)) -import Data.ByteString (ByteString) import Data.Bytes.Get (runGetS) import qualified Data.Bytes.Get as Get -import Data.Foldable (traverse_) import qualified Data.Foldable as Foldable -import Data.Functor (void, (<&>)) import Data.Functor.Identity (Identity) -import Data.Map (Map) import qualified Data.Map as Map import qualified Data.Map.Merge.Lazy as Map -import Data.Maybe (isJust) -import Data.Sequence (Seq) import qualified Data.Sequence as Seq -import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) import qualified Data.Text as Text -import Data.Traversable (for) import Data.Tuple.Extra (uncurry3) import qualified Data.Vector as Vector -import Data.Word (Word64) -import Debug.Trace import qualified U.Codebase.Branch as C.Branch import qualified U.Codebase.Causal as C import U.Codebase.Decl (ConstructorId) @@ -180,6 +161,7 @@ import qualified U.Util.Monoid as Monoid import U.Util.Serialization (Get) import qualified U.Util.Serialization as S import qualified U.Util.Term as TermUtil +import Unison.Prelude import Unison.Sqlite import qualified Unison.Util.Map as Map import qualified Unison.Util.Set as Set @@ -189,24 +171,10 @@ import qualified Unison.Util.Set as Set debug :: Bool debug = False -type ErrString = String - -data DecodeError - = ErrTermFormat - | ErrDeclFormat - | ErrTermElement Word64 - | ErrDeclElement Word64 - | ErrFramedArrayLen - | ErrTypeOfTerm C.Reference.Id - | ErrWatch WatchKind C.Reference.Id - | ErrBranch Db.BranchObjectId - | ErrPatch Db.PatchObjectId - | ErrObjectDependencies OT.ObjectType Db.ObjectId - deriving (Show) - --- TODO rename -data Error - = DecodeError DecodeError ByteString ErrString +data DecodeError = DecodeError + { decoder :: Text, -- the name of the decoder + err :: String -- the error message + } deriving stock (Show) deriving anyclass (SqliteExceptionReason) @@ -215,9 +183,9 @@ newtype NeedTypeForBuiltinMetadata deriving stock (Show) deriving anyclass (SqliteExceptionReason) -getFromBytesOr :: DecodeError -> Get a -> ByteString -> Either Error a -getFromBytesOr e get bs = case runGetS get bs of - Left err -> Left (DecodeError e bs err) +getFromBytesOr :: Text -> Get a -> ByteString -> Either DecodeError a +getFromBytesOr decoder get bs = case runGetS get bs of + Left err -> Left (DecodeError decoder err) Right a -> Right a -- * Database lookups @@ -354,26 +322,34 @@ diffPatch (S.Patch fullTerms fullTypes) (S.Patch refTerms refTypes) = -- * Deserialization helpers -decodeTermFormat :: ByteString -> Either Error S.Term.TermFormat -decodeTermFormat = getFromBytesOr ErrTermFormat S.getTermFormat +decodeBranchFormat :: ByteString -> Either DecodeError S.BranchFormat.BranchFormat +decodeBranchFormat = getFromBytesOr "getBranchFormat" S.getBranchFormat + +decodePatchFormat :: ByteString -> Either DecodeError S.Patch.Format.PatchFormat +decodePatchFormat = getFromBytesOr "getPatchFormat" S.getPatchFormat + +decodeTermFormat :: ByteString -> Either DecodeError S.Term.TermFormat +decodeTermFormat = getFromBytesOr "getTermFormat" S.getTermFormat -decodeComponentLengthOnly :: ByteString -> Either Error Word64 -decodeComponentLengthOnly = getFromBytesOr ErrFramedArrayLen (Get.skip 1 >> S.lengthFramedArray) +decodeComponentLengthOnly :: ByteString -> Either DecodeError Word64 +decodeComponentLengthOnly = getFromBytesOr "lengthFramedArray" (Get.skip 1 >> S.lengthFramedArray) -decodeTermElementWithType :: C.Reference.Pos -> ByteString -> Either Error (LocalIds, S.Term.Term, S.Term.Type) -decodeTermElementWithType i = getFromBytesOr (ErrTermElement i) (S.lookupTermElement i) +decodeTermElementWithType :: C.Reference.Pos -> ByteString -> Either DecodeError (LocalIds, S.Term.Term, S.Term.Type) +decodeTermElementWithType i = getFromBytesOr ("lookupTermElement" <> tShow i) (S.lookupTermElement i) -decodeTermElementDiscardingTerm :: C.Reference.Pos -> ByteString -> Either Error (LocalIds, S.Term.Type) -decodeTermElementDiscardingTerm i = getFromBytesOr (ErrTermElement i) (S.lookupTermElementDiscardingTerm i) +decodeTermElementDiscardingTerm :: C.Reference.Pos -> ByteString -> Either DecodeError (LocalIds, S.Term.Type) +decodeTermElementDiscardingTerm i = + getFromBytesOr ("lookupTermElementDiscardingTerm " <> tShow i) (S.lookupTermElementDiscardingTerm i) -decodeTermElementDiscardingType :: C.Reference.Pos -> ByteString -> Either Error (LocalIds, S.Term.Term) -decodeTermElementDiscardingType i = getFromBytesOr (ErrTermElement i) (S.lookupTermElementDiscardingType i) +decodeTermElementDiscardingType :: C.Reference.Pos -> ByteString -> Either DecodeError (LocalIds, S.Term.Term) +decodeTermElementDiscardingType i = + getFromBytesOr ("lookupTermElementDiscardingType " <> tShow i) (S.lookupTermElementDiscardingType i) -decodeDeclFormat :: ByteString -> Either Error S.Decl.DeclFormat -decodeDeclFormat = getFromBytesOr ErrDeclFormat S.getDeclFormat +decodeDeclFormat :: ByteString -> Either DecodeError S.Decl.DeclFormat +decodeDeclFormat = getFromBytesOr "getDeclFormat" S.getDeclFormat -decodeDeclElement :: Word64 -> ByteString -> Either Error (LocalIds, S.Decl.Decl Symbol) -decodeDeclElement i = getFromBytesOr (ErrDeclElement i) (S.lookupDeclElement i) +decodeDeclElement :: Word64 -> ByteString -> Either DecodeError (LocalIds, S.Decl.Decl Symbol) +decodeDeclElement i = getFromBytesOr ("lookupDeclElement " <> tShow i) (S.lookupDeclElement i) getCycleLen :: DB m => H.Hash -> m (Maybe Word64) getCycleLen h = do @@ -389,9 +365,8 @@ getCycleLen h = do Q.expectObject oid decodeComponentLengthOnly -- | Get the 'C.DeclType.DeclType' of a 'C.Reference.Id'. --- TODO rename to expectDeclTypeById -getDeclTypeById :: DB m => C.Reference.Id -> m C.Decl.DeclType -getDeclTypeById = +expectDeclTypeById :: DB m => C.Reference.Id -> m C.Decl.DeclType +expectDeclTypeById = fmap C.Decl.declType . expectDeclByReference componentByObjectId :: DB m => Db.ObjectId -> m [S.Reference.Id] @@ -681,7 +656,7 @@ listWatches k = Q.loadWatchesByWatchKind k >>= traverse h2cReferenceId loadWatch :: DB m => WatchKind -> C.Reference.Id -> MaybeT m (C.Term Symbol) loadWatch k r = do r' <- C.Reference.idH Q.saveHashHash r - S.Term.WatchResult wlids t <- MaybeT (Q.loadWatch k r' (getFromBytesOr (ErrWatch k r) S.getWatchResultFormat)) + S.Term.WatchResult wlids t <- MaybeT (Q.loadWatch k r' (getFromBytesOr "getWatchResultFormat" S.getWatchResultFormat)) w2cTerm wlids t saveWatch :: DB m => WatchKind -> C.Reference.Id -> C.Term Symbol -> m () @@ -987,7 +962,7 @@ expectDbBranch id = deserializeBranchObject :: DB m => Db.BranchObjectId -> m S.BranchFormat deserializeBranchObject id = do when debug $ traceM $ "deserializeBranchObject " ++ show id - Q.expectNamespaceObject (Db.unBranchObjectId id) (getFromBytesOr (ErrBranch id) S.getBranchFormat) + Q.expectNamespaceObject (Db.unBranchObjectId id) decodeBranchFormat doDiff :: DB m => Db.BranchObjectId -> [S.Branch.Diff] -> m S.DbBranch doDiff ref ds = @@ -1126,7 +1101,7 @@ s2cPatch (S.Patch termEdits typeEdits) = deserializePatchObject :: DB m => Db.PatchObjectId -> m S.PatchFormat deserializePatchObject id = do when debug $ traceM $ "Operations.deserializePatchObject " ++ show id - Q.expectPatchObject (Db.unPatchObjectId id) (getFromBytesOr (ErrPatch id) S.getPatchFormat) + Q.expectPatchObject (Db.unPatchObjectId id) decodePatchFormat lca :: DB m => CausalHash -> CausalHash -> Connection -> Connection -> m (Maybe CausalHash) lca h1 h2 c1 c2 = runMaybeT do diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index f0b0594834..add5b104a5 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -401,7 +401,6 @@ expectObjectIdForPrimaryHash h = do hashId <- expectHashIdByHash h expectObjectIdForPrimaryHashId hashId --- FIXME this doesn't check that the object is actually a patch loadPatchObjectIdForPrimaryHash :: DB m => PatchHash -> m (Maybe PatchObjectId) loadPatchObjectIdForPrimaryHash = (fmap . fmap) PatchObjectId . loadObjectIdForPrimaryHash . unPatchHash diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index cad64cbf82..899380640a 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -282,10 +282,10 @@ sqliteCodebase debugName root localOrRemote action = do ++ ", but I've been asked for it's ConstructorType." in pure . fromMaybe err $ Map.lookup (Reference.Builtin t) Builtins.builtinConstructorType - C.Reference.ReferenceDerived i -> getDeclTypeById i + C.Reference.ReferenceDerived i -> expectDeclTypeById i - getDeclTypeById :: forall m. DB m => C.Reference.Id -> m CT.ConstructorType - getDeclTypeById = fmap Cv.decltype2to1 . Ops.getDeclTypeById + expectDeclTypeById :: forall m. DB m => C.Reference.Id -> m CT.ConstructorType + expectDeclTypeById = fmap Cv.decltype2to1 . Ops.expectDeclTypeById getTypeOfTermImpl :: MonadIO m => Reference.Id -> m (Maybe (Type Symbol Ann)) getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined From 52da285bf67d0afee09f5d58ab76189640969a18 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 1 Apr 2022 10:14:01 -0600 Subject: [PATCH 046/529] Add unison-share-api package with Sync APIs (#3018) --- hie.yaml | 3 + stack.yaml | 1 + unison-share-api/README.md | 5 + unison-share-api/package.yaml | 48 +++ unison-share-api/src/Unison/Sync/API.hs | 28 ++ unison-share-api/src/Unison/Sync/Types.hs | 501 ++++++++++++++++++++++ unison-share-api/unison-share-api.cabal | 64 +++ 7 files changed, 650 insertions(+) create mode 100644 unison-share-api/README.md create mode 100644 unison-share-api/package.yaml create mode 100644 unison-share-api/src/Unison/Sync/API.hs create mode 100644 unison-share-api/src/Unison/Sync/Types.hs create mode 100644 unison-share-api/unison-share-api.cabal diff --git a/hie.yaml b/hie.yaml index ad17559fcb..01a7d9d04e 100644 --- a/hie.yaml +++ b/hie.yaml @@ -30,6 +30,9 @@ cradle: - path: "lib/unison-sqlite/src" component: "unison-sqlite:lib" + - path: "unison-share-api/src" + component: "unison-share-api:lib" + - path: "lib/unison-util-relation/src" component: "unison-util-relation:lib" diff --git a/stack.yaml b/stack.yaml index 08da29dc3b..1abc629fee 100644 --- a/stack.yaml +++ b/stack.yaml @@ -14,6 +14,7 @@ packages: - parser-typechecker - unison-core - unison-cli +- unison-share-api - codebase2/codebase - codebase2/codebase-sqlite - codebase2/codebase-sync diff --git a/unison-share-api/README.md b/unison-share-api/README.md new file mode 100644 index 0000000000..9c6a064c33 --- /dev/null +++ b/unison-share-api/README.md @@ -0,0 +1,5 @@ +# unison-share-api + +This package serves as a shared place to store the API definitions and types +for all of Share's APIs. This facilitates the use of `servant-client` to easily +generate clients for the API, and provides an always-up-to-date view of Share's APIs. diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml new file mode 100644 index 0000000000..cfa0c24516 --- /dev/null +++ b/unison-share-api/package.yaml @@ -0,0 +1,48 @@ +name: unison-share-api +github: unisonweb/unison +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors + +library: + source-dirs: src + +dependencies: + - base + - mtl + - text + - transformers + - unliftio + - servant + - containers + - nonempty-containers + - bytestring + - aeson + - memory + +ghc-options: + -Wall + +default-extensions: + - BlockArguments + - ConstraintKinds + - DeriveAnyClass + - DeriveFunctor + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - DuplicateRecordFields + - FlexibleContexts + - FlexibleInstances + - GADTs + - GeneralizedNewtypeDeriving + - KindSignatures + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - NumericUnderscores + - OverloadedStrings + - PatternSynonyms + - ScopedTypeVariables + - TupleSections + - TypeApplications + - TypeOperators + - ViewPatterns diff --git a/unison-share-api/src/Unison/Sync/API.hs b/unison-share-api/src/Unison/Sync/API.hs new file mode 100644 index 0000000000..5eb6f23a78 --- /dev/null +++ b/unison-share-api/src/Unison/Sync/API.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE DataKinds #-} + +module Unison.Sync.API (API) where + +import Servant.API +import Unison.Sync.Types + +type API = + "path" :> "get" :> GetCausalHashByPathEndpoint + :<|> "path" :> "update" :> UpdatePathEndpoint + :<|> "entities" :> "download" :> DownloadEntitiesEndpoint + :<|> "entities" :> "upload" :> UploadEntitiesEndpoint + +type GetCausalHashByPathEndpoint = + ReqBody '[JSON] GetCausalHashByPathRequest + :> Post '[JSON] GetCausalHashByPathResponse + +type UpdatePathEndpoint = + ReqBody '[JSON] UpdatePathRequest + :> UVerb 'POST '[JSON] '[WithStatus 204 NoContent, WithStatus 404 (NeedDependencies HashJWT), WithStatus 412 HashMismatch] + +type DownloadEntitiesEndpoint = + ReqBody '[JSON] DownloadEntitiesRequest + :> Post '[JSON] DownloadEntitiesResponse + +type UploadEntitiesEndpoint = + ReqBody '[JSON] UploadEntitiesRequest + :> UVerb 'POST '[JSON] '[WithStatus 200 NoContent, WithStatus 202 (NeedDependencies Hash)] diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs new file mode 100644 index 0000000000..9032b623dc --- /dev/null +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -0,0 +1,501 @@ +{-# LANGUAGE RecordWildCards #-} + +module Unison.Sync.Types where + +import Data.Aeson +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.Bifoldable +import Data.Bifunctor +import Data.Bitraversable +import Data.ByteArray.Encoding (Base (Base64), convertFromBase, convertToBase) +import Data.ByteString (ByteString) +import Data.Map.NonEmpty (NEMap) +import Data.Set (Set) +import Data.Set.NonEmpty (NESet) +import Data.Text (Text) +import qualified Data.Text.Encoding as Text + +-- | A newtype for JSON encoding binary data. +newtype Base64Bytes = Base64Bytes ByteString + +instance ToJSON Base64Bytes where + toJSON (Base64Bytes bytes) = String . Text.decodeUtf8 $ convertToBase Base64 bytes + +instance FromJSON Base64Bytes where + parseJSON = Aeson.withText "Base64" $ \txt -> do + either fail (pure . Base64Bytes) $ convertFromBase Base64 (Text.encodeUtf8 txt) + +newtype RepoName = RepoName Text + deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) + +newtype HashJWT = HashJWT Text + deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) + +data HashJWTClaims = HashJWTClaims + { hash :: Hash, + entityType :: EntityType + } + deriving stock (Show, Eq, Ord) + +instance ToJSON HashJWTClaims where + toJSON (HashJWTClaims hash entityType) = + object + [ "h" .= hash, + "t" .= entityType + ] + +instance FromJSON HashJWTClaims where + parseJSON = Aeson.withObject "HashJWTClaims" $ \obj -> do + hash <- obj .: "h" + entityType <- obj .: "t" + pure HashJWTClaims {..} + +newtype Hash = Hash {toBase32Hex :: Text} + deriving newtype (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey) + +data TypedHash = TypedHash + { hash :: Hash, + entityType :: EntityType + } + deriving stock (Show, Eq, Ord) + +instance ToJSON TypedHash where + toJSON (TypedHash hash entityType) = + object + [ "hash" .= hash, + "type" .= entityType + ] + +instance FromJSON TypedHash where + parseJSON = Aeson.withObject "TypedHash" $ \obj -> do + hash <- obj .: "hash" + entityType <- obj .: "type" + pure $ TypedHash {..} + +data RepoPath = RepoPath + { repoName :: RepoName, + pathSegments :: [Text] + } + deriving stock (Show, Eq, Ord) + +instance ToJSON RepoPath where + toJSON (RepoPath name segments) = + object + [ "repo_name" .= name, + "path" .= segments + ] + +instance FromJSON RepoPath where + parseJSON = Aeson.withObject "RepoPath" $ \obj -> do + repoName <- obj .: "repo_name" + pathSegments <- obj .: "path" + pure RepoPath {..} + +newtype GetCausalHashByPathRequest = GetCausalHashByPathRequest + { repoPath :: RepoPath + } + deriving stock (Show, Eq, Ord) + +instance ToJSON GetCausalHashByPathRequest where + toJSON (GetCausalHashByPathRequest repoPath) = + object + [ "repo_path" .= repoPath + ] + +instance FromJSON GetCausalHashByPathRequest where + parseJSON = Aeson.withObject "GetCausalHashByPathRequest" $ \obj -> do + repoPath <- obj .: "repo_path" + pure GetCausalHashByPathRequest {..} + +newtype GetCausalHashByPathResponse = GetCausalHashByPathResponse + { causalHash :: Maybe HashJWT + } + deriving stock (Show, Eq, Ord) + +instance ToJSON GetCausalHashByPathResponse where + toJSON (GetCausalHashByPathResponse hashJWT) = + object + [ "causal_hash" .= hashJWT + ] + +instance FromJSON GetCausalHashByPathResponse where + parseJSON = Aeson.withObject "GetCausalHashByPathResponse" $ \obj -> do + causalHash <- obj .: "causal_hash" + pure GetCausalHashByPathResponse {..} + +data DownloadEntitiesRequest = DownloadEntitiesRequest + { repoName :: RepoName, + hashes :: NESet HashJWT + } + deriving stock (Show, Eq, Ord) + +instance ToJSON DownloadEntitiesRequest where + toJSON (DownloadEntitiesRequest repoName hashes) = + object + [ "repo_name" .= repoName, + "hashes" .= hashes + ] + +instance FromJSON DownloadEntitiesRequest where + parseJSON = Aeson.withObject "DownloadEntitiesRequest" $ \obj -> do + repoName <- obj .: "repo_name" + hashes <- obj .: "hashes" + pure DownloadEntitiesRequest {..} + +data DownloadEntitiesResponse = DownloadEntitiesResponse + { entities :: NEMap Hash (Entity HashJWT Hash Text) + } + deriving stock (Show, Eq, Ord) + +instance ToJSON DownloadEntitiesResponse where + toJSON (DownloadEntitiesResponse entities) = + object + [ "entities" .= entities + ] + +data UpdatePathRequest = UpdatePathRequest + { path :: RepoPath, + expectedHash :: Maybe TypedHash, -- Nothing requires empty history at destination + newHash :: TypedHash + } + deriving stock (Show, Eq, Ord) + +instance ToJSON UpdatePathRequest where + toJSON (UpdatePathRequest path expectedHash newHash) = + object + [ "path" .= path, + "expected_hash" .= expectedHash, + "new_hash" .= newHash + ] + +instance FromJSON UpdatePathRequest where + parseJSON = Aeson.withObject "UpdatePathRequest" $ \obj -> do + path <- obj .: "path" + expectedHash <- obj .: "expected_hash" + newHash <- obj .: "new_hash" + pure UpdatePathRequest {..} + +-- | Not used in the servant API, but is a useful return type for clients to use. +data UpdatePathResponse + = UpdatePathHashMismatch HashMismatch + | UpdatePathMissingDependencies (NeedDependencies Hash) + deriving stock (Show, Eq, Ord) + +data NeedDependencies hash = NeedDependencies + { missingDependencies :: NESet hash + } + deriving stock (Show, Eq, Ord) + +instance ToJSON hash => ToJSON (NeedDependencies hash) where + toJSON (NeedDependencies missingDependencies) = + object ["missing_dependencies" .= missingDependencies] + +instance (FromJSON hash, Ord hash) => FromJSON (NeedDependencies hash) where + parseJSON = Aeson.withObject "NeedDependencies" $ \obj -> do + missingDependencies <- obj .: "missing_dependencies" + pure NeedDependencies {..} + +data HashMismatch = HashMismatch + { repoPath :: RepoPath, + expectedHash :: Maybe TypedHash, + actualHash :: Maybe TypedHash + } + deriving stock (Show, Eq, Ord) + +instance ToJSON HashMismatch where + toJSON (HashMismatch repoPath expectedHash actualHash) = + object + [ "repo_path" .= repoPath, + "expected_hash" .= expectedHash, + "actual_hash" .= actualHash + ] + +instance FromJSON HashMismatch where + parseJSON = Aeson.withObject "HashMismatch" $ \obj -> do + repoPath <- obj .: "repo_path" + expectedHash <- obj .: "expected_hash" + actualHash <- obj .: "actual_hash" + pure HashMismatch {..} + +data UploadEntitiesRequest = UploadEntitiesRequest + { repoName :: RepoName, + entities :: NEMap Hash (Entity TypedHash TypedHash Text) + } + deriving stock (Show, Eq, Ord) + +instance ToJSON UploadEntitiesRequest where + toJSON (UploadEntitiesRequest repoName entities) = + object + [ "repo_name" .= repoName, + "entities" .= entities + ] + +instance FromJSON UploadEntitiesRequest where + parseJSON = Aeson.withObject "UploadEntitiesRequest" $ \obj -> do + repoName <- obj .: "repo_name" + entities <- obj .: "entities" + pure UploadEntitiesRequest {..} + +data Entity hash replacementHash text + = TC (TermComponent hash text) + | DC (DeclComponent hash text) + | P (Patch hash replacementHash text) + | N (Namespace hash text) + | C (Causal hash) + deriving stock (Show, Eq, Ord) + +instance (ToJSON hash, ToJSON replacementHash, ToJSON text) => ToJSON (Entity hash replacementHash text) where + toJSON = \case + TC tc -> + object + [ "type" .= TermComponentType, + "object" .= tc + ] + DC dc -> + object + [ "type" .= DeclComponentType, + "object" .= dc + ] + P patch -> + object + [ "type" .= PatchType, + "object" .= patch + ] + N ns -> + object + [ "type" .= NamespaceType, + "object" .= ns + ] + C causal -> + object + [ "type" .= CausalType, + "object" .= causal + ] + +instance (FromJSON hash, FromJSON replacementHash, FromJSON text, Ord hash) => FromJSON (Entity hash replacementHash text) where + parseJSON = Aeson.withObject "Entity" $ \obj -> do + entityType <- obj .: "type" + case entityType of + TermComponentType -> TC <$> obj .: "object" + DeclComponentType -> DC <$> obj .: "object" + PatchType -> P <$> obj .: "object" + NamespaceType -> N <$> obj .: "object" + CausalType -> C <$> obj .: "object" + +data TermComponent hash text = TermComponent [(LocalIds hash text, ByteString)] + deriving stock (Show, Eq, Ord) + +instance Bifoldable TermComponent where + bifoldMap = bifoldMapDefault + +instance Bifunctor TermComponent where + bimap = bimapDefault + +instance Bitraversable TermComponent where + bitraverse f g (TermComponent xs) = + TermComponent <$> bitraverseComponents f g xs + +instance (ToJSON hash, ToJSON text) => ToJSON (TermComponent hash text) where + toJSON (TermComponent components) = + object + [ "terms" .= (encodeComponentPiece <$> components) + ] + +bitraverseComponents :: + Applicative f => + (a -> f a') -> + (b -> f b') -> + [(LocalIds a b, ByteString)] -> + f [(LocalIds a' b', ByteString)] +bitraverseComponents f g = + traverse . _1 $ bitraverse f g + where + _1 f (l, r) = (,r) <$> f l + +encodeComponentPiece :: (ToJSON hash, ToJSON text) => (LocalIds hash text, ByteString) -> Value +encodeComponentPiece (localIDs, bytes) = + object + [ "local_ids" .= localIDs, + "bytes" .= Base64Bytes bytes + ] + +decodeComponentPiece :: (FromJSON hash, FromJSON text) => Value -> Aeson.Parser (LocalIds hash text, ByteString) +decodeComponentPiece = Aeson.withObject "Component Piece" $ \obj -> do + localIDs <- obj .: "local_ids" + Base64Bytes bytes <- obj .: "local_ids" + pure (localIDs, bytes) + +instance (FromJSON hash, FromJSON text) => FromJSON (TermComponent hash text) where + parseJSON = Aeson.withObject "TermComponent" $ \obj -> do + pieces <- obj .: "terms" + terms <- traverse decodeComponentPiece pieces + pure (TermComponent terms) + +data DeclComponent hash text = DeclComponent [(LocalIds hash text, ByteString)] + deriving stock (Show, Eq, Ord) + +instance Bifoldable DeclComponent where + bifoldMap = bifoldMapDefault + +instance Bifunctor DeclComponent where + bimap = bimapDefault + +instance Bitraversable DeclComponent where + bitraverse f g (DeclComponent xs) = + DeclComponent <$> bitraverseComponents f g xs + +instance (ToJSON hash, ToJSON text) => ToJSON (DeclComponent hash text) where + toJSON (DeclComponent components) = + object + [ "decls" .= (encodeComponentPiece <$> components) + ] + +instance (FromJSON hash, FromJSON text) => FromJSON (DeclComponent hash text) where + parseJSON = Aeson.withObject "DeclComponent" $ \obj -> do + pieces <- obj .: "decls" + terms <- traverse decodeComponentPiece pieces + pure (DeclComponent terms) + +data LocalIds hash text = LocalIds + { hashes :: [hash], + texts :: [text] + } + deriving stock (Show, Eq, Ord) + +instance Bifoldable LocalIds where + bifoldMap = bifoldMapDefault + +instance Bifunctor LocalIds where + bimap = bimapDefault + +instance Bitraversable LocalIds where + bitraverse f g (LocalIds hashes texts) = + LocalIds <$> traverse f hashes <*> traverse g texts + +instance (ToJSON hash, ToJSON text) => ToJSON (LocalIds hash text) where + toJSON (LocalIds hashes texts) = + object + [ "hashes" .= hashes, + "texts" .= texts + ] + +instance (FromJSON hash, FromJSON text) => FromJSON (LocalIds hash text) where + parseJSON = Aeson.withObject "LocalIds" $ \obj -> do + hashes <- obj .: "hashes" + texts <- obj .: "texts" + pure LocalIds {..} + +data Patch hash replacementHash text = Patch + { textLookup :: [text], + oldHashLookup :: [hash], + replacementHashLookup :: [replacementHash], + bytes :: ByteString + } + deriving stock (Show, Eq, Ord) + +instance (ToJSON hash, ToJSON replacementHash, ToJSON text) => ToJSON (Patch hash replacementHash text) where + toJSON (Patch textLookup hashLookup optionalHashLookup bytes) = + object + [ "text_lookup" .= textLookup, + "hash_lookup" .= hashLookup, + "optional_hash_lookup" .= optionalHashLookup, + "bytes" .= Base64Bytes bytes + ] + +instance (FromJSON hash, FromJSON replacementHash, FromJSON text) => FromJSON (Patch hash replacementHash text) where + parseJSON = Aeson.withObject "Patch" $ \obj -> do + textLookup <- obj .: "text_lookup" + oldHashLookup <- obj .: "hash_lookup" + replacementHashLookup <- obj .: "optional_hash_lookup" + Base64Bytes bytes <- obj .: "bytes" + pure (Patch {..}) + +data Namespace hash text = Namespace + { textLookup :: [text], + defnLookup :: [hash], + patchLookup :: [hash], + childLookup :: [hash], + bytes :: ByteString + } + deriving stock (Eq, Ord, Show) + +instance Bifoldable Namespace where + bifoldMap = bifoldMapDefault + +instance Bifunctor Namespace where + bimap = bimapDefault + +instance Bitraversable Namespace where + bitraverse f g (Namespace tl dl pl cl b) = + Namespace + <$> traverse g tl + <*> traverse f dl + <*> traverse f pl + <*> traverse f cl + <*> pure b + +instance (ToJSON hash, ToJSON text) => ToJSON (Namespace hash text) where + toJSON (Namespace textLookup defnLookup patchLookup childLookup bytes) = + object + [ "text_lookup" .= textLookup, + "defn_lookup" .= defnLookup, + "patch_lookup" .= patchLookup, + "child_lookup" .= childLookup, + "bytes" .= Base64Bytes bytes + ] + +instance (FromJSON hash, FromJSON text) => FromJSON (Namespace hash text) where + parseJSON = Aeson.withObject "Namespace" $ \obj -> do + textLookup <- obj .: "text_lookup" + defnLookup <- obj .: "defn_lookup" + patchLookup <- obj .: "patch_lookup" + childLookup <- obj .: "child_lookup" + Base64Bytes bytes <- obj .: "bytes" + pure Namespace {..} + +-- Client _may_ choose not to download the namespace entity in the future, but +-- we still send them the hash/hashjwt. +data Causal hash = Causal + { namespaceHash :: hash, + parents :: Set hash + } + deriving stock (Eq, Ord, Show) + +instance (ToJSON hash) => ToJSON (Causal hash) where + toJSON (Causal namespaceHash parents) = + object + [ "namespace_hash" .= namespaceHash, + "parents" .= parents + ] + +instance (FromJSON hash, Ord hash) => FromJSON (Causal hash) where + parseJSON = Aeson.withObject "Causal" $ \obj -> do + namespaceHash <- obj .: "namespace_hash" + parents <- obj .: "parents" + pure Causal {..} + +data EntityType + = TermComponentType + | DeclComponentType + | PatchType + | NamespaceType + | CausalType + deriving stock (Eq, Ord, Show) + +instance ToJSON EntityType where + toJSON et = String $ case et of + TermComponentType -> "term_component" + DeclComponentType -> "decl_component" + PatchType -> "patch" + NamespaceType -> "namespace" + CausalType -> "causal" + +instance FromJSON EntityType where + parseJSON = Aeson.withText "EntityType" \case + "term_component" -> pure TermComponentType + "decl_component" -> pure DeclComponentType + "patch" -> pure PatchType + "namespace" -> pure NamespaceType + "causal" -> pure CausalType + _ -> fail "Unexpected entity type" diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal new file mode 100644 index 0000000000..0cb38677fb --- /dev/null +++ b/unison-share-api/unison-share-api.cabal @@ -0,0 +1,64 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: unison-share-api +version: 0.0.0 +homepage: https://github.com/unisonweb/unison#readme +bug-reports: https://github.com/unisonweb/unison/issues +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors +build-type: Simple + +source-repository head + type: git + location: https://github.com/unisonweb/unison + +library + exposed-modules: + Unison.Sync.API + Unison.Sync.Types + other-modules: + Paths_unison_share_api + hs-source-dirs: + src + default-extensions: + BlockArguments + ConstraintKinds + DeriveAnyClass + DeriveFunctor + DerivingStrategies + DerivingVia + DoAndIfThenElse + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + KindSignatures + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NumericUnderscores + OverloadedStrings + PatternSynonyms + ScopedTypeVariables + TupleSections + TypeApplications + TypeOperators + ViewPatterns + ghc-options: -Wall + build-depends: + aeson + , base + , bytestring + , containers + , memory + , mtl + , nonempty-containers + , servant + , text + , transformers + , unliftio + default-language: Haskell2010 From be006ae5d05baef5a336ee46d4f59ed3f4c35417 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 1 Apr 2022 12:18:19 -0400 Subject: [PATCH 047/529] Fix a bug with code serialization. Get group was associating variables with local functions incorrectly. I had anticipated the right approach, but mistakenly didn't use it. --- .../src/Unison/Runtime/ANF/Serialize.hs | 2 +- unison-src/transcripts-using-base/codeops.md | 50 ++++++++++ .../transcripts-using-base/codeops.output.md | 92 +++++++++++++++++++ 3 files changed, 143 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs index 0a196d8491..ff0efc8bc1 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs @@ -272,7 +272,7 @@ getGroup = do vs = getFresh <$> take l [0 ..] ctx = pushCtx vs [] cs <- replicateM l (getComb ctx n) - Rec (zip ctx cs) <$> getComb ctx n + Rec (zip vs cs) <$> getComb ctx n putComb :: MonadPut m => diff --git a/unison-src/transcripts-using-base/codeops.md b/unison-src/transcripts-using-base/codeops.md index 0f7841764a..4a95e1e5a6 100644 --- a/unison-src/transcripts-using-base/codeops.md +++ b/unison-src/transcripts-using-base/codeops.md @@ -13,6 +13,14 @@ function. Also ask for its dependencies for display later. save : a -> Bytes save x = Value.serialize (Value.value x) +Code.save : Code -> Bytes +Code.save = Code.serialize + +Code.get : Link.Term -> Code +Code.get tl = match Code.lookup tl with + Some co -> co + None -> throw "could not look up code" + load : Bytes ->{io2.IO, Throw Text} a load b = match Value.deserialize b with Left _ -> throw "could not deserialize value" @@ -20,6 +28,11 @@ load b = match Value.deserialize b with Left _ -> throw "could not load value" Right x -> x +Code.load : Bytes ->{io2.IO, Throw Text} Code +Code.load b = match Code.deserialize b with + Left _ -> throw "could not deserialize code" + Right co -> co + roundtrip : a ->{io2.IO, Throw Text} a roundtrip x = load (save x) @@ -82,6 +95,16 @@ extensionality t f = let identicality : Text -> a ->{io2.IO} Result identicality t x = handle identical "" x (roundtrip x) with handleTest t + +idempotence : Text -> Link.Term ->{io2.IO} Result +idempotence t tl = + handle let + co1 = Code.get tl + b1 = Code.save co1 + co2 = Code.load b1 + b2 = Code.save co2 + identical "" b1 b2 + with handleTest t ``` ```ucm @@ -121,6 +144,13 @@ zapper t = cases { r } -> r { zap -> k } -> handle k t with zapper (rotate t) +bigFun : Nat -> Nat -> Nat -> Nat +bigFun i j k = let + f x y = i + x + y + g x y = j + x + y + h x y = k + x + y + f j k + g i k + h i j + tests : '{io2.IO} [Result] tests = '[ extensionality "ext f" (t x -> handle f x with zapper t) @@ -167,6 +197,26 @@ to actual show that the serialization works. .> io.test badLoad ``` +```unison +codeTests : '{io2.IO} [Result] +codeTests = + '[ idempotence "idem f" (termLink f) + , idempotence "idem h" (termLink h) + , idempotence "idem rotate" (termLink rotate) + , idempotence "idem zapper" (termLink zapper) + , idempotence "idem showThree" (termLink showThree) + , idempotence "idem concatMap" (termLink concatMap) + , idempotence "idem big" (termLink bigFun) + , idempotence "idem extensionality" (termLink extensionality) + , idempotence "idem identicality" (termLink identicality) + ] +``` + +```ucm +.> add +.> io.test codeTests +``` + ```unison validateTest : Link.Term ->{IO} Result validateTest l = match Code.lookup l with diff --git a/unison-src/transcripts-using-base/codeops.output.md b/unison-src/transcripts-using-base/codeops.output.md index 812b79360e..fcd9467b60 100644 --- a/unison-src/transcripts-using-base/codeops.output.md +++ b/unison-src/transcripts-using-base/codeops.output.md @@ -8,6 +8,14 @@ function. Also ask for its dependencies for display later. save : a -> Bytes save x = Value.serialize (Value.value x) +Code.save : Code -> Bytes +Code.save = Code.serialize + +Code.get : Link.Term -> Code +Code.get tl = match Code.lookup tl with + Some co -> co + None -> throw "could not look up code" + load : Bytes ->{io2.IO, Throw Text} a load b = match Value.deserialize b with Left _ -> throw "could not deserialize value" @@ -15,6 +23,11 @@ load b = match Value.deserialize b with Left _ -> throw "could not load value" Right x -> x +Code.load : Bytes ->{io2.IO, Throw Text} Code +Code.load b = match Code.deserialize b with + Left _ -> throw "could not deserialize code" + Right co -> co + roundtrip : a ->{io2.IO, Throw Text} a roundtrip x = load (save x) @@ -77,6 +90,16 @@ extensionality t f = let identicality : Text -> a ->{io2.IO} Result identicality t x = handle identical "" x (roundtrip x) with handleTest t + +idempotence : Text -> Link.Term ->{io2.IO} Result +idempotence t tl = + handle let + co1 = Code.get tl + b1 = Code.save co1 + co2 = Code.load b1 + b2 = Code.save co2 + identical "" b1 b2 + with handleTest t ``` ```ucm @@ -88,6 +111,9 @@ identicality t x โŸ These new definitions are ok to `add`: structural type Three a b c + Code.get : Link.Term ->{IO, Throw Text} Code + Code.load : Bytes ->{IO, Throw Text} Code + Code.save : Code -> Bytes concatMap : (a ->{g} [b]) -> [a] ->{g} [b] extensionality : Text -> (Three Nat Nat Nat -> Nat -> b) @@ -99,6 +125,7 @@ identicality t x ->{Throw Text} () fib10 : [Nat] handleTest : Text -> Request {Throw Text} a -> Result + idempotence : Text -> Link.Term ->{IO} Result identical : Text -> a -> a ->{Throw Text} () identicality : Text -> a ->{IO} Result load : Bytes ->{IO, Throw Text} a @@ -115,6 +142,9 @@ identicality t x โŸ I've added these definitions: structural type Three a b c + Code.get : Link.Term ->{IO, Throw Text} Code + Code.load : Bytes ->{IO, Throw Text} Code + Code.save : Code -> Bytes concatMap : (a ->{g} [b]) -> [a] ->{g} [b] extensionality : Text -> (Three Nat Nat Nat -> Nat -> b) @@ -126,6 +156,7 @@ identicality t x ->{Throw Text} () fib10 : [Nat] handleTest : Text -> Request {Throw Text} a -> Result + idempotence : Text -> Link.Term ->{IO} Result identical : Text -> a -> a ->{Throw Text} () identicality : Text -> a ->{IO} Result load : Bytes ->{IO, Throw Text} a @@ -169,6 +200,13 @@ zapper t = cases { r } -> r { zap -> k } -> handle k t with zapper (rotate t) +bigFun : Nat -> Nat -> Nat -> Nat +bigFun i j k = let + f x y = i + x + y + g x y = j + x + y + h x y = k + x + y + f j k + g i k + h i j + tests : '{io2.IO} [Result] tests = '[ extensionality "ext f" (t x -> handle f x with zapper t) @@ -214,6 +252,7 @@ badLoad _ = structural ability Zap badLoad : '{IO} [Result] + bigFun : Nat -> Nat -> Nat -> Nat f : Nat ->{Zap} Nat fDeps : [Link.Term] fSer : Bytes @@ -235,6 +274,7 @@ to actual show that the serialization works. structural ability Zap badLoad : '{IO} [Result] + bigFun : Nat -> Nat -> Nat -> Nat f : Nat ->{Zap} Nat fDeps : [Link.Term] fSer : Bytes @@ -280,6 +320,58 @@ to actual show that the serialization works. Tip: Use view badLoad to view the source of a test. +``` +```unison +codeTests : '{io2.IO} [Result] +codeTests = + '[ idempotence "idem f" (termLink f) + , idempotence "idem h" (termLink h) + , idempotence "idem rotate" (termLink rotate) + , idempotence "idem zapper" (termLink zapper) + , idempotence "idem showThree" (termLink showThree) + , idempotence "idem concatMap" (termLink concatMap) + , idempotence "idem big" (termLink bigFun) + , idempotence "idem extensionality" (termLink extensionality) + , idempotence "idem identicality" (termLink identicality) + ] +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + codeTests : '{IO} [Result] + +``` +```ucm +.> add + + โŸ I've added these definitions: + + codeTests : '{IO} [Result] + +.> io.test codeTests + + New test results: + + โ—‰ codeTests (idem f) passed + โ—‰ codeTests (idem h) passed + โ—‰ codeTests (idem rotate) passed + โ—‰ codeTests (idem zapper) passed + โ—‰ codeTests (idem showThree) passed + โ—‰ codeTests (idem concatMap) passed + โ—‰ codeTests (idem big) passed + โ—‰ codeTests (idem extensionality) passed + โ—‰ codeTests (idem identicality) passed + + โœ… 9 test(s) passing + + Tip: Use view codeTests to view the source of a test. + ``` ```unison validateTest : Link.Term ->{IO} Result From d728a7aaee36ecde13d4414825741915b72f1dc8 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 1 Apr 2022 10:59:56 -0600 Subject: [PATCH 048/529] Add MonadUnliftIO to unison-prelude --- .../codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 16 ++-------------- lib/unison-prelude/src/Unison/Prelude.hs | 3 ++- .../src/Unison/Sqlite/Connection.hs | 1 - lib/unison-sqlite/src/Unison/Sqlite/DB.hs | 1 - parser-typechecker/src/Unison/Codebase.hs | 1 - .../src/Unison/Codebase/Editor/Git.hs | 1 - parser-typechecker/src/Unison/Codebase/Init.hs | 1 - .../src/Unison/Codebase/SqliteCodebase.hs | 2 +- .../Unison/Codebase/SqliteCodebase/Migrations.hs | 1 - .../Migrations/MigrateSchema1To2.hs | 1 - .../Migrations/MigrateSchema2To3.hs | 2 +- unison-cli/src/Unison/Codebase/Editor/Command.hs | 2 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 1 - 13 files changed, 7 insertions(+), 26 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 0f044f2083..24238a28f4 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -144,28 +144,18 @@ module U.Codebase.Sqlite.Queries where import qualified Control.Exception as Exception -import Control.Monad (when) import Control.Monad.Except (MonadError) import qualified Control.Monad.Except as Except -import Control.Monad.IO.Class (MonadIO) import Control.Monad.Reader (MonadReader (ask)) import qualified Control.Monad.Reader as Reader -import Control.Monad.Trans (MonadIO (liftIO)) -import Control.Monad.Trans.Maybe (MaybeT (MaybeT), runMaybeT) import qualified Control.Monad.Writer as Writer -import Data.ByteString (ByteString) import qualified Data.Char as Char -import Data.Foldable (traverse_) -import Data.Functor ((<&>)) -import Data.Int (Int8) import qualified Data.List.Extra as List import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel import Data.Maybe (fromJust) import qualified Data.Set as Set -import Data.String (fromString) import Data.String.Here.Uninterpolated (here, hereFile) -import Data.Text (Text) import Database.SQLite.Simple ( FromRow, Only (..), @@ -175,9 +165,6 @@ import Database.SQLite.Simple import qualified Database.SQLite.Simple as SQLite import Database.SQLite.Simple.FromField (FromField (..)) import Database.SQLite.Simple.ToField (ToField (..)) -import Debug.Trace (trace, traceM) -import GHC.Stack (HasCallStack) -import Safe (headMay) import U.Codebase.HashTags (BranchHash (..), CausalHash (..)) import U.Codebase.Reference (Reference' (..)) import qualified U.Codebase.Reference as C.Reference @@ -204,7 +191,8 @@ import qualified U.Util.Alternative as Alternative import U.Util.Base32Hex (Base32Hex (..)) import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash -import UnliftIO (MonadUnliftIO, throwIO, try, tryAny, withRunInIO) +import Unison.Prelude +import UnliftIO (throwIO, tryAny) import qualified UnliftIO import UnliftIO.Concurrent (myThreadId) diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index 504bdb7dc7..827aa52cb0 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -25,7 +25,7 @@ where import Control.Applicative as X import Control.Category as X ((>>>)) -import Control.Exception as X (Exception, IOException, SomeException, try) +import Control.Exception as X (Exception, IOException, SomeException) import Control.Monad as X import Control.Monad.Extra as X (ifM, mapMaybeM, unlessM, whenM) import Control.Monad.IO.Class as X (MonadIO (liftIO)) @@ -61,6 +61,7 @@ import GHC.Stack as X (HasCallStack) import Safe as X (atMay, headMay, lastMay, readMay) import qualified System.IO as IO import Text.Read as X (readMaybe) +import UnliftIO as X (MonadUnliftIO (..), askRunInIO, askUnliftIO, toIO, try, withUnliftIO) import qualified UnliftIO -- | E.g. diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index f6f48c8c00..e0955ba50f 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -67,7 +67,6 @@ import qualified Unison.Debug as Debug import Unison.Prelude import Unison.Sqlite.Exception import Unison.Sqlite.Sql -import UnliftIO (MonadUnliftIO) import UnliftIO.Exception -- | A /non-thread safe/ connection to a SQLite database. diff --git a/lib/unison-sqlite/src/Unison/Sqlite/DB.hs b/lib/unison-sqlite/src/Unison/Sqlite/DB.hs index 6bddcc6595..0c025d5f75 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/DB.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/DB.hs @@ -56,7 +56,6 @@ module Unison.Sqlite.DB ) where -import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) import qualified Database.SQLite.Simple as Sqlite import qualified Database.SQLite.Simple.FromField as Sqlite diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index b82d8ec2c7..c944dd7da9 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -142,7 +142,6 @@ import qualified Unison.UnisonFile as UF import qualified Unison.Util.Relation as Rel import Unison.Var (Var) import qualified Unison.WatchKind as WK -import UnliftIO (MonadUnliftIO) -- | Get a branch from the codebase. getBranchForHash :: Monad m => Codebase m v a -> Branch.Hash -> m (Maybe (Branch m)) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs index 421eeb5fd1..7d2432e933 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs @@ -32,7 +32,6 @@ import Unison.Codebase.Editor.RemoteRepo (ReadRepo (..)) import Unison.Codebase.GitError (GitProtocolError) import qualified Unison.Codebase.GitError as GitError import Unison.Prelude -import UnliftIO (MonadUnliftIO) import qualified UnliftIO import UnliftIO.Directory (XdgDirectory (XdgCache), doesDirectoryExist, findExecutable, getXdgDirectory) import UnliftIO.Environment (lookupEnv) diff --git a/parser-typechecker/src/Unison/Codebase/Init.hs b/parser-typechecker/src/Unison/Codebase/Init.hs index 2e1cffc0e0..ee3fe950a3 100644 --- a/parser-typechecker/src/Unison/Codebase/Init.hs +++ b/parser-typechecker/src/Unison/Codebase/Init.hs @@ -28,7 +28,6 @@ import Unison.Prelude import qualified Unison.PrettyTerminal as PT import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P -import UnliftIO (MonadUnliftIO) import qualified UnliftIO import UnliftIO.Directory (canonicalizePath) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 5ff40d44a2..338b75e7a6 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -97,7 +97,7 @@ import Unison.Type (Type) import qualified Unison.Type as Type import qualified Unison.Util.Set as Set import qualified Unison.WatchKind as UF -import UnliftIO (MonadUnliftIO, catchIO, finally, throwIO, try) +import UnliftIO (catchIO, finally, throwIO, try) import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import UnliftIO.Exception (bracket, catch) import UnliftIO.STM diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index ff747ab47d..e993517d71 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -19,7 +19,6 @@ import Unison.Codebase.Type (Codebase, LocalOrRemote (..)) import Unison.Prelude import Unison.Symbol (Symbol) import Unison.Var (Var) -import UnliftIO (MonadUnliftIO) import qualified UnliftIO type Migration m a v = Connection -> Codebase m v a -> m (Either MigrationError ()) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index bd4e61db50..0964c07fc6 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -79,7 +79,6 @@ import Unison.Type (Type) import qualified Unison.Type as Type import qualified Unison.Util.Set as Set import Unison.Var (Var) -import UnliftIO (MonadUnliftIO) import UnliftIO.Exception (bracket_, onException) -- todo: diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs index 0dfd2350c0..0517d95b8b 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs @@ -7,7 +7,7 @@ import qualified U.Codebase.Sqlite.Queries as Q import Unison.Codebase (Codebase) import Unison.Codebase.SqliteCodebase.Migrations.Errors (MigrationError (IncorrectStartingSchemaVersion)) import Unison.Var (Var) -import UnliftIO (MonadUnliftIO) +import Unison.Prelude import qualified UnliftIO -- | The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this diff --git a/unison-cli/src/Unison/Codebase/Editor/Command.hs b/unison-cli/src/Unison/Codebase/Editor/Command.hs index 48d3fa6c04..ce966729ce 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Command.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Command.hs @@ -74,7 +74,7 @@ import qualified Unison.UnisonFile as UF import Unison.Util.Free (Free) import qualified Unison.Util.Free as Free import qualified Unison.WatchKind as WK -import UnliftIO (MonadUnliftIO (..), UnliftIO) +import UnliftIO (UnliftIO) import qualified UnliftIO type AmbientAbilities v = [Type v Ann] diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index d405d47e97..723e8fbed8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -151,7 +151,6 @@ import Unison.Util.TransitiveClosure (transitiveClosure) import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.WatchKind as WK -import UnliftIO (MonadUnliftIO) defaultPatchNameSegment :: NameSegment defaultPatchNameSegment = "patch" From 298397503ac0bde6aeac052bd914a8853ce9d238 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 1 Apr 2022 16:07:25 -0600 Subject: [PATCH 049/529] Remove toIO from prelude --- lib/unison-prelude/src/Unison/Prelude.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index 827aa52cb0..83025193c9 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -61,7 +61,7 @@ import GHC.Stack as X (HasCallStack) import Safe as X (atMay, headMay, lastMay, readMay) import qualified System.IO as IO import Text.Read as X (readMaybe) -import UnliftIO as X (MonadUnliftIO (..), askRunInIO, askUnliftIO, toIO, try, withUnliftIO) +import UnliftIO as X (MonadUnliftIO (..), askRunInIO, askUnliftIO, try, withUnliftIO) import qualified UnliftIO -- | E.g. From 3e2a1fc7ed181732f1959ca5bae7622aadfdb4f0 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 4 Apr 2022 10:30:35 -0400 Subject: [PATCH 050/529] pretty-print exceptions in default exception handler --- unison-cli/unison/Main.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index f8f0b5bdda..c8c747f414 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -24,6 +24,7 @@ import Compat (defaultInterruptHandler, withInterruptHandler) import Control.Concurrent (forkIO, newEmptyMVar, takeMVar) import Control.Error.Safe (rightMay) import Control.Exception (evaluate) +import Data.Bifunctor import qualified Data.ByteString.Lazy as BL import Data.Configurator.Types (Config) import Data.Either.Validation (Validation (..)) @@ -31,6 +32,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.IO as Text +import GHC.Conc (setUncaughtExceptionHandler) import qualified GHC.Conc import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTP @@ -38,11 +40,13 @@ import System.Directory (canonicalizePath, getCurrentDirectory, removeDirectoryR import System.Environment (getProgName, withArgs) import qualified System.Exit as Exit import qualified System.FilePath as FP +import System.IO (stderr) import System.IO.CodePage (withCP65001) import System.IO.Error (catchIOError) import qualified System.IO.Temp as Temp import qualified System.Path as Path import Text.Megaparsec (runParser) +import Text.Pretty.Simple (pHPrint) import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Editor.Input as Input @@ -70,10 +74,12 @@ import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P import UnliftIO.Directory (getHomeDirectory) import qualified Version -import Data.Bifunctor main :: IO () main = withCP65001 do + -- Replace the default exception handler with one that pretty-prints. + setUncaughtExceptionHandler (pHPrint stderr) + interruptHandler <- defaultInterruptHandler withInterruptHandler interruptHandler $ do forkIO initHTTPClient From fddb55ba3c44a5c17cf0a4950c60f7d804bf7557 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 4 Apr 2022 11:51:07 -0400 Subject: [PATCH 051/529] remove Unison.Sqlite.DB from unison-sqlite --- lib/unison-sqlite/package.yaml | 1 + lib/unison-sqlite/src/Unison/Sqlite.hs | 16 +- lib/unison-sqlite/src/Unison/Sqlite/DB.hs | 265 ------------------ .../src/Unison/Sqlite/Transaction.hs | 21 +- lib/unison-sqlite/unison-sqlite.cabal | 2 +- 5 files changed, 28 insertions(+), 277 deletions(-) delete mode 100644 lib/unison-sqlite/src/Unison/Sqlite/DB.hs diff --git a/lib/unison-sqlite/package.yaml b/lib/unison-sqlite/package.yaml index cfd4f2e5ac..094e72421e 100644 --- a/lib/unison-sqlite/package.yaml +++ b/lib/unison-sqlite/package.yaml @@ -15,6 +15,7 @@ dependencies: - direct-sqlite - exceptions - mtl + - random - recover-rtti - sqlite-simple - text diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index 86dac3ad33..d1446c2834 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -8,18 +8,17 @@ -- -- * "Unison.Sqlite.Connection" provides an interface in @IO@, which takes the 'Connection' argument as an explicit -- argument. --- * "Unison.Sqlite.DB" provides a type class interface, which moves the 'Connection' to an implicit argument. This --- interface is also re-exported by this module, for convenient backwards compatibility with the existing queries. --- * "Unison.Sqlite.Transaction" provides a newer, yet-unused interface that executes queries in transactions, with --- automatic retries on @SQLITE_BUSY@ due to concurrent writers. +-- * "Unison.Sqlite.Transaction" provides a safer interface that executes queries in transactions, with automatic +-- retries on @SQLITE_BUSY@ due to concurrent writers. module Unison.Sqlite ( -- * Connection management Connection, withConnection, - -- * Type class query interface - DB, - runDB, + -- * Transaction interface + Transaction, + runTransaction, + savepoint, -- * Executing queries Sql (..), @@ -77,7 +76,6 @@ module Unison.Sqlite trySetJournalMode, -- ** Low-level - withSavepoint, withStatement, -- * Exceptions @@ -114,7 +112,6 @@ import Unison.Sqlite.Connection withConnection, withStatement, ) -import Unison.Sqlite.DB import Unison.Sqlite.DataVersion (DataVersion (..), getDataVersion) import Unison.Sqlite.Exception ( SomeSqliteException (..), @@ -126,6 +123,7 @@ import Unison.Sqlite.Exception ) import Unison.Sqlite.JournalMode (JournalMode (..), SetJournalModeException (..), trySetJournalMode) import Unison.Sqlite.Sql (Sql (..)) +import Unison.Sqlite.Transaction -- $query-naming-convention -- diff --git a/lib/unison-sqlite/src/Unison/Sqlite/DB.hs b/lib/unison-sqlite/src/Unison/Sqlite/DB.hs deleted file mode 100644 index bfd234ea9f..0000000000 --- a/lib/unison-sqlite/src/Unison/Sqlite/DB.hs +++ /dev/null @@ -1,265 +0,0 @@ --- | A type class interface to SQLite. -module Unison.Sqlite.DB - ( -- * Type-class - DB, - runDB, - runTransaction, - - -- * Executing queries - - -- ** Without results - - -- *** With parameters - execute, - executeMany, - - -- *** Without parameters - execute_, - - -- ** With results - - -- *** With parameters - queryListRow, - queryListCol, - queryMaybeRow, - queryMaybeCol, - queryOneRow, - queryOneCol, - - -- **** With checks - queryListRowCheck, - queryListColCheck, - queryMaybeRowCheck, - queryMaybeColCheck, - queryOneRowCheck, - queryOneColCheck, - - -- *** Without parameters - queryListRow_, - queryListCol_, - queryMaybeRow_, - queryMaybeCol_, - queryOneRow_, - queryOneCol_, - - -- **** With checks - queryListRowCheck_, - queryListColCheck_, - queryMaybeRowCheck_, - queryMaybeColCheck_, - queryOneRowCheck_, - queryOneColCheck_, - - -- * Low-level operations - withSavepoint, - ) -where - -import Control.Monad.Reader (MonadReader, ReaderT, ask, runReaderT) -import qualified Database.SQLite.Simple as Sqlite -import qualified Database.SQLite.Simple.FromField as Sqlite -import Unison.Prelude -import Unison.Sqlite.Connection (Connection) -import qualified Unison.Sqlite.Connection as Connection -import Unison.Sqlite.Exception (SqliteExceptionReason) -import Unison.Sqlite.Sql (Sql (..)) -import Unison.Sqlite.Transaction (Transaction) -import qualified Unison.Sqlite.Transaction as Transaction - -type DB m = - (MonadIO m, MonadReader Connection m) - -runDB :: MonadIO m => Connection -> ReaderT Connection m a -> m a -runDB conn action = - runReaderT action conn - -runTransaction :: DB m => Transaction a -> m a -runTransaction transaction = do - conn <- ask - Transaction.runTransaction conn transaction - --- Without results, with parameters - -execute :: (DB m, Sqlite.ToRow a) => Sql -> a -> m () -execute s params = do - conn <- ask - liftIO (Connection.execute conn s params) - -executeMany :: (DB m, Sqlite.ToRow a) => Sql -> [a] -> m () -executeMany s params = do - conn <- ask - liftIO (Connection.executeMany conn s params) - --- Without results, without parameters - -execute_ :: DB m => Sql -> m () -execute_ s = do - conn <- ask - liftIO (Connection.execute_ conn s) - --- With results, with parameters, without checks - -queryListRow :: (DB m, Sqlite.FromRow a, Sqlite.ToRow b) => Sql -> b -> m [a] -queryListRow s params = do - conn <- ask - liftIO (Connection.queryListRow conn s params) - -queryListCol :: (DB m, Sqlite.FromField a, Sqlite.ToRow b) => Sql -> b -> m [a] -queryListCol s params = do - conn <- ask - liftIO (Connection.queryListCol conn s params) - -queryMaybeRow :: (DB m, Sqlite.FromRow a, Sqlite.ToRow b) => Sql -> b -> m (Maybe a) -queryMaybeRow s params = do - conn <- ask - liftIO (Connection.queryMaybeRow conn s params) - -queryMaybeCol :: (DB m, Sqlite.FromField a, Sqlite.ToRow b) => Sql -> b -> m (Maybe a) -queryMaybeCol s params = do - conn <- ask - liftIO (Connection.queryMaybeCol conn s params) - -queryOneRow :: (DB m, Sqlite.FromRow b, Sqlite.ToRow a) => Sql -> a -> m b -queryOneRow s params = do - conn <- ask - liftIO (Connection.queryOneRow conn s params) - -queryOneCol :: (DB m, Sqlite.FromField b, Sqlite.ToRow a) => Sql -> a -> m b -queryOneCol s params = do - conn <- ask - liftIO (Connection.queryOneCol conn s params) - --- With results, with parameters, with checks - -queryListRowCheck :: - (DB m, Sqlite.FromRow b, Sqlite.ToRow a, SqliteExceptionReason e) => - Sql -> - a -> - ([b] -> Either e r) -> - m r -queryListRowCheck s params check = do - conn <- ask - liftIO (Connection.queryListRowCheck conn s params check) - -queryListColCheck :: - (DB m, Sqlite.FromField b, Sqlite.ToRow a, SqliteExceptionReason e) => - Sql -> - a -> - ([b] -> Either e r) -> - m r -queryListColCheck s params check = do - conn <- ask - liftIO (Connection.queryListColCheck conn s params check) - -queryMaybeRowCheck :: - (DB m, Sqlite.FromRow b, Sqlite.ToRow a, SqliteExceptionReason e) => - Sql -> - a -> - (b -> Either e r) -> - m (Maybe r) -queryMaybeRowCheck s params check = do - conn <- ask - liftIO (Connection.queryMaybeRowCheck conn s params check) - -queryMaybeColCheck :: - (DB m, Sqlite.FromField b, Sqlite.ToRow a, SqliteExceptionReason e) => - Sql -> - a -> - (b -> Either e r) -> - m (Maybe r) -queryMaybeColCheck s params check = do - conn <- ask - liftIO (Connection.queryMaybeColCheck conn s params check) - -queryOneRowCheck :: - (DB m, Sqlite.FromRow b, Sqlite.ToRow a, SqliteExceptionReason e) => - Sql -> - a -> - (b -> Either e r) -> - m r -queryOneRowCheck s params check = do - conn <- ask - liftIO (Connection.queryOneRowCheck conn s params check) - -queryOneColCheck :: - (DB m, Sqlite.FromField b, Sqlite.ToRow a, SqliteExceptionReason e) => - Sql -> - a -> - (b -> Either e r) -> - m r -queryOneColCheck s params check = do - conn <- ask - liftIO (Connection.queryOneColCheck conn s params check) - --- With results, without parameters, without checks - -queryListRow_ :: (DB m, Sqlite.FromRow a) => Sql -> m [a] -queryListRow_ s = do - conn <- ask - liftIO (Connection.queryListRow_ conn s) - -queryListCol_ :: (DB m, Sqlite.FromField a) => Sql -> m [a] -queryListCol_ s = do - conn <- ask - liftIO (Connection.queryListCol_ conn s) - -queryMaybeRow_ :: (DB m, Sqlite.FromRow a) => Sql -> m (Maybe a) -queryMaybeRow_ s = do - conn <- ask - liftIO (Connection.queryMaybeRow_ conn s) - -queryMaybeCol_ :: (DB m, Sqlite.FromField a) => Sql -> m (Maybe a) -queryMaybeCol_ s = do - conn <- ask - liftIO (Connection.queryMaybeCol_ conn s) - -queryOneRow_ :: (DB m, Sqlite.FromRow a) => Sql -> m a -queryOneRow_ s = do - conn <- ask - liftIO (Connection.queryOneRow_ conn s) - -queryOneCol_ :: (DB m, Sqlite.FromField a) => Sql -> m a -queryOneCol_ s = do - conn <- ask - liftIO (Connection.queryOneCol_ conn s) - --- With results, without parameters, with checks - -queryListRowCheck_ :: (DB m, Sqlite.FromRow a, SqliteExceptionReason e) => Sql -> ([a] -> Either e r) -> m r -queryListRowCheck_ s check = do - conn <- ask - liftIO (Connection.queryListRowCheck_ conn s check) - -queryListColCheck_ :: (DB m, Sqlite.FromField a, SqliteExceptionReason e) => Sql -> ([a] -> Either e r) -> m r -queryListColCheck_ s check = do - conn <- ask - liftIO (Connection.queryListColCheck_ conn s check) - -queryMaybeRowCheck_ :: (DB m, Sqlite.FromRow a, SqliteExceptionReason e) => Sql -> (a -> Either e r) -> m (Maybe r) -queryMaybeRowCheck_ s check = do - conn <- ask - liftIO (Connection.queryMaybeRowCheck_ conn s check) - -queryMaybeColCheck_ :: (DB m, Sqlite.FromField a, SqliteExceptionReason e) => Sql -> (a -> Either e r) -> m (Maybe r) -queryMaybeColCheck_ s check = do - conn <- ask - liftIO (Connection.queryMaybeColCheck_ conn s check) - -queryOneRowCheck_ :: (DB m, Sqlite.FromRow a, SqliteExceptionReason e) => Sql -> (a -> Either e r) -> m r -queryOneRowCheck_ s check = do - conn <- ask - liftIO (Connection.queryOneRowCheck_ conn s check) - -queryOneColCheck_ :: (DB m, Sqlite.FromField a, SqliteExceptionReason e) => Sql -> (a -> Either e r) -> m r -queryOneColCheck_ s check = do - conn <- ask - liftIO (Connection.queryOneColCheck_ conn s check) - --- Low-level - --- | Perform an action within a named savepoint. The action is provided a rollback action. -withSavepoint :: (DB m, MonadUnliftIO m) => Text -> (m () -> m a) -> m a -withSavepoint name action = do - conn <- ask - withRunInIO \unlift -> - liftIO (Connection.withSavepointIO conn name (unlift . action . liftIO)) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index e80171d1a3..16976b3c13 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -2,6 +2,7 @@ module Unison.Sqlite.Transaction ( -- * Transaction management Transaction, runTransaction, + savepoint, -- * Executing queries @@ -53,14 +54,16 @@ where import Control.Concurrent (threadDelay) import Control.Exception (Exception (fromException), onException, throwIO) import Control.Monad.Trans.Reader (ReaderT (..)) +import qualified Data.Text as Text import qualified Database.SQLite.Simple as Sqlite import qualified Database.SQLite.Simple.FromField as Sqlite -import Unison.Prelude hiding (try) +import qualified System.Random as Random +import Unison.Prelude import Unison.Sqlite.Connection (Connection (..)) import qualified Unison.Sqlite.Connection as Connection import Unison.Sqlite.Exception (SqliteExceptionReason, SqliteQueryException, pattern SqliteBusyException) import Unison.Sqlite.Sql -import UnliftIO.Exception (catchAny, try, trySyncOrAsync, uninterruptibleMask) +import UnliftIO.Exception (catchAny, trySyncOrAsync, uninterruptibleMask) newtype Transaction a = Transaction (Connection -> IO a) @@ -100,6 +103,20 @@ runTransaction conn (Transaction f) = liftIO do ignoringExceptions action = action `catchAny` \_ -> pure () +savepoint :: Transaction (Either a a) -> Transaction a +savepoint (Transaction action) = do + Transaction \conn -> do + -- Generate a random name for the savepoint, so the caller isn't burdened with coming up with a name. Seems + -- extremely unlikely for this to go wrong (i.e. some super nested withSavepoint call that ends up generating the + -- same savepoint name twice in a single scope). + name <- Text.pack <$> replicateM 10 (Random.randomRIO ('a', 'z')) + Connection.withSavepointIO conn name \rollback -> + action conn >>= \case + Left result -> do + rollback + pure result + Right result -> pure result + -- Without results, with parameters execute :: Sqlite.ToRow a => Sql -> a -> Transaction () diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 0d7820ebba..8c1aae765a 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -20,7 +20,6 @@ library Unison.Sqlite Unison.Sqlite.Connection Unison.Sqlite.Connection.Internal - Unison.Sqlite.DB Unison.Sqlite.Transaction other-modules: Unison.Sqlite.DataVersion @@ -59,6 +58,7 @@ library , direct-sqlite , exceptions , mtl + , random , recover-rtti , sqlite-simple , text From 3f66cf9a6f957bf86dad0f3e095bfd463f5b7fa6 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 4 Apr 2022 18:10:38 -0400 Subject: [PATCH 052/529] do some work on ooo-sync --- codebase2/codebase-sqlite/package.yaml | 1 + .../unison-codebase-sqlite.cabal | 1 + unison-cli/package.yaml | 4 + unison-cli/src/Unison/Share/Sync.hs | 90 +++++++++++++++++++ unison-cli/unison-cli.cabal | 21 +++++ 5 files changed, 117 insertions(+) create mode 100644 unison-cli/src/Unison/Share/Sync.hs diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index 6763204c62..caadc6620b 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -7,6 +7,7 @@ default-extensions: - BlockArguments - ConstraintKinds - DeriveFunctor + - DeriveGeneric - DerivingStrategies - DoAndIfThenElse - FlexibleContexts diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 9b6712975c..06d552a9b9 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -52,6 +52,7 @@ library BlockArguments ConstraintKinds DeriveFunctor + DeriveGeneric DerivingStrategies DoAndIfThenElse FlexibleContexts diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 0abd6d0f6b..87062002fb 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -34,6 +34,7 @@ dependencies: - regex-tdfa - stm - text + - unison-codebase - unison-codebase-sqlite - unison-core1 - unison-parser-typechecker @@ -41,6 +42,7 @@ dependencies: - unison-util - unison-util-relation - unison-pretty-printer + - unison-share-api - unliftio - network-uri - aeson @@ -125,12 +127,14 @@ default-extensions: - DeriveGeneric - DerivingStrategies - DoAndIfThenElse + - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving - LambdaCase - MultiParamTypeClasses - NamedFieldPuns + - OverloadedLabels - OverloadedStrings - PatternSynonyms - RankNTypes diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs new file mode 100644 index 0000000000..a33382201d --- /dev/null +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -0,0 +1,90 @@ +module Unison.Share.Sync where + +import U.Codebase.HashTags (CausalHash (unCausalHash)) +import U.Codebase.Sqlite.Causal (DbCausal, GDbCausal (..)) +import qualified U.Codebase.Sqlite.Causal as Sqlite.Causal (GDbCausal (..)) +import U.Codebase.Sqlite.DbId (CausalHashId (..), HashId) +import qualified U.Util.Base32Hex as Base32Hex +import qualified U.Util.Hash as Hash +import Unison.Prelude +import qualified Unison.Sync.Types as Share + +data UpdatePathResponse + = UpdatePathSuccess + | UpdatePathHashMismatch Share.HashMismatch + | UpdatePathMissingDependencies (Share.NeedDependencies Share.Hash) + +-- deriving stock (Show, Eq, Ord, Generic) + +__api_updatePath :: Share.UpdatePathRequest -> IO UpdatePathResponse +__api_updatePath = undefined + +-- Push +-- +-- 1. Update path +-- 2. Possibly do some upload entities +-- +-- I can communicate with my fingers +-- + +data PushError + = PushErrorHashMismatch Share.HashMismatch + +-- Option 1: have push be itself in the Transaction monad, use unsafePerformIdempotentIO +-- fuction to do the interleaved IO calls (http, etc) +-- +-- push :: RepoPath -> ... -> Transaction (Either PushError ()) +-- push = do +-- unsafePerformIdempotentIO (updatePath ...) +-- +-- Option 2: have push "go around" the Transaction abstraction by beginning/commiting explicitly, +-- and immediately un-Transaction-newtyping the low-level calls like loadHashId +-- +-- push :: Connection -> RepoPath -> ... -> IO (Either PushError ()) +-- push conn = do +-- let foo transaction = unsafeUnTransaction transaction conn +-- +-- ... +-- result <- foo (loadHashId hashId) +-- ... +-- +-- newtype Transaction a = Transaction { unsafeUnTransaction :: Connection -> IO a } + +type Connection = () + +type Transaction a = () + +expectHash :: HashId -> Transaction Hash.Hash +expectHash = undefined + +push :: Connection -> Share.RepoPath -> Maybe Share.Hash -> CausalHash -> IO (Either PushError ()) +push conn repoPath expectedHash causalHash = do + -- 1. Attempt to update path. + + -- causalHash <- + -- _ (unCausalHashId (Sqlite.Causal.selfHash causal)) + let request = + Share.UpdatePathRequest + { path = repoPath, + expectedHash = + expectedHash <&> \hash -> + Share.TypedHash + { hash, + entityType = Share.CausalType + }, + newHash = + Share.TypedHash + { hash = + causalHash + & unCausalHash + & Hash.toBase32Hex + & Base32Hex.toText + & Share.Hash, + entityType = Share.CausalType + } + } + __api_updatePath request >>= \case + UpdatePathSuccess -> pure (Right ()) + UpdatePathHashMismatch mismatch -> pure (Left (PushErrorHashMismatch mismatch)) + UpdatePathMissingDependencies dependencies -> undefined + undefined diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 7264cb123c..76b7f081b5 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -59,6 +59,7 @@ library Unison.CommandLine.Main Unison.CommandLine.OutputMessages Unison.CommandLine.Welcome + Unison.Share.Sync Unison.Util.HTTP other-modules: Paths_unison_cli @@ -74,12 +75,14 @@ library DeriveGeneric DerivingStrategies DoAndIfThenElse + DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns + OverloadedLabels OverloadedStrings PatternSynonyms RankNTypes @@ -123,11 +126,13 @@ library , these , time , transformers + , unison-codebase , unison-codebase-sqlite , unison-core1 , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-share-api , unison-util , unison-util-relation , unliftio @@ -157,12 +162,14 @@ executable integration-tests DeriveGeneric DerivingStrategies DoAndIfThenElse + DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns + OverloadedLabels OverloadedStrings PatternSynonyms RankNTypes @@ -212,11 +219,13 @@ executable integration-tests , these , time , transformers + , unison-codebase , unison-codebase-sqlite , unison-core1 , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-share-api , unison-util , unison-util-relation , unliftio @@ -242,12 +251,14 @@ executable transcripts DeriveGeneric DerivingStrategies DoAndIfThenElse + DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns + OverloadedLabels OverloadedStrings PatternSynonyms RankNTypes @@ -296,11 +307,13 @@ executable transcripts , time , transformers , unison-cli + , unison-codebase , unison-codebase-sqlite , unison-core1 , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-share-api , unison-util , unison-util-relation , unliftio @@ -329,12 +342,14 @@ executable unison DeriveGeneric DerivingStrategies DoAndIfThenElse + DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns + OverloadedLabels OverloadedStrings PatternSynonyms RankNTypes @@ -384,11 +399,13 @@ executable unison , time , transformers , unison-cli + , unison-codebase , unison-codebase-sqlite , unison-core1 , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-share-api , unison-util , unison-util-relation , unliftio @@ -421,12 +438,14 @@ test-suite tests DeriveGeneric DerivingStrategies DoAndIfThenElse + DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving LambdaCase MultiParamTypeClasses NamedFieldPuns + OverloadedLabels OverloadedStrings PatternSynonyms RankNTypes @@ -476,11 +495,13 @@ test-suite tests , time , transformers , unison-cli + , unison-codebase , unison-codebase-sqlite , unison-core1 , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-share-api , unison-util , unison-util-relation , unliftio From 04846d3b7d9aaf28f03498d2985e06d19668e4ff Mon Sep 17 00:00:00 2001 From: iamevn Date: Mon, 4 Apr 2022 15:26:32 -0700 Subject: [PATCH 053/529] Add builtin for reading bytes from a handle without blocking. --- parser-typechecker/src/Unison/Builtin.hs | 1 + parser-typechecker/src/Unison/Runtime/Builtin.hs | 5 ++++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 9e8857c64b..136b066dc4 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -579,6 +579,7 @@ ioBuiltins = , ("IO.getBuffering.impl.v3", handle --> iof bmode) , ("IO.setBuffering.impl.v3", handle --> bmode --> iof unit) , ("IO.getBytes.impl.v3", handle --> nat --> iof bytes) + , ("IO.getSomeBytes.impl.v1", handle --> nat --> iof bytes) , ("IO.putBytes.impl.v3", handle --> bytes --> iof unit) , ("IO.getLine.impl.v1", handle --> iof text) , ("IO.systemTime.impl.v3", unit --> iof nat) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 08cb6c43f2..ca11a0247c 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -34,7 +34,7 @@ import Control.Monad.State.Strict (State, execState, modify) import qualified Crypto.Hash as Hash import qualified Crypto.MAC.HMAC as HMAC import qualified Data.ByteArray as BA -import Data.ByteString (hGet, hPut) +import Data.ByteString (hGet, hGetSome, hPut) import qualified Data.ByteString.Lazy as L import Data.Default (def) import Data.IORef as SYS @@ -1790,6 +1790,9 @@ declareForeigns = do declareForeign Tracked "IO.getBytes.impl.v3" boxNatToEFBox . mkForeignIOF $ \(h, n) -> Bytes.fromArray <$> hGet h n + declareForeign Tracked "IO.getSomeBytes.impl.v1" boxNatToEFBox . mkForeignIOF $ + \(h, n) -> Bytes.fromArray <$> hGetSome h n + declareForeign Tracked "IO.putBytes.impl.v3" boxBoxToEF0 . mkForeignIOF $ \(h, bs) -> hPut h (Bytes.toArray bs) declareForeign Tracked "IO.systemTime.impl.v3" unitToEFNat $ From ccd2edbbd0266929f409104c24bcd050e8a3c3cc Mon Sep 17 00:00:00 2001 From: iamevn Date: Mon, 4 Apr 2022 15:55:44 -0700 Subject: [PATCH 054/529] edit transcripts to test io.getSomeBytes --- unison-src/transcripts-using-base/base.u | 1 + unison-src/transcripts/io.md | 59 ++++++++++++++++++++++++ 2 files changed, 60 insertions(+) diff --git a/unison-src/transcripts-using-base/base.u b/unison-src/transcripts-using-base/base.u index 9fd1adbc63..7f2fbca005 100644 --- a/unison-src/transcripts-using-base/base.u +++ b/unison-src/transcripts-using-base/base.u @@ -198,6 +198,7 @@ isSeekable = compose reraise isSeekable.impl isFileEOF = compose reraise isFileEOF.impl Text.fromUtf8 = compose reraise fromUtf8.impl getBytes = compose2 reraise getBytes.impl +getSomeBytes = compose2 reraise getSomeBytes.impl handlePosition = compose reraise handlePosition.impl getBuffering = compose reraise getBuffering.impl setBuffering mode = compose reraise (setBuffering.impl mode) diff --git a/unison-src/transcripts/io.md b/unison-src/transcripts/io.md index 18655cc509..8067f8c774 100644 --- a/unison-src/transcripts/io.md +++ b/unison-src/transcripts/io.md @@ -111,6 +111,65 @@ testOpenClose _ = .> io.test testOpenClose ``` +### Reading files with getSomeBytes + +Tests: getSomeBytes + putBytes + isFileOpen + seekHandle + +```unison +testGetSomeBytes : '{io2.IO} [Result] +testGetSomeBytes _ = + test = 'let + tempDir = (newTempDir "getSomeBytes") + fooFile = tempDir ++ "/foo" + + testData = "0123456789" + testSize = size testData + + chunkSize = 7 + check "chunk size splits data into 2 uneven sides" ((chunkSize > (testSize / 2)) && (chunkSize < testSize)) + + + -- write testData to a temporary file + fooWrite = openFile fooFile Write + putBytes fooWrite (toUtf8 testData) + closeFile fooWrite + check "file should be closed" (not (isFileOpen fooWrite)) + + -- reopen for reading back the data in chunks + fooRead = openFile fooFile Read + + -- read first part of file + chunk1 = getSomeBytes fooRead chunkSize |> fromUtf8 + check "first chunk matches first part of testData" (chunk1 == take chunkSize testData) + + -- read rest of file + chunk2 = getSomeBytes fooRead chunkSize |> fromUtf8 + check "second chunk matches rest of testData" (chunk2 == drop chunkSize testData) + + check "should be at end of file" (isFileEOF fooRead) + + readAtEOF = getSomeBytes fooRead chunkSize + check "reading at end of file results in Bytes.empty" (readAtEOF == Bytes.empty) + + -- request many bytes from the start of the file + seekHandle fooRead AbsoluteSeek +0 + bigRead = getSomeBytes fooRead (testSize * 999) |> fromUtf8 + check "requesting many bytes results in what's available" (bigRead == testData) + + closeFile fooRead + check "file should be closed" (not (isFileOpen fooRead)) + + runTest test +``` + +```ucm +.> add +.> io.test testGetSomeBytes +``` + ### Seeking in open files Tests: openFile From fdddfacc7c651e51178a4a0a0708a23ac80c37e3 Mon Sep 17 00:00:00 2001 From: iamevn Date: Mon, 4 Apr 2022 15:56:08 -0700 Subject: [PATCH 055/529] stack exec transcripts --- unison-src/transcripts/alias-many.output.md | 405 +++++++++--------- .../transcripts/builtins-merge.output.md | 2 +- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/io.output.md | 90 ++++ unison-src/transcripts/merges.output.md | 12 +- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 7 files changed, 318 insertions(+), 225 deletions(-) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index ac71c7e2cf..1c25b61154 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -217,260 +217,263 @@ Let's try it! 181. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat 182. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 183. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 184. io2.IO.handlePosition.impl : Handle + 183. io2.IO.getSomeBytes.impl : Handle + -> Nat + ->{IO} Either Failure Bytes + 184. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 185. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 185. io2.IO.isDirectory.impl : Text + 186. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 186. io2.IO.isFileEOF.impl : Handle + 187. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 187. io2.IO.isFileOpen.impl : Handle + 188. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 188. io2.IO.isSeekable.impl : Handle + 189. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 189. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 190. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 191. io2.IO.openFile.impl : Text + 190. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 191. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 192. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 192. io2.IO.putBytes.impl : Handle + 193. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 193. io2.IO.ref : a ->{IO} Ref {IO} a - 194. io2.IO.removeDirectory.impl : Text + 194. io2.IO.ref : a ->{IO} Ref {IO} a + 195. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 195. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 196. io2.IO.renameDirectory.impl : Text + 196. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 197. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 197. io2.IO.renameFile.impl : Text + 198. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 198. io2.IO.seekHandle.impl : Handle + 199. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 199. io2.IO.serverSocket.impl : Optional Text + 200. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 200. io2.IO.setBuffering.impl : Handle + 201. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 201. io2.IO.setCurrentDirectory.impl : Text + 202. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 202. io2.IO.socketAccept.impl : Socket + 203. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 203. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 204. io2.IO.socketReceive.impl : Socket + 204. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 205. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 205. io2.IO.socketSend.impl : Socket + 206. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 206. io2.IO.stdHandle : StdHandle -> Handle - 207. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 208. io2.IO.systemTimeMicroseconds : '{IO} Int - 209. unique type io2.IOError - 210. io2.IOError.AlreadyExists : IOError - 211. io2.IOError.EOF : IOError - 212. io2.IOError.IllegalOperation : IOError - 213. io2.IOError.NoSuchThing : IOError - 214. io2.IOError.PermissionDenied : IOError - 215. io2.IOError.ResourceBusy : IOError - 216. io2.IOError.ResourceExhausted : IOError - 217. io2.IOError.UserError : IOError - 218. unique type io2.IOFailure - 219. builtin type io2.MVar - 220. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 221. io2.MVar.new : a ->{IO} MVar a - 222. io2.MVar.newEmpty : '{IO} MVar a - 223. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 224. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 225. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 226. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 227. io2.MVar.tryPut.impl : MVar a + 207. io2.IO.stdHandle : StdHandle -> Handle + 208. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 209. io2.IO.systemTimeMicroseconds : '{IO} Int + 210. unique type io2.IOError + 211. io2.IOError.AlreadyExists : IOError + 212. io2.IOError.EOF : IOError + 213. io2.IOError.IllegalOperation : IOError + 214. io2.IOError.NoSuchThing : IOError + 215. io2.IOError.PermissionDenied : IOError + 216. io2.IOError.ResourceBusy : IOError + 217. io2.IOError.ResourceExhausted : IOError + 218. io2.IOError.UserError : IOError + 219. unique type io2.IOFailure + 220. builtin type io2.MVar + 221. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 222. io2.MVar.new : a ->{IO} MVar a + 223. io2.MVar.newEmpty : '{IO} MVar a + 224. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 225. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 226. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 227. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 228. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 228. io2.MVar.tryRead.impl : MVar a + 229. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 229. io2.MVar.tryTake : MVar a ->{IO} Optional a - 230. unique type io2.SeekMode - 231. io2.SeekMode.AbsoluteSeek : SeekMode - 232. io2.SeekMode.RelativeSeek : SeekMode - 233. io2.SeekMode.SeekFromEnd : SeekMode - 234. builtin type io2.Socket - 235. unique type io2.StdHandle - 236. io2.StdHandle.StdErr : StdHandle - 237. io2.StdHandle.StdIn : StdHandle - 238. io2.StdHandle.StdOut : StdHandle - 239. builtin type io2.STM - 240. io2.STM.atomically : '{STM} a ->{IO} a - 241. io2.STM.retry : '{STM} a - 242. builtin type io2.ThreadId - 243. builtin type io2.Tls - 244. builtin type io2.Tls.Cipher - 245. builtin type io2.Tls.ClientConfig - 246. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 230. io2.MVar.tryTake : MVar a ->{IO} Optional a + 231. unique type io2.SeekMode + 232. io2.SeekMode.AbsoluteSeek : SeekMode + 233. io2.SeekMode.RelativeSeek : SeekMode + 234. io2.SeekMode.SeekFromEnd : SeekMode + 235. builtin type io2.Socket + 236. unique type io2.StdHandle + 237. io2.StdHandle.StdErr : StdHandle + 238. io2.StdHandle.StdIn : StdHandle + 239. io2.StdHandle.StdOut : StdHandle + 240. builtin type io2.STM + 241. io2.STM.atomically : '{STM} a ->{IO} a + 242. io2.STM.retry : '{STM} a + 243. builtin type io2.ThreadId + 244. builtin type io2.Tls + 245. builtin type io2.Tls.Cipher + 246. builtin type io2.Tls.ClientConfig + 247. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 247. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 248. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 248. io2.Tls.ClientConfig.default : Text + 249. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 249. io2.Tls.ClientConfig.versions.set : [Version] + 250. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 250. io2.Tls.decodeCert.impl : Bytes + 251. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 251. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 252. io2.Tls.encodeCert : SignedCert -> Bytes - 253. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 254. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 255. io2.Tls.newClient.impl : ClientConfig + 252. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 253. io2.Tls.encodeCert : SignedCert -> Bytes + 254. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 255. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 256. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 256. io2.Tls.newServer.impl : ServerConfig + 257. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 257. builtin type io2.Tls.PrivateKey - 258. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 259. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 260. builtin type io2.Tls.ServerConfig - 261. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 258. builtin type io2.Tls.PrivateKey + 259. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 260. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 261. builtin type io2.Tls.ServerConfig + 262. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 262. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 263. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 263. io2.Tls.ServerConfig.default : [SignedCert] + 264. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 264. io2.Tls.ServerConfig.versions.set : [Version] + 265. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 265. builtin type io2.Tls.SignedCert - 266. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 267. builtin type io2.Tls.Version - 268. unique type io2.TlsFailure - 269. builtin type io2.TVar - 270. io2.TVar.new : a ->{STM} TVar a - 271. io2.TVar.newIO : a ->{IO} TVar a - 272. io2.TVar.read : TVar a ->{STM} a - 273. io2.TVar.readIO : TVar a ->{IO} a - 274. io2.TVar.swap : TVar a -> a ->{STM} a - 275. io2.TVar.write : TVar a -> a ->{STM} () - 276. io2.validateSandboxed : [Term] -> a -> Boolean - 277. unique type IsPropagated - 278. IsPropagated.IsPropagated : IsPropagated - 279. unique type IsTest - 280. IsTest.IsTest : IsTest - 281. unique type Link - 282. builtin type Link.Term - 283. Link.Term : Term -> Link - 284. Link.Term.toText : Term -> Text - 285. builtin type Link.Type - 286. Link.Type : Type -> Link - 287. builtin type List - 288. List.++ : [a] -> [a] -> [a] - 289. List.+: : a -> [a] -> [a] - 290. List.:+ : [a] -> a -> [a] - 291. List.at : Nat -> [a] -> Optional a - 292. List.cons : a -> [a] -> [a] - 293. List.drop : Nat -> [a] -> [a] - 294. List.empty : [a] - 295. List.size : [a] -> Nat - 296. List.snoc : [a] -> a -> [a] - 297. List.take : Nat -> [a] -> [a] - 298. metadata.isPropagated : IsPropagated - 299. metadata.isTest : IsTest - 300. builtin type Nat - 301. Nat.* : Nat -> Nat -> Nat - 302. Nat.+ : Nat -> Nat -> Nat - 303. Nat./ : Nat -> Nat -> Nat - 304. Nat.and : Nat -> Nat -> Nat - 305. Nat.complement : Nat -> Nat - 306. Nat.drop : Nat -> Nat -> Nat - 307. Nat.eq : Nat -> Nat -> Boolean - 308. Nat.fromText : Text -> Optional Nat - 309. Nat.gt : Nat -> Nat -> Boolean - 310. Nat.gteq : Nat -> Nat -> Boolean - 311. Nat.increment : Nat -> Nat - 312. Nat.isEven : Nat -> Boolean - 313. Nat.isOdd : Nat -> Boolean - 314. Nat.leadingZeros : Nat -> Nat - 315. Nat.lt : Nat -> Nat -> Boolean - 316. Nat.lteq : Nat -> Nat -> Boolean - 317. Nat.mod : Nat -> Nat -> Nat - 318. Nat.or : Nat -> Nat -> Nat - 319. Nat.popCount : Nat -> Nat - 320. Nat.pow : Nat -> Nat -> Nat - 321. Nat.shiftLeft : Nat -> Nat -> Nat - 322. Nat.shiftRight : Nat -> Nat -> Nat - 323. Nat.sub : Nat -> Nat -> Int - 324. Nat.toFloat : Nat -> Float - 325. Nat.toInt : Nat -> Int - 326. Nat.toText : Nat -> Text - 327. Nat.trailingZeros : Nat -> Nat - 328. Nat.xor : Nat -> Nat -> Nat - 329. structural type Optional a - 330. Optional.None : Optional a - 331. Optional.Some : a -> Optional a - 332. builtin type Ref - 333. Ref.read : Ref g a ->{g} a - 334. Ref.write : Ref g a -> a ->{g} () - 335. builtin type Request - 336. builtin type Scope - 337. Scope.ref : a ->{Scope s} Ref {Scope s} a - 338. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 339. structural type SeqView a b - 340. SeqView.VElem : a -> b -> SeqView a b - 341. SeqView.VEmpty : SeqView a b - 342. Socket.toText : Socket -> Text - 343. unique type Test.Result - 344. Test.Result.Fail : Text -> Result - 345. Test.Result.Ok : Text -> Result - 346. builtin type Text - 347. Text.!= : Text -> Text -> Boolean - 348. Text.++ : Text -> Text -> Text - 349. Text.drop : Nat -> Text -> Text - 350. Text.empty : Text - 351. Text.eq : Text -> Text -> Boolean - 352. Text.fromCharList : [Char] -> Text - 353. Text.fromUtf8.impl : Bytes -> Either Failure Text - 354. Text.gt : Text -> Text -> Boolean - 355. Text.gteq : Text -> Text -> Boolean - 356. Text.lt : Text -> Text -> Boolean - 357. Text.lteq : Text -> Text -> Boolean - 358. Text.repeat : Nat -> Text -> Text - 359. Text.size : Text -> Nat - 360. Text.take : Nat -> Text -> Text - 361. Text.toCharList : Text -> [Char] - 362. Text.toUtf8 : Text -> Bytes - 363. Text.uncons : Text -> Optional (Char, Text) - 364. Text.unsnoc : Text -> Optional (Text, Char) - 365. ThreadId.toText : ThreadId -> Text - 366. todo : a -> b - 367. structural type Tuple a b - 368. Tuple.Cons : a -> b -> Tuple a b - 369. structural type Unit - 370. Unit.Unit : () - 371. Universal.< : a -> a -> Boolean - 372. Universal.<= : a -> a -> Boolean - 373. Universal.== : a -> a -> Boolean - 374. Universal.> : a -> a -> Boolean - 375. Universal.>= : a -> a -> Boolean - 376. Universal.compare : a -> a -> Int - 377. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 378. builtin type Value - 379. Value.dependencies : Value -> [Term] - 380. Value.deserialize : Bytes -> Either Text Value - 381. Value.load : Value ->{IO} Either [Term] a - 382. Value.serialize : Value -> Bytes - 383. Value.value : a -> Value + 266. builtin type io2.Tls.SignedCert + 267. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 268. builtin type io2.Tls.Version + 269. unique type io2.TlsFailure + 270. builtin type io2.TVar + 271. io2.TVar.new : a ->{STM} TVar a + 272. io2.TVar.newIO : a ->{IO} TVar a + 273. io2.TVar.read : TVar a ->{STM} a + 274. io2.TVar.readIO : TVar a ->{IO} a + 275. io2.TVar.swap : TVar a -> a ->{STM} a + 276. io2.TVar.write : TVar a -> a ->{STM} () + 277. io2.validateSandboxed : [Term] -> a -> Boolean + 278. unique type IsPropagated + 279. IsPropagated.IsPropagated : IsPropagated + 280. unique type IsTest + 281. IsTest.IsTest : IsTest + 282. unique type Link + 283. builtin type Link.Term + 284. Link.Term : Term -> Link + 285. Link.Term.toText : Term -> Text + 286. builtin type Link.Type + 287. Link.Type : Type -> Link + 288. builtin type List + 289. List.++ : [a] -> [a] -> [a] + 290. List.+: : a -> [a] -> [a] + 291. List.:+ : [a] -> a -> [a] + 292. List.at : Nat -> [a] -> Optional a + 293. List.cons : a -> [a] -> [a] + 294. List.drop : Nat -> [a] -> [a] + 295. List.empty : [a] + 296. List.size : [a] -> Nat + 297. List.snoc : [a] -> a -> [a] + 298. List.take : Nat -> [a] -> [a] + 299. metadata.isPropagated : IsPropagated + 300. metadata.isTest : IsTest + 301. builtin type Nat + 302. Nat.* : Nat -> Nat -> Nat + 303. Nat.+ : Nat -> Nat -> Nat + 304. Nat./ : Nat -> Nat -> Nat + 305. Nat.and : Nat -> Nat -> Nat + 306. Nat.complement : Nat -> Nat + 307. Nat.drop : Nat -> Nat -> Nat + 308. Nat.eq : Nat -> Nat -> Boolean + 309. Nat.fromText : Text -> Optional Nat + 310. Nat.gt : Nat -> Nat -> Boolean + 311. Nat.gteq : Nat -> Nat -> Boolean + 312. Nat.increment : Nat -> Nat + 313. Nat.isEven : Nat -> Boolean + 314. Nat.isOdd : Nat -> Boolean + 315. Nat.leadingZeros : Nat -> Nat + 316. Nat.lt : Nat -> Nat -> Boolean + 317. Nat.lteq : Nat -> Nat -> Boolean + 318. Nat.mod : Nat -> Nat -> Nat + 319. Nat.or : Nat -> Nat -> Nat + 320. Nat.popCount : Nat -> Nat + 321. Nat.pow : Nat -> Nat -> Nat + 322. Nat.shiftLeft : Nat -> Nat -> Nat + 323. Nat.shiftRight : Nat -> Nat -> Nat + 324. Nat.sub : Nat -> Nat -> Int + 325. Nat.toFloat : Nat -> Float + 326. Nat.toInt : Nat -> Int + 327. Nat.toText : Nat -> Text + 328. Nat.trailingZeros : Nat -> Nat + 329. Nat.xor : Nat -> Nat -> Nat + 330. structural type Optional a + 331. Optional.None : Optional a + 332. Optional.Some : a -> Optional a + 333. builtin type Ref + 334. Ref.read : Ref g a ->{g} a + 335. Ref.write : Ref g a -> a ->{g} () + 336. builtin type Request + 337. builtin type Scope + 338. Scope.ref : a ->{Scope s} Ref {Scope s} a + 339. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r + 340. structural type SeqView a b + 341. SeqView.VElem : a -> b -> SeqView a b + 342. SeqView.VEmpty : SeqView a b + 343. Socket.toText : Socket -> Text + 344. unique type Test.Result + 345. Test.Result.Fail : Text -> Result + 346. Test.Result.Ok : Text -> Result + 347. builtin type Text + 348. Text.!= : Text -> Text -> Boolean + 349. Text.++ : Text -> Text -> Text + 350. Text.drop : Nat -> Text -> Text + 351. Text.empty : Text + 352. Text.eq : Text -> Text -> Boolean + 353. Text.fromCharList : [Char] -> Text + 354. Text.fromUtf8.impl : Bytes -> Either Failure Text + 355. Text.gt : Text -> Text -> Boolean + 356. Text.gteq : Text -> Text -> Boolean + 357. Text.lt : Text -> Text -> Boolean + 358. Text.lteq : Text -> Text -> Boolean + 359. Text.repeat : Nat -> Text -> Text + 360. Text.size : Text -> Nat + 361. Text.take : Nat -> Text -> Text + 362. Text.toCharList : Text -> [Char] + 363. Text.toUtf8 : Text -> Bytes + 364. Text.uncons : Text -> Optional (Char, Text) + 365. Text.unsnoc : Text -> Optional (Text, Char) + 366. ThreadId.toText : ThreadId -> Text + 367. todo : a -> b + 368. structural type Tuple a b + 369. Tuple.Cons : a -> b -> Tuple a b + 370. structural type Unit + 371. Unit.Unit : () + 372. Universal.< : a -> a -> Boolean + 373. Universal.<= : a -> a -> Boolean + 374. Universal.== : a -> a -> Boolean + 375. Universal.> : a -> a -> Boolean + 376. Universal.>= : a -> a -> Boolean + 377. Universal.compare : a -> a -> Int + 378. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 379. builtin type Value + 380. Value.dependencies : Value -> [Term] + 381. Value.deserialize : Bytes -> Either Text Value + 382. Value.load : Value ->{IO} Either [Term] a + 383. Value.serialize : Value -> Bytes + 384. Value.value : a -> Value .builtin> alias.many 94-104 .mylib diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index 80d53acb92..90c706a252 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -64,7 +64,7 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 53. Value/ (5 definitions) 54. bug (a -> b) 55. crypto/ (12 definitions) - 56. io2/ (125 definitions) + 56. io2/ (126 definitions) 57. metadata/ (2 definitions) 58. todo (a -> b) 59. unsafe/ (1 definition) diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index aaa9da0207..e8a7ffbf64 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (383 definitions) + 1. builtin/ (384 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (569 definitions) + 1. builtin/ (570 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/io.output.md b/unison-src/transcripts/io.output.md index e389cf159d..f12ca97af4 100644 --- a/unison-src/transcripts/io.output.md +++ b/unison-src/transcripts/io.output.md @@ -157,6 +157,96 @@ testOpenClose _ = Tip: Use view testOpenClose to view the source of a test. +``` +### Reading files with getSomeBytes + +Tests: getSomeBytes + putBytes + isFileOpen + seekHandle + +```unison +testGetSomeBytes : '{io2.IO} [Result] +testGetSomeBytes _ = + test = 'let + tempDir = (newTempDir "getSomeBytes") + fooFile = tempDir ++ "/foo" + + testData = "0123456789" + testSize = size testData + + chunkSize = 7 + check "chunk size splits data into 2 uneven sides" ((chunkSize > (testSize / 2)) && (chunkSize < testSize)) + + + -- write testData to a temporary file + fooWrite = openFile fooFile Write + putBytes fooWrite (toUtf8 testData) + closeFile fooWrite + check "file should be closed" (not (isFileOpen fooWrite)) + + -- reopen for reading back the data in chunks + fooRead = openFile fooFile Read + + -- read first part of file + chunk1 = getSomeBytes fooRead chunkSize |> fromUtf8 + check "first chunk matches first part of testData" (chunk1 == take chunkSize testData) + + -- read rest of file + chunk2 = getSomeBytes fooRead chunkSize |> fromUtf8 + check "second chunk matches rest of testData" (chunk2 == drop chunkSize testData) + + check "should be at end of file" (isFileEOF fooRead) + + readAtEOF = getSomeBytes fooRead chunkSize + check "reading at end of file results in Bytes.empty" (readAtEOF == Bytes.empty) + + -- request many bytes from the start of the file + seekHandle fooRead AbsoluteSeek +0 + bigRead = getSomeBytes fooRead (testSize * 999) |> fromUtf8 + check "requesting many bytes results in what's available" (bigRead == testData) + + closeFile fooRead + check "file should be closed" (not (isFileOpen fooRead)) + + runTest test +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + testGetSomeBytes : '{IO} [Result] + +``` +```ucm +.> add + + โŸ I've added these definitions: + + testGetSomeBytes : '{IO} [Result] + +.> io.test testGetSomeBytes + + New test results: + + โ—‰ testGetSomeBytes chunk size splits data into 2 uneven sides + โ—‰ testGetSomeBytes file should be closed + โ—‰ testGetSomeBytes first chunk matches first part of testData + โ—‰ testGetSomeBytes second chunk matches rest of testData + โ—‰ testGetSomeBytes should be at end of file + โ—‰ testGetSomeBytes reading at end of file results in Bytes.empty + โ—‰ testGetSomeBytes requesting many bytes results in what's available + โ—‰ testGetSomeBytes file should be closed + + โœ… 8 test(s) passing + + Tip: Use view testGetSomeBytes to view the source of a test. + ``` ### Seeking in open files diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 7389d1cd45..55c929e70e 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -125,13 +125,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #6meejv5nn9 + โŠ™ 1. #j1lsljjhdd - Deletes: feature1.y - โŠ™ 2. #jiaec3stf0 + โŠ™ 2. #r969k3jgve + Adds / updates: @@ -142,26 +142,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - โŠ™ 3. #oi6qeaaasg + โŠ™ 3. #0gi7v0d7tu + Adds / updates: feature1.y - โŠ™ 4. #s0e9mj6462 + โŠ™ 4. #2nqtlij18m > Moves: Original name New name x master.x - โŠ™ 5. #uiim9cuh1n + โŠ™ 5. #heict59ifr + Adds / updates: x - โ–ก 6. #8oo4auc4cv (start of history) + โ–ก 6. #pnv2a0gkq2 (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index 230dcd5c8e..79b70f905f 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #n5s5u3ncj8 .old` to make an old namespace + `fork #252vcd822j .old` to make an old namespace accessible again, - `reset-root #n5s5u3ncj8` to reset the root namespace and + `reset-root #252vcd822j` to reset the root namespace and its history to that of the specified namespace. - 1. #tv14d51d4l : add - 2. #n5s5u3ncj8 : add - 3. #8oo4auc4cv : builtins.merge + 1. #1svuebjsh1 : add + 2. #252vcd822j : add + 3. #pnv2a0gkq2 : builtins.merge 4. #sg60bvjo91 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index d81fa84985..46c8db1404 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - โ–ก 1. #soipbkdq9m (start of history) + โ–ก 1. #aktpkdqc1d (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #u2acmt4ut5 + โŠ™ 1. #su54dhbbgp > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #tq3np8qtmn + โŠ™ 2. #nhe50pjji2 > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #soipbkdq9m (start of history) + โ–ก 3. #aktpkdqc1d (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #u2acmt4ut5 + โŠ™ 1. #su54dhbbgp > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #tq3np8qtmn + โŠ™ 2. #nhe50pjji2 > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #soipbkdq9m (start of history) + โ–ก 3. #aktpkdqc1d (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - โ–ก 1. #soipbkdq9m (start of history) + โ–ก 1. #aktpkdqc1d (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #n48gujdtqf + โŠ™ 1. #bl7pg3asuu - Deletes: Nat.* Nat.+ - โ–ก 2. #soipbkdq9m (start of history) + โ–ก 2. #aktpkdqc1d (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From fa57bd72e8e0bf1579773cd1162c6c9764d4572c Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 5 Apr 2022 10:48:52 -0400 Subject: [PATCH 056/529] rewrite Queries/Operations to use Transaction --- .../U/Codebase/Sqlite/Operations.hs | 299 ++++++++++-------- .../U/Codebase/Sqlite/Queries.hs | 205 ++++++------ .../U/Codebase/Sqlite/Sync22.hs | 15 +- lib/unison-sqlite/src/Unison/Sqlite.hs | 7 + .../src/Unison/Sqlite/Connection.hs | 16 + .../src/Unison/Sqlite/Transaction.hs | 7 + .../Migrations/MigrateSchema1To2/DbHelpers.hs | 43 +-- 7 files changed, 319 insertions(+), 273 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 1c269cfb0c..537850925e 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -157,7 +157,6 @@ import qualified U.Core.ABT as ABT import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as H import qualified U.Util.Lens as Lens -import qualified U.Util.Monoid as Monoid import U.Util.Serialization (Get) import qualified U.Util.Serialization as S import qualified U.Util.Term as TermUtil @@ -190,25 +189,25 @@ getFromBytesOr decoder get bs = case runGetS get bs of -- * Database lookups -objectExistsForHash :: DB m => H.Hash -> m Bool +objectExistsForHash :: H.Hash -> Transaction Bool objectExistsForHash h = isJust <$> runMaybeT do id <- MaybeT . Q.loadHashId . H.toBase32Hex $ h MaybeT $ Q.loadObjectIdForAnyHashId id -expectValueHashByCausalHashId :: DB m => Db.CausalHashId -> m BranchHash +expectValueHashByCausalHashId :: Db.CausalHashId -> Transaction BranchHash expectValueHashByCausalHashId = loadValueHashById <=< Q.expectCausalValueHashId where - loadValueHashById :: DB m => Db.BranchHashId -> m BranchHash + loadValueHashById :: Db.BranchHashId -> Transaction BranchHash loadValueHashById = fmap BranchHash . Q.expectHash . Db.unBranchHashId -expectRootCausalHash :: DB m => m CausalHash +expectRootCausalHash :: Transaction CausalHash expectRootCausalHash = Q.expectCausalHash =<< Q.expectNamespaceRoot -loadRootCausalHash :: DB m => m (Maybe CausalHash) +loadRootCausalHash :: Transaction (Maybe CausalHash) loadRootCausalHash = runMaybeT $ - Q.expectCausalHash =<< MaybeT Q.loadNamespaceRoot + lift . Q.expectCausalHash =<< MaybeT Q.loadNamespaceRoot -- * Reference transformations @@ -217,54 +216,54 @@ loadRootCausalHash = -- | Assumes that a derived reference would already exist in the database -- (by virtue of dependencies being stored before dependents), but does -- not assume a builtin reference would. -c2sReference :: DB m => C.Reference -> m S.Reference +c2sReference :: C.Reference -> Transaction S.Reference c2sReference = bitraverse Q.saveText Q.expectObjectIdForPrimaryHash -s2cReference :: DB m => S.Reference -> m C.Reference +s2cReference :: S.Reference -> Transaction C.Reference s2cReference = bitraverse Q.expectText Q.expectPrimaryHashByObjectId -c2sReferenceId :: DB m => C.Reference.Id -> m S.Reference.Id +c2sReferenceId :: C.Reference.Id -> Transaction S.Reference.Id c2sReferenceId = C.Reference.idH Q.expectObjectIdForPrimaryHash -s2cReferenceId :: DB m => S.Reference.Id -> m C.Reference.Id +s2cReferenceId :: S.Reference.Id -> Transaction C.Reference.Id s2cReferenceId = C.Reference.idH Q.expectPrimaryHashByObjectId -h2cReferenceId :: DB m => S.Reference.IdH -> m C.Reference.Id +h2cReferenceId :: S.Reference.IdH -> Transaction C.Reference.Id h2cReferenceId = C.Reference.idH Q.expectHash -h2cReference :: DB m => S.ReferenceH -> m C.Reference +h2cReference :: S.ReferenceH -> Transaction C.Reference h2cReference = bitraverse Q.expectText Q.expectHash -c2hReference :: DB m => C.Reference -> MaybeT m S.ReferenceH +c2hReference :: C.Reference -> MaybeT Transaction S.ReferenceH c2hReference = bitraverse (MaybeT . Q.loadTextId) (MaybeT . Q.loadHashIdByHash) -s2cReferent :: DB m => S.Referent -> m C.Referent +s2cReferent :: S.Referent -> Transaction C.Referent s2cReferent = bitraverse s2cReference s2cReference -s2cReferentId :: DB m => S.Referent.Id -> m C.Referent.Id +s2cReferentId :: S.Referent.Id -> Transaction C.Referent.Id s2cReferentId = bitraverse Q.expectPrimaryHashByObjectId Q.expectPrimaryHashByObjectId -c2sReferent :: DB m => C.Referent -> m S.Referent +c2sReferent :: C.Referent -> Transaction S.Referent c2sReferent = bitraverse c2sReference c2sReference -c2sReferentId :: DB m => C.Referent.Id -> m S.Referent.Id +c2sReferentId :: C.Referent.Id -> Transaction S.Referent.Id c2sReferentId = bitraverse Q.expectObjectIdForPrimaryHash Q.expectObjectIdForPrimaryHash -h2cReferent :: DB m => S.ReferentH -> m C.Referent +h2cReferent :: S.ReferentH -> Transaction C.Referent h2cReferent = bitraverse h2cReference h2cReference -- ** convert and save references -- | Save the text and hash parts of a Reference to the database and substitute their ids. -saveReferenceH :: DB m => C.Reference -> m S.ReferenceH +saveReferenceH :: C.Reference -> Transaction S.ReferenceH saveReferenceH = bitraverse Q.saveText Q.saveHashHash -saveReferentH :: DB m => C.Referent -> m S.ReferentH +saveReferentH :: C.Referent -> Transaction S.ReferentH saveReferentH = bitraverse saveReferenceH saveReferenceH -- ** Edits transformations -s2cTermEdit :: DB m => S.TermEdit -> m C.TermEdit +s2cTermEdit :: S.TermEdit -> Transaction C.TermEdit s2cTermEdit = \case S.TermEdit.Replace r t -> C.TermEdit.Replace <$> s2cReferent r <*> pure (s2cTyping t) S.TermEdit.Deprecate -> pure C.TermEdit.Deprecate @@ -281,13 +280,13 @@ c2sTyping = \case C.TermEdit.Subtype -> S.TermEdit.Subtype C.TermEdit.Different -> S.TermEdit.Different -s2cTypeEdit :: DB m => S.TypeEdit -> m C.TypeEdit +s2cTypeEdit :: S.TypeEdit -> Transaction C.TypeEdit s2cTypeEdit = \case S.TypeEdit.Replace r -> C.TypeEdit.Replace <$> s2cReference r S.TypeEdit.Deprecate -> pure C.TypeEdit.Deprecate -- | assumes that all relevant defns are already in the DB -c2sPatch :: DB m => C.Branch.Patch -> m S.Patch +c2sPatch :: C.Branch.Patch -> Transaction S.Patch c2sPatch (C.Branch.Patch termEdits typeEdits) = S.Patch <$> Map.bitraverse saveReferentH (Set.traverse c2sTermEdit) termEdits @@ -351,7 +350,7 @@ decodeDeclFormat = getFromBytesOr "getDeclFormat" S.getDeclFormat decodeDeclElement :: Word64 -> ByteString -> Either DecodeError (LocalIds, S.Decl.Decl Symbol) decodeDeclElement i = getFromBytesOr ("lookupDeclElement " <> tShow i) (S.lookupDeclElement i) -getCycleLen :: DB m => H.Hash -> m (Maybe Word64) +getCycleLen :: H.Hash -> Transaction (Maybe Word64) getCycleLen h = do when debug $ traceM $ "\ngetCycleLen " ++ (Text.unpack . Base32Hex.toText $ H.toBase32Hex h) runMaybeT do @@ -362,14 +361,14 @@ getCycleLen h = do -- components) have the same basic serialized structure: first a format -- byte that is always 0 for now, followed by a framed array representing -- the strongly-connected component. :grimace: - Q.expectObject oid decodeComponentLengthOnly + lift (Q.expectObject oid decodeComponentLengthOnly) -- | Get the 'C.DeclType.DeclType' of a 'C.Reference.Id'. -expectDeclTypeById :: DB m => C.Reference.Id -> m C.Decl.DeclType +expectDeclTypeById :: C.Reference.Id -> Transaction C.Decl.DeclType expectDeclTypeById = fmap C.Decl.declType . expectDeclByReference -componentByObjectId :: DB m => Db.ObjectId -> m [S.Reference.Id] +componentByObjectId :: Db.ObjectId -> Transaction [S.Reference.Id] componentByObjectId id = do when debug . traceM $ "Operations.componentByObjectId " ++ show id len <- Q.expectObject id decodeComponentLengthOnly @@ -379,13 +378,13 @@ componentByObjectId id = do -- ** Saving & loading terms -loadTermComponent :: DB m => H.Hash -> MaybeT m [(C.Term Symbol, C.Term.Type Symbol)] +loadTermComponent :: H.Hash -> MaybeT Transaction [(C.Term Symbol, C.Term.Type Symbol)] loadTermComponent h = do oid <- MaybeT (Q.loadObjectIdForAnyHash h) S.Term.Term (S.Term.LocallyIndexedComponent elements) <- MaybeT (Q.loadTermObject oid decodeTermFormat) lift . traverse (uncurry3 s2cTermWithType) $ Foldable.toList elements -saveTermComponent :: DB m => H.Hash -> [(C.Term Symbol, C.Term.Type Symbol)] -> m Db.ObjectId +saveTermComponent :: H.Hash -> [(C.Term Symbol, C.Term.Type Symbol)] -> Transaction Db.ObjectId saveTermComponent h terms = do when debug . traceM $ "Operations.saveTermComponent " ++ show h sTermElements <- traverse (uncurry c2sTerm) terms @@ -534,40 +533,40 @@ c2xTerm saveText saveDefn tm tp = (Vector.fromList (Foldable.toList defnIds)) pure (ids, void tm, void <$> tp) -loadTermWithTypeByReference :: DB m => C.Reference.Id -> MaybeT m (C.Term Symbol, C.Term.Type Symbol) +loadTermWithTypeByReference :: C.Reference.Id -> MaybeT Transaction (C.Term Symbol, C.Term.Type Symbol) loadTermWithTypeByReference (C.Reference.Id h i) = do oid <- MaybeT (Q.loadObjectIdForPrimaryHash h) -- retrieve and deserialize the blob (localIds, term, typ) <- MaybeT (Q.loadTermObject oid (decodeTermElementWithType i)) - s2cTermWithType localIds term typ + lift (s2cTermWithType localIds term typ) -loadTermByReference :: DB m => C.Reference.Id -> MaybeT m (C.Term Symbol) +loadTermByReference :: C.Reference.Id -> MaybeT Transaction (C.Term Symbol) loadTermByReference r@(C.Reference.Id h i) = do when debug . traceM $ "loadTermByReference " ++ show r oid <- MaybeT (Q.loadObjectIdForPrimaryHash h) -- retrieve and deserialize the blob (localIds, term) <- MaybeT (Q.loadTermObject oid (decodeTermElementDiscardingType i)) - s2cTerm localIds term + lift (s2cTerm localIds term) -loadTypeOfTermByTermReference :: DB m => C.Reference.Id -> MaybeT m (C.Term.Type Symbol) +loadTypeOfTermByTermReference :: C.Reference.Id -> MaybeT Transaction (C.Term.Type Symbol) loadTypeOfTermByTermReference id@(C.Reference.Id h i) = do when debug . traceM $ "loadTypeOfTermByTermReference " ++ show id oid <- MaybeT (Q.loadObjectIdForPrimaryHash h) -- retrieve and deserialize the blob (localIds, typ) <- MaybeT (Q.loadTermObject oid (decodeTermElementDiscardingTerm i)) - s2cTypeOfTerm localIds typ + lift (s2cTypeOfTerm localIds typ) -s2cTermWithType :: DB m => LocalIds -> S.Term.Term -> S.Term.Type -> m (C.Term Symbol, C.Term.Type Symbol) +s2cTermWithType :: LocalIds -> S.Term.Term -> S.Term.Type -> Transaction (C.Term Symbol, C.Term.Type Symbol) s2cTermWithType ids tm tp = do (substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids pure (x2cTerm substText substHash tm, x2cTType substText substHash tp) -s2cTerm :: DB m => LocalIds -> S.Term.Term -> m (C.Term Symbol) +s2cTerm :: LocalIds -> S.Term.Term -> Transaction (C.Term Symbol) s2cTerm ids tm = do (substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids pure $ x2cTerm substText substHash tm -s2cTypeOfTerm :: DB m => LocalIds -> S.Term.Type -> m (C.Term.Type Symbol) +s2cTypeOfTerm :: LocalIds -> S.Term.Type -> Transaction (C.Term.Type Symbol) s2cTypeOfTerm ids tp = do (substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids pure $ x2cTType substText substHash tp @@ -581,7 +580,7 @@ localIdsToLookups loadText loadHash localIds = do substHash (LocalDefnId w) = hashes Vector.! fromIntegral w pure (substText, substHash) -localIdsToTypeRefLookup :: DB m => LocalIds -> m (S.Decl.TypeRef -> C.Decl.TypeRef) +localIdsToTypeRefLookup :: LocalIds -> Transaction (S.Decl.TypeRef -> C.Decl.TypeRef) localIdsToTypeRefLookup localIds = do (substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId localIds pure $ bimap substText (fmap substHash) @@ -644,48 +643,48 @@ lookup_ stateLens writerLens mk t = do pure id Just t' -> pure t' -c2sTerm :: DB m => C.Term Symbol -> C.Term.Type Symbol -> m (LocalIds, S.Term.Term, S.Term.Type) +c2sTerm :: C.Term Symbol -> C.Term.Type Symbol -> Transaction (LocalIds, S.Term.Term, S.Term.Type) c2sTerm tm tp = c2xTerm Q.saveText Q.expectObjectIdForPrimaryHash tm (Just tp) <&> \(w, tm, Just tp) -> (w, tm, tp) -- *** Watch expressions -listWatches :: DB m => WatchKind -> m [C.Reference.Id] +listWatches :: WatchKind -> Transaction [C.Reference.Id] listWatches k = Q.loadWatchesByWatchKind k >>= traverse h2cReferenceId -- | returns Nothing if the expression isn't cached. -loadWatch :: DB m => WatchKind -> C.Reference.Id -> MaybeT m (C.Term Symbol) +loadWatch :: WatchKind -> C.Reference.Id -> MaybeT Transaction (C.Term Symbol) loadWatch k r = do - r' <- C.Reference.idH Q.saveHashHash r + r' <- C.Reference.idH (lift . Q.saveHashHash) r S.Term.WatchResult wlids t <- MaybeT (Q.loadWatch k r' (getFromBytesOr "getWatchResultFormat" S.getWatchResultFormat)) - w2cTerm wlids t + lift (w2cTerm wlids t) -saveWatch :: DB m => WatchKind -> C.Reference.Id -> C.Term Symbol -> m () +saveWatch :: WatchKind -> C.Reference.Id -> C.Term Symbol -> Transaction () saveWatch w r t = do rs <- C.Reference.idH Q.saveHashHash r wterm <- c2wTerm t let bytes = S.putBytes S.putWatchResultFormat (uncurry S.Term.WatchResult wterm) Q.saveWatch w rs bytes -clearWatches :: DB m => m () +clearWatches :: Transaction () clearWatches = Q.clearWatches -c2wTerm :: DB m => C.Term Symbol -> m (WatchLocalIds, S.Term.Term) +c2wTerm :: C.Term Symbol -> Transaction (WatchLocalIds, S.Term.Term) c2wTerm tm = c2xTerm Q.saveText Q.saveHashHash tm Nothing <&> \(w, tm, _) -> (w, tm) -w2cTerm :: DB m => WatchLocalIds -> S.Term.Term -> m (C.Term Symbol) +w2cTerm :: WatchLocalIds -> S.Term.Term -> Transaction (C.Term Symbol) w2cTerm ids tm = do (substText, substHash) <- localIdsToLookups Q.expectText Q.expectHash ids pure $ x2cTerm substText substHash tm -- ** Saving & loading type decls -loadDeclComponent :: DB m => H.Hash -> MaybeT m [C.Decl Symbol] +loadDeclComponent :: H.Hash -> MaybeT Transaction [C.Decl Symbol] loadDeclComponent h = do oid <- MaybeT (Q.loadObjectIdForAnyHash h) S.Decl.Decl (S.Decl.LocallyIndexedComponent elements) <- MaybeT (Q.loadDeclObject oid decodeDeclFormat) lift . traverse (uncurry s2cDecl) $ Foldable.toList elements -saveDeclComponent :: DB m => H.Hash -> [C.Decl Symbol] -> m Db.ObjectId +saveDeclComponent :: H.Hash -> [C.Decl Symbol] -> Transaction Db.ObjectId saveDeclComponent h decls = do when debug . traceM $ "Operations.saveDeclComponent " ++ show h sDeclElements <- traverse (c2sDecl Q.saveText Q.expectObjectIdForPrimaryHash) decls @@ -709,7 +708,13 @@ saveDeclComponent h decls = do pure oId -c2sDecl :: forall m t d. DB m => (Text -> m t) -> (H.Hash -> m d) -> C.Decl Symbol -> m (LocalIds' t d, S.Decl.Decl Symbol) +c2sDecl :: + forall m t d. + Monad m => + (Text -> m t) -> + (H.Hash -> m d) -> + C.Decl Symbol -> + m (LocalIds' t d, S.Decl.Decl Symbol) c2sDecl saveText saveDefn (C.Decl.DataDeclaration dt m b cts) = do done =<< (runWriterT . flip evalStateT mempty) do cts' <- traverse (ABT.transformM goType) cts @@ -740,19 +745,19 @@ c2sDecl saveText saveDefn (C.Decl.DataDeclaration dt m b cts) = do pure (ids, decl) -- | Unlocalize a decl. -s2cDecl :: DB m => LocalIds -> S.Decl.Decl Symbol -> m (C.Decl Symbol) +s2cDecl :: LocalIds -> S.Decl.Decl Symbol -> Transaction (C.Decl Symbol) s2cDecl ids (C.Decl.DataDeclaration dt m b ct) = do substTypeRef <- localIdsToTypeRefLookup ids pure (C.Decl.DataDeclaration dt m b (C.Type.rmap substTypeRef <$> ct)) -loadDeclByReference :: DB m => C.Reference.Id -> MaybeT m (C.Decl Symbol) +loadDeclByReference :: C.Reference.Id -> MaybeT Transaction (C.Decl Symbol) loadDeclByReference r@(C.Reference.Id h i) = do when debug . traceM $ "loadDeclByReference " ++ show r oid <- MaybeT (Q.loadObjectIdForPrimaryHash h) (localIds, decl) <- MaybeT (Q.loadDeclObject oid (decodeDeclElement i)) - s2cDecl localIds decl + lift (s2cDecl localIds decl) -expectDeclByReference :: DB m => C.Reference.Id -> m (C.Decl Symbol) +expectDeclByReference :: C.Reference.Id -> Transaction (C.Decl Symbol) expectDeclByReference r@(C.Reference.Id h i) = do when debug . traceM $ "expectDeclByReference " ++ show r -- retrieve the blob @@ -762,7 +767,7 @@ expectDeclByReference r@(C.Reference.Id h i) = do -- * Branch transformation -s2cBranch :: DB m => S.DbBranch -> m (C.Branch.Branch m) +s2cBranch :: S.DbBranch -> Transaction (C.Branch.Branch Transaction) s2cBranch (S.Branch.Full.Branch tms tps patches children) = C.Branch.Branch <$> doTerms tms @@ -770,15 +775,23 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = <*> doPatches patches <*> doChildren children where - loadMetadataType :: DB m => S.Reference -> m C.Reference + loadMetadataType :: S.Reference -> Transaction C.Reference loadMetadataType = \case C.ReferenceBuiltin tId -> Q.expectTextCheck tId (Left . NeedTypeForBuiltinMetadata) C.ReferenceDerived id -> typeReferenceForTerm id >>= h2cReference - loadTypesForMetadata rs = Map.fromList <$> traverse (\r -> (,) <$> s2cReference r <*> loadMetadataType r) (Foldable.toList rs) - doTerms :: DB m => Map Db.TextId (Map S.Referent S.DbMetadataSet) -> m (Map C.Branch.NameSegment (Map C.Referent (m C.Branch.MdValues))) + loadTypesForMetadata :: Set S.Reference -> Transaction (Map C.Reference C.Reference) + loadTypesForMetadata rs = + Map.fromList + <$> traverse + (\r -> (,) <$> s2cReference r <*> loadMetadataType r) + (Foldable.toList rs) + + doTerms :: + Map Db.TextId (Map S.Referent S.DbMetadataSet) -> + Transaction (Map C.Branch.NameSegment (Map C.Referent (Transaction C.Branch.MdValues))) doTerms = Map.bitraverse (fmap C.Branch.NameSegment . Q.expectText) @@ -786,7 +799,9 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = S.MetadataSet.Inline rs -> pure $ C.Branch.MdValues <$> loadTypesForMetadata rs ) - doTypes :: DB m => Map Db.TextId (Map S.Reference S.DbMetadataSet) -> m (Map C.Branch.NameSegment (Map C.Reference (m C.Branch.MdValues))) + doTypes :: + Map Db.TextId (Map S.Reference S.DbMetadataSet) -> + Transaction (Map C.Branch.NameSegment (Map C.Reference (Transaction C.Branch.MdValues))) doTypes = Map.bitraverse (fmap C.Branch.NameSegment . Q.expectText) @@ -794,38 +809,55 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = S.MetadataSet.Inline rs -> pure $ C.Branch.MdValues <$> loadTypesForMetadata rs ) - doPatches :: DB m => Map Db.TextId Db.PatchObjectId -> m (Map C.Branch.NameSegment (PatchHash, m C.Branch.Patch)) + doPatches :: + Map Db.TextId Db.PatchObjectId -> + Transaction (Map C.Branch.NameSegment (PatchHash, Transaction C.Branch.Patch)) doPatches = Map.bitraverse (fmap C.Branch.NameSegment . Q.expectText) \patchId -> do h <- PatchHash <$> (Q.expectPrimaryHashByObjectId . Db.unPatchObjectId) patchId pure (h, expectPatch patchId) - doChildren :: DB m => Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) -> m (Map C.Branch.NameSegment (C.Causal m CausalHash BranchHash (C.Branch.Branch m))) + doChildren :: + Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) -> + Transaction (Map C.Branch.NameSegment (C.Causal Transaction CausalHash BranchHash (C.Branch.Branch Transaction))) doChildren = Map.bitraverse (fmap C.Branch.NameSegment . Q.expectText) \(boId, chId) -> C.Causal <$> Q.expectCausalHash chId <*> expectValueHashByCausalHashId chId <*> headParents chId <*> pure (expectBranch boId) where - headParents :: DB m => Db.CausalHashId -> m (Map CausalHash (m (C.Causal m CausalHash BranchHash (C.Branch.Branch m)))) + headParents :: + Db.CausalHashId -> + Transaction + ( Map + CausalHash + (Transaction (C.Causal Transaction CausalHash BranchHash (C.Branch.Branch Transaction))) + ) headParents chId = do parentsChIds <- Q.loadCausalParents chId fmap Map.fromList $ traverse pairParent parentsChIds - pairParent :: DB m => Db.CausalHashId -> m (CausalHash, m (C.Causal m CausalHash BranchHash (C.Branch.Branch m))) + pairParent :: + Db.CausalHashId -> + Transaction + ( CausalHash, + Transaction (C.Causal Transaction CausalHash BranchHash (C.Branch.Branch Transaction)) + ) pairParent chId = do h <- Q.expectCausalHash chId pure (h, loadCausal chId) - loadCausal :: DB m => Db.CausalHashId -> m (C.Causal m CausalHash BranchHash (C.Branch.Branch m)) + loadCausal :: + Db.CausalHashId -> + Transaction (C.Causal Transaction CausalHash BranchHash (C.Branch.Branch Transaction)) loadCausal chId = do C.Causal <$> Q.expectCausalHash chId <*> expectValueHashByCausalHashId chId <*> headParents chId <*> pure (loadValue chId) - loadValue :: DB m => Db.CausalHashId -> m (C.Branch.Branch m) + loadValue :: Db.CausalHashId -> Transaction (C.Branch.Branch Transaction) loadValue chId = do boId <- Q.expectBranchObjectIdByCausalHashId chId expectBranch boId -saveRootBranch :: DB m => C.Branch.Causal m -> m (Db.BranchObjectId, Db.CausalHashId) +saveRootBranch :: C.Branch.Causal Transaction -> Transaction (Db.BranchObjectId, Db.CausalHashId) saveRootBranch c = do when debug $ traceM $ "Operations.saveRootBranch " ++ show (C.causalHash c) (boId, chId) <- saveBranch c @@ -871,7 +903,7 @@ saveRootBranch c = do -- References, but also values -- Shallow - Hash? representation of the database relationships -saveBranch :: DB m => C.Branch.Causal m -> m (Db.BranchObjectId, Db.CausalHashId) +saveBranch :: C.Branch.Causal Transaction -> Transaction (Db.BranchObjectId, Db.CausalHashId) saveBranch (C.Causal hc he parents me) = do when debug $ traceM $ "\nOperations.saveBranch \n hc = " ++ show hc ++ ",\n he = " ++ show he ++ ",\n parents = " ++ show (Map.keys parents) @@ -898,7 +930,7 @@ saveBranch (C.Causal hc he parents me) = do saveBranchObject bhId li lBranch pure (boId, chId) where - c2sBranch :: DB m => C.Branch.Branch m -> m S.DbBranch + c2sBranch :: C.Branch.Branch Transaction -> Transaction S.DbBranch c2sBranch (C.Branch.Branch terms types patches children) = S.Branch <$> Map.bitraverse saveNameSegment (Map.bitraverse c2sReferent c2sMetadata) terms @@ -906,15 +938,15 @@ saveBranch (C.Causal hc he parents me) = do <*> Map.bitraverse saveNameSegment savePatchObjectId patches <*> Map.bitraverse saveNameSegment saveBranch children - saveNameSegment :: DB m => C.Branch.NameSegment -> m Db.TextId + saveNameSegment :: C.Branch.NameSegment -> Transaction Db.TextId saveNameSegment = Q.saveText . C.Branch.unNameSegment - c2sMetadata :: DB m => m C.Branch.MdValues -> m S.Branch.Full.DbMetadataSet + c2sMetadata :: Transaction C.Branch.MdValues -> Transaction S.Branch.Full.DbMetadataSet c2sMetadata mm = do C.Branch.MdValues m <- mm S.Branch.Full.Inline <$> Set.traverse c2sReference (Map.keysSet m) - savePatchObjectId :: DB m => (PatchHash, m C.Branch.Patch) -> m Db.PatchObjectId + savePatchObjectId :: (PatchHash, Transaction C.Branch.Patch) -> Transaction Db.PatchObjectId savePatchObjectId (h, mp) = do Q.loadPatchObjectIdForPrimaryHash h >>= \case Just patchOID -> pure patchOID @@ -922,23 +954,23 @@ saveBranch (C.Causal hc he parents me) = do patch <- mp savePatch h patch -saveBranchObject :: DB m => Db.BranchHashId -> BranchLocalIds -> S.Branch.Full.LocalBranch -> m Db.BranchObjectId +saveBranchObject :: Db.BranchHashId -> BranchLocalIds -> S.Branch.Full.LocalBranch -> Transaction Db.BranchObjectId saveBranchObject id@(Db.unBranchHashId -> hashId) li lBranch = do when debug $ traceM $ "saveBranchObject\n\tid = " ++ show id ++ "\n\tli = " ++ show li ++ "\n\tlBranch = " ++ show lBranch let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full li lBranch oId <- Q.saveObject hashId OT.Namespace bytes pure $ Db.BranchObjectId oId -expectRootCausal :: DB m => m (C.Branch.Causal m) +expectRootCausal :: Transaction (C.Branch.Causal Transaction) expectRootCausal = Q.expectNamespaceRoot >>= expectCausalByCausalHashId -loadCausalBranchByCausalHash :: DB m => CausalHash -> m (Maybe (C.Branch.Causal m)) +loadCausalBranchByCausalHash :: CausalHash -> Transaction (Maybe (C.Branch.Causal Transaction)) loadCausalBranchByCausalHash hc = do Q.loadCausalHashIdByCausalHash hc >>= \case Just chId -> Just <$> expectCausalByCausalHashId chId Nothing -> pure Nothing -expectCausalByCausalHashId :: DB m => Db.CausalHashId -> m (C.Branch.Causal m) +expectCausalByCausalHashId :: Db.CausalHashId -> Transaction (C.Branch.Causal Transaction) expectCausalByCausalHashId id = do hc <- Q.expectCausalHash id hb <- expectValueHashByCausalHashId id @@ -948,30 +980,30 @@ expectCausalByCausalHashId id = do pure (h, expectCausalByCausalHashId hId) pure $ C.Causal hc hb (Map.fromList loadParents) (expectBranchByCausalHashId id) -expectBranchByCausalHashId :: DB m => Db.CausalHashId -> m (C.Branch.Branch m) +expectBranchByCausalHashId :: Db.CausalHashId -> Transaction (C.Branch.Branch Transaction) expectBranchByCausalHashId id = do boId <- Q.expectBranchObjectIdByCausalHashId id expectBranch boId -expectDbBranch :: DB m => Db.BranchObjectId -> m S.DbBranch +expectDbBranch :: Db.BranchObjectId -> Transaction S.DbBranch expectDbBranch id = deserializeBranchObject id >>= \case S.BranchFormat.Full li f -> pure (S.BranchFormat.localToDbBranch li f) S.BranchFormat.Diff r li d -> doDiff r [S.BranchFormat.localToDbDiff li d] where - deserializeBranchObject :: DB m => Db.BranchObjectId -> m S.BranchFormat + deserializeBranchObject :: Db.BranchObjectId -> Transaction S.BranchFormat deserializeBranchObject id = do when debug $ traceM $ "deserializeBranchObject " ++ show id Q.expectNamespaceObject (Db.unBranchObjectId id) decodeBranchFormat - doDiff :: DB m => Db.BranchObjectId -> [S.Branch.Diff] -> m S.DbBranch + doDiff :: Db.BranchObjectId -> [S.Branch.Diff] -> Transaction S.DbBranch doDiff ref ds = deserializeBranchObject ref >>= \case - S.BranchFormat.Full li f -> joinFull (S.BranchFormat.localToDbBranch li f) ds + S.BranchFormat.Full li f -> pure (joinFull (S.BranchFormat.localToDbBranch li f) ds) S.BranchFormat.Diff ref' li' d' -> doDiff ref' (S.BranchFormat.localToDbDiff li' d' : ds) where - joinFull :: DB m => S.DbBranch -> [S.Branch.Diff] -> m S.DbBranch - joinFull f [] = pure f + joinFull :: S.DbBranch -> [S.Branch.Diff] -> S.DbBranch + joinFull f [] = f joinFull (S.Branch.Full.Branch tms tps patches children) (S.Branch.Diff tms' tps' patches' children' : ds) = joinFull f' ds @@ -1059,58 +1091,58 @@ expectDbBranch id = let (Set.fromList -> adds, Set.fromList -> removes) = S.BranchDiff.addsRemoves md' in Just . S.MetadataSet.Inline $ (Set.union adds $ Set.difference md removes) -expectBranch :: DB m => Db.BranchObjectId -> m (C.Branch.Branch m) +expectBranch :: Db.BranchObjectId -> Transaction (C.Branch.Branch Transaction) expectBranch id = expectDbBranch id >>= s2cBranch -- * Patch transformation -expectPatch :: DB m => Db.PatchObjectId -> m C.Branch.Patch +expectPatch :: Db.PatchObjectId -> Transaction C.Branch.Patch expectPatch patchId = expectDbPatch patchId >>= s2cPatch -expectDbPatch :: DB m => Db.PatchObjectId -> m S.Patch +expectDbPatch :: Db.PatchObjectId -> Transaction S.Patch expectDbPatch patchId = deserializePatchObject patchId >>= \case S.Patch.Format.Full li p -> pure (S.Patch.Format.localPatchToPatch li p) S.Patch.Format.Diff ref li d -> doDiff ref [S.Patch.Format.localPatchDiffToPatchDiff li d] where - doDiff :: DB m => Db.PatchObjectId -> [S.PatchDiff] -> m S.Patch + doDiff :: Db.PatchObjectId -> [S.PatchDiff] -> Transaction S.Patch doDiff ref ds = deserializePatchObject ref >>= \case S.Patch.Format.Full li f -> pure (S.Patch.Format.applyPatchDiffs (S.Patch.Format.localPatchToPatch li f) ds) S.Patch.Format.Diff ref' li' d' -> doDiff ref' (S.Patch.Format.localPatchDiffToPatchDiff li' d' : ds) -savePatch :: DB m => PatchHash -> C.Branch.Patch -> m Db.PatchObjectId +savePatch :: PatchHash -> C.Branch.Patch -> Transaction Db.PatchObjectId savePatch h c = do (li, lPatch) <- LocalizeObject.localizePatch <$> c2sPatch c saveDbPatch h (S.Patch.Format.Full li lPatch) -saveDbPatch :: DB m => PatchHash -> S.PatchFormat -> m Db.PatchObjectId +saveDbPatch :: PatchHash -> S.PatchFormat -> Transaction Db.PatchObjectId saveDbPatch hash patch = do hashId <- Q.saveHashHash (unPatchHash hash) let bytes = S.putBytes S.putPatchFormat patch Db.PatchObjectId <$> Q.saveObject hashId OT.Patch bytes -s2cPatch :: DB m => S.Patch -> m C.Branch.Patch +s2cPatch :: S.Patch -> Transaction C.Branch.Patch s2cPatch (S.Patch termEdits typeEdits) = C.Branch.Patch <$> Map.bitraverse h2cReferent (Set.traverse s2cTermEdit) termEdits <*> Map.bitraverse h2cReference (Set.traverse s2cTypeEdit) typeEdits -deserializePatchObject :: DB m => Db.PatchObjectId -> m S.PatchFormat +deserializePatchObject :: Db.PatchObjectId -> Transaction S.PatchFormat deserializePatchObject id = do when debug $ traceM $ "Operations.deserializePatchObject " ++ show id Q.expectPatchObject (Db.unPatchObjectId id) decodePatchFormat -lca :: DB m => CausalHash -> CausalHash -> Connection -> Connection -> m (Maybe CausalHash) +lca :: CausalHash -> CausalHash -> Connection -> Connection -> Transaction (Maybe CausalHash) lca h1 h2 c1 c2 = runMaybeT do chId1 <- MaybeT $ Q.loadCausalHashIdByCausalHash h1 chId2 <- MaybeT $ Q.loadCausalHashIdByCausalHash h2 - chId3 <- MaybeT . liftIO $ Q.lca chId1 chId2 c1 c2 - Q.expectCausalHash chId3 + chId3 <- MaybeT . idempotentIO $ Q.lca chId1 chId2 c1 c2 + lift (Q.expectCausalHash chId3) -before :: DB m => CausalHash -> CausalHash -> m (Maybe Bool) +before :: CausalHash -> CausalHash -> Transaction (Maybe Bool) before h1 h2 = runMaybeT do chId2 <- MaybeT $ Q.loadCausalHashIdByCausalHash h2 lift (Q.loadCausalHashIdByCausalHash h1) >>= \case @@ -1119,76 +1151,75 @@ before h1 h2 = runMaybeT do -- * Searches -termsHavingType :: DB m => C.Reference -> m (Set C.Referent.Id) -termsHavingType cTypeRef = do - maySet <- runMaybeT $ do - sTypeRef <- c2hReference cTypeRef - sIds <- Q.getReferentsByType sTypeRef - traverse s2cReferentId sIds - pure case maySet of - Nothing -> mempty - Just set -> Set.fromList set - -typeReferenceForTerm :: DB m => S.Reference.Id -> m S.ReferenceH +termsHavingType :: C.Reference -> Transaction (Set C.Referent.Id) +termsHavingType cTypeRef = + runMaybeT (c2hReference cTypeRef) >>= \case + Nothing -> pure Set.empty + Just sTypeRef -> do + sIds <- Q.getReferentsByType sTypeRef + set <- traverse s2cReferentId sIds + pure (Set.fromList set) + +typeReferenceForTerm :: S.Reference.Id -> Transaction S.ReferenceH typeReferenceForTerm = Q.getTypeReferenceForReferent . C.Referent.RefId -termsMentioningType :: DB m => C.Reference -> m (Set C.Referent.Id) -termsMentioningType cTypeRef = do - maySet <- runMaybeT $ do - sTypeRef <- c2hReference cTypeRef - sIds <- Q.getReferentsByTypeMention sTypeRef - traverse s2cReferentId sIds - pure case maySet of - Nothing -> mempty - Just set -> Set.fromList set - -addTypeToIndexForTerm :: DB m => S.Referent.Id -> C.Reference -> m () +termsMentioningType :: C.Reference -> Transaction (Set C.Referent.Id) +termsMentioningType cTypeRef = + runMaybeT (c2hReference cTypeRef) >>= \case + Nothing -> pure Set.empty + Just sTypeRef -> do + sIds <- Q.getReferentsByTypeMention sTypeRef + set <- traverse s2cReferentId sIds + pure (Set.fromList set) + +addTypeToIndexForTerm :: S.Referent.Id -> C.Reference -> Transaction () addTypeToIndexForTerm sTermId cTypeRef = do sTypeRef <- saveReferenceH cTypeRef Q.addToTypeIndex sTypeRef sTermId -addTypeMentionsToIndexForTerm :: DB m => S.Referent.Id -> Set C.Reference -> m () +addTypeMentionsToIndexForTerm :: S.Referent.Id -> Set C.Reference -> Transaction () addTypeMentionsToIndexForTerm sTermId cTypeMentionRefs = do traverse_ (flip Q.addToTypeMentionsIndex sTermId <=< saveReferenceH) cTypeMentionRefs -- something kind of funny here. first, we don't need to enumerate all the reference pos if we're just picking one -- second, it would be nice if we could leave these as S.References a little longer -- so that we remember how to blow up if they're missing -componentReferencesByPrefix :: DB m => OT.ObjectType -> Text -> Maybe C.Reference.Pos -> m [S.Reference.Id] +componentReferencesByPrefix :: OT.ObjectType -> Text -> Maybe C.Reference.Pos -> Transaction [S.Reference.Id] componentReferencesByPrefix ot b32prefix pos = do oIds :: [Db.ObjectId] <- Q.objectIdByBase32Prefix ot b32prefix let test = maybe (const True) (==) pos let filterComponent l = [x | x@(C.Reference.Id _ pos) <- l, test pos] - fmap Monoid.fromMaybe . runMaybeT $ - join <$> traverse (fmap filterComponent . componentByObjectId) oIds + join <$> traverse (fmap filterComponent . componentByObjectId) oIds -termReferencesByPrefix :: DB m => Text -> Maybe Word64 -> m [C.Reference.Id] +termReferencesByPrefix :: Text -> Maybe Word64 -> Transaction [C.Reference.Id] termReferencesByPrefix t w = componentReferencesByPrefix OT.TermComponent t w >>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId) -declReferencesByPrefix :: DB m => Text -> Maybe Word64 -> m [C.Reference.Id] +declReferencesByPrefix :: Text -> Maybe Word64 -> Transaction [C.Reference.Id] declReferencesByPrefix t w = componentReferencesByPrefix OT.DeclComponent t w >>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId) -termReferentsByPrefix :: DB m => Text -> Maybe Word64 -> m [C.Referent.Id] +termReferentsByPrefix :: Text -> Maybe Word64 -> Transaction [C.Referent.Id] termReferentsByPrefix b32prefix pos = fmap C.Referent.RefId <$> termReferencesByPrefix b32prefix pos -- todo: simplify this if we stop caring about constructor type -- todo: remove the cycle length once we drop it from Unison.Reference declReferentsByPrefix :: - DB m => Text -> Maybe C.Reference.Pos -> Maybe ConstructorId -> - m [(H.Hash, C.Reference.Pos, C.DeclType, [C.Decl.ConstructorId])] + Transaction [(H.Hash, C.Reference.Pos, C.DeclType, [C.Decl.ConstructorId])] declReferentsByPrefix b32prefix pos cid = do componentReferencesByPrefix OT.DeclComponent b32prefix pos >>= traverse (loadConstructors cid) where - loadConstructors :: DB m => Maybe Word64 -> S.Reference.Id -> m (H.Hash, C.Reference.Pos, C.DeclType, [ConstructorId]) + loadConstructors :: + Maybe Word64 -> + S.Reference.Id -> + Transaction (H.Hash, C.Reference.Pos, C.DeclType, [ConstructorId]) loadConstructors cid rid@(C.Reference.Id oId pos) = do (dt, ctorCount) <- getDeclCtorCount rid h <- Q.expectPrimaryHashByObjectId oId @@ -1196,26 +1227,26 @@ declReferentsByPrefix b32prefix pos cid = do test = maybe (const True) (==) cid cids = [cid | cid <- [0 :: ConstructorId .. ctorCount - 1], test cid] pure (h, pos, dt, cids) - getDeclCtorCount :: DB m => S.Reference.Id -> m (C.Decl.DeclType, ConstructorId) + getDeclCtorCount :: S.Reference.Id -> Transaction (C.Decl.DeclType, ConstructorId) getDeclCtorCount id@(C.Reference.Id r i) = do when debug $ traceM $ "getDeclCtorCount " ++ show id (_localIds, decl) <- Q.expectDeclObject r (decodeDeclElement i) pure (C.Decl.declType decl, fromIntegral $ length (C.Decl.constructorTypes decl)) -branchHashesByPrefix :: DB m => ShortBranchHash -> m (Set BranchHash) +branchHashesByPrefix :: ShortBranchHash -> Transaction (Set BranchHash) branchHashesByPrefix (ShortBranchHash b32prefix) = do hashIds <- Q.namespaceHashIdByBase32Prefix b32prefix hashes <- traverse (Q.expectHash . Db.unBranchHashId) hashIds pure $ Set.fromList . map BranchHash $ hashes -causalHashesByPrefix :: DB m => ShortBranchHash -> m (Set CausalHash) +causalHashesByPrefix :: ShortBranchHash -> Transaction (Set CausalHash) causalHashesByPrefix (ShortBranchHash b32prefix) = do hashIds <- Q.causalHashIdByBase32Prefix b32prefix hashes <- traverse (Q.expectHash . Db.unCausalHashId) hashIds pure $ Set.fromList . map CausalHash $ hashes -- | returns a list of known definitions referencing `r` -dependents :: DB m => C.Reference -> m (Set C.Reference.Id) +dependents :: C.Reference -> Transaction (Set C.Reference.Id) dependents r = do r' <- c2sReference r sIds :: [S.Reference.Id] <- Q.getDependentsForDependency r' @@ -1223,7 +1254,7 @@ dependents r = do pure $ Set.fromList cIds -- | returns a list of known definitions referencing `h` -dependentsOfComponent :: DB m => H.Hash -> m (Set C.Reference.Id) +dependentsOfComponent :: H.Hash -> Transaction (Set C.Reference.Id) dependentsOfComponent h = do oId <- Q.expectObjectIdForPrimaryHash h sIds :: [S.Reference.Id] <- Q.getDependentsForDependencyComponent oId @@ -1231,7 +1262,7 @@ dependentsOfComponent h = do pure $ Set.fromList cIds -- | returns empty set for unknown inputs; doesn't distinguish between term and decl -derivedDependencies :: DB m => C.Reference.Id -> m (Set C.Reference.Id) +derivedDependencies :: C.Reference.Id -> Transaction (Set C.Reference.Id) derivedDependencies cid = do sid <- c2sReferenceId cid sids <- Q.getDependencyIdsForDependent sid diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 025e98aa58..566ababc34 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -117,7 +117,6 @@ module U.Codebase.Sqlite.Queries causalHashIdByBase32Prefix, -- * garbage collection - vacuum, garbageCollectObjectsWithoutHashes, garbageCollectWatchesWithoutObjects, @@ -125,11 +124,9 @@ module U.Codebase.Sqlite.Queries createSchema, schemaVersion, setSchemaVersion, - vacuumInto, ) where -import qualified Data.List.Extra as List import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel import qualified Data.Set as Set @@ -158,119 +155,111 @@ import qualified U.Util.Alternative as Alternative import U.Util.Base32Hex (Base32Hex (..)) import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash -import Unison.Sqlite -import qualified Unison.Sqlite.DB as DB -import qualified Unison.Sqlite.Transaction as Transaction import Unison.Prelude +import Unison.Sqlite -- * main squeeze -createSchema :: (DB m, MonadUnliftIO m) => m () +createSchema :: Transaction () createSchema = - DB.runTransaction do - traverse_ (Transaction.execute_ . fromString) $ List.splitOn ";" [hereFile|sql/create.sql|] - --- | Copy the database into the specified location, performing a VACUUM in the process. -vacuumInto :: DB m => FilePath -> m () -vacuumInto dest = do - execute "VACUUM INTO ?" [dest] + execute_ [hereFile|sql/create.sql|] -schemaVersion :: DB m => m SchemaVersion +schemaVersion :: Transaction SchemaVersion schemaVersion = queryOneCol_ sql where sql = "SELECT version from schema_version;" -setSchemaVersion :: DB m => SchemaVersion -> m () +setSchemaVersion :: SchemaVersion -> Transaction () setSchemaVersion schemaVersion = execute sql (Only schemaVersion) where sql = "UPDATE schema_version SET version = ?" {- ORMOLU_DISABLE -} {- Please don't try to format the SQL blocks โ€”AI -} -countObjects :: DB m => m Int +countObjects :: Transaction Int countObjects = queryOneCol_ [here| SELECT COUNT(*) FROM object |] -countCausals :: DB m => m Int +countCausals :: Transaction Int countCausals = queryOneCol_ [here| SELECT COUNT(*) FROM causal |] -countWatches :: DB m => m Int +countWatches :: Transaction Int countWatches = queryOneCol_ [here| SELECT COUNT(*) FROM watch |] -saveHash :: DB m => Base32Hex -> m HashId +saveHash :: Base32Hex -> Transaction HashId saveHash base32 = execute sql (Only base32) >> expectHashId base32 where sql = [here| INSERT INTO hash (base32) VALUES (?) ON CONFLICT DO NOTHING |] -saveHashHash :: DB m => Hash -> m HashId +saveHashHash :: Hash -> Transaction HashId saveHashHash = saveHash . Hash.toBase32Hex -loadHashId :: DB m => Base32Hex -> m (Maybe HashId) +loadHashId :: Base32Hex -> Transaction (Maybe HashId) loadHashId base32 = queryMaybeCol loadHashIdSql (Only base32) -expectHashId :: DB m => Base32Hex -> m HashId +expectHashId :: Base32Hex -> Transaction HashId expectHashId base32 = queryOneCol loadHashIdSql (Only base32) loadHashIdSql :: Sql loadHashIdSql = [here| SELECT id FROM hash WHERE base32 = ? |] -loadHashIdByHash :: DB m => Hash -> m (Maybe HashId) +loadHashIdByHash :: Hash -> Transaction (Maybe HashId) loadHashIdByHash = loadHashId . Hash.toBase32Hex -saveCausalHash :: DB m => CausalHash -> m CausalHashId +saveCausalHash :: CausalHash -> Transaction CausalHashId saveCausalHash = fmap CausalHashId . saveHashHash . unCausalHash -saveBranchHash :: DB m => BranchHash -> m BranchHashId +saveBranchHash :: BranchHash -> Transaction BranchHashId saveBranchHash = fmap BranchHashId . saveHashHash . unBranchHash -loadCausalHashIdByCausalHash :: DB m => CausalHash -> m (Maybe CausalHashId) +loadCausalHashIdByCausalHash :: CausalHash -> Transaction (Maybe CausalHashId) loadCausalHashIdByCausalHash ch = runMaybeT do hId <- MaybeT $ loadHashIdByHash (unCausalHash ch) - Alternative.whenM (isCausalHash hId) (CausalHashId hId) + Alternative.whenM (lift (isCausalHash hId)) (CausalHashId hId) -loadCausalByCausalHash :: DB m => CausalHash -> m (Maybe (CausalHashId, BranchHashId)) +loadCausalByCausalHash :: CausalHash -> Transaction (Maybe (CausalHashId, BranchHashId)) loadCausalByCausalHash ch = runMaybeT do hId <- MaybeT $ loadHashIdByHash (unCausalHash ch) bhId <- MaybeT $ loadCausalValueHashId hId pure (CausalHashId hId, bhId) -expectHashIdByHash :: DB m => Hash -> m HashId +expectHashIdByHash :: Hash -> Transaction HashId expectHashIdByHash = expectHashId . Hash.toBase32Hex -expectHash :: DB m => HashId -> m Hash +expectHash :: HashId -> Transaction Hash expectHash h = Hash.fromBase32Hex <$> expectHash32 h -expectHash32 :: DB m => HashId -> m Base32Hex +expectHash32 :: HashId -> Transaction Base32Hex expectHash32 h = queryOneCol sql (Only h) where sql = [here|ย SELECT base32 FROM hash WHERE id = ? |] -saveText :: DB m => Text -> m TextId +saveText :: Text -> Transaction TextId saveText t = execute sql (Only t) >> expectTextId t where sql = [here| INSERT INTO text (text) VALUES (?) ON CONFLICT DO NOTHING|] -loadTextId :: DB m => Text -> m (Maybe TextId) +loadTextId :: Text -> Transaction (Maybe TextId) loadTextId t = queryMaybeCol loadTextIdSql (Only t) -expectTextId :: DB m => Text -> m TextId +expectTextId :: Text -> Transaction TextId expectTextId t = queryOneCol loadTextIdSql (Only t) loadTextIdSql :: Sql loadTextIdSql = [here| SELECT id FROM text WHERE text = ? |] -expectText :: DB m => TextId -> m Text +expectText :: TextId -> Transaction Text expectText h = queryOneCol loadTextSql (Only h) -expectTextCheck :: (DB m, SqliteExceptionReason e) => TextId -> (Text -> Either e a) -> m a +expectTextCheck :: SqliteExceptionReason e => TextId -> (Text -> Either e a) -> Transaction a expectTextCheck h = queryOneColCheck loadTextSql (Only h) loadTextSql :: Sql loadTextSql = [here|ย SELECT text FROM text WHERE id = ? |] -saveHashObject :: DB m => HashId -> ObjectId -> HashVersion -> m () +saveHashObject :: HashId -> ObjectId -> HashVersion -> Transaction () saveHashObject hId oId version = execute sql (hId, oId, version) where sql = [here| INSERT INTO hash_object (hash_id, object_id, hash_version) @@ -278,7 +267,7 @@ saveHashObject hId oId version = execute sql (hId, oId, version) where ON CONFLICT DO NOTHING |] -saveObject :: DB m => HashId -> ObjectType -> ByteString -> m ObjectId +saveObject :: HashId -> ObjectType -> ByteString -> Transaction ObjectId saveObject h t blob = do oId <- execute sql (h, t, blob) >> expectObjectIdForPrimaryHashId h saveHashObject h oId 2 -- todo: remove this from here, and add it to other relevant places once there are v1 and v2 hashes @@ -290,7 +279,7 @@ saveObject h t blob = do ON CONFLICT DO NOTHING |] -expectObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a expectObject oId check = do result <- queryOneColCheck sql (Only oId) check pure result @@ -299,15 +288,15 @@ expectObject oId check = do |] loadObjectOfType :: - (DB m, SqliteExceptionReason e) => + SqliteExceptionReason e => ObjectId -> ObjectType -> (ByteString -> Either e a) -> - m (Maybe a) + Transaction (Maybe a) loadObjectOfType oid ty = queryMaybeColCheck loadObjectOfTypeSql (oid, ty) -expectObjectOfType :: (DB m, SqliteExceptionReason e) => ObjectId -> ObjectType -> (ByteString -> Either e a) -> m a +expectObjectOfType :: SqliteExceptionReason e => ObjectId -> ObjectType -> (ByteString -> Either e a) -> Transaction a expectObjectOfType oid ty = queryOneColCheck loadObjectOfTypeSql (oid, ty) @@ -321,57 +310,57 @@ loadObjectOfTypeSql = |] -- | Load a decl component object. -loadDeclObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) +loadDeclObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a) loadDeclObject oid = loadObjectOfType oid DeclComponent -- | Expect a decl component object. -expectDeclObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectDeclObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a expectDeclObject oid = expectObjectOfType oid DeclComponent -- | Load a namespace object. -loadNamespaceObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) +loadNamespaceObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a) loadNamespaceObject oid = loadObjectOfType oid Namespace -- | Expect a namespace object. -expectNamespaceObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectNamespaceObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a expectNamespaceObject oid = expectObjectOfType oid Namespace -- | Load a patch object. -loadPatchObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) +loadPatchObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a) loadPatchObject oid = loadObjectOfType oid Patch -- | Expect a patch object. -expectPatchObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectPatchObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a expectPatchObject oid = expectObjectOfType oid Patch -- | Load a term component object. -loadTermObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m (Maybe a) +loadTermObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a) loadTermObject oid = loadObjectOfType oid TermComponent -- | Expect a term component object. -expectTermObject :: (DB m, SqliteExceptionReason e) => ObjectId -> (ByteString -> Either e a) -> m a +expectTermObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a expectTermObject oid = expectObjectOfType oid TermComponent -expectObjectWithHashIdAndType :: DB m => ObjectId -> m (HashId, ObjectType, ByteString) +expectObjectWithHashIdAndType :: ObjectId -> Transaction (HashId, ObjectType, ByteString) expectObjectWithHashIdAndType oId = queryOneRow sql (Only oId) where sql = [here| SELECT primary_hash_id, type_id, bytes FROM object WHERE id = ? |] -loadObjectIdForPrimaryHashId :: DB m => HashId -> m (Maybe ObjectId) +loadObjectIdForPrimaryHashId :: HashId -> Transaction (Maybe ObjectId) loadObjectIdForPrimaryHashId h = queryMaybeCol loadObjectIdForPrimaryHashIdSql (Only h) -- | Not all hashes have corresponding objects; e.g., hashes of term types -expectObjectIdForPrimaryHashId :: DB m => HashId -> m ObjectId +expectObjectIdForPrimaryHashId :: HashId -> Transaction ObjectId expectObjectIdForPrimaryHashId h = queryOneCol loadObjectIdForPrimaryHashIdSql (Only h) @@ -383,32 +372,32 @@ loadObjectIdForPrimaryHashIdSql = WHERE primary_hash_id = ? |] -loadObjectIdForPrimaryHash :: DB m => Hash -> m (Maybe ObjectId) +loadObjectIdForPrimaryHash :: Hash -> Transaction (Maybe ObjectId) loadObjectIdForPrimaryHash h = loadHashIdByHash h >>= \case Nothing -> pure Nothing Just hashId -> loadObjectIdForPrimaryHashId hashId -expectObjectIdForPrimaryHash :: DB m => Hash -> m ObjectId +expectObjectIdForPrimaryHash :: Hash -> Transaction ObjectId expectObjectIdForPrimaryHash h = do hashId <- expectHashIdByHash h expectObjectIdForPrimaryHashId hashId -loadPatchObjectIdForPrimaryHash :: DB m => PatchHash -> m (Maybe PatchObjectId) +loadPatchObjectIdForPrimaryHash :: PatchHash -> Transaction (Maybe PatchObjectId) loadPatchObjectIdForPrimaryHash = (fmap . fmap) PatchObjectId . loadObjectIdForPrimaryHash . unPatchHash -loadObjectIdForAnyHash :: DB m => Hash -> m (Maybe ObjectId) +loadObjectIdForAnyHash :: Hash -> Transaction (Maybe ObjectId) loadObjectIdForAnyHash h = loadHashIdByHash h >>= \case Nothing -> pure Nothing Just hashId -> loadObjectIdForAnyHashId hashId -loadObjectIdForAnyHashId :: DB m => HashId -> m (Maybe ObjectId) +loadObjectIdForAnyHashId :: HashId -> Transaction (Maybe ObjectId) loadObjectIdForAnyHashId h = queryMaybeCol loadObjectIdForAnyHashIdSql (Only h) -expectObjectIdForAnyHashId :: DB m => HashId -> m ObjectId +expectObjectIdForAnyHashId :: HashId -> Transaction ObjectId expectObjectIdForAnyHashId h = queryOneCol loadObjectIdForAnyHashIdSql (Only h) @@ -417,11 +406,11 @@ loadObjectIdForAnyHashIdSql = [here| SELECT object_id FROM hash_object WHERE hash_id = ? |] -- | All objects have corresponding hashes. -expectPrimaryHashByObjectId :: DB m => ObjectId -> m Hash +expectPrimaryHashByObjectId :: ObjectId -> Transaction Hash expectPrimaryHashByObjectId = fmap Hash.fromBase32Hex . expectPrimaryHash32ByObjectId -expectPrimaryHash32ByObjectId :: DB m => ObjectId -> m Base32Hex +expectPrimaryHash32ByObjectId :: ObjectId -> Transaction Base32Hex expectPrimaryHash32ByObjectId oId = queryOneCol sql (Only oId) where sql = [here| SELECT hash.base32 @@ -429,7 +418,7 @@ expectPrimaryHash32ByObjectId oId = queryOneCol sql (Only oId) WHERE object.id = ? |] -expectHashIdsForObject :: DB m => ObjectId -> m (NonEmpty HashId) +expectHashIdsForObject :: ObjectId -> Transaction (NonEmpty HashId) expectHashIdsForObject oId = do primaryHashId <- queryOneCol sql1 (Only oId) hashIds <- queryListCol sql2 (Only oId) @@ -438,7 +427,7 @@ expectHashIdsForObject oId = do sql1 = "SELECT primary_hash_id FROM object WHERE id = ?" sql2 = "SELECT hash_id FROM hash_object WHERE object_id = ?" -hashIdWithVersionForObject :: DB m => ObjectId -> m [(HashId, HashVersion)] +hashIdWithVersionForObject :: ObjectId -> Transaction [(HashId, HashVersion)] hashIdWithVersionForObject = queryListRow sql . Only where sql = [here| SELECT hash_id, hash_version FROM hash_object WHERE object_id = ? |] @@ -446,7 +435,7 @@ hashIdWithVersionForObject = queryListRow sql . Only where sql = [here| -- | @recordObjectRehash old new@ records that object @old@ was rehashed and inserted as a new object, @new@. -- -- This function rewrites @old@'s @hash_object@ rows in place to point at the new object. -recordObjectRehash :: DB m => ObjectId -> ObjectId -> m () +recordObjectRehash :: ObjectId -> ObjectId -> Transaction () recordObjectRehash old new = execute sql (new, old) where @@ -458,7 +447,7 @@ recordObjectRehash old new = -- |Maybe we would generalize this to something other than NamespaceHash if we -- end up wanting to store other kinds of Causals here too. -saveCausal :: DB m => CausalHashId -> BranchHashId -> m () +saveCausal :: CausalHashId -> BranchHashId -> Transaction () saveCausal self value = execute sql (self, value) where sql = [here| INSERT INTO causal (self_hash_id, value_hash_id) VALUES (?, ?) @@ -482,14 +471,14 @@ saveCausal self value = execute sql (self, value) where sql = [here| -- SELECT MAX(gc_generation) FROM causal; -- |] -expectCausalValueHashId :: DB m => CausalHashId -> m BranchHashId +expectCausalValueHashId :: CausalHashId -> Transaction BranchHashId expectCausalValueHashId (CausalHashId id) = queryOneCol loadCausalValueHashIdSql (Only id) -expectCausalHash :: DB m => CausalHashId -> m CausalHash +expectCausalHash :: CausalHashId -> Transaction CausalHash expectCausalHash (CausalHashId id) = CausalHash <$> expectHash id -loadCausalValueHashId :: DB m => HashId -> m (Maybe BranchHashId) +loadCausalValueHashId :: HashId -> Transaction (Maybe BranchHashId) loadCausalValueHashId id = queryMaybeCol loadCausalValueHashIdSql (Only id) @@ -497,15 +486,15 @@ loadCausalValueHashIdSql :: Sql loadCausalValueHashIdSql = [here| SELECT value_hash_id FROM causal WHERE self_hash_id = ? |] -isCausalHash :: DB m => HashId -> m Bool +isCausalHash :: HashId -> Transaction Bool isCausalHash = queryOneCol sql . Only where sql = [here| SELECT EXISTS (SELECT 1 FROM causal WHERE self_hash_id = ?) |] -loadBranchObjectIdByCausalHashId :: DB m => CausalHashId -> m (Maybe BranchObjectId) +loadBranchObjectIdByCausalHashId :: CausalHashId -> Transaction (Maybe BranchObjectId) loadBranchObjectIdByCausalHashId id = queryMaybeCol loadBranchObjectIdByCausalHashIdSql (Only id) -expectBranchObjectIdByCausalHashId :: DB m => CausalHashId -> m BranchObjectId +expectBranchObjectIdByCausalHashId :: CausalHashId -> Transaction BranchObjectId expectBranchObjectIdByCausalHashId id = queryOneCol loadBranchObjectIdByCausalHashIdSql (Only id) loadBranchObjectIdByCausalHashIdSql :: Sql @@ -516,23 +505,23 @@ loadBranchObjectIdByCausalHashIdSql = WHERE causal.self_hash_id = ? |] -saveCausalParents :: DB m => CausalHashId -> [CausalHashId] -> m () +saveCausalParents :: CausalHashId -> [CausalHashId] -> Transaction () saveCausalParents child parents = executeMany sql $ (child,) <$> parents where sql = [here| INSERT INTO causal_parent (causal_id, parent_id) VALUES (?, ?) ON CONFLICT DO NOTHING |] -loadCausalParents :: DB m => CausalHashId -> m [CausalHashId] +loadCausalParents :: CausalHashId -> Transaction [CausalHashId] loadCausalParents h = queryListCol sql (Only h) where sql = [here| SELECT parent_id FROM causal_parent WHERE causal_id = ? |] -expectNamespaceRoot :: DB m => m CausalHashId +expectNamespaceRoot :: Transaction CausalHashId expectNamespaceRoot = queryOneCol_ loadNamespaceRootSql -loadNamespaceRoot :: DB m => m (Maybe CausalHashId) +loadNamespaceRoot :: Transaction (Maybe CausalHashId) loadNamespaceRoot = queryMaybeCol_ loadNamespaceRootSql @@ -543,7 +532,7 @@ loadNamespaceRootSql = FROM namespace_root |] -setNamespaceRoot :: forall m. DB m => CausalHashId -> m () +setNamespaceRoot :: CausalHashId -> Transaction () setNamespaceRoot id = queryOneCol_ "SELECT EXISTS (SELECT 1 FROM namespace_root)" >>= \case False -> execute insert (Only id) @@ -552,7 +541,7 @@ setNamespaceRoot id = insert = "INSERT INTO namespace_root VALUES (?)" update = "UPDATE namespace_root SET causal_id = ?" -saveWatch :: DB m => WatchKind -> Reference.IdH -> ByteString -> m () +saveWatch :: WatchKind -> Reference.IdH -> ByteString -> Transaction () saveWatch k r blob = execute sql (r :. Only blob) >> execute sql2 (r :. Only k) where sql = [here| @@ -566,7 +555,12 @@ saveWatch k r blob = execute sql (r :. Only blob) >> execute sql2 (r :. Only k) ON CONFLICT DO NOTHING |] -loadWatch :: (DB m, SqliteExceptionReason e) => WatchKind -> Reference.IdH -> (ByteString -> Either e a) -> m (Maybe a) +loadWatch :: + SqliteExceptionReason e => + WatchKind -> + Reference.IdH -> + (ByteString -> Either e a) -> + Transaction (Maybe a) loadWatch k r check = queryMaybeColCheck sql (Only k :. r) check where sql = [here| SELECT result FROM watch_result INNER JOIN watch @@ -577,7 +571,7 @@ loadWatch k r check = queryMaybeColCheck sql (Only k :. r) check where sql = [he AND watch.component_index = ? |] -loadWatchKindsByReference :: DB m => Reference.IdH -> m [WatchKind] +loadWatchKindsByReference :: Reference.IdH -> Transaction [WatchKind] loadWatchKindsByReference r = queryListCol sql r where sql = [here| SELECT watch_kind_id FROM watch_result INNER JOIN watch @@ -587,18 +581,18 @@ loadWatchKindsByReference r = queryListCol sql r where sql = [here| AND watch.component_index = ? |] -loadWatchesByWatchKind :: DB m => WatchKind -> m [Reference.IdH] +loadWatchesByWatchKind :: WatchKind -> Transaction [Reference.IdH] loadWatchesByWatchKind k = queryListRow sql (Only k) where sql = [here| SELECT hash_id, component_index FROM watch WHERE watch_kind_id = ? |] -clearWatches :: DB m => m () +clearWatches :: Transaction () clearWatches = do execute_ "DELETE FROM watch_result" execute_ "DELETE FROM watch" -- * Index-building -addToTypeIndex :: DB m => Reference' TextId HashId -> Referent.Id -> m () +addToTypeIndex :: Reference' TextId HashId -> Referent.Id -> Transaction () addToTypeIndex tp tm = execute sql (tp :. tm) where sql = [here| INSERT INTO find_type_index ( type_reference_builtin, @@ -611,7 +605,7 @@ addToTypeIndex tp tm = execute sql (tp :. tm) where sql = [here| ON CONFLICT DO NOTHING |] -getReferentsByType :: DB m => Reference' TextId HashId -> m [Referent.Id] +getReferentsByType :: Reference' TextId HashId -> Transaction [Referent.Id] getReferentsByType r = queryListRow sql r where sql = [here| SELECT term_referent_object_id, @@ -623,7 +617,7 @@ getReferentsByType r = queryListRow sql r where sql = [here| AND type_reference_component_index IS ? |] -getTypeReferenceForReferent :: DB m => Referent.Id -> m (Reference' TextId HashId) +getTypeReferenceForReferent :: Referent.Id -> Transaction (Reference' TextId HashId) getTypeReferenceForReferent r = queryOneRow sql r where sql = [here| @@ -638,7 +632,7 @@ getTypeReferenceForReferent r = |] -- todo: error if no results -getTypeReferencesForComponent :: DB m => ObjectId -> m [(Reference' TextId HashId, Referent.Id)] +getTypeReferencesForComponent :: ObjectId -> Transaction [(Reference' TextId HashId, Referent.Id)] getTypeReferencesForComponent oId = queryListRow sql (Only oId) <&> map fixupTypeIndexRow where sql = [here| SELECT @@ -652,7 +646,7 @@ getTypeReferencesForComponent oId = WHERE term_referent_object_id = ? |] -addToTypeMentionsIndex :: DB m => Reference' TextId HashId -> Referent.Id -> m () +addToTypeMentionsIndex :: Reference' TextId HashId -> Referent.Id -> Transaction () addToTypeMentionsIndex tp tm = execute sql (tp :. tm) where sql = [here| INSERT INTO find_type_mentions_index ( type_reference_builtin, @@ -665,7 +659,7 @@ addToTypeMentionsIndex tp tm = execute sql (tp :. tm) where sql = [here| ON CONFLICT DO NOTHING |] -getReferentsByTypeMention :: DB m => Reference' TextId HashId -> m [Referent.Id] +getReferentsByTypeMention :: Reference' TextId HashId -> Transaction [Referent.Id] getReferentsByTypeMention r = queryListRow sql r where sql = [here| SELECT term_referent_object_id, @@ -678,7 +672,7 @@ getReferentsByTypeMention r = queryListRow sql r where sql = [here| |] -- todo: error if no results -getTypeMentionsReferencesForComponent :: DB m => ObjectId -> m [(Reference' TextId HashId, Referent.Id)] +getTypeMentionsReferencesForComponent :: ObjectId -> Transaction [(Reference' TextId HashId, Referent.Id)] getTypeMentionsReferencesForComponent r = queryListRow sql (Only r) <&> map fixupTypeIndexRow where sql = [here| SELECT @@ -698,7 +692,7 @@ fixupTypeIndexRow (rh :. ri) = (rh, ri) -- | Delete objects without hashes. An object typically *would* have a hash, but (for example) during a migration in which an object's hash -- may change, its corresponding hash_object row may be updated to point at a new version of that object. This procedure clears out all -- references to objects that do not have any corresponding hash_object rows. -garbageCollectObjectsWithoutHashes :: DB m => m () +garbageCollectObjectsWithoutHashes :: Transaction () garbageCollectObjectsWithoutHashes = do execute_ [here| @@ -737,7 +731,7 @@ garbageCollectObjectsWithoutHashes = do |] -- | Delete all -garbageCollectWatchesWithoutObjects :: DB m => m () +garbageCollectWatchesWithoutObjects :: Transaction () garbageCollectWatchesWithoutObjects = do execute_ [here| @@ -746,12 +740,7 @@ garbageCollectWatchesWithoutObjects = do (SELECT hash_object.hash_id FROM hash_object) |] --- | Clean the database and recover disk space. --- This is an expensive operation. Also note that it cannot be executed within a transaction. -vacuum :: DB m => m () -vacuum = execute_ "VACUUM" - -addToDependentsIndex :: DB m => Reference.Reference -> Reference.Id -> m () +addToDependentsIndex :: Reference.Reference -> Reference.Id -> Transaction () addToDependentsIndex dependency dependent = execute sql (dependency :. dependent) where sql = [here| INSERT INTO dependents_index ( @@ -765,7 +754,7 @@ addToDependentsIndex dependency dependent = execute sql (dependency :. dependent |] -- | Get non-self, user-defined dependents of a dependency. -getDependentsForDependency :: DB m => Reference.Reference -> m [Reference.Id] +getDependentsForDependency :: Reference.Reference -> Transaction [Reference.Id] getDependentsForDependency dependency = filter isNotSelfReference <$> queryListRow sql dependency where @@ -784,7 +773,7 @@ getDependentsForDependency dependency = ReferenceBuiltin _ -> const True ReferenceDerived (C.Reference.Id oid0 _pos0) -> \(C.Reference.Id oid1 _pos1) -> oid0 /= oid1 -getDependentsForDependencyComponent :: DB m => ObjectId -> m [Reference.Id] +getDependentsForDependencyComponent :: ObjectId -> Transaction [Reference.Id] getDependentsForDependencyComponent dependency = filter isNotSelfReference <$> queryListRow sql (Only dependency) where @@ -801,7 +790,7 @@ getDependentsForDependencyComponent dependency = (C.Reference.Id oid1 _pos1) -> dependency /= oid1 -- | Get non-self dependencies of a user-defined dependent. -getDependenciesForDependent :: DB m => Reference.Id -> m [Reference.Reference] +getDependenciesForDependent :: Reference.Id -> Transaction [Reference.Reference] getDependenciesForDependent dependent@(C.Reference.Id oid0 _) = filter isNotSelfReference <$> queryListRow sql dependent where @@ -819,7 +808,7 @@ getDependenciesForDependent dependent@(C.Reference.Id oid0 _) = ReferenceDerived (C.Reference.Id oid1 _) -> oid0 /= oid1 -- | Get non-self, user-defined dependencies of a user-defined dependent. -getDependencyIdsForDependent :: DB m => Reference.Id -> m [Reference.Id] +getDependencyIdsForDependent :: Reference.Id -> Transaction [Reference.Id] getDependencyIdsForDependent dependent@(C.Reference.Id oid0 _) = filter isNotSelfReference <$> queryListRow sql dependent where @@ -836,7 +825,7 @@ getDependencyIdsForDependent dependent@(C.Reference.Id oid0 _) = isNotSelfReference (C.Reference.Id oid1 _) = oid0 /= oid1 -objectIdByBase32Prefix :: DB m => ObjectType -> Text -> m [ObjectId] +objectIdByBase32Prefix :: ObjectType -> Text -> Transaction [ObjectId] objectIdByBase32Prefix objType prefix = queryListCol sql (objType, prefix <> "%") where sql = [here| SELECT object.id FROM object INNER JOIN hash_object ON hash_object.object_id = object.id @@ -845,14 +834,14 @@ objectIdByBase32Prefix objType prefix = queryListCol sql (objType, prefix <> "%" AND hash.base32 LIKE ? |] -causalHashIdByBase32Prefix :: DB m => Text -> m [CausalHashId] +causalHashIdByBase32Prefix :: Text -> Transaction [CausalHashId] causalHashIdByBase32Prefix prefix = queryListCol sql (Only $ prefix <> "%") where sql = [here| SELECT self_hash_id FROM causal INNER JOIN hash ON id = self_hash_id WHERE base32 LIKE ? |] -namespaceHashIdByBase32Prefix :: DB m => Text -> m [BranchHashId] +namespaceHashIdByBase32Prefix :: Text -> Transaction [BranchHashId] namespaceHashIdByBase32Prefix prefix = queryListCol sql (Only $ prefix <> "%") where sql = [here| SELECT value_hash_id FROM causal INNER JOIN hash ON id = value_hash_id @@ -862,7 +851,7 @@ namespaceHashIdByBase32Prefix prefix = queryListCol sql (Only $ prefix <> "%") w -- | Finds all causals that refer to a branch for which we don't have an object stored. -- Although there are plans to support this in the future, currently all such cases -- are the result of database inconsistencies and are unexpected. -getCausalsWithoutBranchObjects :: DB m => m [CausalHashId] +getCausalsWithoutBranchObjects :: Transaction [CausalHashId] getCausalsWithoutBranchObjects = queryListCol_ sql where sql = [here| SELECT self_hash_id from causal @@ -873,7 +862,7 @@ getCausalsWithoutBranchObjects = queryListCol_ sql -- | Delete all hash objects of a given hash version. -- Leaves the corresponding `hash`es in the hash table alone. -removeHashObjectsByHashingVersion :: DB m => HashVersion -> m () +removeHashObjectsByHashingVersion :: HashVersion -> Transaction () removeHashObjectsByHashingVersion hashVersion = execute sql (Only hashVersion) where @@ -883,12 +872,12 @@ removeHashObjectsByHashingVersion hashVersion = WHERE hash_version = ? |] -before :: DB m => CausalHashId -> CausalHashId -> m Bool +before :: CausalHashId -> CausalHashId -> Transaction Bool before chId1 chId2 = queryOneCol sql (chId2, chId1) where sql = fromString $ "SELECT EXISTS (" ++ ancestorSql ++ " WHERE ancestor.id = ?)" --- the `Connection` arguments come second to fit the shape of Exception.bracket + uncurry curry +-- | the `Connection` arguments come second to fit the shape of Exception.bracket + uncurry curry lca :: CausalHashId -> CausalHashId -> Connection -> Connection -> IO (Maybe CausalHashId) lca x y cx cy = withStatement cx sql (Only x) \nextX -> diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs index 246b944181..b78927237c 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs @@ -11,7 +11,6 @@ module U.Codebase.Sqlite.Sync22 where import Control.Monad.Except (MonadError (throwError)) import Control.Monad.RWS (MonadReader) -import Control.Monad.Reader (ReaderT) import qualified Control.Monad.Reader as Reader import Control.Monad.Validate (ValidateT, runValidateT) import qualified Control.Monad.Validate as Validate @@ -40,7 +39,7 @@ import qualified U.Codebase.WatchKind as WK import U.Util.Cache (Cache) import qualified U.Util.Cache as Cache import Unison.Prelude -import Unison.Sqlite (Connection) +import Unison.Sqlite (Connection, Transaction, runTransaction) data Entity = O ObjectId @@ -413,12 +412,8 @@ trySync tCache hCache oCache cCache = \case runSrc, runDest :: - MonadReader Env m => - ReaderT Connection m a -> + (MonadIO m, MonadReader Env m) => + Transaction a -> m a -runSrc ma = Reader.reader srcDB >>= flip runDB ma -runDest ma = Reader.reader destDB >>= flip runDB ma - -runDB :: Connection -> ReaderT Connection m a -> m a -runDB conn action = - Reader.runReaderT action conn +runSrc ma = Reader.reader srcDB >>= flip runTransaction ma +runDest ma = Reader.reader destDB >>= flip runTransaction ma diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index d1446c2834..5e802cfb74 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -19,6 +19,7 @@ module Unison.Sqlite Transaction, runTransaction, savepoint, + idempotentIO, -- * Executing queries Sql (..), @@ -75,6 +76,10 @@ module Unison.Sqlite JournalMode (..), trySetJournalMode, + -- * Vacuum + vacuum, + vacuumInto, + -- ** Low-level withStatement, @@ -109,6 +114,8 @@ import Unison.Sqlite.Connection ( Connection, ExpectedAtMostOneRowException (..), ExpectedExactlyOneRowException (..), + vacuum, + vacuumInto, withConnection, withStatement, ) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index 90e9412632..8f1ab5b7e7 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -48,6 +48,10 @@ module Unison.Sqlite.Connection queryOneRowCheck_, queryOneColCheck_, + -- * Vacuum (into) + vacuum, + vacuumInto, + -- * Low-level operations withSavepoint, withSavepointIO, @@ -415,6 +419,18 @@ queryOneColCheck_ :: queryOneColCheck_ conn s check = queryOneRowCheck_ conn s (coerce @(a -> Either e r) @(Sqlite.Only a -> Either e r) check) +-- Vacuum + +-- | @VACUUM@ +vacuum :: Connection -> IO () +vacuum conn = + execute_ conn "VACUUM" + +-- | @VACUUM INTO@ +vacuumInto :: Connection -> Text -> IO () +vacuumInto conn file = + execute conn "VACUUM INTO ?" (Sqlite.Only file) + -- Low-level -- | Perform an action within a named savepoint. The action is provided a rollback action. diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 16976b3c13..8db9756f2f 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -3,6 +3,7 @@ module Unison.Sqlite.Transaction Transaction, runTransaction, savepoint, + idempotentIO, -- * Executing queries @@ -103,6 +104,7 @@ runTransaction conn (Transaction f) = liftIO do ignoringExceptions action = action `catchAny` \_ -> pure () +-- | Perform an atomic sub-computation within a transaction; if it returns 'Left', it's rolled back. savepoint :: Transaction (Either a a) -> Transaction a savepoint (Transaction action) = do Transaction \conn -> do @@ -117,6 +119,11 @@ savepoint (Transaction action) = do pure result Right result -> pure result +-- | Perform IO inside a transaction, which should be idempotent, because it may be run more than once. +idempotentIO :: IO a -> Transaction a +idempotentIO action = + Transaction \_ -> action + -- Without results, with parameters execute :: Sqlite.ToRow a => Sql -> a -> Transaction () diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs index 351f500c71..8331d812bf 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs @@ -35,11 +35,11 @@ import qualified Unison.Hashing.V2.TermEdit as Hashing.TermEdit import qualified Unison.Hashing.V2.TypeEdit as Hashing (TypeEdit) import qualified Unison.Hashing.V2.TypeEdit as Hashing.TypeEdit import Unison.Prelude -import Unison.Sqlite (DB) +import Unison.Sqlite (Transaction) import qualified Unison.Util.Map as Map import qualified Unison.Util.Set as Set -dbBranchHash :: DB m => S.DbBranch -> m Hash +dbBranchHash :: S.DbBranch -> Transaction Hash dbBranchHash (S.Branch.Full.Branch tms tps patches children) = fmap Hashing.Branch.hashBranch $ Hashing.Branch.Raw @@ -48,92 +48,93 @@ dbBranchHash (S.Branch.Full.Branch tms tps patches children) = <*> doPatches patches <*> doChildren children where - doTerms :: DB m => Map Db.TextId (Map S.Referent S.DbMetadataSet) -> m (Map NameSegment (Map Hashing.Referent Hashing.Branch.MdValues)) + doTerms :: + Map Db.TextId (Map S.Referent S.DbMetadataSet) -> + Transaction (Map NameSegment (Map Hashing.Referent Hashing.Branch.MdValues)) doTerms = Map.bitraverse s2hNameSegment (Map.bitraverse s2hReferent s2hMetadataSet) doTypes :: - DB m => Map Db.TextId (Map S.Reference S.DbMetadataSet) -> - m (Map NameSegment (Map Hashing.Reference Hashing.Branch.MdValues)) + Transaction (Map NameSegment (Map Hashing.Reference Hashing.Branch.MdValues)) doTypes = Map.bitraverse s2hNameSegment (Map.bitraverse s2hReference s2hMetadataSet) - doPatches :: DB m => Map Db.TextId Db.PatchObjectId -> m (Map NameSegment Hash) + doPatches :: Map Db.TextId Db.PatchObjectId -> Transaction (Map NameSegment Hash) doPatches = Map.bitraverse s2hNameSegment (objectIdToPrimaryHash . Db.unPatchObjectId) - doChildren :: DB m => Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) -> m (Map NameSegment Hash) + doChildren :: Map Db.TextId (Db.BranchObjectId, Db.CausalHashId) -> Transaction (Map NameSegment Hash) doChildren = Map.bitraverse s2hNameSegment \(_boId, chId) -> causalHashIdToHash chId -dbPatchHash :: forall m. DB m => S.Patch -> m Hash +dbPatchHash :: S.Patch -> Transaction Hash dbPatchHash S.Patch {S.termEdits, S.typeEdits} = fmap Hashing.Patch.hashPatch $ Hashing.Patch <$> doTermEdits termEdits <*> doTypeEdits typeEdits where - doTermEdits :: Map S.ReferentH (Set S.TermEdit) -> m (Map Hashing.Referent (Set Hashing.TermEdit)) + doTermEdits :: Map S.ReferentH (Set S.TermEdit) -> Transaction (Map Hashing.Referent (Set Hashing.TermEdit)) doTermEdits = Map.bitraverse s2hReferentH (Set.traverse s2hTermEdit) - doTypeEdits :: Map S.ReferenceH (Set S.TypeEdit) -> m (Map Hashing.Reference (Set Hashing.TypeEdit)) + doTypeEdits :: Map S.ReferenceH (Set S.TypeEdit) -> Transaction (Map Hashing.Reference (Set Hashing.TypeEdit)) doTypeEdits = Map.bitraverse s2hReferenceH (Set.traverse s2hTypeEdit) -s2hMetadataSet :: DB m => DbMetadataSet -> m Hashing.Branch.MdValues +s2hMetadataSet :: DbMetadataSet -> Transaction Hashing.Branch.MdValues s2hMetadataSet = \case S.MetadataSet.Inline rs -> Hashing.Branch.MdValues <$> Set.traverse s2hReference rs -s2hNameSegment :: DB m => Db.TextId -> m NameSegment +s2hNameSegment :: Db.TextId -> Transaction NameSegment s2hNameSegment = fmap NameSegment . Q.expectText -s2hReferent :: DB m => S.Referent -> m Hashing.Referent +s2hReferent :: S.Referent -> Transaction Hashing.Referent s2hReferent = \case S.Referent.Ref r -> Hashing.Referent.Ref <$> s2hReference r S.Referent.Con r cid -> Hashing.Referent.Con <$> s2hReference r <*> pure (fromIntegral cid) -s2hReferentH :: DB m => S.ReferentH -> m Hashing.Referent +s2hReferentH :: S.ReferentH -> Transaction Hashing.Referent s2hReferentH = \case S.Referent.Ref r -> Hashing.Referent.Ref <$> s2hReferenceH r S.Referent.Con r cid -> Hashing.Referent.Con <$> s2hReferenceH r <*> pure (fromIntegral cid) -s2hReference :: DB m => S.Reference -> m Hashing.Reference +s2hReference :: S.Reference -> Transaction Hashing.Reference s2hReference = \case S.ReferenceBuiltin t -> Hashing.Reference.Builtin <$> Q.expectText t S.Reference.Derived h i -> Hashing.Reference.Derived <$> objectIdToPrimaryHash h <*> pure i -s2hReferenceH :: DB m => S.ReferenceH -> m Hashing.Reference +s2hReferenceH :: S.ReferenceH -> Transaction Hashing.Reference s2hReferenceH = \case S.ReferenceBuiltin t -> Hashing.Reference.Builtin <$> Q.expectText t S.Reference.Derived h i -> Hashing.Reference.Derived <$> expectHash h <*> pure i -s2hTermEdit :: DB m => S.TermEdit -> m Hashing.TermEdit +s2hTermEdit :: S.TermEdit -> Transaction Hashing.TermEdit s2hTermEdit = \case S.TermEdit.Replace r _typing -> Hashing.TermEdit.Replace <$> s2hReferent r S.TermEdit.Deprecate -> pure Hashing.TermEdit.Deprecate -s2hTypeEdit :: DB m => S.TypeEdit -> m Hashing.TypeEdit +s2hTypeEdit :: S.TypeEdit -> Transaction Hashing.TypeEdit s2hTypeEdit = \case S.TypeEdit.Replace r -> Hashing.TypeEdit.Replace <$> s2hReference r S.TypeEdit.Deprecate -> pure Hashing.TypeEdit.Deprecate -- Mitchell: Do these variants of Q.* queries belong somewhere else? Or in Q perhaps? -causalHashIdToHash :: DB m => Db.CausalHashId -> m Hash +causalHashIdToHash :: Db.CausalHashId -> Transaction Hash causalHashIdToHash = fmap Cv.hash2to1 . Q.expectHash . Db.unCausalHashId -objectIdToPrimaryHash :: DB m => Db.ObjectId -> m Hash +objectIdToPrimaryHash :: Db.ObjectId -> Transaction Hash objectIdToPrimaryHash = fmap Cv.hash2to1 . Q.expectPrimaryHashByObjectId -expectHash :: DB m => Db.HashId -> m Hash +expectHash :: Db.HashId -> Transaction Hash expectHash = fmap Cv.hash2to1 . Q.expectHash From 359b5871446ba093b815c2c2d5f012bba7328074 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 5 Apr 2022 17:01:02 -0400 Subject: [PATCH 057/529] more ooo sync work --- unison-cli/src/Unison/Share/Sync.hs | 105 +++++++++++++++------- unison-share-api/src/Unison/Sync/Types.hs | 92 +++++++++---------- 2 files changed, 121 insertions(+), 76 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index a33382201d..ac32b9c192 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -1,5 +1,13 @@ -module Unison.Share.Sync where +module Unison.Share.Sync + ( push, + PushError (..), + ) +where +import qualified Data.Map.NonEmpty as NEMap +import qualified Data.Set as Set +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NESet import U.Codebase.HashTags (CausalHash (unCausalHash)) import U.Codebase.Sqlite.Causal (DbCausal, GDbCausal (..)) import qualified U.Codebase.Sqlite.Causal as Sqlite.Causal (GDbCausal (..)) @@ -8,16 +16,21 @@ import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as Hash import Unison.Prelude import qualified Unison.Sync.Types as Share +import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) data UpdatePathResponse = UpdatePathSuccess | UpdatePathHashMismatch Share.HashMismatch | UpdatePathMissingDependencies (Share.NeedDependencies Share.Hash) +data UploadEntitiesResponse + = UploadEntitiesSuccess + | UploadEntitiesNeedDependencies (Share.NeedDependencies Share.Hash) + -- deriving stock (Show, Eq, Ord, Generic) -__api_updatePath :: Share.UpdatePathRequest -> IO UpdatePathResponse -__api_updatePath = undefined +updatePath :: Share.UpdatePathRequest -> IO UpdatePathResponse +updatePath = undefined -- Push -- @@ -28,7 +41,8 @@ __api_updatePath = undefined -- data PushError - = PushErrorHashMismatch Share.HashMismatch + = PushErrorServerMissingDependencies (NESet Share.Hash) + | PushErrorHashMismatch Share.HashMismatch -- Option 1: have push be itself in the Transaction monad, use unsafePerformIdempotentIO -- fuction to do the interleaved IO calls (http, etc) @@ -59,32 +73,63 @@ expectHash = undefined push :: Connection -> Share.RepoPath -> Maybe Share.Hash -> CausalHash -> IO (Either PushError ()) push conn repoPath expectedHash causalHash = do - -- 1. Attempt to update path. - - -- causalHash <- - -- _ (unCausalHashId (Sqlite.Causal.selfHash causal)) - let request = - Share.UpdatePathRequest - { path = repoPath, - expectedHash = - expectedHash <&> \hash -> - Share.TypedHash - { hash, - entityType = Share.CausalType - }, - newHash = - Share.TypedHash - { hash = - causalHash - & unCausalHash - & Hash.toBase32Hex - & Base32Hex.toText - & Share.Hash, - entityType = Share.CausalType - } - } - __api_updatePath request >>= \case + updatePath request >>= \case UpdatePathSuccess -> pure (Right ()) UpdatePathHashMismatch mismatch -> pure (Left (PushErrorHashMismatch mismatch)) - UpdatePathMissingDependencies dependencies -> undefined + UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do + upload conn (Share.RepoPath.repoName repoPath) dependencies + updatePath request <&> \case + UpdatePathSuccess -> Right () + UpdatePathHashMismatch mismatch -> Left (PushErrorHashMismatch mismatch) + UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> + Left (PushErrorServerMissingDependencies dependencies) + where + request = + Share.UpdatePathRequest + { path = repoPath, + expectedHash = + expectedHash <&> \hash -> + Share.TypedHash + { hash, + entityType = Share.CausalType + }, + newHash = + Share.TypedHash + { hash = + causalHash + & unCausalHash + & Hash.toBase32Hex + & Base32Hex.toText + & Share.Hash, + entityType = Share.CausalType + } + } + +-- { repoName :: RepoName, +-- entities :: NEMap Hash (Entity Text Hash Hash) +-- } +upload :: Connection -> Share.RepoName -> NESet Share.Hash -> IO () +upload conn repoName dependencies = do + -- 1. Resolve each Hash to Entity + request <- do + entities <- + NEMap.fromAscList <$> traverse (\dep -> (dep,) <$> resolveHashToEntity conn dep) (NESet.toAscList dependencies) + pure Share.UploadEntitiesRequest {repoName, entities} + + -- 2. Perform upload HTTP call + + -- 3. If UploadEntitiesMissingDependencies, recur + undefined + +-- FIXME rename, etc +resolveHashToEntity :: Connection -> Share.Hash -> IO (Share.Entity Text Share.Hash Share.Hash) +resolveHashToEntity = undefined + +-- let loop :: Set Share.Hash -> IO () +-- loop dependencies0 = +-- case Set.minView dependencies0 of +-- Nothing -> pure () +-- Just (dependency, dependencies) -> do +-- undefined +-- in loop (NESet.toSet dependencies1) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 9032b623dc..f3ba83c71a 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -144,7 +144,7 @@ instance FromJSON DownloadEntitiesRequest where pure DownloadEntitiesRequest {..} data DownloadEntitiesResponse = DownloadEntitiesResponse - { entities :: NEMap Hash (Entity HashJWT Hash Text) + { entities :: NEMap Hash (Entity Text Hash HashJWT) } deriving stock (Show, Eq, Ord) @@ -220,7 +220,7 @@ instance FromJSON HashMismatch where data UploadEntitiesRequest = UploadEntitiesRequest { repoName :: RepoName, - entities :: NEMap Hash (Entity TypedHash TypedHash Text) + entities :: NEMap Hash (Entity Text Hash Hash) } deriving stock (Show, Eq, Ord) @@ -237,15 +237,15 @@ instance FromJSON UploadEntitiesRequest where entities <- obj .: "entities" pure UploadEntitiesRequest {..} -data Entity hash replacementHash text - = TC (TermComponent hash text) - | DC (DeclComponent hash text) - | P (Patch hash replacementHash text) - | N (Namespace hash text) +data Entity text noSyncHash hash + = TC (TermComponent text hash) + | DC (DeclComponent text hash) + | P (Patch text noSyncHash hash) + | N (Namespace text hash) | C (Causal hash) deriving stock (Show, Eq, Ord) -instance (ToJSON hash, ToJSON replacementHash, ToJSON text) => ToJSON (Entity hash replacementHash text) where +instance (ToJSON text, ToJSON noSyncHash, ToJSON hash) => ToJSON (Entity text noSyncHash hash) where toJSON = \case TC tc -> object @@ -273,7 +273,7 @@ instance (ToJSON hash, ToJSON replacementHash, ToJSON text) => ToJSON (Entity ha "object" .= causal ] -instance (FromJSON hash, FromJSON replacementHash, FromJSON text, Ord hash) => FromJSON (Entity hash replacementHash text) where +instance (FromJSON text, FromJSON noSyncHash, FromJSON hash, Ord hash) => FromJSON (Entity text noSyncHash hash) where parseJSON = Aeson.withObject "Entity" $ \obj -> do entityType <- obj .: "type" case entityType of @@ -283,7 +283,7 @@ instance (FromJSON hash, FromJSON replacementHash, FromJSON text, Ord hash) => F NamespaceType -> N <$> obj .: "object" CausalType -> C <$> obj .: "object" -data TermComponent hash text = TermComponent [(LocalIds hash text, ByteString)] +data TermComponent text hash = TermComponent [(LocalIds text hash, ByteString)] deriving stock (Show, Eq, Ord) instance Bifoldable TermComponent where @@ -296,7 +296,7 @@ instance Bitraversable TermComponent where bitraverse f g (TermComponent xs) = TermComponent <$> bitraverseComponents f g xs -instance (ToJSON hash, ToJSON text) => ToJSON (TermComponent hash text) where +instance (ToJSON text, ToJSON hash) => ToJSON (TermComponent text hash) where toJSON (TermComponent components) = object [ "terms" .= (encodeComponentPiece <$> components) @@ -313,26 +313,26 @@ bitraverseComponents f g = where _1 f (l, r) = (,r) <$> f l -encodeComponentPiece :: (ToJSON hash, ToJSON text) => (LocalIds hash text, ByteString) -> Value +encodeComponentPiece :: (ToJSON text, ToJSON hash) => (LocalIds text hash, ByteString) -> Value encodeComponentPiece (localIDs, bytes) = object [ "local_ids" .= localIDs, "bytes" .= Base64Bytes bytes ] -decodeComponentPiece :: (FromJSON hash, FromJSON text) => Value -> Aeson.Parser (LocalIds hash text, ByteString) +decodeComponentPiece :: (FromJSON text, FromJSON hash) => Value -> Aeson.Parser (LocalIds text hash, ByteString) decodeComponentPiece = Aeson.withObject "Component Piece" $ \obj -> do localIDs <- obj .: "local_ids" Base64Bytes bytes <- obj .: "local_ids" pure (localIDs, bytes) -instance (FromJSON hash, FromJSON text) => FromJSON (TermComponent hash text) where +instance (FromJSON text, FromJSON hash) => FromJSON (TermComponent text hash) where parseJSON = Aeson.withObject "TermComponent" $ \obj -> do pieces <- obj .: "terms" terms <- traverse decodeComponentPiece pieces pure (TermComponent terms) -data DeclComponent hash text = DeclComponent [(LocalIds hash text, ByteString)] +data DeclComponent text hash = DeclComponent [(LocalIds text hash, ByteString)] deriving stock (Show, Eq, Ord) instance Bifoldable DeclComponent where @@ -345,21 +345,21 @@ instance Bitraversable DeclComponent where bitraverse f g (DeclComponent xs) = DeclComponent <$> bitraverseComponents f g xs -instance (ToJSON hash, ToJSON text) => ToJSON (DeclComponent hash text) where +instance (ToJSON text, ToJSON hash) => ToJSON (DeclComponent text hash) where toJSON (DeclComponent components) = object [ "decls" .= (encodeComponentPiece <$> components) ] -instance (FromJSON hash, FromJSON text) => FromJSON (DeclComponent hash text) where +instance (FromJSON text, FromJSON hash) => FromJSON (DeclComponent text hash) where parseJSON = Aeson.withObject "DeclComponent" $ \obj -> do pieces <- obj .: "decls" terms <- traverse decodeComponentPiece pieces pure (DeclComponent terms) -data LocalIds hash text = LocalIds - { hashes :: [hash], - texts :: [text] +data LocalIds text hash = LocalIds + { texts :: [text], + hashes :: [hash] } deriving stock (Show, Eq, Ord) @@ -370,48 +370,48 @@ instance Bifunctor LocalIds where bimap = bimapDefault instance Bitraversable LocalIds where - bitraverse f g (LocalIds hashes texts) = - LocalIds <$> traverse f hashes <*> traverse g texts + bitraverse f g (LocalIds texts hashes) = + LocalIds <$> traverse f texts <*> traverse g hashes -instance (ToJSON hash, ToJSON text) => ToJSON (LocalIds hash text) where - toJSON (LocalIds hashes texts) = +instance (ToJSON text, ToJSON hash) => ToJSON (LocalIds text hash) where + toJSON (LocalIds texts hashes) = object - [ "hashes" .= hashes, - "texts" .= texts + [ "texts" .= texts, + "hashes" .= hashes ] -instance (FromJSON hash, FromJSON text) => FromJSON (LocalIds hash text) where +instance (FromJSON text, FromJSON hash) => FromJSON (LocalIds text hash) where parseJSON = Aeson.withObject "LocalIds" $ \obj -> do - hashes <- obj .: "hashes" texts <- obj .: "texts" + hashes <- obj .: "hashes" pure LocalIds {..} -data Patch hash replacementHash text = Patch +data Patch text oldHash newHash = Patch { textLookup :: [text], - oldHashLookup :: [hash], - replacementHashLookup :: [replacementHash], + oldHashLookup :: [oldHash], + newHashLookup :: [newHash], bytes :: ByteString } deriving stock (Show, Eq, Ord) -instance (ToJSON hash, ToJSON replacementHash, ToJSON text) => ToJSON (Patch hash replacementHash text) where - toJSON (Patch textLookup hashLookup optionalHashLookup bytes) = +instance (ToJSON text, ToJSON oldHash, ToJSON newHash) => ToJSON (Patch text oldHash newHash) where + toJSON (Patch textLookup oldHashLookup newHashLookup bytes) = object [ "text_lookup" .= textLookup, - "hash_lookup" .= hashLookup, - "optional_hash_lookup" .= optionalHashLookup, + "optional_hash_lookup" .= oldHashLookup, + "hash_lookup" .= newHashLookup, "bytes" .= Base64Bytes bytes ] -instance (FromJSON hash, FromJSON replacementHash, FromJSON text) => FromJSON (Patch hash replacementHash text) where +instance (FromJSON text, FromJSON oldHash, FromJSON newHash) => FromJSON (Patch text oldHash newHash) where parseJSON = Aeson.withObject "Patch" $ \obj -> do textLookup <- obj .: "text_lookup" - oldHashLookup <- obj .: "hash_lookup" - replacementHashLookup <- obj .: "optional_hash_lookup" + oldHashLookup <- obj .: "optional_hash_lookup" + newHashLookup <- obj .: "hash_lookup" Base64Bytes bytes <- obj .: "bytes" - pure (Patch {..}) + pure Patch {..} -data Namespace hash text = Namespace +data Namespace text hash = Namespace { textLookup :: [text], defnLookup :: [hash], patchLookup :: [hash], @@ -429,13 +429,13 @@ instance Bifunctor Namespace where instance Bitraversable Namespace where bitraverse f g (Namespace tl dl pl cl b) = Namespace - <$> traverse g tl - <*> traverse f dl - <*> traverse f pl - <*> traverse f cl + <$> traverse f tl + <*> traverse g dl + <*> traverse g pl + <*> traverse g cl <*> pure b -instance (ToJSON hash, ToJSON text) => ToJSON (Namespace hash text) where +instance (ToJSON text, ToJSON hash) => ToJSON (Namespace text hash) where toJSON (Namespace textLookup defnLookup patchLookup childLookup bytes) = object [ "text_lookup" .= textLookup, @@ -445,7 +445,7 @@ instance (ToJSON hash, ToJSON text) => ToJSON (Namespace hash text) where "bytes" .= Base64Bytes bytes ] -instance (FromJSON hash, FromJSON text) => FromJSON (Namespace hash text) where +instance (FromJSON text, FromJSON hash) => FromJSON (Namespace text hash) where parseJSON = Aeson.withObject "Namespace" $ \obj -> do textLookup <- obj .: "text_lookup" defnLookup <- obj .: "defn_lookup" From 57f0d938f5ad45f5d27173353ec5ab4eb3d70700 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 6 Apr 2022 09:26:44 -0400 Subject: [PATCH 058/529] start building out Unison.Codebase.SqliteCodebase.Operations --- .../src/Unison/Sqlite/Transaction.hs | 1 + .../src/Unison/Codebase/SqliteCodebase.hs | 44 +- .../Codebase/SqliteCodebase/Migrations.hs | 4 +- .../Migrations/MigrateSchema1To2.hs | 1589 +++++++++-------- .../Migrations/MigrateSchema2To3.hs | 11 +- .../Codebase/SqliteCodebase/Operations.hs | 605 +++++++ .../unison-parser-typechecker.cabal | 1 + 7 files changed, 1434 insertions(+), 821 deletions(-) create mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 8db9756f2f..2667e2afd2 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -120,6 +120,7 @@ savepoint (Transaction action) = do Right result -> pure result -- | Perform IO inside a transaction, which should be idempotent, because it may be run more than once. +-- FIXME rename to unsafeIO or something idempotentIO :: IO a -> Transaction a idempotentIO action = Transaction \_ -> action diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 369d5dc47b..13e7f44714 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -85,7 +85,7 @@ import qualified Unison.Referent as Referent import Unison.ShortHash (ShortHash) import qualified Unison.ShortHash as SH import qualified Unison.ShortHash as ShortHash -import Unison.Sqlite (Connection, DB) +import Unison.Sqlite (Connection) import qualified Unison.Sqlite as Sqlite import qualified Unison.Sqlite.Connection as Sqlite.Connection import qualified Unison.Sqlite.Transaction as Sqlite.Transaction @@ -146,19 +146,20 @@ createCodebaseOrError :: ((Codebase m Symbol Ann, Connection) -> m r) -> m (Either Codebase1.CreateCodebaseError r) createCodebaseOrError debugName path action = do - ifM - (doesFileExist $ makeCodebasePath path) - (pure $ Left Codebase1.CreateCodebaseAlreadyExists) - do - createDirectoryIfMissing True (makeCodebaseDirPath path) - withConnection (debugName ++ ".createSchema") path $ - runReaderT do - Q.createSchema - void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty - - sqliteCodebase debugName path Local action >>= \case - Left schemaVersion -> error ("Failed to open codebase with schema version: " ++ show schemaVersion ++ ", which is unexpected because I just created this codebase.") - Right result -> pure (Right result) + undefined + -- ifM + -- (doesFileExist $ makeCodebasePath path) + -- (pure $ Left Codebase1.CreateCodebaseAlreadyExists) + -- do + -- createDirectoryIfMissing True (makeCodebaseDirPath path) + -- withConnection (debugName ++ ".createSchema") path $ + -- runReaderT do + -- Q.createSchema + -- void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty + + -- sqliteCodebase debugName path Local action >>= \case + -- Left schemaVersion -> error ("Failed to open codebase with schema version: " ++ show schemaVersion ++ ", which is unexpected because I just created this codebase.") + -- Right result -> pure (Right result) -- | Use the codebase in the provided path. -- The codebase is automatically closed when the action completes or throws an exception. @@ -177,10 +178,11 @@ withCodebaseOrError debugName dir action = do initSchemaIfNotExist :: MonadIO m => FilePath -> m () initSchemaIfNotExist path = liftIO do - unlessM (doesDirectoryExist $ makeCodebaseDirPath path) $ - createDirectoryIfMissing True (makeCodebaseDirPath path) - unlessM (doesFileExist $ makeCodebasePath path) $ - withConnection "initSchemaIfNotExist" path $ runReaderT Q.createSchema + undefined + -- unlessM (doesDirectoryExist $ makeCodebaseDirPath path) $ + -- createDirectoryIfMissing True (makeCodebaseDirPath path) + -- unlessM (doesFileExist $ makeCodebasePath path) $ + -- withConnection "initSchemaIfNotExist" path $ runReaderT Q.createSchema -- 1) buffer up the component -- 2) in the event that the component is complete, then what? @@ -254,11 +256,12 @@ sqliteCodebase :: ((Codebase m Symbol Ann, Connection) -> m r) -> m (Either Codebase1.OpenCodebaseError r) sqliteCodebase debugName root localOrRemote action = do + undefined +{- Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root withConnection debugName root $ \conn -> do termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable - typeOfTermCache <- Cache.semispaceCache 8192 - declCache <- Cache.semispaceCache 1024 + typeOfTermCache <- Cache.semispaceCache 8192 declCache <- Cache.semispaceCache 1024 rootBranchCache <- newTVarIO Nothing -- The v1 codebase interface has operations to read and write individual definitions -- whereas the v2 codebase writes them as complete components. These two fields buffer @@ -1231,3 +1234,4 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift (successful, _stdout, stderr) <- gitInCaptured remotePath $ ["push", "--quiet", url] ++ maybe [] (pure @[]) mayGitBranch when (not successful) . throwIO $ GitError.PushException repo (Text.unpack stderr) pure True +-} diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index d0c7808e2a..ff9ad4e9ef 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -42,7 +42,7 @@ migrations = -- Returns an error if the schema version is newer than this ucm knows about. ensureCodebaseIsUpToDate :: (MonadUnliftIO m, Var v) => LocalOrRemote -> CodebasePath -> Sqlite.Connection -> Codebase m v a -> m (Either Codebase.OpenCodebaseError ()) ensureCodebaseIsUpToDate localOrRemote root conn codebase = UnliftIO.try do - schemaVersion <- runReaderT Q.schemaVersion conn + schemaVersion <- undefined -- runReaderT Q.schemaVersion conn when (schemaVersion > currentSchemaVersion) $ UnliftIO.throwIO $ OpenCodebaseUnknownSchemaVersion (fromIntegral schemaVersion) let migrationsToRun = Map.filterWithKey (\v _ -> v > schemaVersion) migrations @@ -53,7 +53,7 @@ ensureCodebaseIsUpToDate localOrRemote root conn codebase = UnliftIO.try do when ((not . null) migrationsToRun) $ do -- Vacuum once now that any migrations have taken place. liftIO $ putStrLn $ "Cleaning up..." - liftIO . flip runReaderT conn $ Q.vacuum + undefined -- liftIO . flip runReaderT conn $ Q.vacuum liftIO . putStrLn $ "๐Ÿ Migration complete. ๐Ÿ" -- | Copy the sqlite database to a new file with a unique name based on current time. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 8395b25f6a..3890f7aa00 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -105,799 +105,800 @@ import Unison.Var (Var) -- * [x] Update the schema version in the database after migrating so we only migrate -- once. -verboseOutput :: Bool -verboseOutput = - isJust (unsafePerformIO (lookupEnv "UNISON_MIGRATION_DEBUG")) -{-# NOINLINE verboseOutput #-} +-- verboseOutput :: Bool +-- verboseOutput = +-- isJust (unsafePerformIO (lookupEnv "UNISON_MIGRATION_DEBUG")) +-- {-# NOINLINE verboseOutput #-} migrateSchema1To2 :: forall a m v. (MonadUnliftIO m, Var v) => Sqlite.Connection -> Codebase m v a -> m (Either MigrationError ()) -migrateSchema1To2 conn codebase = - Sqlite.runDB conn do - Sqlite.withSavepoint "MIGRATESCHEMA12" \_rollback -> do - liftIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" - corruptedCausals <- Q.getCausalsWithoutBranchObjects - when (not . null $ corruptedCausals) $ do - liftIO $ putStrLn $ "โš ๏ธ I detected " <> show (length corruptedCausals) <> " corrupted namespace(s) in the history of the codebase." - liftIO $ putStrLn $ "This is due to a bug in a previous version of ucm." - liftIO $ putStrLn $ "This only affects the history of your codebase, the most up-to-date iteration will remain intact." - liftIO $ putStrLn $ "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." - - liftIO $ putStrLn $ "Updating Namespace Root..." - rootCausalHashId <- Q.expectNamespaceRoot - numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] - v2EmptyBranchHashInfo <- saveV2EmptyBranch - watches <- - lift do - foldMapM - (\watchKind -> map (W watchKind) <$> Codebase.watches codebase (Cv.watchKind2to1 watchKind)) - [WK.RegularWatch, WK.TestWatch] - migrationState <- - lift do - (Sync.sync @_ @Entity migrationSync (progress numEntitiesToMigrate) (CausalE rootCausalHashId : watches)) - `runReaderT` Env {db = conn, codebase} - `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo - let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId - liftIO $ putStrLn $ "Updating Namespace Root..." - Q.setNamespaceRoot newRootCausalHashId - liftIO $ putStrLn $ "Rewriting old object IDs..." - ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do - Q.recordObjectRehash oldObjId newObjId - liftIO $ putStrLn $ "Garbage collecting orphaned objects..." - Q.garbageCollectObjectsWithoutHashes - liftIO $ putStrLn $ "Garbage collecting orphaned watches..." - Q.garbageCollectWatchesWithoutObjects - liftIO $ putStrLn $ "Updating Schema Version..." - Q.setSchemaVersion 2 - pure $ Right () - where - progress :: Int -> Sync.Progress (ReaderT (Env m v a) (StateT MigrationState m)) Entity - progress numToMigrate = - let incrementProgress :: ReaderT (Env m v a) (StateT MigrationState m) () - incrementProgress = do - numDone <- field @"numMigrated" <+= 1 - liftIO $ putStr $ "\r ๐Ÿ— " <> show numDone <> " / ~" <> show numToMigrate <> " entities migrated. ๐Ÿšง" - need :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () - need e = when verboseOutput $ liftIO $ putStrLn $ "Need: " ++ show e - done :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () - done e = do - when verboseOutput $ liftIO $ putStrLn $ "Done: " ++ show e - incrementProgress - errorHandler :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () - errorHandler e = do - case e of - -- We expect non-fatal errors when migrating watches. - W {} -> pure () - e -> liftIO $ putStrLn $ "Error: " ++ show e - incrementProgress - allDone :: ReaderT (Env m v a) (StateT MigrationState m) () - allDone = liftIO $ putStrLn $ "\nFinished migrating, initiating cleanup." - in Sync.Progress {need, done, error = errorHandler, allDone} - -type Old a = a - -type New a = a - -type ConstructorName v = v - -type DeclName v = v - -data MigrationState = MigrationState - -- Mapping between old cycle-position -> new cycle-position for a given Decl object. - { referenceMapping :: Map (Old SomeReferenceId) (New SomeReferenceId), - causalMapping :: Map (Old CausalHashId) (New (CausalHash, CausalHashId)), - -- We also store the old hash for this object ID since we need a way to - -- convert Object Reference IDs into Hash Reference IDs so we can use the referenceMapping. - objLookup :: Map (Old ObjectId) (New ObjectId, New HashId, New Hash, Old Hash), - -- Remember the hashes of term/decls that we have already migrated to avoid migrating them twice. - migratedDefnHashes :: Set (Old Hash), - numMigrated :: Int, - v2EmptyBranchHashInfo :: (BranchHashId, Hash) - } - deriving (Generic) - -data Entity - = TermComponent Unison.Hash - | DeclComponent Unison.Hash - | CausalE CausalHashId - | BranchE ObjectId - | PatchE ObjectId - | W WK.WatchKind Reference.Id - deriving (Eq, Ord, Show) - -data Env m v a = Env {db :: Sqlite.Connection, codebase :: Codebase m v a} - -migrationSync :: - (MonadIO m, Var v) => - Sync (ReaderT (Env m v a) (StateT MigrationState m)) Entity -migrationSync = Sync \case - TermComponent hash -> do - Env {codebase, db} <- ask - lift (migrateTermComponent db codebase hash) - DeclComponent hash -> do - Env {codebase, db} <- ask - lift (migrateDeclComponent db codebase hash) - BranchE objectId -> do - Env {db} <- ask - lift (migrateBranch db objectId) - CausalE causalHashId -> do - Env {db} <- ask - lift (migrateCausal db causalHashId) - PatchE objectId -> do - Env {db} <- ask - lift (migratePatch db (PatchObjectId objectId)) - W watchKind watchId -> do - Env {codebase} <- ask - lift (migrateWatch codebase watchKind watchId) - -migrateCausal :: MonadIO m => Sqlite.Connection -> CausalHashId -> StateT MigrationState m (Sync.TrySyncResult Entity) -migrateCausal conn oldCausalHashId = fmap (either id id) . runExceptT $ do - whenM (Map.member oldCausalHashId <$> use (field @"causalMapping")) (throwE Sync.PreviouslyDone) - - oldBranchHashId <- Sqlite.runDB conn $ Q.expectCausalValueHashId oldCausalHashId - oldCausalParentHashIds <- Sqlite.runDB conn $ Q.loadCausalParents oldCausalHashId - - maybeOldBranchObjId <- - Sqlite.runDB conn $ - Q.loadObjectIdForAnyHashId (unBranchHashId oldBranchHashId) - migratedObjIds <- gets objLookup - -- If the branch for this causal hasn't been migrated, migrate it first. - let unmigratedBranch = - case maybeOldBranchObjId of - Just branchObjId | branchObjId `Map.notMember` migratedObjIds -> [BranchE branchObjId] - _ -> [] - - migratedCausals <- gets causalMapping - let unmigratedParents = - oldCausalParentHashIds - & filter (`Map.notMember` migratedCausals) - & fmap CausalE - let unmigratedEntities = unmigratedBranch <> unmigratedParents - when (not . null $ unmigratedParents <> unmigratedBranch) (throwE $ Sync.Missing unmigratedEntities) - - (newBranchHashId, newBranchHash) <- case maybeOldBranchObjId of - -- Some codebases are corrupted, likely due to interrupted save operations. - -- It's unfortunate, but rather than fail the whole migration we'll just replace them - -- with an empty branch. - Nothing -> use (field @"v2EmptyBranchHashInfo") - Just branchObjId -> do - let (_, newBranchHashId, newBranchHash, _) = migratedObjIds ^?! ix branchObjId - pure (BranchHashId newBranchHashId, newBranchHash) - - let (newParentHashes, newParentHashIds) = - oldCausalParentHashIds - & fmap - (\oldParentHashId -> migratedCausals ^?! ix oldParentHashId) - & unzip - & bimap (Set.fromList . map unCausalHash) Set.fromList - - let newCausalHash :: CausalHash - newCausalHash = - CausalHash . Cv.hash1to2 $ - Hashing.hashCausal - ( Hashing.Causal - { branchHash = newBranchHash, - parents = Set.mapMonotonic Cv.hash2to1 newParentHashes - } - ) - newCausalHashId <- Sqlite.runDB conn (Q.saveCausalHash newCausalHash) - let newCausal = - DbCausal - { selfHash = newCausalHashId, - valueHash = newBranchHashId, - parents = newParentHashIds - } - Sqlite.runDB conn do - Q.saveCausal (SC.selfHash newCausal) (SC.valueHash newCausal) - Q.saveCausalParents (SC.selfHash newCausal) (Set.toList $ SC.parents newCausal) - - field @"causalMapping" %= Map.insert oldCausalHashId (newCausalHash, newCausalHashId) - - pure Sync.Done - -migrateBranch :: MonadIO m => Sqlite.Connection -> ObjectId -> StateT MigrationState m (Sync.TrySyncResult Entity) -migrateBranch conn oldObjectId = fmap (either id id) . runExceptT $ do - whenM (Map.member oldObjectId <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone) - - oldBranch <- Sqlite.runDB conn (Ops.expectDbBranch (BranchObjectId oldObjectId)) - oldHash <- fmap Cv.hash2to1 . Sqlite.runDB conn $ Q.expectPrimaryHashByObjectId oldObjectId - oldBranchWithHashes <- Sqlite.runDB conn (traverseOf S.branchHashes_ (fmap Cv.hash2to1 . Q.expectPrimaryHashByObjectId) oldBranch) - migratedRefs <- gets referenceMapping - migratedObjects <- gets objLookup - migratedCausals <- gets causalMapping - let allMissingTypesAndTerms :: [Entity] - allMissingTypesAndTerms = - oldBranchWithHashes - ^.. branchSomeRefs_ - . uRefIdAsRefId_ - . filtered (`Map.notMember` migratedRefs) - . to someReferenceIdToEntity - - let allMissingPatches :: [Entity] = - oldBranch - ^.. S.patches_ - . to unPatchObjectId - . filtered (`Map.notMember` migratedObjects) - . to PatchE - - let allMissingChildBranches :: [Entity] = - oldBranch - ^.. S.childrenHashes_ - . _1 - . to unBranchObjectId - . filtered (`Map.notMember` migratedObjects) - . to BranchE - - let allMissingChildCausals :: [Entity] = - oldBranch - ^.. S.childrenHashes_ - . _2 - . filtered (`Map.notMember` migratedCausals) - . to CausalE - - -- Identify dependencies and bail out if they aren't all built - let allMissingReferences :: [Entity] - allMissingReferences = - allMissingTypesAndTerms - ++ allMissingPatches - ++ allMissingChildBranches - ++ allMissingChildCausals - - when (not . null $ allMissingReferences) $ - throwE $ Sync.Missing allMissingReferences - - let remapPatchObjectId patchObjId = case Map.lookup (unPatchObjectId patchObjId) migratedObjects of - Nothing -> error $ "Expected patch: " <> show patchObjId <> " to be migrated" - Just (newPatchObjId, _, _, _) -> PatchObjectId newPatchObjId - let remapCausalHashId causalHashId = case Map.lookup causalHashId migratedCausals of - Nothing -> error $ "Expected causal hash id: " <> show causalHashId <> " to be migrated" - Just (_, newCausalHashId) -> newCausalHashId - let remapBranchObjectId objId = case Map.lookup (unBranchObjectId objId) migratedObjects of - Nothing -> error $ "Expected object: " <> show objId <> " to be migrated" - Just (newBranchObjId, _, _, _) -> BranchObjectId newBranchObjId - - let newBranch :: S.DbBranch - newBranch = - oldBranch - & branchSomeRefs_ %~ remapObjIdRefs migratedObjects migratedRefs - & S.patches_ %~ remapPatchObjectId - & S.childrenHashes_ %~ (remapBranchObjectId *** remapCausalHashId) - - let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch newBranch - newHash <- Sqlite.runDB conn (Hashing.dbBranchHash newBranch) - newHashId <- Sqlite.runDB conn (Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash))) - newObjectId <- Sqlite.runDB conn (Ops.saveBranchObject newHashId localBranchIds localBranch) - field @"objLookup" %= Map.insert oldObjectId (unBranchObjectId newObjectId, unBranchHashId newHashId, newHash, oldHash) - pure Sync.Done - -migratePatch :: - forall m. - MonadIO m => - Sqlite.Connection -> - Old PatchObjectId -> - StateT MigrationState m (Sync.TrySyncResult Entity) -migratePatch conn oldObjectId = fmap (either id id) . runExceptT $ do - whenM (Map.member (unPatchObjectId oldObjectId) <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone) - - oldHash <- fmap Cv.hash2to1 . Sqlite.runDB conn $ Q.expectPrimaryHashByObjectId (unPatchObjectId oldObjectId) - oldPatch <- Sqlite.runDB conn (Ops.expectDbPatch oldObjectId) - let hydrateHashes :: forall m. Sqlite.DB m => HashId -> m Hash - hydrateHashes hashId = do - Cv.hash2to1 <$> Q.expectHash hashId - let hydrateObjectIds :: forall m. Sqlite.DB m => ObjectId -> m Hash - hydrateObjectIds objId = do - Cv.hash2to1 <$> Q.expectPrimaryHashByObjectId objId - - oldPatchWithHashes :: S.Patch' TextId Hash Hash <- - Sqlite.runDB conn do - (oldPatch & S.patchH_ %%~ hydrateHashes) - >>= (S.patchO_ %%~ hydrateObjectIds) - - migratedRefs <- gets referenceMapping - let isUnmigratedRef ref = Map.notMember ref migratedRefs - -- 2. Determine whether all things the patch refers to are built. - let unmigratedDependencies :: [Entity] - unmigratedDependencies = - oldPatchWithHashes ^.. patchSomeRefsH_ . uRefIdAsRefId_ . filtered isUnmigratedRef . to someReferenceIdToEntity - <> oldPatchWithHashes ^.. patchSomeRefsO_ . uRefIdAsRefId_ . filtered isUnmigratedRef . to someReferenceIdToEntity - when (not . null $ unmigratedDependencies) (throwE (Sync.Missing unmigratedDependencies)) - - let hashToHashId :: forall m. Sqlite.DB m => Hash -> m HashId - hashToHashId h = - fromMaybe (error $ "expected hashId for hash: " <> show h) <$> (Q.loadHashIdByHash (Cv.hash1to2 h)) - let hashToObjectId :: forall m. Sqlite.DB m => Hash -> m ObjectId - hashToObjectId = hashToHashId >=> Q.expectObjectIdForPrimaryHashId - - migratedReferences <- gets referenceMapping - let remapRef :: SomeReferenceId -> SomeReferenceId - remapRef ref = Map.findWithDefault ref ref migratedReferences - - let newPatch = - oldPatchWithHashes - & patchSomeRefsH_ . uRefIdAsRefId_ %~ remapRef - & patchSomeRefsO_ . uRefIdAsRefId_ %~ remapRef - - newPatchWithIds :: S.Patch <- - Sqlite.runDB conn $ do - (newPatch & S.patchH_ %%~ hashToHashId) - >>= (S.patchO_ %%~ hashToObjectId) - - let (localPatchIds, localPatch) = S.LocalizeObject.localizePatch newPatchWithIds - newHash <- Sqlite.runDB conn (Hashing.dbPatchHash newPatchWithIds) - newObjectId <- Sqlite.runDB conn (Ops.saveDbPatch (PatchHash (Cv.hash1to2 newHash)) (S.Patch.Format.Full localPatchIds localPatch)) - newHashId <- Sqlite.runDB conn (Q.expectHashIdByHash (Cv.hash1to2 newHash)) - field @"objLookup" %= Map.insert (unPatchObjectId oldObjectId) (unPatchObjectId newObjectId, newHashId, newHash, oldHash) - pure Sync.Done - --- | PLAN --- * --- NOTE: this implementation assumes that watches will be migrated AFTER everything else is finished. --- This is because it's difficult for us to know otherwise whether a reference refers to something which doesn't exist, or just --- something that hasn't been migrated yet. If we do it last, we know that missing references are indeed just missing from the codebase. -migrateWatch :: - forall m v a. - (MonadIO m, Ord v) => - Codebase m v a -> - WatchKind -> - Reference.Id -> - StateT MigrationState m (Sync.TrySyncResult Entity) -migrateWatch Codebase {getWatch, putWatch} watchKind oldWatchId = fmap (either id id) . runExceptT $ do - let watchKindV1 = Cv.watchKind2to1 watchKind - watchResultTerm <- - (lift . lift) (getWatch watchKindV1 oldWatchId) >>= \case - -- The hash which we're watching doesn't exist in the codebase, throw out this watch. - Nothing -> throwE Sync.Done - Just term -> pure term - migratedReferences <- gets referenceMapping - newWatchId <- case Map.lookup (TermReference oldWatchId) migratedReferences of - (Just (TermReference newRef)) -> pure newRef - _ -> throwE Sync.NonFatalError - let maybeRemappedTerm :: Maybe (Term.Term v a) - maybeRemappedTerm = - watchResultTerm - & termReferences_ %%~ \someRef -> Map.lookup someRef migratedReferences - case maybeRemappedTerm of - -- One or more references in the result didn't exist in our codebase. - Nothing -> pure Sync.NonFatalError - Just remappedTerm -> do - lift . lift $ putWatch watchKindV1 newWatchId remappedTerm - pure Sync.Done - -uRefIdAsRefId_ :: Iso' (SomeReference (UReference.Id' Hash)) SomeReferenceId -uRefIdAsRefId_ = mapping uRefAsRef_ - -uRefAsRef_ :: Iso' (UReference.Id' Hash) Reference.Id -uRefAsRef_ = iso intoRef intoURef - where - intoRef (UReference.Id hash pos) = Reference.Id hash pos - intoURef (Reference.Id hash pos) = UReference.Id hash pos - --- Project an S.Referent'' into its SomeReferenceObjId's -someReferent_ :: - forall t h. - (forall ref. Traversal' ref (SomeReference ref)) -> - Traversal' (S.Branch.Full.Referent'' t h) (SomeReference (UReference.Id' h)) -someReferent_ typeOrTermTraversal_ = - (UReferent._Ref . someReference_ typeOrTermTraversal_) - `failing` ( UReferent._Con - . asPair_ -- Need to unpack the embedded reference AND remap between mismatched Constructor ID types. - . asConstructorReference_ - ) - where - asPair_ f (UReference.ReferenceDerived id', conId) = - f (ConstructorReference.ConstructorReference id' (fromIntegral conId)) - <&> \(ConstructorReference.ConstructorReference newId newConId) -> - (UReference.ReferenceDerived newId, fromIntegral newConId) - asPair_ _ (UReference.ReferenceBuiltin x, conId) = pure (UReference.ReferenceBuiltin x, conId) - --- asPair_ f (UReference.ReferenceDerived id', conId) = --- f (id', fromIntegral conId) --- <&> \(newId, newConId) -> (UReference.ReferenceDerived newId, fromIntegral newConId) --- asPair_ _ (UReference.ReferenceBuiltin x, conId) = pure (UReference.ReferenceBuiltin x, conId) - -someReference_ :: - (forall ref. Traversal' ref (SomeReference ref)) -> - Traversal' (UReference.Reference' t h) (SomeReference (UReference.Id' h)) -someReference_ typeOrTermTraversal_ = UReference._ReferenceDerived . typeOrTermTraversal_ - -someMetadataSetFormat_ :: - (Ord t, Ord h) => - (forall ref. Traversal' ref (SomeReference ref)) -> - Traversal' (S.Branch.Full.MetadataSetFormat' t h) (SomeReference (UReference.Id' h)) -someMetadataSetFormat_ typeOrTermTraversal_ = - S.Branch.Full.metadataSetFormatReferences_ . someReference_ typeOrTermTraversal_ - -someReferenceMetadata_ :: - (Ord k, Ord t, Ord h) => - Traversal' k (SomeReference (UReference.Id' h)) -> - Traversal' - (Map k (S.Branch.Full.MetadataSetFormat' t h)) - (SomeReference (UReference.Id' h)) -someReferenceMetadata_ keyTraversal_ f m = - Map.toList m - & traversed . beside keyTraversal_ (someMetadataSetFormat_ asTermReference_) %%~ f - <&> Map.fromList - -branchSomeRefs_ :: (Ord t, Ord h) => Traversal' (S.Branch' t h p c) (SomeReference (UReference.Id' h)) -branchSomeRefs_ f S.Branch.Full.Branch {children, patches, terms, types} = do - let newTypesMap = types & traversed . someReferenceMetadata_ (someReference_ asTypeReference_) %%~ f - let newTermsMap = terms & traversed . someReferenceMetadata_ (someReferent_ asTermReference_) %%~ f - S.Branch.Full.Branch <$> newTermsMap <*> newTypesMap <*> pure patches <*> pure children - -patchSomeRefsH_ :: (Ord t, Ord h) => Traversal (S.Patch' t h o) (S.Patch' t h o) (SomeReference (UReference.Id' h)) (SomeReference (UReference.Id' h)) -patchSomeRefsH_ f S.Patch {termEdits, typeEdits} = do - newTermEdits <- Map.fromList <$> (Map.toList termEdits & traversed . _1 . (someReferent_ asTermReference_) %%~ f) - newTypeEdits <- Map.fromList <$> (Map.toList typeEdits & traversed . _1 . (someReference_ asTypeReference_) %%~ f) - pure S.Patch {termEdits = newTermEdits, typeEdits = newTypeEdits} - -patchSomeRefsO_ :: (Ord t, Ord h, Ord o) => Traversal' (S.Patch' t h o) (SomeReference (UReference.Id' o)) -patchSomeRefsO_ f S.Patch {termEdits, typeEdits} = do - newTermEdits <- (termEdits & traversed . Set.traverse . termEditRefs_ %%~ f) - newTypeEdits <- (typeEdits & traversed . Set.traverse . typeEditRefs_ %%~ f) - pure (S.Patch {termEdits = newTermEdits, typeEdits = newTypeEdits}) - -termEditRefs_ :: Traversal' (TermEdit.TermEdit' t h) (SomeReference (UReference.Id' h)) -termEditRefs_ f (TermEdit.Replace ref typing) = - TermEdit.Replace <$> (ref & someReferent_ asTermReference_ %%~ f) <*> pure typing -termEditRefs_ _f (TermEdit.Deprecate) = pure TermEdit.Deprecate - -typeEditRefs_ :: Traversal' (TypeEdit.TypeEdit' t h) (SomeReference (UReference.Id' h)) -typeEditRefs_ f (TypeEdit.Replace ref) = - TypeEdit.Replace <$> (ref & someReference_ asTypeReference_ %%~ f) -typeEditRefs_ _f (TypeEdit.Deprecate) = pure TypeEdit.Deprecate - -migrateTermComponent :: - forall m v a. - (Ord v, Var v, Monad m, MonadIO m) => - Sqlite.Connection -> - Codebase m v a -> - Unison.Hash -> - StateT MigrationState m (Sync.TrySyncResult Entity) -migrateTermComponent conn Codebase {..} oldHash = fmap (either id id) . runExceptT $ do - whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone) - - oldComponent <- - (lift . lift $ getTermComponentWithTypes oldHash) >>= \case - Nothing -> error $ "Hash was missing from codebase: " <> show oldHash - Just c -> pure c - - let componentIDMap :: Map (Old Reference.Id) (Term.Term v a, Type v a) - componentIDMap = Map.fromList $ Reference.componentFor oldHash oldComponent - let unhashed :: Map (Old Reference.Id) (v, Term.Term v a) - unhashed = Term.unhashComponent (fst <$> componentIDMap) - let vToOldReferenceMapping :: Map v (Old Reference.Id) - vToOldReferenceMapping = - unhashed - & Map.toList - & fmap (\(refId, (v, _trm)) -> (v, refId)) - & Map.fromList - - referencesMap <- gets referenceMapping - - let allMissingReferences :: [Old SomeReferenceId] - allMissingReferences = - let missingTermRefs = - unhashed & foldSetter (traversed . _2 . termReferences_) - missingTypeRefs = - componentIDMap - & foldSetter (traversed . _2 . typeReferences_) - in filter (`Map.notMember` referencesMap) (missingTermRefs <> missingTypeRefs) - - when (not . null $ allMissingReferences) $ - throwE $ Sync.Missing . nubOrd $ (someReferenceIdToEntity <$> allMissingReferences) - - let getMigratedReference :: Old SomeReferenceId -> New SomeReferenceId - getMigratedReference ref = - Map.findWithDefault (error $ "unmigrated reference" <> show ref) ref referencesMap - - let remappedReferences :: Map (Old Reference.Id) (v, Term.Term v a, Type v a) = - Zip.zipWith - ( \(v, trm) (_, typ) -> - ( v, - trm & termReferences_ %~ getMigratedReference, - typ & typeReferences_ %~ getMigratedReference - ) - ) - unhashed - componentIDMap - - let newTermComponents :: Map v (New Reference.Id, Term.Term v a, Type v a) - newTermComponents = - remappedReferences - & Map.elems - & fmap (\(v, trm, typ) -> (v, (trm, typ))) - & Map.fromList - & Convert.hashTermComponents - - ifor newTermComponents $ \v (newReferenceId, trm, typ) -> do - let oldReferenceId = vToOldReferenceMapping ^?! ix v - field @"referenceMapping" %= Map.insert (TermReference oldReferenceId) (TermReference newReferenceId) - lift . lift $ putTerm newReferenceId trm typ - - -- Need to get one of the new references to grab its hash, doesn't matter which one since - -- all hashes in the component are the same. - case newTermComponents ^? traversed . _1 . to Reference.idToHash of - Nothing -> pure () - Just newHash -> insertObjectMappingForHash conn oldHash newHash - - field @"migratedDefnHashes" %= Set.insert oldHash - pure Sync.Done - -migrateDeclComponent :: - forall m v a. - (Ord v, Var v, Monad m, MonadIO m) => - Sqlite.Connection -> - Codebase m v a -> - Unison.Hash -> - StateT MigrationState m (Sync.TrySyncResult Entity) -migrateDeclComponent conn Codebase {..} oldHash = fmap (either id id) . runExceptT $ do - whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone) - - declComponent :: [DD.Decl v a] <- - (lift . lift $ getDeclComponent oldHash) >>= \case - Nothing -> error $ "Expected decl component for hash:" <> show oldHash - Just dc -> pure dc - - let componentIDMap :: Map (Old Reference.Id) (DD.Decl v a) - componentIDMap = Map.fromList $ Reference.componentFor oldHash declComponent - - let unhashed :: Map (Old Reference.Id) (DeclName v, DD.Decl v a) - unhashed = DD.unhashComponent componentIDMap - - let allTypes :: [Type v a] - allTypes = - unhashed - ^.. traversed - . _2 - . beside DD.asDataDecl_ id - . to DD.constructors' - . traversed - . _3 - - migratedReferences <- gets referenceMapping - let unmigratedRefIds :: [SomeReferenceId] - unmigratedRefIds = - allTypes - & foldSetter - ( traversed -- Every type in the list - . typeReferences_ - . filtered (`Map.notMember` migratedReferences) - ) - - when (not . null $ unmigratedRefIds) do - throwE (Sync.Missing (nubOrd . fmap someReferenceIdToEntity $ unmigratedRefIds)) - - -- At this point we know we have all the required mappings from old references to new ones. - let remapTerm :: Type v a -> Type v a - remapTerm = typeReferences_ %~ \ref -> Map.findWithDefault (error "unmigrated reference") ref migratedReferences - - let remappedReferences :: Map (Old Reference.Id) (DeclName v, DD.Decl v a) - remappedReferences = - unhashed - & traversed -- Traverse map of reference IDs - . _2 -- Select the DataDeclaration - . beside DD.asDataDecl_ id -- Unpack effect decls - . DD.constructors_ -- Get the data constructors - . traversed -- traverse the list of them - . _3 -- Select the Type term. - %~ remapTerm - - let declNameToOldReference :: Map (DeclName v) (Old Reference.Id) - declNameToOldReference = Map.fromList . fmap swap . Map.toList . fmap fst $ remappedReferences - - let newComponent :: [(DeclName v, Reference.Id, DD.Decl v a)] - newComponent = - remappedReferences - & Map.elems - & Map.fromList - & Convert.hashDecls - & fromRight (error "unexpected resolution error") - - for_ newComponent $ \(declName, newReferenceId, dd) -> do - let oldReferenceId = declNameToOldReference ^?! ix declName - field @"referenceMapping" %= Map.insert (TypeReference oldReferenceId) (TypeReference newReferenceId) - - let oldConstructorIds :: Map (ConstructorName v) (Old ConstructorId) - oldConstructorIds = - (componentIDMap ^?! ix oldReferenceId) - & DD.asDataDecl - & DD.constructors' - & imap (\constructorId (_ann, constructorName, _type) -> (constructorName, fromIntegral constructorId)) - & Map.fromList - - ifor_ (DD.constructors' (DD.asDataDecl dd)) \(fromIntegral -> newConstructorId) (_ann, constructorName, _type) -> do - field @"referenceMapping" - %= Map.insert - (ConstructorReference oldReferenceId (oldConstructorIds ^?! ix constructorName)) - (ConstructorReference newReferenceId newConstructorId) - - lift . lift $ putTypeDeclaration newReferenceId dd - - -- Need to get one of the new references to grab its hash, doesn't matter which one since - -- all hashes in the component are the same. - case newComponent ^? traversed . _2 . to Reference.idToHash of - Nothing -> pure () - Just newHash -> insertObjectMappingForHash conn oldHash newHash - field @"migratedDefnHashes" %= Set.insert oldHash - - pure Sync.Done - -insertObjectMappingForHash :: - (MonadIO m, MonadState MigrationState m) => - Sqlite.Connection -> - Old Hash -> - New Hash -> - m () -insertObjectMappingForHash conn oldHash newHash = do - (oldObjectId, newHashId, newObjectId) <- Sqlite.runDB conn $ do - oldHashId <- Q.expectHashIdByHash . Cv.hash1to2 $ oldHash - oldObjectId <- Q.expectObjectIdForPrimaryHashId $ oldHashId - newHashId <- Q.expectHashIdByHash . Cv.hash1to2 $ newHash - newObjectId <- Q.expectObjectIdForPrimaryHashId $ newHashId - pure (oldObjectId, newHashId, newObjectId) - field @"objLookup" %= Map.insert oldObjectId (newObjectId, newHashId, newHash, oldHash) - -typeReferences_ :: (Monad m, Ord v) => LensLike' m (Type v a) SomeReferenceId -typeReferences_ = - ABT.rewriteDown_ -- Focus all terms - . ABT.baseFunctor_ -- Focus Type.F - . Type._Ref -- Only the Ref constructor has references - . Reference._DerivedId - . asTypeReference_ - -termReferences_ :: (Monad m, Ord v) => LensLike' m (Term.Term v a) SomeReferenceId -termReferences_ = - ABT.rewriteDown_ -- Focus all terms - . ABT.baseFunctor_ -- Focus Term.F - . termFReferences_ - -termFReferences_ :: (Ord tv, Monad m) => LensLike' m (Term.F tv ta pa a) SomeReferenceId -termFReferences_ f t = - (t & Term._Ref . Reference._DerivedId . asTermReference_ %%~ f) - >>= Term._Constructor . someRefCon_ %%~ f - >>= Term._Request . someRefCon_ %%~ f - >>= Term._Ann . _2 . typeReferences_ %%~ f - >>= Term._Match . _2 . traversed . Term.matchPattern_ . patternReferences_ %%~ f - >>= Term._TermLink . referentAsSomeTermReference_ %%~ f - >>= Term._TypeLink . Reference._DerivedId . asTypeReference_ %%~ f - --- | Build a SomeConstructorReference -someRefCon_ :: Traversal' ConstructorReference.ConstructorReference SomeReferenceId -someRefCon_ = refConPair_ . asConstructorReference_ - where - refConPair_ :: Traversal' ConstructorReference.ConstructorReference ConstructorReference.ConstructorReferenceId - refConPair_ f s = - case s of - ConstructorReference.ConstructorReference (Reference.Builtin _) _ -> pure s - ConstructorReference.ConstructorReference (Reference.DerivedId n) c -> - ( \(ConstructorReference.ConstructorReference n' c') -> - ConstructorReference.ConstructorReference (Reference.DerivedId n') c' - ) - <$> f (ConstructorReference.ConstructorReference n c) - -patternReferences_ :: Traversal' (Pattern loc) SomeReferenceId -patternReferences_ f = \case - p@(Pattern.Unbound {}) -> pure p - p@(Pattern.Var {}) -> pure p - p@(Pattern.Boolean {}) -> pure p - p@(Pattern.Int {}) -> pure p - p@(Pattern.Nat {}) -> pure p - p@(Pattern.Float {}) -> pure p - p@(Pattern.Text {}) -> pure p - p@(Pattern.Char {}) -> pure p - (Pattern.Constructor loc ref patterns) -> - (\newRef newPatterns -> Pattern.Constructor loc newRef newPatterns) - <$> (ref & someRefCon_ %%~ f) - <*> (patterns & traversed . patternReferences_ %%~ f) - (Pattern.As loc pat) -> Pattern.As loc <$> patternReferences_ f pat - (Pattern.EffectPure loc pat) -> Pattern.EffectPure loc <$> patternReferences_ f pat - (Pattern.EffectBind loc ref patterns pat) -> - do - (\newRef newPatterns newPat -> Pattern.EffectBind loc newRef newPatterns newPat) - <$> (ref & someRefCon_ %%~ f) - <*> (patterns & traversed . patternReferences_ %%~ f) - <*> (patternReferences_ f pat) - (Pattern.SequenceLiteral loc patterns) -> - Pattern.SequenceLiteral loc <$> (patterns & traversed . patternReferences_ %%~ f) - Pattern.SequenceOp loc pat seqOp pat2 -> do - Pattern.SequenceOp loc <$> patternReferences_ f pat <*> pure seqOp <*> patternReferences_ f pat2 - -referentAsSomeTermReference_ :: Traversal' Referent.Referent SomeReferenceId -referentAsSomeTermReference_ f = \case - (Referent'.Ref' (Reference.DerivedId refId)) -> do - newRefId <- refId & asTermReference_ %%~ f - pure (Referent'.Ref' (Reference.DerivedId newRefId)) - (Referent'.Con' (ConstructorReference.ConstructorReference (Reference.DerivedId refId) conId) conType) -> - (ConstructorReference.ConstructorReference refId conId & asConstructorReference_ %%~ f) - <&> \(ConstructorReference.ConstructorReference newRefId newConId) -> - Referent'.Con' - (ConstructorReference.ConstructorReference (Reference.DerivedId newRefId) newConId) - conType - r -> pure r - -type SomeReferenceId = SomeReference Reference.Id - -type SomeReferenceObjId = SomeReference (UReference.Id' ObjectId) - -remapObjIdRefs :: - (Map (Old ObjectId) (New ObjectId, New HashId, New Hash, Old Hash)) -> - (Map SomeReferenceId SomeReferenceId) -> - SomeReferenceObjId -> - SomeReferenceObjId -remapObjIdRefs objMapping refMapping someObjIdRef = newSomeObjId - where - oldObjId :: ObjectId - oldObjId = someObjIdRef ^. someRef_ . UReference.idH - (newObjId, _, _, oldHash) = - case Map.lookup oldObjId objMapping of - Nothing -> error $ "Expected object mapping for ID: " <> show oldObjId - Just found -> found - oldSomeRefId :: SomeReferenceId - oldSomeRefId = (someObjIdRef & someRef_ . UReference.idH .~ oldHash) ^. uRefIdAsRefId_ - newSomeRefId :: SomeReferenceId - newSomeRefId = case Map.lookup oldSomeRefId refMapping of - Nothing -> error $ "Expected reference mapping for ID: " <> show oldSomeRefId - Just r -> r - newSomeObjId :: SomeReference (UReference.Id' (New ObjectId)) - newSomeObjId = (newSomeRefId ^. from uRefIdAsRefId_) & someRef_ . UReference.idH .~ newObjId - -data SomeReference ref - = TermReference ref - | TypeReference ref - | ConstructorReference ref ConstructorId - deriving (Eq, Functor, Generic, Ord, Show, Foldable, Traversable) - -someRef_ :: Lens (SomeReference ref) (SomeReference ref') ref ref' -someRef_ = lens getter setter - where - setter (TermReference _) r = TermReference r - setter (TypeReference _) r = TypeReference r - setter (ConstructorReference _ conId) r = (ConstructorReference r conId) - getter = \case - TermReference r -> r - TypeReference r -> r - ConstructorReference r _ -> r - -_TermReference :: Prism' (SomeReference ref) ref -_TermReference = _Ctor @"TermReference" - --- | This is only safe as long as you don't change the constructor of your SomeReference -asTermReference_ :: Traversal' ref (SomeReference ref) -asTermReference_ f ref = - f (TermReference ref) <&> \case - TermReference ref' -> ref' - _ -> error "asTermReference_: SomeReferenceId constructor was changed." - --- | This is only safe as long as you don't change the constructor of your SomeReference -asTypeReference_ :: Traversal' ref (SomeReference ref) -asTypeReference_ f ref = - f (TypeReference ref) <&> \case - TypeReference ref' -> ref' - _ -> error "asTypeReference_: SomeReferenceId constructor was changed." - --- | This is only safe as long as you don't change the constructor of your SomeReference -asConstructorReference_ :: Traversal' (ConstructorReference.GConstructorReference ref) (SomeReference ref) -asConstructorReference_ f (ConstructorReference.ConstructorReference ref cId) = - f (ConstructorReference ref cId) <&> \case - ConstructorReference ref' cId -> ConstructorReference.ConstructorReference ref' cId - _ -> error "asConstructorReference_: SomeReferenceId constructor was changed." - -someReferenceIdToEntity :: SomeReferenceId -> Entity -someReferenceIdToEntity = \case - (TermReference ref) -> TermComponent (Reference.idToHash ref) - (TypeReference ref) -> DeclComponent (Reference.idToHash ref) - -- Constructors are migrated by their decl component. - (ConstructorReference ref _conId) -> DeclComponent (Reference.idToHash ref) - -foldSetter :: LensLike (Writer [a]) s t a a -> s -> [a] -foldSetter t s = execWriter (s & t %%~ \a -> tell [a] *> pure a) - --- | Save an empty branch and get its new hash to use when replacing --- branches which are missing due to database corruption. -saveV2EmptyBranch :: Sqlite.DB m => m (BranchHashId, Hash) -saveV2EmptyBranch = do - let branch = S.emptyBranch - let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch branch - newHash <- Hashing.dbBranchHash branch - newHashId <- Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash)) - _ <- Ops.saveBranchObject newHashId localBranchIds localBranch - pure (newHashId, newHash) +migrateSchema1To2 = undefined +-- migrateSchema1To2 conn codebase = +-- Sqlite.runDB conn do +-- Sqlite.withSavepoint "MIGRATESCHEMA12" \_rollback -> do +-- liftIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" +-- corruptedCausals <- Q.getCausalsWithoutBranchObjects +-- when (not . null $ corruptedCausals) $ do +-- liftIO $ putStrLn $ "โš ๏ธ I detected " <> show (length corruptedCausals) <> " corrupted namespace(s) in the history of the codebase." +-- liftIO $ putStrLn $ "This is due to a bug in a previous version of ucm." +-- liftIO $ putStrLn $ "This only affects the history of your codebase, the most up-to-date iteration will remain intact." +-- liftIO $ putStrLn $ "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." + +-- liftIO $ putStrLn $ "Updating Namespace Root..." +-- rootCausalHashId <- Q.expectNamespaceRoot +-- numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] +-- v2EmptyBranchHashInfo <- saveV2EmptyBranch +-- watches <- +-- lift do +-- foldMapM +-- (\watchKind -> map (W watchKind) <$> Codebase.watches codebase (Cv.watchKind2to1 watchKind)) +-- [WK.RegularWatch, WK.TestWatch] +-- migrationState <- +-- lift do +-- (Sync.sync @_ @Entity migrationSync (progress numEntitiesToMigrate) (CausalE rootCausalHashId : watches)) +-- `runReaderT` Env {db = conn, codebase} +-- `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo +-- let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId +-- liftIO $ putStrLn $ "Updating Namespace Root..." +-- Q.setNamespaceRoot newRootCausalHashId +-- liftIO $ putStrLn $ "Rewriting old object IDs..." +-- ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do +-- Q.recordObjectRehash oldObjId newObjId +-- liftIO $ putStrLn $ "Garbage collecting orphaned objects..." +-- Q.garbageCollectObjectsWithoutHashes +-- liftIO $ putStrLn $ "Garbage collecting orphaned watches..." +-- Q.garbageCollectWatchesWithoutObjects +-- liftIO $ putStrLn $ "Updating Schema Version..." +-- Q.setSchemaVersion 2 +-- pure $ Right () +-- where +-- progress :: Int -> Sync.Progress (ReaderT (Env m v a) (StateT MigrationState m)) Entity +-- progress numToMigrate = +-- let incrementProgress :: ReaderT (Env m v a) (StateT MigrationState m) () +-- incrementProgress = do +-- numDone <- field @"numMigrated" <+= 1 +-- liftIO $ putStr $ "\r ๐Ÿ— " <> show numDone <> " / ~" <> show numToMigrate <> " entities migrated. ๐Ÿšง" +-- need :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () +-- need e = when verboseOutput $ liftIO $ putStrLn $ "Need: " ++ show e +-- done :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () +-- done e = do +-- when verboseOutput $ liftIO $ putStrLn $ "Done: " ++ show e +-- incrementProgress +-- errorHandler :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () +-- errorHandler e = do +-- case e of +-- -- We expect non-fatal errors when migrating watches. +-- W {} -> pure () +-- e -> liftIO $ putStrLn $ "Error: " ++ show e +-- incrementProgress +-- allDone :: ReaderT (Env m v a) (StateT MigrationState m) () +-- allDone = liftIO $ putStrLn $ "\nFinished migrating, initiating cleanup." +-- in Sync.Progress {need, done, error = errorHandler, allDone} + +-- type Old a = a + +-- type New a = a + +-- type ConstructorName v = v + +-- type DeclName v = v + +-- data MigrationState = MigrationState +-- -- Mapping between old cycle-position -> new cycle-position for a given Decl object. +-- { referenceMapping :: Map (Old SomeReferenceId) (New SomeReferenceId), +-- causalMapping :: Map (Old CausalHashId) (New (CausalHash, CausalHashId)), +-- -- We also store the old hash for this object ID since we need a way to +-- -- convert Object Reference IDs into Hash Reference IDs so we can use the referenceMapping. +-- objLookup :: Map (Old ObjectId) (New ObjectId, New HashId, New Hash, Old Hash), +-- -- Remember the hashes of term/decls that we have already migrated to avoid migrating them twice. +-- migratedDefnHashes :: Set (Old Hash), +-- numMigrated :: Int, +-- v2EmptyBranchHashInfo :: (BranchHashId, Hash) +-- } +-- deriving (Generic) + +-- data Entity +-- = TermComponent Unison.Hash +-- | DeclComponent Unison.Hash +-- | CausalE CausalHashId +-- | BranchE ObjectId +-- | PatchE ObjectId +-- | W WK.WatchKind Reference.Id +-- deriving (Eq, Ord, Show) + +-- data Env m v a = Env {db :: Sqlite.Connection, codebase :: Codebase m v a} + +-- migrationSync :: +-- (MonadIO m, Var v) => +-- Sync (ReaderT (Env m v a) (StateT MigrationState m)) Entity +-- migrationSync = Sync \case +-- TermComponent hash -> do +-- Env {codebase, db} <- ask +-- lift (migrateTermComponent db codebase hash) +-- DeclComponent hash -> do +-- Env {codebase, db} <- ask +-- lift (migrateDeclComponent db codebase hash) +-- BranchE objectId -> do +-- Env {db} <- ask +-- lift (migrateBranch db objectId) +-- CausalE causalHashId -> do +-- Env {db} <- ask +-- lift (migrateCausal db causalHashId) +-- PatchE objectId -> do +-- Env {db} <- ask +-- lift (migratePatch db (PatchObjectId objectId)) +-- W watchKind watchId -> do +-- Env {codebase} <- ask +-- lift (migrateWatch codebase watchKind watchId) + +-- migrateCausal :: MonadIO m => Sqlite.Connection -> CausalHashId -> StateT MigrationState m (Sync.TrySyncResult Entity) +-- migrateCausal conn oldCausalHashId = fmap (either id id) . runExceptT $ do +-- whenM (Map.member oldCausalHashId <$> use (field @"causalMapping")) (throwE Sync.PreviouslyDone) + +-- oldBranchHashId <- Sqlite.runDB conn $ Q.expectCausalValueHashId oldCausalHashId +-- oldCausalParentHashIds <- Sqlite.runDB conn $ Q.loadCausalParents oldCausalHashId + +-- maybeOldBranchObjId <- +-- Sqlite.runDB conn $ +-- Q.loadObjectIdForAnyHashId (unBranchHashId oldBranchHashId) +-- migratedObjIds <- gets objLookup +-- -- If the branch for this causal hasn't been migrated, migrate it first. +-- let unmigratedBranch = +-- case maybeOldBranchObjId of +-- Just branchObjId | branchObjId `Map.notMember` migratedObjIds -> [BranchE branchObjId] +-- _ -> [] + +-- migratedCausals <- gets causalMapping +-- let unmigratedParents = +-- oldCausalParentHashIds +-- & filter (`Map.notMember` migratedCausals) +-- & fmap CausalE +-- let unmigratedEntities = unmigratedBranch <> unmigratedParents +-- when (not . null $ unmigratedParents <> unmigratedBranch) (throwE $ Sync.Missing unmigratedEntities) + +-- (newBranchHashId, newBranchHash) <- case maybeOldBranchObjId of +-- -- Some codebases are corrupted, likely due to interrupted save operations. +-- -- It's unfortunate, but rather than fail the whole migration we'll just replace them +-- -- with an empty branch. +-- Nothing -> use (field @"v2EmptyBranchHashInfo") +-- Just branchObjId -> do +-- let (_, newBranchHashId, newBranchHash, _) = migratedObjIds ^?! ix branchObjId +-- pure (BranchHashId newBranchHashId, newBranchHash) + +-- let (newParentHashes, newParentHashIds) = +-- oldCausalParentHashIds +-- & fmap +-- (\oldParentHashId -> migratedCausals ^?! ix oldParentHashId) +-- & unzip +-- & bimap (Set.fromList . map unCausalHash) Set.fromList + +-- let newCausalHash :: CausalHash +-- newCausalHash = +-- CausalHash . Cv.hash1to2 $ +-- Hashing.hashCausal +-- ( Hashing.Causal +-- { branchHash = newBranchHash, +-- parents = Set.mapMonotonic Cv.hash2to1 newParentHashes +-- } +-- ) +-- newCausalHashId <- Sqlite.runDB conn (Q.saveCausalHash newCausalHash) +-- let newCausal = +-- DbCausal +-- { selfHash = newCausalHashId, +-- valueHash = newBranchHashId, +-- parents = newParentHashIds +-- } +-- Sqlite.runDB conn do +-- Q.saveCausal (SC.selfHash newCausal) (SC.valueHash newCausal) +-- Q.saveCausalParents (SC.selfHash newCausal) (Set.toList $ SC.parents newCausal) + +-- field @"causalMapping" %= Map.insert oldCausalHashId (newCausalHash, newCausalHashId) + +-- pure Sync.Done + +-- migrateBranch :: MonadIO m => Sqlite.Connection -> ObjectId -> StateT MigrationState m (Sync.TrySyncResult Entity) +-- migrateBranch conn oldObjectId = fmap (either id id) . runExceptT $ do +-- whenM (Map.member oldObjectId <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone) + +-- oldBranch <- Sqlite.runDB conn (Ops.expectDbBranch (BranchObjectId oldObjectId)) +-- oldHash <- fmap Cv.hash2to1 . Sqlite.runDB conn $ Q.expectPrimaryHashByObjectId oldObjectId +-- oldBranchWithHashes <- Sqlite.runDB conn (traverseOf S.branchHashes_ (fmap Cv.hash2to1 . Q.expectPrimaryHashByObjectId) oldBranch) +-- migratedRefs <- gets referenceMapping +-- migratedObjects <- gets objLookup +-- migratedCausals <- gets causalMapping +-- let allMissingTypesAndTerms :: [Entity] +-- allMissingTypesAndTerms = +-- oldBranchWithHashes +-- ^.. branchSomeRefs_ +-- . uRefIdAsRefId_ +-- . filtered (`Map.notMember` migratedRefs) +-- . to someReferenceIdToEntity + +-- let allMissingPatches :: [Entity] = +-- oldBranch +-- ^.. S.patches_ +-- . to unPatchObjectId +-- . filtered (`Map.notMember` migratedObjects) +-- . to PatchE + +-- let allMissingChildBranches :: [Entity] = +-- oldBranch +-- ^.. S.childrenHashes_ +-- . _1 +-- . to unBranchObjectId +-- . filtered (`Map.notMember` migratedObjects) +-- . to BranchE + +-- let allMissingChildCausals :: [Entity] = +-- oldBranch +-- ^.. S.childrenHashes_ +-- . _2 +-- . filtered (`Map.notMember` migratedCausals) +-- . to CausalE + +-- -- Identify dependencies and bail out if they aren't all built +-- let allMissingReferences :: [Entity] +-- allMissingReferences = +-- allMissingTypesAndTerms +-- ++ allMissingPatches +-- ++ allMissingChildBranches +-- ++ allMissingChildCausals + +-- when (not . null $ allMissingReferences) $ +-- throwE $ Sync.Missing allMissingReferences + +-- let remapPatchObjectId patchObjId = case Map.lookup (unPatchObjectId patchObjId) migratedObjects of +-- Nothing -> error $ "Expected patch: " <> show patchObjId <> " to be migrated" +-- Just (newPatchObjId, _, _, _) -> PatchObjectId newPatchObjId +-- let remapCausalHashId causalHashId = case Map.lookup causalHashId migratedCausals of +-- Nothing -> error $ "Expected causal hash id: " <> show causalHashId <> " to be migrated" +-- Just (_, newCausalHashId) -> newCausalHashId +-- let remapBranchObjectId objId = case Map.lookup (unBranchObjectId objId) migratedObjects of +-- Nothing -> error $ "Expected object: " <> show objId <> " to be migrated" +-- Just (newBranchObjId, _, _, _) -> BranchObjectId newBranchObjId + +-- let newBranch :: S.DbBranch +-- newBranch = +-- oldBranch +-- & branchSomeRefs_ %~ remapObjIdRefs migratedObjects migratedRefs +-- & S.patches_ %~ remapPatchObjectId +-- & S.childrenHashes_ %~ (remapBranchObjectId *** remapCausalHashId) + +-- let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch newBranch +-- newHash <- Sqlite.runDB conn (Hashing.dbBranchHash newBranch) +-- newHashId <- Sqlite.runDB conn (Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash))) +-- newObjectId <- Sqlite.runDB conn (Ops.saveBranchObject newHashId localBranchIds localBranch) +-- field @"objLookup" %= Map.insert oldObjectId (unBranchObjectId newObjectId, unBranchHashId newHashId, newHash, oldHash) +-- pure Sync.Done + +-- migratePatch :: +-- forall m. +-- MonadIO m => +-- Sqlite.Connection -> +-- Old PatchObjectId -> +-- StateT MigrationState m (Sync.TrySyncResult Entity) +-- migratePatch conn oldObjectId = fmap (either id id) . runExceptT $ do +-- whenM (Map.member (unPatchObjectId oldObjectId) <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone) + +-- oldHash <- fmap Cv.hash2to1 . Sqlite.runDB conn $ Q.expectPrimaryHashByObjectId (unPatchObjectId oldObjectId) +-- oldPatch <- Sqlite.runDB conn (Ops.expectDbPatch oldObjectId) +-- let hydrateHashes :: forall m. Sqlite.DB m => HashId -> m Hash +-- hydrateHashes hashId = do +-- Cv.hash2to1 <$> Q.expectHash hashId +-- let hydrateObjectIds :: forall m. Sqlite.DB m => ObjectId -> m Hash +-- hydrateObjectIds objId = do +-- Cv.hash2to1 <$> Q.expectPrimaryHashByObjectId objId + +-- oldPatchWithHashes :: S.Patch' TextId Hash Hash <- +-- Sqlite.runDB conn do +-- (oldPatch & S.patchH_ %%~ hydrateHashes) +-- >>= (S.patchO_ %%~ hydrateObjectIds) + +-- migratedRefs <- gets referenceMapping +-- let isUnmigratedRef ref = Map.notMember ref migratedRefs +-- -- 2. Determine whether all things the patch refers to are built. +-- let unmigratedDependencies :: [Entity] +-- unmigratedDependencies = +-- oldPatchWithHashes ^.. patchSomeRefsH_ . uRefIdAsRefId_ . filtered isUnmigratedRef . to someReferenceIdToEntity +-- <> oldPatchWithHashes ^.. patchSomeRefsO_ . uRefIdAsRefId_ . filtered isUnmigratedRef . to someReferenceIdToEntity +-- when (not . null $ unmigratedDependencies) (throwE (Sync.Missing unmigratedDependencies)) + +-- let hashToHashId :: forall m. Sqlite.DB m => Hash -> m HashId +-- hashToHashId h = +-- fromMaybe (error $ "expected hashId for hash: " <> show h) <$> (Q.loadHashIdByHash (Cv.hash1to2 h)) +-- let hashToObjectId :: forall m. Sqlite.DB m => Hash -> m ObjectId +-- hashToObjectId = hashToHashId >=> Q.expectObjectIdForPrimaryHashId + +-- migratedReferences <- gets referenceMapping +-- let remapRef :: SomeReferenceId -> SomeReferenceId +-- remapRef ref = Map.findWithDefault ref ref migratedReferences + +-- let newPatch = +-- oldPatchWithHashes +-- & patchSomeRefsH_ . uRefIdAsRefId_ %~ remapRef +-- & patchSomeRefsO_ . uRefIdAsRefId_ %~ remapRef + +-- newPatchWithIds :: S.Patch <- +-- Sqlite.runDB conn $ do +-- (newPatch & S.patchH_ %%~ hashToHashId) +-- >>= (S.patchO_ %%~ hashToObjectId) + +-- let (localPatchIds, localPatch) = S.LocalizeObject.localizePatch newPatchWithIds +-- newHash <- Sqlite.runDB conn (Hashing.dbPatchHash newPatchWithIds) +-- newObjectId <- Sqlite.runDB conn (Ops.saveDbPatch (PatchHash (Cv.hash1to2 newHash)) (S.Patch.Format.Full localPatchIds localPatch)) +-- newHashId <- Sqlite.runDB conn (Q.expectHashIdByHash (Cv.hash1to2 newHash)) +-- field @"objLookup" %= Map.insert (unPatchObjectId oldObjectId) (unPatchObjectId newObjectId, newHashId, newHash, oldHash) +-- pure Sync.Done + +-- -- | PLAN +-- -- * +-- -- NOTE: this implementation assumes that watches will be migrated AFTER everything else is finished. +-- -- This is because it's difficult for us to know otherwise whether a reference refers to something which doesn't exist, or just +-- -- something that hasn't been migrated yet. If we do it last, we know that missing references are indeed just missing from the codebase. +-- migrateWatch :: +-- forall m v a. +-- (MonadIO m, Ord v) => +-- Codebase m v a -> +-- WatchKind -> +-- Reference.Id -> +-- StateT MigrationState m (Sync.TrySyncResult Entity) +-- migrateWatch Codebase {getWatch, putWatch} watchKind oldWatchId = fmap (either id id) . runExceptT $ do +-- let watchKindV1 = Cv.watchKind2to1 watchKind +-- watchResultTerm <- +-- (lift . lift) (getWatch watchKindV1 oldWatchId) >>= \case +-- -- The hash which we're watching doesn't exist in the codebase, throw out this watch. +-- Nothing -> throwE Sync.Done +-- Just term -> pure term +-- migratedReferences <- gets referenceMapping +-- newWatchId <- case Map.lookup (TermReference oldWatchId) migratedReferences of +-- (Just (TermReference newRef)) -> pure newRef +-- _ -> throwE Sync.NonFatalError +-- let maybeRemappedTerm :: Maybe (Term.Term v a) +-- maybeRemappedTerm = +-- watchResultTerm +-- & termReferences_ %%~ \someRef -> Map.lookup someRef migratedReferences +-- case maybeRemappedTerm of +-- -- One or more references in the result didn't exist in our codebase. +-- Nothing -> pure Sync.NonFatalError +-- Just remappedTerm -> do +-- lift . lift $ putWatch watchKindV1 newWatchId remappedTerm +-- pure Sync.Done + +-- uRefIdAsRefId_ :: Iso' (SomeReference (UReference.Id' Hash)) SomeReferenceId +-- uRefIdAsRefId_ = mapping uRefAsRef_ + +-- uRefAsRef_ :: Iso' (UReference.Id' Hash) Reference.Id +-- uRefAsRef_ = iso intoRef intoURef +-- where +-- intoRef (UReference.Id hash pos) = Reference.Id hash pos +-- intoURef (Reference.Id hash pos) = UReference.Id hash pos + +-- -- Project an S.Referent'' into its SomeReferenceObjId's +-- someReferent_ :: +-- forall t h. +-- (forall ref. Traversal' ref (SomeReference ref)) -> +-- Traversal' (S.Branch.Full.Referent'' t h) (SomeReference (UReference.Id' h)) +-- someReferent_ typeOrTermTraversal_ = +-- (UReferent._Ref . someReference_ typeOrTermTraversal_) +-- `failing` ( UReferent._Con +-- . asPair_ -- Need to unpack the embedded reference AND remap between mismatched Constructor ID types. +-- . asConstructorReference_ +-- ) +-- where +-- asPair_ f (UReference.ReferenceDerived id', conId) = +-- f (ConstructorReference.ConstructorReference id' (fromIntegral conId)) +-- <&> \(ConstructorReference.ConstructorReference newId newConId) -> +-- (UReference.ReferenceDerived newId, fromIntegral newConId) +-- asPair_ _ (UReference.ReferenceBuiltin x, conId) = pure (UReference.ReferenceBuiltin x, conId) + +-- -- asPair_ f (UReference.ReferenceDerived id', conId) = +-- -- f (id', fromIntegral conId) +-- -- <&> \(newId, newConId) -> (UReference.ReferenceDerived newId, fromIntegral newConId) +-- -- asPair_ _ (UReference.ReferenceBuiltin x, conId) = pure (UReference.ReferenceBuiltin x, conId) + +-- someReference_ :: +-- (forall ref. Traversal' ref (SomeReference ref)) -> +-- Traversal' (UReference.Reference' t h) (SomeReference (UReference.Id' h)) +-- someReference_ typeOrTermTraversal_ = UReference._ReferenceDerived . typeOrTermTraversal_ + +-- someMetadataSetFormat_ :: +-- (Ord t, Ord h) => +-- (forall ref. Traversal' ref (SomeReference ref)) -> +-- Traversal' (S.Branch.Full.MetadataSetFormat' t h) (SomeReference (UReference.Id' h)) +-- someMetadataSetFormat_ typeOrTermTraversal_ = +-- S.Branch.Full.metadataSetFormatReferences_ . someReference_ typeOrTermTraversal_ + +-- someReferenceMetadata_ :: +-- (Ord k, Ord t, Ord h) => +-- Traversal' k (SomeReference (UReference.Id' h)) -> +-- Traversal' +-- (Map k (S.Branch.Full.MetadataSetFormat' t h)) +-- (SomeReference (UReference.Id' h)) +-- someReferenceMetadata_ keyTraversal_ f m = +-- Map.toList m +-- & traversed . beside keyTraversal_ (someMetadataSetFormat_ asTermReference_) %%~ f +-- <&> Map.fromList + +-- branchSomeRefs_ :: (Ord t, Ord h) => Traversal' (S.Branch' t h p c) (SomeReference (UReference.Id' h)) +-- branchSomeRefs_ f S.Branch.Full.Branch {children, patches, terms, types} = do +-- let newTypesMap = types & traversed . someReferenceMetadata_ (someReference_ asTypeReference_) %%~ f +-- let newTermsMap = terms & traversed . someReferenceMetadata_ (someReferent_ asTermReference_) %%~ f +-- S.Branch.Full.Branch <$> newTermsMap <*> newTypesMap <*> pure patches <*> pure children + +-- patchSomeRefsH_ :: (Ord t, Ord h) => Traversal (S.Patch' t h o) (S.Patch' t h o) (SomeReference (UReference.Id' h)) (SomeReference (UReference.Id' h)) +-- patchSomeRefsH_ f S.Patch {termEdits, typeEdits} = do +-- newTermEdits <- Map.fromList <$> (Map.toList termEdits & traversed . _1 . (someReferent_ asTermReference_) %%~ f) +-- newTypeEdits <- Map.fromList <$> (Map.toList typeEdits & traversed . _1 . (someReference_ asTypeReference_) %%~ f) +-- pure S.Patch {termEdits = newTermEdits, typeEdits = newTypeEdits} + +-- patchSomeRefsO_ :: (Ord t, Ord h, Ord o) => Traversal' (S.Patch' t h o) (SomeReference (UReference.Id' o)) +-- patchSomeRefsO_ f S.Patch {termEdits, typeEdits} = do +-- newTermEdits <- (termEdits & traversed . Set.traverse . termEditRefs_ %%~ f) +-- newTypeEdits <- (typeEdits & traversed . Set.traverse . typeEditRefs_ %%~ f) +-- pure (S.Patch {termEdits = newTermEdits, typeEdits = newTypeEdits}) + +-- termEditRefs_ :: Traversal' (TermEdit.TermEdit' t h) (SomeReference (UReference.Id' h)) +-- termEditRefs_ f (TermEdit.Replace ref typing) = +-- TermEdit.Replace <$> (ref & someReferent_ asTermReference_ %%~ f) <*> pure typing +-- termEditRefs_ _f (TermEdit.Deprecate) = pure TermEdit.Deprecate + +-- typeEditRefs_ :: Traversal' (TypeEdit.TypeEdit' t h) (SomeReference (UReference.Id' h)) +-- typeEditRefs_ f (TypeEdit.Replace ref) = +-- TypeEdit.Replace <$> (ref & someReference_ asTypeReference_ %%~ f) +-- typeEditRefs_ _f (TypeEdit.Deprecate) = pure TypeEdit.Deprecate + +-- migrateTermComponent :: +-- forall m v a. +-- (Ord v, Var v, Monad m, MonadIO m) => +-- Sqlite.Connection -> +-- Codebase m v a -> +-- Unison.Hash -> +-- StateT MigrationState m (Sync.TrySyncResult Entity) +-- migrateTermComponent conn Codebase {..} oldHash = fmap (either id id) . runExceptT $ do +-- whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone) + +-- oldComponent <- +-- (lift . lift $ getTermComponentWithTypes oldHash) >>= \case +-- Nothing -> error $ "Hash was missing from codebase: " <> show oldHash +-- Just c -> pure c + +-- let componentIDMap :: Map (Old Reference.Id) (Term.Term v a, Type v a) +-- componentIDMap = Map.fromList $ Reference.componentFor oldHash oldComponent +-- let unhashed :: Map (Old Reference.Id) (v, Term.Term v a) +-- unhashed = Term.unhashComponent (fst <$> componentIDMap) +-- let vToOldReferenceMapping :: Map v (Old Reference.Id) +-- vToOldReferenceMapping = +-- unhashed +-- & Map.toList +-- & fmap (\(refId, (v, _trm)) -> (v, refId)) +-- & Map.fromList + +-- referencesMap <- gets referenceMapping + +-- let allMissingReferences :: [Old SomeReferenceId] +-- allMissingReferences = +-- let missingTermRefs = +-- unhashed & foldSetter (traversed . _2 . termReferences_) +-- missingTypeRefs = +-- componentIDMap +-- & foldSetter (traversed . _2 . typeReferences_) +-- in filter (`Map.notMember` referencesMap) (missingTermRefs <> missingTypeRefs) + +-- when (not . null $ allMissingReferences) $ +-- throwE $ Sync.Missing . nubOrd $ (someReferenceIdToEntity <$> allMissingReferences) + +-- let getMigratedReference :: Old SomeReferenceId -> New SomeReferenceId +-- getMigratedReference ref = +-- Map.findWithDefault (error $ "unmigrated reference" <> show ref) ref referencesMap + +-- let remappedReferences :: Map (Old Reference.Id) (v, Term.Term v a, Type v a) = +-- Zip.zipWith +-- ( \(v, trm) (_, typ) -> +-- ( v, +-- trm & termReferences_ %~ getMigratedReference, +-- typ & typeReferences_ %~ getMigratedReference +-- ) +-- ) +-- unhashed +-- componentIDMap + +-- let newTermComponents :: Map v (New Reference.Id, Term.Term v a, Type v a) +-- newTermComponents = +-- remappedReferences +-- & Map.elems +-- & fmap (\(v, trm, typ) -> (v, (trm, typ))) +-- & Map.fromList +-- & Convert.hashTermComponents + +-- ifor newTermComponents $ \v (newReferenceId, trm, typ) -> do +-- let oldReferenceId = vToOldReferenceMapping ^?! ix v +-- field @"referenceMapping" %= Map.insert (TermReference oldReferenceId) (TermReference newReferenceId) +-- lift . lift $ putTerm newReferenceId trm typ + +-- -- Need to get one of the new references to grab its hash, doesn't matter which one since +-- -- all hashes in the component are the same. +-- case newTermComponents ^? traversed . _1 . to Reference.idToHash of +-- Nothing -> pure () +-- Just newHash -> insertObjectMappingForHash conn oldHash newHash + +-- field @"migratedDefnHashes" %= Set.insert oldHash +-- pure Sync.Done + +-- migrateDeclComponent :: +-- forall m v a. +-- (Ord v, Var v, Monad m, MonadIO m) => +-- Sqlite.Connection -> +-- Codebase m v a -> +-- Unison.Hash -> +-- StateT MigrationState m (Sync.TrySyncResult Entity) +-- migrateDeclComponent conn Codebase {..} oldHash = fmap (either id id) . runExceptT $ do +-- whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone) + +-- declComponent :: [DD.Decl v a] <- +-- (lift . lift $ getDeclComponent oldHash) >>= \case +-- Nothing -> error $ "Expected decl component for hash:" <> show oldHash +-- Just dc -> pure dc + +-- let componentIDMap :: Map (Old Reference.Id) (DD.Decl v a) +-- componentIDMap = Map.fromList $ Reference.componentFor oldHash declComponent + +-- let unhashed :: Map (Old Reference.Id) (DeclName v, DD.Decl v a) +-- unhashed = DD.unhashComponent componentIDMap + +-- let allTypes :: [Type v a] +-- allTypes = +-- unhashed +-- ^.. traversed +-- . _2 +-- . beside DD.asDataDecl_ id +-- . to DD.constructors' +-- . traversed +-- . _3 + +-- migratedReferences <- gets referenceMapping +-- let unmigratedRefIds :: [SomeReferenceId] +-- unmigratedRefIds = +-- allTypes +-- & foldSetter +-- ( traversed -- Every type in the list +-- . typeReferences_ +-- . filtered (`Map.notMember` migratedReferences) +-- ) + +-- when (not . null $ unmigratedRefIds) do +-- throwE (Sync.Missing (nubOrd . fmap someReferenceIdToEntity $ unmigratedRefIds)) + +-- -- At this point we know we have all the required mappings from old references to new ones. +-- let remapTerm :: Type v a -> Type v a +-- remapTerm = typeReferences_ %~ \ref -> Map.findWithDefault (error "unmigrated reference") ref migratedReferences + +-- let remappedReferences :: Map (Old Reference.Id) (DeclName v, DD.Decl v a) +-- remappedReferences = +-- unhashed +-- & traversed -- Traverse map of reference IDs +-- . _2 -- Select the DataDeclaration +-- . beside DD.asDataDecl_ id -- Unpack effect decls +-- . DD.constructors_ -- Get the data constructors +-- . traversed -- traverse the list of them +-- . _3 -- Select the Type term. +-- %~ remapTerm + +-- let declNameToOldReference :: Map (DeclName v) (Old Reference.Id) +-- declNameToOldReference = Map.fromList . fmap swap . Map.toList . fmap fst $ remappedReferences + +-- let newComponent :: [(DeclName v, Reference.Id, DD.Decl v a)] +-- newComponent = +-- remappedReferences +-- & Map.elems +-- & Map.fromList +-- & Convert.hashDecls +-- & fromRight (error "unexpected resolution error") + +-- for_ newComponent $ \(declName, newReferenceId, dd) -> do +-- let oldReferenceId = declNameToOldReference ^?! ix declName +-- field @"referenceMapping" %= Map.insert (TypeReference oldReferenceId) (TypeReference newReferenceId) + +-- let oldConstructorIds :: Map (ConstructorName v) (Old ConstructorId) +-- oldConstructorIds = +-- (componentIDMap ^?! ix oldReferenceId) +-- & DD.asDataDecl +-- & DD.constructors' +-- & imap (\constructorId (_ann, constructorName, _type) -> (constructorName, fromIntegral constructorId)) +-- & Map.fromList + +-- ifor_ (DD.constructors' (DD.asDataDecl dd)) \(fromIntegral -> newConstructorId) (_ann, constructorName, _type) -> do +-- field @"referenceMapping" +-- %= Map.insert +-- (ConstructorReference oldReferenceId (oldConstructorIds ^?! ix constructorName)) +-- (ConstructorReference newReferenceId newConstructorId) + +-- lift . lift $ putTypeDeclaration newReferenceId dd + +-- -- Need to get one of the new references to grab its hash, doesn't matter which one since +-- -- all hashes in the component are the same. +-- case newComponent ^? traversed . _2 . to Reference.idToHash of +-- Nothing -> pure () +-- Just newHash -> insertObjectMappingForHash conn oldHash newHash +-- field @"migratedDefnHashes" %= Set.insert oldHash + +-- pure Sync.Done + +-- insertObjectMappingForHash :: +-- (MonadIO m, MonadState MigrationState m) => +-- Sqlite.Connection -> +-- Old Hash -> +-- New Hash -> +-- m () +-- insertObjectMappingForHash conn oldHash newHash = do +-- (oldObjectId, newHashId, newObjectId) <- Sqlite.runDB conn $ do +-- oldHashId <- Q.expectHashIdByHash . Cv.hash1to2 $ oldHash +-- oldObjectId <- Q.expectObjectIdForPrimaryHashId $ oldHashId +-- newHashId <- Q.expectHashIdByHash . Cv.hash1to2 $ newHash +-- newObjectId <- Q.expectObjectIdForPrimaryHashId $ newHashId +-- pure (oldObjectId, newHashId, newObjectId) +-- field @"objLookup" %= Map.insert oldObjectId (newObjectId, newHashId, newHash, oldHash) + +-- typeReferences_ :: (Monad m, Ord v) => LensLike' m (Type v a) SomeReferenceId +-- typeReferences_ = +-- ABT.rewriteDown_ -- Focus all terms +-- . ABT.baseFunctor_ -- Focus Type.F +-- . Type._Ref -- Only the Ref constructor has references +-- . Reference._DerivedId +-- . asTypeReference_ + +-- termReferences_ :: (Monad m, Ord v) => LensLike' m (Term.Term v a) SomeReferenceId +-- termReferences_ = +-- ABT.rewriteDown_ -- Focus all terms +-- . ABT.baseFunctor_ -- Focus Term.F +-- . termFReferences_ + +-- termFReferences_ :: (Ord tv, Monad m) => LensLike' m (Term.F tv ta pa a) SomeReferenceId +-- termFReferences_ f t = +-- (t & Term._Ref . Reference._DerivedId . asTermReference_ %%~ f) +-- >>= Term._Constructor . someRefCon_ %%~ f +-- >>= Term._Request . someRefCon_ %%~ f +-- >>= Term._Ann . _2 . typeReferences_ %%~ f +-- >>= Term._Match . _2 . traversed . Term.matchPattern_ . patternReferences_ %%~ f +-- >>= Term._TermLink . referentAsSomeTermReference_ %%~ f +-- >>= Term._TypeLink . Reference._DerivedId . asTypeReference_ %%~ f + +-- -- | Build a SomeConstructorReference +-- someRefCon_ :: Traversal' ConstructorReference.ConstructorReference SomeReferenceId +-- someRefCon_ = refConPair_ . asConstructorReference_ +-- where +-- refConPair_ :: Traversal' ConstructorReference.ConstructorReference ConstructorReference.ConstructorReferenceId +-- refConPair_ f s = +-- case s of +-- ConstructorReference.ConstructorReference (Reference.Builtin _) _ -> pure s +-- ConstructorReference.ConstructorReference (Reference.DerivedId n) c -> +-- ( \(ConstructorReference.ConstructorReference n' c') -> +-- ConstructorReference.ConstructorReference (Reference.DerivedId n') c' +-- ) +-- <$> f (ConstructorReference.ConstructorReference n c) + +-- patternReferences_ :: Traversal' (Pattern loc) SomeReferenceId +-- patternReferences_ f = \case +-- p@(Pattern.Unbound {}) -> pure p +-- p@(Pattern.Var {}) -> pure p +-- p@(Pattern.Boolean {}) -> pure p +-- p@(Pattern.Int {}) -> pure p +-- p@(Pattern.Nat {}) -> pure p +-- p@(Pattern.Float {}) -> pure p +-- p@(Pattern.Text {}) -> pure p +-- p@(Pattern.Char {}) -> pure p +-- (Pattern.Constructor loc ref patterns) -> +-- (\newRef newPatterns -> Pattern.Constructor loc newRef newPatterns) +-- <$> (ref & someRefCon_ %%~ f) +-- <*> (patterns & traversed . patternReferences_ %%~ f) +-- (Pattern.As loc pat) -> Pattern.As loc <$> patternReferences_ f pat +-- (Pattern.EffectPure loc pat) -> Pattern.EffectPure loc <$> patternReferences_ f pat +-- (Pattern.EffectBind loc ref patterns pat) -> +-- do +-- (\newRef newPatterns newPat -> Pattern.EffectBind loc newRef newPatterns newPat) +-- <$> (ref & someRefCon_ %%~ f) +-- <*> (patterns & traversed . patternReferences_ %%~ f) +-- <*> (patternReferences_ f pat) +-- (Pattern.SequenceLiteral loc patterns) -> +-- Pattern.SequenceLiteral loc <$> (patterns & traversed . patternReferences_ %%~ f) +-- Pattern.SequenceOp loc pat seqOp pat2 -> do +-- Pattern.SequenceOp loc <$> patternReferences_ f pat <*> pure seqOp <*> patternReferences_ f pat2 + +-- referentAsSomeTermReference_ :: Traversal' Referent.Referent SomeReferenceId +-- referentAsSomeTermReference_ f = \case +-- (Referent'.Ref' (Reference.DerivedId refId)) -> do +-- newRefId <- refId & asTermReference_ %%~ f +-- pure (Referent'.Ref' (Reference.DerivedId newRefId)) +-- (Referent'.Con' (ConstructorReference.ConstructorReference (Reference.DerivedId refId) conId) conType) -> +-- (ConstructorReference.ConstructorReference refId conId & asConstructorReference_ %%~ f) +-- <&> \(ConstructorReference.ConstructorReference newRefId newConId) -> +-- Referent'.Con' +-- (ConstructorReference.ConstructorReference (Reference.DerivedId newRefId) newConId) +-- conType +-- r -> pure r + +-- type SomeReferenceId = SomeReference Reference.Id + +-- type SomeReferenceObjId = SomeReference (UReference.Id' ObjectId) + +-- remapObjIdRefs :: +-- (Map (Old ObjectId) (New ObjectId, New HashId, New Hash, Old Hash)) -> +-- (Map SomeReferenceId SomeReferenceId) -> +-- SomeReferenceObjId -> +-- SomeReferenceObjId +-- remapObjIdRefs objMapping refMapping someObjIdRef = newSomeObjId +-- where +-- oldObjId :: ObjectId +-- oldObjId = someObjIdRef ^. someRef_ . UReference.idH +-- (newObjId, _, _, oldHash) = +-- case Map.lookup oldObjId objMapping of +-- Nothing -> error $ "Expected object mapping for ID: " <> show oldObjId +-- Just found -> found +-- oldSomeRefId :: SomeReferenceId +-- oldSomeRefId = (someObjIdRef & someRef_ . UReference.idH .~ oldHash) ^. uRefIdAsRefId_ +-- newSomeRefId :: SomeReferenceId +-- newSomeRefId = case Map.lookup oldSomeRefId refMapping of +-- Nothing -> error $ "Expected reference mapping for ID: " <> show oldSomeRefId +-- Just r -> r +-- newSomeObjId :: SomeReference (UReference.Id' (New ObjectId)) +-- newSomeObjId = (newSomeRefId ^. from uRefIdAsRefId_) & someRef_ . UReference.idH .~ newObjId + +-- data SomeReference ref +-- = TermReference ref +-- | TypeReference ref +-- | ConstructorReference ref ConstructorId +-- deriving (Eq, Functor, Generic, Ord, Show, Foldable, Traversable) + +-- someRef_ :: Lens (SomeReference ref) (SomeReference ref') ref ref' +-- someRef_ = lens getter setter +-- where +-- setter (TermReference _) r = TermReference r +-- setter (TypeReference _) r = TypeReference r +-- setter (ConstructorReference _ conId) r = (ConstructorReference r conId) +-- getter = \case +-- TermReference r -> r +-- TypeReference r -> r +-- ConstructorReference r _ -> r + +-- _TermReference :: Prism' (SomeReference ref) ref +-- _TermReference = _Ctor @"TermReference" + +-- -- | This is only safe as long as you don't change the constructor of your SomeReference +-- asTermReference_ :: Traversal' ref (SomeReference ref) +-- asTermReference_ f ref = +-- f (TermReference ref) <&> \case +-- TermReference ref' -> ref' +-- _ -> error "asTermReference_: SomeReferenceId constructor was changed." + +-- -- | This is only safe as long as you don't change the constructor of your SomeReference +-- asTypeReference_ :: Traversal' ref (SomeReference ref) +-- asTypeReference_ f ref = +-- f (TypeReference ref) <&> \case +-- TypeReference ref' -> ref' +-- _ -> error "asTypeReference_: SomeReferenceId constructor was changed." + +-- -- | This is only safe as long as you don't change the constructor of your SomeReference +-- asConstructorReference_ :: Traversal' (ConstructorReference.GConstructorReference ref) (SomeReference ref) +-- asConstructorReference_ f (ConstructorReference.ConstructorReference ref cId) = +-- f (ConstructorReference ref cId) <&> \case +-- ConstructorReference ref' cId -> ConstructorReference.ConstructorReference ref' cId +-- _ -> error "asConstructorReference_: SomeReferenceId constructor was changed." + +-- someReferenceIdToEntity :: SomeReferenceId -> Entity +-- someReferenceIdToEntity = \case +-- (TermReference ref) -> TermComponent (Reference.idToHash ref) +-- (TypeReference ref) -> DeclComponent (Reference.idToHash ref) +-- -- Constructors are migrated by their decl component. +-- (ConstructorReference ref _conId) -> DeclComponent (Reference.idToHash ref) + +-- foldSetter :: LensLike (Writer [a]) s t a a -> s -> [a] +-- foldSetter t s = execWriter (s & t %%~ \a -> tell [a] *> pure a) + +-- -- | Save an empty branch and get its new hash to use when replacing +-- -- branches which are missing due to database corruption. +-- saveV2EmptyBranch :: Sqlite.DB m => m (BranchHashId, Hash) +-- saveV2EmptyBranch = do +-- let branch = S.emptyBranch +-- let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch branch +-- newHash <- Hashing.dbBranchHash branch +-- newHashId <- Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash)) +-- _ <- Ops.saveBranchObject newHashId localBranchIds localBranch +-- pure (newHashId, newHash) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs index 1629e42aaf..bf19122521 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs @@ -27,8 +27,9 @@ import qualified UnliftIO -- weren't being used for anything anyways. migrateSchema2To3 :: forall a m v. (MonadUnliftIO m, Var v) => Sqlite.Connection -> Codebase m v a -> m (Either MigrationError ()) migrateSchema2To3 conn _ = UnliftIO.try . flip runReaderT conn $ - Sqlite.withSavepoint "MIGRATE_SCHEMA_2_TO_3" $ \_rollback -> do - version <- Q.schemaVersion - when (version /= 2) $ UnliftIO.throwIO (IncorrectStartingSchemaVersion version) - Q.removeHashObjectsByHashingVersion (HashVersion 1) - Q.setSchemaVersion (SchemaVersion 3) + undefined + -- Sqlite.withSavepoint "MIGRATE_SCHEMA_2_TO_3" $ \_rollback -> do + -- version <- Q.schemaVersion + -- when (version /= 2) $ UnliftIO.throwIO (IncorrectStartingSchemaVersion version) + -- Q.removeHashObjectsByHashingVersion (HashVersion 1) + -- Q.setSchemaVersion (SchemaVersion 3) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs new file mode 100644 index 0000000000..735cf447fb --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -0,0 +1,605 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | This module contains sqlite-specific operations on high-level "parser-typechecker" types all in the Transaction +-- monad. +-- +-- The Codebase record-of-functions wraps this functionality, and runs each transaction to IO, so that the operations' +-- are unified with non-sqlite operations in the Codebase interface, like 'appendReflog'. +module Unison.Codebase.SqliteCodebase.Operations where + +import qualified Control.Concurrent +import Control.Monad.Except (ExceptT, runExceptT, throwError) +import qualified Control.Monad.Except as Except +import qualified Control.Monad.Extra as Monad +import Control.Monad.Reader (ReaderT (runReaderT)) +import Control.Monad.State (MonadState) +import qualified Control.Monad.State as State +import Data.Bifunctor (Bifunctor (bimap), second) +import Data.Bitraversable (bitraverse) +import qualified Data.Char as Char +import Data.Either.Extra () +import qualified Data.List as List +import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1) +import qualified Data.Map as Map +import Data.Maybe (fromJust) +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO +import qualified System.Console.ANSI as ANSI +import System.FilePath (()) +import qualified System.FilePath as FilePath +import qualified System.FilePath.Posix as FilePath.Posix +import U.Codebase.HashTags (CausalHash (CausalHash, unCausalHash)) +import qualified U.Codebase.Reference as C.Reference +import qualified U.Codebase.Referent as C.Referent +import U.Codebase.Sqlite.DbId (ObjectId) +import qualified U.Codebase.Sqlite.ObjectType as OT +import qualified U.Codebase.Sqlite.Operations as Ops +import qualified U.Codebase.Sqlite.Queries as Q +import qualified U.Codebase.Sqlite.Sync22 as Sync22 +import qualified U.Codebase.Sync as Sync +import qualified U.Util.Cache as Cache +import qualified U.Util.Hash as H2 +import qualified U.Util.Monoid as Monoid +import U.Util.Timing (time) +import qualified Unison.Builtin as Builtins +import Unison.Codebase (Codebase, CodebasePath) +import qualified Unison.Codebase as Codebase1 +import Unison.Codebase.Branch (Branch (..)) +import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Causal.Type as Causal +import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo) +import qualified Unison.Codebase.Editor.Git as Git +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo (..), printWriteRepo, writeToRead) +import qualified Unison.Codebase.GitError as GitError +import qualified Unison.Codebase.Init as Codebase +import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1 +import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase1 +import Unison.Codebase.Patch (Patch) +import qualified Unison.Codebase.Reflog as Reflog +import Unison.Codebase.ShortBranchHash (ShortBranchHash) +import qualified Unison.Codebase.SqliteCodebase.Branch.Dependencies as BD +import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv +import qualified Unison.Codebase.SqliteCodebase.GitError as GitError +import Unison.Codebase.SqliteCodebase.Migrations (ensureCodebaseIsUpToDate) +import Unison.Codebase.SqliteCodebase.Paths +import qualified Unison.Codebase.SqliteCodebase.SyncEphemeral as SyncEphemeral +import Unison.Codebase.SyncMode (SyncMode) +import Unison.Codebase.Type (LocalOrRemote (..), PushGitBranchOpts (..)) +import qualified Unison.Codebase.Type as C +import Unison.ConstructorReference (GConstructorReference (..)) +import qualified Unison.ConstructorType as CT +import Unison.DataDeclaration (Decl) +import qualified Unison.DataDeclaration as Decl +import Unison.Hash (Hash) +import qualified Unison.Hashing.V2.Convert as Hashing +import Unison.Parser.Ann (Ann) +import Unison.Prelude +import Unison.Reference (Reference) +import qualified Unison.Reference as Reference +import qualified Unison.Referent as Referent +import Unison.ShortHash (ShortHash) +import qualified Unison.ShortHash as SH +import qualified Unison.ShortHash as ShortHash +import Unison.Sqlite (Connection, Transaction) +import qualified Unison.Sqlite as Sqlite +import qualified Unison.Sqlite.Connection as Sqlite.Connection +import Unison.Symbol (Symbol) +import Unison.Term (Term) +import qualified Unison.Term as Term +import Unison.Type (Type) +import qualified Unison.Type as Type +import qualified Unison.Util.Set as Set +import qualified Unison.WatchKind as UF +import UnliftIO (catchIO, finally, throwIO, try) +import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) +import UnliftIO.Exception (catch) +import UnliftIO.STM + +------------------------------------------------------------------------------------------------------------------------ +-- Buffer entry + +-- 1) buffer up the component +-- 2) in the event that the component is complete, then what? +-- * can write component provided all of its dependency components are complete. +-- if dependency not complete, +-- register yourself to be written when that dependency is complete + +-- an entry for a single hash +data BufferEntry a = BufferEntry + { -- First, you are waiting for the cycle to fill up with all elements + -- Then, you check: are all dependencies of the cycle in the db? + -- If yes: write yourself to database and trigger check of dependents + -- If no: just wait, do nothing + beComponentTargetSize :: Maybe Word64, + beComponent :: Map Reference.Pos a, + beMissingDependencies :: Set Hash, + beWaitingDependents :: Set Hash + } + deriving (Eq, Show) + +prettyBufferEntry :: Show a => Hash -> BufferEntry a -> String +prettyBufferEntry (h :: Hash) BufferEntry {..} = + "BufferEntry " ++ show h ++ "\n" + ++ " { beComponentTargetSize = " + ++ show beComponentTargetSize + ++ "\n" + ++ " , beComponent = " + ++ if Map.size beComponent < 2 + then show $ Map.toList beComponent + else + mkString (Map.toList beComponent) (Just "\n [ ") " , " (Just "]\n") + ++ " , beMissingDependencies =" + ++ if Set.size beMissingDependencies < 2 + then show $ Set.toList beMissingDependencies + else + mkString (Set.toList beMissingDependencies) (Just "\n [ ") " , " (Just "]\n") + ++ " , beWaitingDependents =" + ++ if Set.size beWaitingDependents < 2 + then show $ Set.toList beWaitingDependents + else + mkString (Set.toList beWaitingDependents) (Just "\n [ ") " , " (Just "]\n") + ++ " }" + where + mkString :: (Foldable f, Show a) => f a -> Maybe String -> String -> Maybe String -> String + mkString as start middle end = + fromMaybe "" start ++ List.intercalate middle (show <$> toList as) ++ fromMaybe "" end + +type TermBufferEntry = BufferEntry (Term Symbol Ann, Type Symbol Ann) + +type DeclBufferEntry = BufferEntry (Decl Symbol Ann) + +getBuffer :: TVar (Map Hash (BufferEntry a)) -> Hash -> IO (BufferEntry a) +getBuffer tv h = do + (Map.lookup h <$> readTVarIO tv) <&> \case + Just e -> e + Nothing -> BufferEntry Nothing Map.empty Set.empty Set.empty + +putBuffer :: TVar (Map Hash (BufferEntry a)) -> Hash -> BufferEntry a -> IO () +putBuffer tv h e = + atomically $ modifyTVar' tv (Map.insert h e) + +removeBuffer :: TVar (Map Hash (BufferEntry a)) -> Hash -> IO () +removeBuffer tv h = + atomically $ modifyTVar' tv (Map.delete h) + +addBufferDependent :: Hash -> TVar (Map Hash (BufferEntry a)) -> Hash -> IO () +addBufferDependent dependent tv dependency = do + be <- getBuffer tv dependency + putBuffer tv dependency be {beWaitingDependents = Set.insert dependent $ beWaitingDependents be} + +tryFlushBuffer :: + forall a. + (Show a) => + TVar (Map Hash (BufferEntry a)) -> + (H2.Hash -> [a] -> Transaction ()) -> + (Hash -> Transaction ()) -> + Hash -> + Transaction () +tryFlushBuffer buf saveComponent tryWaiting h@(Cv.hash1to2 -> h2) = + -- skip if it has already been flushed + unlessM (Ops.objectExistsForHash h2) do + BufferEntry size comp (Set.delete h -> missing) waiting <- Sqlite.idempotentIO (getBuffer buf h) + case size of + Just size -> do + missing' <- filterM (fmap not . Ops.objectExistsForHash . Cv.hash1to2) (toList missing) + if null missing' && size == fromIntegral (length comp) + then do + saveComponent h2 (toList comp) + Sqlite.idempotentIO (removeBuffer buf h) + traverse_ tryWaiting waiting + else Sqlite.idempotentIO do + putBuffer buf h $ + BufferEntry (Just size) comp (Set.fromList missing') waiting + Nothing -> + -- it's never even been added, so there's nothing to do. + pure () + +------------------------------------------------------------------------------------------------------------------------ +-- Operations + +getTerm :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Transaction CT.ConstructorType) -> + Reference.Id -> + Transaction (Maybe (Term Symbol Ann)) +getTerm doGetDeclType (Reference.Id h1@(Cv.hash1to2 -> h2) i) = + runMaybeT do + term2 <- Ops.loadTermByReference (C.Reference.Id h2 i) + lift (Cv.term2to1 h1 doGetDeclType term2) + +getDeclType :: C.Reference.Reference -> Transaction CT.ConstructorType +getDeclType = \case + C.Reference.ReferenceBuiltin t -> + let err = + error $ + "I don't know about the builtin type ##" + ++ show t + ++ ", but I've been asked for it's ConstructorType." + in pure . fromMaybe err $ + Map.lookup (Reference.Builtin t) Builtins.builtinConstructorType + C.Reference.ReferenceDerived i -> expectDeclTypeById i + +expectDeclTypeById :: C.Reference.Id -> Transaction CT.ConstructorType +expectDeclTypeById = fmap Cv.decltype2to1 . Ops.expectDeclTypeById + +getTypeOfTermImpl :: Reference.Id -> Transaction (Maybe (Type Symbol Ann)) +getTypeOfTermImpl (Reference.Id (Cv.hash1to2 -> h2) i) = + runMaybeT do + type2 <- Ops.loadTypeOfTermByTermReference (C.Reference.Id h2 i) + pure (Cv.ttype2to1 type2) + +getTermComponentWithTypes :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Transaction CT.ConstructorType) -> + Hash -> + Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)]) +getTermComponentWithTypes doGetDeclType h1@(Cv.hash1to2 -> h2) = + runMaybeT do + tms <- Ops.loadTermComponent h2 + for tms (bitraverse (lift . Cv.term2to1 h1 doGetDeclType) (pure . Cv.ttype2to1)) + +getTypeDeclaration :: Reference.Id -> Transaction (Maybe (Decl Symbol Ann)) +getTypeDeclaration (Reference.Id h1@(Cv.hash1to2 -> h2) i) = + runMaybeT do + decl2 <- Ops.loadDeclByReference (C.Reference.Id h2 i) + pure (Cv.decl2to1 h1 decl2) + +getDeclComponent :: Hash -> Transaction (Maybe [Decl Symbol Ann]) +getDeclComponent h1@(Cv.hash1to2 -> h2) = + runMaybeT do + decl2 <- Ops.loadDeclComponent h2 + pure (map (Cv.decl2to1 h1) decl2) + +getCycleLength :: Hash -> Transaction (Maybe Reference.CycleSize) +getCycleLength (Cv.hash1to2 -> h2) = + Ops.getCycleLen h2 + +putTerm :: + TVar (Map Hash TermBufferEntry) -> + TVar (Map Hash DeclBufferEntry) -> + Reference.Id -> + Term Symbol Ann -> + Type Symbol Ann -> + Transaction () +putTerm termBuffer declBuffer (Reference.Id h@(Cv.hash1to2 -> h2) i) tm tp = + unlessM (Ops.objectExistsForHash h2) do + BufferEntry size comp missing waiting <- Sqlite.idempotentIO (getBuffer termBuffer h) + let termDependencies = Set.toList $ Term.termDependencies tm + -- update the component target size if we encounter any higher self-references + let size' = max size (Just $ biggestSelfReference + 1) + where + biggestSelfReference = + maximum1 $ + i :| [i' | Reference.Derived h' i' <- termDependencies, h == h'] + let comp' = Map.insert i (tm, tp) comp + -- for the component element that's been passed in, add its dependencies to missing' + missingTerms' <- + filterM + (fmap not . Ops.objectExistsForHash . Cv.hash1to2) + [h | Reference.Derived h _i <- termDependencies] + missingTypes' <- + filterM (fmap not . Ops.objectExistsForHash . Cv.hash1to2) $ + [h | Reference.Derived h _i <- Set.toList $ Term.typeDependencies tm] + ++ [h | Reference.Derived h _i <- Set.toList $ Type.dependencies tp] + let missing' = missing <> Set.fromList (missingTerms' <> missingTypes') + Sqlite.idempotentIO do + -- notify each of the dependencies that h depends on them. + traverse_ (addBufferDependent h termBuffer) missingTerms' + traverse_ (addBufferDependent h declBuffer) missingTypes' + putBuffer termBuffer h (BufferEntry size' comp' missing' waiting) + tryFlushTermBuffer termBuffer h + +tryFlushTermBuffer :: TVar (Map Hash TermBufferEntry) -> Hash -> Transaction () +tryFlushTermBuffer termBuffer = + let loop h = + tryFlushBuffer + termBuffer + ( \h2 component -> do + oId <- + Ops.saveTermComponent h2 $ + fmap (bimap (Cv.term1to2 h) Cv.ttype1to2) component + addTermComponentTypeIndex oId (fmap snd component) + ) + loop + h + in loop + +addTermComponentTypeIndex :: ObjectId -> [Type Symbol Ann] -> Transaction () +addTermComponentTypeIndex oId types = for_ (types `zip` [0 ..]) \(tp, i) -> do + let self = C.Referent.RefId (C.Reference.Id oId i) + typeForIndexing = Hashing.typeToReference tp + typeMentionsForIndexing = Hashing.typeToReferenceMentions tp + Ops.addTypeToIndexForTerm self (Cv.reference1to2 typeForIndexing) + Ops.addTypeMentionsToIndexForTerm self (Set.map Cv.reference1to2 typeMentionsForIndexing) + +addDeclComponentTypeIndex :: ObjectId -> [[Type Symbol Ann]] -> Transaction () +addDeclComponentTypeIndex oId ctorss = + for_ (ctorss `zip` [0 ..]) \(ctors, i) -> + for_ (ctors `zip` [0 ..]) \(tp, j) -> do + let self = C.Referent.ConId (C.Reference.Id oId i) j + typeForIndexing = Hashing.typeToReference tp + typeMentionsForIndexing = Hashing.typeToReferenceMentions tp + Ops.addTypeToIndexForTerm self (Cv.reference1to2 typeForIndexing) + Ops.addTypeMentionsToIndexForTerm self (Set.map Cv.reference1to2 typeMentionsForIndexing) + +putTypeDeclaration :: + TVar (Map Hash TermBufferEntry) -> + TVar (Map Hash DeclBufferEntry) -> + Reference.Id -> + Decl Symbol Ann -> + Transaction () +putTypeDeclaration termBuffer declBuffer (Reference.Id h@(Cv.hash1to2 -> h2) i) decl = + unlessM (Ops.objectExistsForHash h2) do + BufferEntry size comp missing waiting <- Sqlite.idempotentIO (getBuffer declBuffer h) + let declDependencies = Set.toList $ Decl.declDependencies decl + let size' = max size (Just $ biggestSelfReference + 1) + where + biggestSelfReference = + maximum1 $ + i :| [i' | Reference.Derived h' i' <- declDependencies, h == h'] + let comp' = Map.insert i decl comp + moreMissing <- + filterM (fmap not . Ops.objectExistsForHash . Cv.hash1to2) $ + [h | Reference.Derived h _i <- declDependencies] + let missing' = missing <> Set.fromList moreMissing + Sqlite.idempotentIO do + traverse_ (addBufferDependent h declBuffer) moreMissing + putBuffer declBuffer h (BufferEntry size' comp' missing' waiting) + tryFlushDeclBuffer termBuffer declBuffer h + +tryFlushDeclBuffer :: + TVar (Map Hash TermBufferEntry) -> + TVar (Map Hash DeclBufferEntry) -> + Hash -> + Transaction () +tryFlushDeclBuffer termBuffer declBuffer = + let loop h = + tryFlushBuffer + declBuffer + ( \h2 component -> do + oId <- Ops.saveDeclComponent h2 $ fmap (Cv.decl1to2 h) component + addDeclComponentTypeIndex oId $ + fmap (map snd . Decl.constructors . Decl.asDataDecl) component + ) + (\h -> tryFlushTermBuffer termBuffer h >> loop h) + h + in loop + +getRootBranch :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Transaction CT.ConstructorType) -> + TVar (Maybe (Sqlite.DataVersion, Branch Transaction)) -> + Transaction (Branch Transaction) +getRootBranch doGetDeclType rootBranchCache = + Sqlite.idempotentIO (readTVarIO rootBranchCache) >>= \case + Nothing -> forceReload + Just (v, b) -> do + -- check to see if root namespace hash has been externally modified + -- and reload it if necessary + v' <- Sqlite.getDataVersion + if v == v' + then pure b + else do + newRootHash <- Ops.expectRootCausalHash + if Branch.headHash b == Cv.branchHash2to1 newRootHash + then pure b + else do + traceM $ "database was externally modified (" ++ show v ++ " -> " ++ show v' ++ ")" + forceReload + where + forceReload :: Transaction (Branch Transaction) + forceReload = do + causal2 <- Ops.expectRootCausal + branch1 <- Cv.causalbranch2to1 doGetDeclType causal2 + ver <- Sqlite.getDataVersion + Sqlite.idempotentIO (atomically (writeTVar rootBranchCache (Just (ver, branch1)))) + pure branch1 + +getRootBranchExists :: Transaction Bool +getRootBranchExists = + isJust <$> Ops.loadRootCausalHash + +putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Transaction)) -> Branch Transaction -> Transaction () +putRootBranch rootBranchCache branch1 = do + -- todo: check to see if root namespace hash has been externally modified + -- and do something (merge?) it if necessary. But for now, we just overwrite it. + void (Ops.saveRootBranch (Cv.causalbranch1to2 branch1)) + Sqlite.idempotentIO (atomically $ modifyTVar' rootBranchCache (fmap . second $ const branch1)) + +-- rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.Hash)) +-- rootBranchUpdates _rootBranchCache = do +-- -- branchHeadChanges <- TQueue.newIO +-- -- (cancelWatch, watcher) <- Watch.watchDirectory' (v2dir root) +-- -- watcher1 <- +-- -- liftIO . forkIO +-- -- $ forever +-- -- $ do +-- -- -- void ignores the name and time of the changed file, +-- -- -- and assume 'unison.sqlite3' has changed +-- -- (filename, time) <- watcher +-- -- traceM $ "SqliteCodebase.watcher " ++ show (filename, time) +-- -- readTVarIO rootBranchCache >>= \case +-- -- Nothing -> pure () +-- -- Just (v, _) -> do +-- -- -- this use of `conn` in a separate thread may be problematic. +-- -- -- hopefully sqlite will produce an obvious error message if it is. +-- -- v' <- runDB conn Ops.dataVersion +-- -- if v /= v' then +-- -- atomically +-- -- . TQueue.enqueue branchHeadChanges =<< runDB conn Ops.loadRootCausalHash +-- -- else pure () + +-- -- -- case hashFromFilePath filePath of +-- -- -- Nothing -> failWith $ CantParseBranchHead filePath +-- -- -- Just h -> +-- -- -- atomically . TQueue.enqueue branchHeadChanges $ Branch.Hash h +-- -- -- smooth out intermediate queue +-- -- pure +-- -- ( cancelWatch >> killThread watcher1 +-- -- , Set.fromList <$> Watch.collectUntilPause branchHeadChanges 400000 +-- -- ) +-- pure (cleanup, liftIO newRootsDiscovered) +-- where +-- newRootsDiscovered = do +-- Control.Concurrent.threadDelay maxBound -- hold off on returning +-- pure mempty -- returning nothing +-- cleanup = pure () + +-- if this blows up on cromulent hashes, then switch from `hashToHashId` +-- to one that returns Maybe. +getBranchForHash :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Transaction CT.ConstructorType) -> + Branch.Hash -> + Transaction (Maybe (Branch Transaction)) +getBranchForHash doGetDeclType h = do + Ops.loadCausalBranchByCausalHash (Cv.branchHash1to2 h) >>= \case + Nothing -> pure Nothing + Just causal2 -> do + branch1 <- Cv.causalbranch2to1 doGetDeclType causal2 + pure (Just branch1) + +putBranch :: Branch Transaction -> Transaction () +putBranch = + void . Ops.saveBranch . Cv.causalbranch1to2 + +isCausalHash :: Branch.Hash -> Transaction Bool +isCausalHash (Causal.RawHash h) = + Q.loadHashIdByHash (Cv.hash1to2 h) >>= \case + Nothing -> pure False + Just hId -> Q.isCausalHash hId + +getPatch :: Branch.EditHash -> Transaction (Maybe Patch) +getPatch h = + runMaybeT do + patchId <- MaybeT (Q.loadPatchObjectIdForPrimaryHash (Cv.patchHash1to2 h)) + patch <- lift (Ops.expectPatch patchId) + pure (Cv.patch2to1 patch) + +putPatch :: Branch.EditHash -> Patch -> Transaction () +putPatch h p = + void $ Ops.savePatch (Cv.patchHash1to2 h) (Cv.patch1to2 p) + +patchExists :: Branch.EditHash -> Transaction Bool +patchExists h = fmap isJust $ Q.loadPatchObjectIdForPrimaryHash (Cv.patchHash1to2 h) + +dependentsImpl :: Reference -> Transaction (Set Reference.Id) +dependentsImpl r = + Set.map Cv.referenceid2to1 + <$> Ops.dependents (Cv.reference1to2 r) + +dependentsOfComponentImpl :: Hash -> Transaction (Set Reference.Id) +dependentsOfComponentImpl h = + Set.map Cv.referenceid2to1 + <$> Ops.dependentsOfComponent (Cv.hash1to2 h) + +-- syncFromDirectory :: MonadUnliftIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m () +-- syncFromDirectory srcRoot _syncMode b = do +-- withConnection (debugName ++ ".sync.src") srcRoot $ \srcConn -> do +-- flip State.evalStateT emptySyncProgressState $ do +-- syncInternal syncProgress srcConn conn $ Branch.transform lift b + +-- syncToDirectory :: MonadUnliftIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m () +-- syncToDirectory destRoot _syncMode b = +-- withConnection (debugName ++ ".sync.dest") destRoot $ \destConn -> +-- flip State.evalStateT emptySyncProgressState $ do +-- initSchemaIfNotExist destRoot +-- syncInternal syncProgress conn destConn $ Branch.transform lift b + +watches :: UF.WatchKind -> Transaction [Reference.Id] +watches w = + Ops.listWatches (Cv.watchKind1to2 w) + <&> fmap Cv.referenceid2to1 + +getWatch :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Transaction CT.ConstructorType) -> + UF.WatchKind -> + Reference.Id -> + Transaction (Maybe (Term Symbol Ann)) +getWatch doGetDeclType k r@(Reference.Id h _i) = + if elem k standardWatchKinds + then runMaybeT do + watch <- Ops.loadWatch (Cv.watchKind1to2 k) (Cv.referenceid1to2 r) + lift (Cv.term2to1 h doGetDeclType watch) + else pure Nothing + +putWatch :: UF.WatchKind -> Reference.Id -> Term Symbol Ann -> Transaction () +putWatch k r@(Reference.Id h _i) tm = + when (elem k standardWatchKinds) do + Ops.saveWatch + (Cv.watchKind1to2 k) + (Cv.referenceid1to2 r) + (Cv.term1to2 h tm) + +standardWatchKinds :: [UF.WatchKind] +standardWatchKinds = [UF.RegularWatch, UF.TestWatch] + +clearWatches :: Transaction () +clearWatches = Ops.clearWatches + +termsOfTypeImpl :: Reference -> Transaction (Set Referent.Id) +termsOfTypeImpl r = + Ops.termsHavingType (Cv.reference1to2 r) + >>= Set.traverse (Cv.referentid2to1 getDeclType) + +termsMentioningTypeImpl :: Reference -> Transaction (Set Referent.Id) +termsMentioningTypeImpl r = + Ops.termsMentioningType (Cv.reference1to2 r) + >>= Set.traverse (Cv.referentid2to1 getDeclType) + +hashLength :: Transaction Int +hashLength = pure 10 + +branchHashLength :: Transaction Int +branchHashLength = pure 10 + +defnReferencesByPrefix :: OT.ObjectType -> ShortHash -> Transaction (Set Reference.Id) +defnReferencesByPrefix _ (ShortHash.Builtin _) = pure mempty +defnReferencesByPrefix ot (ShortHash.ShortHash prefix (fmap Cv.shortHashSuffix1to2 -> cycle) _cid) = do + refs <- do + Ops.componentReferencesByPrefix ot prefix cycle + >>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId) + >>= pure . Set.fromList + pure $ Set.map Cv.referenceid2to1 refs + +termReferencesByPrefix :: ShortHash -> Transaction (Set Reference.Id) +termReferencesByPrefix = defnReferencesByPrefix OT.TermComponent + +declReferencesByPrefix :: ShortHash -> Transaction (Set Reference.Id) +declReferencesByPrefix = defnReferencesByPrefix OT.DeclComponent + +referentsByPrefix :: ShortHash -> Transaction (Set Referent.Id) +referentsByPrefix SH.Builtin {} = pure mempty +referentsByPrefix (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to2 -> cycle) cid) = do + termReferents <- + Ops.termReferentsByPrefix prefix cycle + >>= traverse (Cv.referentid2to1 getDeclType) + declReferents' <- Ops.declReferentsByPrefix prefix cycle (read . Text.unpack <$> cid) + let declReferents = + [ Referent.ConId (ConstructorReference (Reference.Id (Cv.hash2to1 h) pos) (fromIntegral cid)) (Cv.decltype2to1 ct) + | (h, pos, ct, cids) <- declReferents', + cid <- cids + ] + pure . Set.fromList $ termReferents <> declReferents + +branchHashesByPrefix :: ShortBranchHash -> Transaction (Set Branch.Hash) +branchHashesByPrefix sh = do + -- given that a Branch is shallow, it's really `CausalHash` that you'd + -- refer to to specify a full namespace w/ history. + -- but do we want to be able to refer to a namespace without its history? + cs <- Ops.causalHashesByPrefix (Cv.sbh1to2 sh) + pure $ Set.map (Causal.RawHash . Cv.hash2to1 . unCausalHash) cs + +{- +sqlLca :: MonadIO m => Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash) +sqlLca h1 h2 = + liftIO $ + withConnection (debugName ++ ".lca.left") root $ \c1 -> do + withConnection (debugName ++ ".lca.right") root $ \c2 -> do + Sqlite.runDB conn + . (fmap . fmap) Cv.causalHash2to1 + $ Ops.lca (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) c1 c2 + +-} diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 22c5def578..1595218690 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -70,6 +70,7 @@ library Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3 + Unison.Codebase.SqliteCodebase.Operations Unison.Codebase.SqliteCodebase.Paths Unison.Codebase.SqliteCodebase.SyncEphemeral Unison.Codebase.SyncMode From c2111daed24df10dfb21a9d6b950dd6ae68965fd Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Wed, 6 Apr 2022 09:08:42 -0500 Subject: [PATCH 059/529] filling in a couple of things --- unison-cli/src/Unison/Share/Sync.hs | 24 ++++++++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index ac32b9c192..b6117b56ae 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -27,11 +27,21 @@ data UploadEntitiesResponse = UploadEntitiesSuccess | UploadEntitiesNeedDependencies (Share.NeedDependencies Share.Hash) +data GetCausalHashByPathResponse + = GetCausalHashByPathSuccess Share.HashJWT + | GetCausalHashByPathEmpty + -- deriving stock (Show, Eq, Ord, Generic) updatePath :: Share.UpdatePathRequest -> IO UpdatePathResponse updatePath = undefined +uploadEntities :: Share.UploadEntitiesRequest -> IO UploadEntitiesResponse +uploadEntities = undefined + +getCausalHashByPath :: Share.GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse +getCausalHashByPath = undefined + -- Push -- -- 1. Update path @@ -44,6 +54,8 @@ data PushError = PushErrorServerMissingDependencies (NESet Share.Hash) | PushErrorHashMismatch Share.HashMismatch +data PullError + -- Option 1: have push be itself in the Transaction monad, use unsafePerformIdempotentIO -- fuction to do the interleaved IO calls (http, etc) -- @@ -71,6 +83,9 @@ type Transaction a = () expectHash :: HashId -> Transaction Hash.Hash expectHash = undefined +pull :: Connection -> Share.RepoPath -> IO (Either PullError CausalHash) +pull _conn _repoPath = undefined + push :: Connection -> Share.RepoPath -> Maybe Share.Hash -> CausalHash -> IO (Either PushError ()) push conn repoPath expectedHash causalHash = do updatePath request >>= \case @@ -117,10 +132,11 @@ upload conn repoName dependencies = do pure Share.UploadEntitiesRequest {repoName, entities} -- 2. Perform upload HTTP call - - -- 3. If UploadEntitiesMissingDependencies, recur - - undefined + undefined "http call" request >>= \case + -- 3. If UploadEntitiesMissingDependencies, recur + UploadEntitiesNeedDependencies (Share.NeedDependencies dependencies) -> + upload conn repoName dependencies + UploadEntitiesSuccess -> pure () -- FIXME rename, etc resolveHashToEntity :: Connection -> Share.Hash -> IO (Share.Entity Text Share.Hash Share.Hash) From f3c7dea316feaeb63b739435ae3e33edf9a85758 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Wed, 6 Apr 2022 11:02:55 -0400 Subject: [PATCH 060/529] Make POp serialization more reliable There was a huge list of all the ops associated with numbers used to serialize them, but there was no way to check that every POp was in the list (and some were actually missing). Instead, use a function from POp to number so that the coverage checker can complain if a new op is added. Then the list is generated from the Enum/Bounded instances. --- parser-typechecker/src/Unison/Runtime/ANF.hs | 6 +- .../src/Unison/Runtime/ANF/Serialize.hs | 233 +++++++++--------- 2 files changed, 128 insertions(+), 111 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index 30fb45f36a..f7406a6624 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -822,6 +822,10 @@ litRef (C _) = Ty.charRef litRef (LM _) = Ty.termLinkRef litRef (LY _) = Ty.typeLinkRef +-- Note: Enum/Bounded instances should only be used for things like +-- getting a list of all ops. Using auto-generated numberings for +-- serialization, for instance, could cause observable changes to +-- formats that we want to control and version. data POp = -- Int ADDI @@ -954,7 +958,7 @@ data POp | TRCE | -- STM ATOM - deriving (Show, Eq, Ord) + deriving (Show, Eq, Ord, Enum, Bounded) type ANormal = ABTN.Term ANormalF diff --git a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs index ff0efc8bc1..f3b1d29d21 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF/Serialize.hs @@ -403,7 +403,7 @@ getFunc ctx = putPOp :: MonadPut m => POp -> m () putPOp op | Just w <- Map.lookup op pop2word = putWord16be w - | otherwise = exn "putPOp: unknown POp" + | otherwise = exn $ "putPOp: unknown POp: " ++ show op getPOp :: MonadGet m => m POp getPOp = @@ -411,116 +411,129 @@ getPOp = Just op -> pure op Nothing -> exn "getPOp: unknown enum code" +pOpCode :: POp -> Word16 +pOpCode op = case op of + ADDI -> 0 + SUBI -> 1 + MULI -> 2 + DIVI -> 3 + SGNI -> 4 + NEGI -> 5 + MODI -> 6 + POWI -> 7 + SHLI -> 8 + SHRI -> 9 + INCI -> 10 + DECI -> 11 + LEQI -> 12 + EQLI -> 13 + ADDN -> 14 + SUBN -> 15 + MULN -> 16 + DIVN -> 17 + MODN -> 18 + TZRO -> 19 + LZRO -> 20 + POWN -> 21 + SHLN -> 22 + SHRN -> 23 + ANDN -> 24 + IORN -> 25 + XORN -> 26 + COMN -> 27 + INCN -> 28 + DECN -> 29 + LEQN -> 30 + EQLN -> 31 + ADDF -> 32 + SUBF -> 33 + MULF -> 34 + DIVF -> 35 + MINF -> 36 + MAXF -> 37 + LEQF -> 38 + EQLF -> 39 + POWF -> 40 + EXPF -> 41 + SQRT -> 42 + LOGF -> 43 + LOGB -> 44 + ABSF -> 45 + CEIL -> 46 + FLOR -> 47 + TRNF -> 48 + RNDF -> 49 + COSF -> 50 + ACOS -> 51 + COSH -> 52 + ACSH -> 53 + SINF -> 54 + ASIN -> 55 + SINH -> 56 + ASNH -> 57 + TANF -> 58 + ATAN -> 59 + TANH -> 60 + ATNH -> 61 + ATN2 -> 62 + CATT -> 63 + TAKT -> 64 + DRPT -> 65 + SIZT -> 66 + UCNS -> 67 + USNC -> 68 + EQLT -> 69 + LEQT -> 70 + PAKT -> 71 + UPKT -> 72 + CATS -> 73 + TAKS -> 74 + DRPS -> 75 + SIZS -> 76 + CONS -> 77 + SNOC -> 78 + IDXS -> 79 + BLDS -> 80 + VWLS -> 81 + VWRS -> 82 + SPLL -> 83 + SPLR -> 84 + PAKB -> 85 + UPKB -> 86 + TAKB -> 87 + DRPB -> 88 + IDXB -> 89 + SIZB -> 90 + FLTB -> 91 + CATB -> 92 + ITOF -> 93 + NTOF -> 94 + ITOT -> 95 + NTOT -> 96 + TTOI -> 97 + TTON -> 98 + TTOF -> 99 + FTOT -> 100 + FORK -> 101 + EQLU -> 102 + CMPU -> 103 + EROR -> 104 + PRNT -> 105 + INFO -> 106 + POPC -> 107 + MISS -> 108 + CACH -> 109 + LKUP -> 110 + LOAD -> 111 + CVLD -> 112 + SDBX -> 113 + VALU -> 114 + TLTT -> 115 + TRCE -> 116 + ATOM -> 117 + pOpAssoc :: [(POp, Word16)] -pOpAssoc = - [ (ADDI, 0), - (SUBI, 1), - (MULI, 2), - (DIVI, 3), - (SGNI, 4), - (NEGI, 5), - (MODI, 6), - (POWI, 7), - (SHLI, 8), - (SHRI, 9), - (INCI, 10), - (DECI, 11), - (LEQI, 12), - (EQLI, 13), - (ADDN, 14), - (SUBN, 15), - (MULN, 16), - (DIVN, 17), - (MODN, 18), - (TZRO, 19), - (LZRO, 20), - (POWN, 21), - (SHLN, 22), - (SHRN, 23), - (ANDN, 24), - (IORN, 25), - (XORN, 26), - (COMN, 27), - (INCN, 28), - (DECN, 29), - (LEQN, 30), - (EQLN, 31), - (ADDF, 32), - (SUBF, 33), - (MULF, 34), - (DIVF, 35), - (MINF, 36), - (MAXF, 37), - (LEQF, 38), - (EQLF, 39), - (POWF, 40), - (EXPF, 41), - (SQRT, 42), - (LOGF, 43), - (LOGB, 44), - (ABSF, 45), - (CEIL, 46), - (FLOR, 47), - (TRNF, 48), - (RNDF, 49), - (COSF, 50), - (ACOS, 51), - (COSH, 52), - (ACSH, 53), - (SINF, 54), - (ASIN, 55), - (SINH, 56), - (ASNH, 57), - (TANF, 58), - (ATAN, 59), - (TANH, 60), - (ATNH, 61), - (ATN2, 62), - (CATT, 63), - (TAKT, 64), - (DRPT, 65), - (SIZT, 66), - (UCNS, 67), - (USNC, 68), - (EQLT, 69), - (LEQT, 70), - (PAKT, 71), - (UPKT, 72), - (CATS, 73), - (TAKS, 74), - (DRPS, 75), - (SIZS, 76), - (CONS, 77), - (SNOC, 78), - (IDXS, 79), - (BLDS, 80), - (VWLS, 81), - (VWRS, 82), - (SPLL, 83), - (SPLR, 84), - (PAKB, 85), - (UPKB, 86), - (TAKB, 87), - (DRPB, 88), - (IDXB, 89), - (SIZB, 90), - (FLTB, 91), - (CATB, 92), - (ITOF, 93), - (NTOF, 94), - (ITOT, 95), - (NTOT, 96), - (TTOI, 97), - (TTON, 98), - (TTOF, 99), - (FTOT, 100), - (FORK, 101), - (EQLU, 102), - (CMPU, 103), - (EROR, 104), - (PRNT, 105), - (INFO, 106) - ] +pOpAssoc = map (\op -> (op, pOpCode op)) [minBound .. maxBound] pop2word :: Map POp Word16 pop2word = fromList pOpAssoc From 913216c4f5848c37986d1ebe27d51b129c0a9efc Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 6 Apr 2022 14:33:40 -0400 Subject: [PATCH 061/529] more ooo-sync work --- .../sql/001-temp-entity-tables.sql | 40 +++++ unison-cli/src/Unison/Share/Sync.hs | 167 ++++++++++-------- 2 files changed, 137 insertions(+), 70 deletions(-) create mode 100644 codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql diff --git a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql new file mode 100644 index 0000000000..b48bc77a5b --- /dev/null +++ b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql @@ -0,0 +1,40 @@ +begin; +create table temp_entity_type_description ( + id integer primary key not null, + description text unique not null +); +insert into temp_entity_type_description +values + (0, 'Term Component'), + (1, 'Decl Component'), + (2, 'Namespace'), + (3, 'Patch'), + (4, 'Causal'); +create table temp_entity ( + hash text primary key not null, + blob bytes not null, + type_id integer not null references temp_entity_type_description(id) +); +create table temp_entity_missing_dependency ( + dependent text not null references temp_entity(hash), + dependency text not null +); +create index temp_entity_missing_dependency_ix_dependent on temp_entity_missing_dependency (dependent); +create index temp_entity_missing_dependency_ix_dependency on temp_entity_missing_dependency (dependency); +select count(*) from object; +rollback; + +begin; +create table foo(a int); +create index foo on foo (a); +rollback; + +.schema hash + +.schema object + +.schema object_type_description + +select * from object_type_description; + +select 1; diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index b6117b56ae..f15eaab966 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -1,5 +1,10 @@ module Unison.Share.Sync - ( push, + ( -- * Get causal hash by path + getCausalHashByPath, + GetCausalHashByPathError (..), + + -- * Push + push, PushError (..), ) where @@ -18,82 +23,48 @@ import Unison.Prelude import qualified Unison.Sync.Types as Share import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) -data UpdatePathResponse - = UpdatePathSuccess - | UpdatePathHashMismatch Share.HashMismatch - | UpdatePathMissingDependencies (Share.NeedDependencies Share.Hash) - -data UploadEntitiesResponse - = UploadEntitiesSuccess - | UploadEntitiesNeedDependencies (Share.NeedDependencies Share.Hash) +------------------------------------------------------------------------------------------------------------------------ +-- Get causal hash by path data GetCausalHashByPathResponse = GetCausalHashByPathSuccess Share.HashJWT | GetCausalHashByPathEmpty + | GetCausalHashByPathNoReadPermission --- deriving stock (Show, Eq, Ord, Generic) +data GetCausalHashByPathError + = GetCausalHashByPathErrorNoReadPermission -updatePath :: Share.UpdatePathRequest -> IO UpdatePathResponse -updatePath = undefined +getCausalHashByPath :: Share.RepoPath -> IO (Either GetCausalHashByPathError (Maybe Share.HashJWT)) +getCausalHashByPath repoPath = + _getCausalHashByPath (Share.GetCausalHashByPathRequest repoPath) <&> \case + GetCausalHashByPathSuccess hashJwt -> Right (Just hashJwt) + GetCausalHashByPathEmpty -> Right Nothing + GetCausalHashByPathNoReadPermission -> Left GetCausalHashByPathErrorNoReadPermission -uploadEntities :: Share.UploadEntitiesRequest -> IO UploadEntitiesResponse -uploadEntities = undefined - -getCausalHashByPath :: Share.GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse -getCausalHashByPath = undefined +_getCausalHashByPath :: Share.GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse +_getCausalHashByPath = undefined +------------------------------------------------------------------------------------------------------------------------ -- Push --- --- 1. Update path --- 2. Possibly do some upload entities --- --- I can communicate with my fingers --- data PushError = PushErrorServerMissingDependencies (NESet Share.Hash) | PushErrorHashMismatch Share.HashMismatch -data PullError +_updatePath :: Share.UpdatePathRequest -> IO UpdatePathResponse +_updatePath = undefined --- Option 1: have push be itself in the Transaction monad, use unsafePerformIdempotentIO --- fuction to do the interleaved IO calls (http, etc) --- --- push :: RepoPath -> ... -> Transaction (Either PushError ()) --- push = do --- unsafePerformIdempotentIO (updatePath ...) --- --- Option 2: have push "go around" the Transaction abstraction by beginning/commiting explicitly, --- and immediately un-Transaction-newtyping the low-level calls like loadHashId --- --- push :: Connection -> RepoPath -> ... -> IO (Either PushError ()) --- push conn = do --- let foo transaction = unsafeUnTransaction transaction conn --- --- ... --- result <- foo (loadHashId hashId) --- ... --- --- newtype Transaction a = Transaction { unsafeUnTransaction :: Connection -> IO a } - -type Connection = () - -type Transaction a = () - -expectHash :: HashId -> Transaction Hash.Hash -expectHash = undefined - -pull :: Connection -> Share.RepoPath -> IO (Either PullError CausalHash) -pull _conn _repoPath = undefined +_uploadEntities :: Share.UploadEntitiesRequest -> IO UploadEntitiesResponse +_uploadEntities = undefined push :: Connection -> Share.RepoPath -> Maybe Share.Hash -> CausalHash -> IO (Either PushError ()) push conn repoPath expectedHash causalHash = do - updatePath request >>= \case + _updatePath request >>= \case UpdatePathSuccess -> pure (Right ()) UpdatePathHashMismatch mismatch -> pure (Left (PushErrorHashMismatch mismatch)) UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do upload conn (Share.RepoPath.repoName repoPath) dependencies - updatePath request <&> \case + _updatePath request <&> \case UpdatePathSuccess -> Right () UpdatePathHashMismatch mismatch -> Left (PushErrorHashMismatch mismatch) UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> @@ -120,32 +91,88 @@ push conn repoPath expectedHash causalHash = do } } --- { repoName :: RepoName, --- entities :: NEMap Hash (Entity Text Hash Hash) --- } upload :: Connection -> Share.RepoName -> NESet Share.Hash -> IO () upload conn repoName dependencies = do - -- 1. Resolve each Hash to Entity request <- do entities <- NEMap.fromAscList <$> traverse (\dep -> (dep,) <$> resolveHashToEntity conn dep) (NESet.toAscList dependencies) pure Share.UploadEntitiesRequest {repoName, entities} - -- 2. Perform upload HTTP call - undefined "http call" request >>= \case - -- 3. If UploadEntitiesMissingDependencies, recur + _uploadEntities request >>= \case UploadEntitiesNeedDependencies (Share.NeedDependencies dependencies) -> upload conn repoName dependencies UploadEntitiesSuccess -> pure () +------------------------------------------------------------------------------------------------------------------------ +-- Pull + +-- If we just got #thing from the server, +-- If we already have the entity in the main database, we're done. +-- - This should't happen, why would the server have sent us this? +-- +-- Otherwise, if we already have the entity in temp_entity, ??? +-- +-- Otherwise (if we don't have it at all), +-- 1. Extract dependencies #dep1, #dep2, #dep3 from #thing blob. +-- 2. Filter down to just the dependencies we don't have. <-- "have" means in either real/temp storage. +-- 3. If that's {}, then store it in the main table. +-- 4. If that's (say) {#dep1, #dep2}, +-- 1. Add (#thing, #dep1), (#thing, #dep2) to temp_entity_missing_dependency +-- +-- Note: beef up insert_entity procedure to flush temp_entity table +-- 1. When inserting object #foo, +-- look up all dependents of #foo in +-- temp_entity_missing_dependency table (say #bar, #baz). +-- 2. Delete (#bar, #foo) and (#baz, #foo) from temp_entity_missing_dependency. +-- 3. Delete #foo from temp_entity (if it's there) +-- 4. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, +-- insert_entity them. +-- + +------------------------------------------------------------------------------------------------------------------------ +-- + +data UpdatePathResponse + = UpdatePathSuccess + | UpdatePathHashMismatch Share.HashMismatch + | UpdatePathMissingDependencies (Share.NeedDependencies Share.Hash) + +data UploadEntitiesResponse + = UploadEntitiesSuccess + | UploadEntitiesNeedDependencies (Share.NeedDependencies Share.Hash) + +data PullError + +-- Option 1: have push be itself in the Transaction monad, use unsafePerformIdempotentIO +-- fuction to do the interleaved IO calls (http, etc) +-- +-- push :: RepoPath -> ... -> Transaction (Either PushError ()) +-- push = do +-- unsafePerformIdempotentIO (updatePath ...) +-- +-- Option 2: have push "go around" the Transaction abstraction by beginning/commiting explicitly, +-- and immediately un-Transaction-newtyping the low-level calls like loadHashId +-- +-- push :: Connection -> RepoPath -> ... -> IO (Either PushError ()) +-- push conn = do +-- let foo transaction = unsafeUnTransaction transaction conn +-- +-- ... +-- result <- foo (loadHashId hashId) +-- ... +-- +-- newtype Transaction a = Transaction { unsafeUnTransaction :: Connection -> IO a } + +type Connection = () + +type Transaction a = () + +expectHash :: HashId -> Transaction Hash.Hash +expectHash = undefined + +pull :: Connection -> Share.RepoPath -> IO (Either PullError CausalHash) +pull _conn _repoPath = undefined + -- FIXME rename, etc resolveHashToEntity :: Connection -> Share.Hash -> IO (Share.Entity Text Share.Hash Share.Hash) resolveHashToEntity = undefined - --- let loop :: Set Share.Hash -> IO () --- loop dependencies0 = --- case Set.minView dependencies0 of --- Nothing -> pure () --- Just (dependency, dependencies) -> do --- undefined --- in loop (NESet.toSet dependencies1) From d6d2cca9189e36a976fb45fb3814680ad5e3bbf6 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 6 Apr 2022 14:35:06 -0400 Subject: [PATCH 062/529] add streaming queries --- .../U/Codebase/Sqlite/Queries.hs | 13 ++--- lib/unison-sqlite/README.md | 2 +- lib/unison-sqlite/src/Unison/Sqlite.hs | 8 ++- .../src/Unison/Sqlite/Connection.hs | 53 ++++++++++++------- .../src/Unison/Sqlite/Transaction.hs | 30 +++++++++++ 5 files changed, 75 insertions(+), 31 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 566ababc34..5b0f94f5b0 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -157,6 +157,7 @@ import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash import Unison.Prelude import Unison.Sqlite +import qualified Unison.Sqlite.Connection as Connection -- * main squeeze @@ -880,12 +881,12 @@ before chId1 chId2 = queryOneCol sql (chId2, chId1) -- | the `Connection` arguments come second to fit the shape of Exception.bracket + uncurry curry lca :: CausalHashId -> CausalHashId -> Connection -> Connection -> IO (Maybe CausalHashId) lca x y cx cy = - withStatement cx sql (Only x) \nextX -> - withStatement cy sql (Only y) \nextY -> do + Connection.queryStreamCol cx sql (Only x) \nextX -> + Connection.queryStreamCol cy sql (Only y) \nextY -> do let getNext = (,) <$> nextX <*> nextY loop2 seenX seenY = getNext >>= \case - (Just (Only px), Just (Only py)) -> + (Just px, Just py) -> let seenX' = Set.insert px seenX seenY' = Set.insert py seenY in if Set.member px seenY' @@ -895,14 +896,14 @@ lca x y cx cy = then pure (Just py) else loop2 seenX' seenY' (Nothing, Nothing) -> pure Nothing - (Just (Only px), Nothing) -> loop1 nextX seenY px - (Nothing, Just (Only py)) -> loop1 nextY seenX py + (Just px, Nothing) -> loop1 nextX seenY px + (Nothing, Just py) -> loop1 nextY seenX py loop1 getNext matches v = if Set.member v matches then pure (Just v) else getNext >>= \case - Just (Only v) -> loop1 getNext matches v + Just v -> loop1 getNext matches v Nothing -> pure Nothing loop2 (Set.singleton x) (Set.singleton y) where diff --git a/lib/unison-sqlite/README.md b/lib/unison-sqlite/README.md index 074201eba2..a08b865264 100644 --- a/lib/unison-sqlite/README.md +++ b/lib/unison-sqlite/README.md @@ -2,4 +2,4 @@ This package provides a interface to SQLite for Unison packages. -To print all queries and their responses to stderr, set the `UNISON_SQLITE_DEBUG` environment variable (to anything). +To print all queries and their responses to stderr, set `UNISON_DEBUG=sqlite` (or just `UNISON_DEBUG=`). diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index 5e802cfb74..16143b3d3d 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -37,6 +37,8 @@ module Unison.Sqlite -- $query-naming-convention -- *** With parameters + queryStreamRow, + queryStreamCol, queryListRow, queryListCol, queryMaybeRow, @@ -80,9 +82,6 @@ module Unison.Sqlite vacuum, vacuumInto, - -- ** Low-level - withStatement, - -- * Exceptions SomeSqliteException (..), isCantOpenException, @@ -117,7 +116,6 @@ import Unison.Sqlite.Connection vacuum, vacuumInto, withConnection, - withStatement, ) import Unison.Sqlite.DataVersion (DataVersion (..), getDataVersion) import Unison.Sqlite.Exception @@ -139,7 +137,7 @@ import Unison.Sqlite.Transaction -- Every function name begins with the string @__query__@. -- -- 1. /Row count/. The caller may expect /exactly one/, /zero or one/, or /zero or more/ rows, in which case the --- function name includes the string @__List__@, @__Maybe__@, or @__One__@, respectively. +-- function name includes the string @__One__@, @__Maybe__@, or (@__List__@ or @__Stream__@), respectively. -- Example: @query__List__Row@. -- -- 2. /Row width/. The caller may expect the returned rows may contain /exactly one/ or /more than one/ column, in diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index 8f1ab5b7e7..f412b9571c 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -17,6 +17,8 @@ module Unison.Sqlite.Connection -- ** With results -- *** With parameters + queryStreamRow, + queryStreamCol, queryListRow, queryListCol, queryMaybeRow, @@ -58,7 +60,6 @@ module Unison.Sqlite.Connection savepoint, rollback, release, - withStatement, -- * Exceptions ExpectedAtMostOneRowException (..), @@ -179,6 +180,36 @@ execute_ conn@(Connection _ _ conn0) s = do -- With results, with parameters, without checks +queryStreamRow :: (Sqlite.FromRow b, Sqlite.ToRow a) => Connection -> Sql -> a -> (IO (Maybe b) -> IO r) -> IO r +queryStreamRow conn@(Connection _ _ conn0) s params callback = + thing `catch` \(exception :: Sqlite.SQLError) -> + throwSqliteQueryException + SqliteQueryExceptionInfo + { connection = conn, + exception = SomeSqliteExceptionReason exception, + params = Just params, + sql = s + } + where + thing = + bracket (Sqlite.openStatement conn0 (coerce s)) Sqlite.closeStatement \statement -> do + Sqlite.bind statement params + callback (Sqlite.nextRow statement) + +queryStreamCol :: + forall a b r. + (Sqlite.FromField b, Sqlite.ToRow a) => + Connection -> + Sql -> + a -> + (IO (Maybe b) -> IO r) -> + IO r +queryStreamCol = + coerce + @(Connection -> Sql -> a -> (IO (Maybe (Sqlite.Only b)) -> IO r) -> IO r) + @(Connection -> Sql -> a -> (IO (Maybe b) -> IO r) -> IO r) + queryStreamRow + queryListRow :: (Sqlite.FromRow b, Sqlite.ToRow a) => Connection -> Sql -> a -> IO [b] queryListRow conn@(Connection _ _ conn0) s params = do result <- @@ -195,8 +226,8 @@ queryListRow conn@(Connection _ _ conn0) s params = do pure result queryListCol :: forall a b. (Sqlite.FromField b, Sqlite.ToRow a) => Connection -> Sql -> a -> IO [b] -queryListCol conn s params = - coerce @(IO [Sqlite.Only b]) @(IO [b]) (queryListRow conn s params) +queryListCol = + coerce @(Connection -> Sql -> a -> IO [Sqlite.Only b]) @(Connection -> Sql -> a -> IO [b]) queryListRow queryMaybeRow :: (Sqlite.ToRow a, Sqlite.FromRow b) => Connection -> Sql -> a -> IO (Maybe b) queryMaybeRow conn s params = @@ -469,22 +500,6 @@ release :: Connection -> Text -> IO () release conn name = execute_ conn (Sql ("RELEASE " <> name)) -withStatement :: (Sqlite.FromRow a, Sqlite.ToRow b) => Connection -> Sql -> b -> (IO (Maybe a) -> IO c) -> IO c -withStatement conn@(Connection _ _ conn0) s params callback = - thing `catch` \(exception :: Sqlite.SQLError) -> - throwSqliteQueryException - SqliteQueryExceptionInfo - { connection = conn, - exception = SomeSqliteExceptionReason exception, - params = Just params, - sql = s - } - where - thing = - bracket (Sqlite.openStatement conn0 (coerce s)) Sqlite.closeStatement \statement -> do - Sqlite.bind statement params - callback (Sqlite.nextRow statement) - ------------------------------------------------------------------------------------------------------------------------ -- Exceptions diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 2667e2afd2..aede5392df 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -19,6 +19,8 @@ module Unison.Sqlite.Transaction -- ** With results -- *** With parameters + queryStreamRow, + queryStreamCol, queryListRow, queryListCol, queryMaybeRow, @@ -72,6 +74,10 @@ newtype Transaction a -- Omit MonadThrow instance so we always throw SqliteException (via *Check) with lots of context deriving (Applicative, Functor, Monad) via (ReaderT Connection IO) +unTransaction :: Transaction a -> Connection -> IO a +unTransaction (Transaction action) = + action + -- | Run a transaction on the given connection. runTransaction :: MonadIO m => Connection -> Transaction a -> m a runTransaction conn (Transaction f) = liftIO do @@ -143,6 +149,30 @@ execute_ s = -- With results, with parameters, without checks +queryStreamRow :: + (Sqlite.FromRow a, Sqlite.ToRow b) => + Sql -> + b -> + (Transaction (Maybe a) -> Transaction r) -> + Transaction r +queryStreamRow s params callback = + Transaction \conn -> + Connection.queryStreamRow conn s params \next -> + unTransaction (callback (idempotentIO next)) conn + +queryStreamCol :: + forall a b r. + (Sqlite.FromField a, Sqlite.ToRow b) => + Sql -> + b -> + (Transaction (Maybe a) -> Transaction r) -> + Transaction r +queryStreamCol = + coerce + @(Sql -> b -> (Transaction (Maybe (Sqlite.Only a)) -> Transaction r) -> Transaction r) + @(Sql -> b -> (Transaction (Maybe a) -> Transaction r) -> Transaction r) + queryStreamRow + queryListRow :: (Sqlite.FromRow a, Sqlite.ToRow b) => Sql -> b -> Transaction [a] queryListRow s params = Transaction \conn -> Connection.queryListRow conn s params From 4284f12897322c4ff33100a47190ce4b851a0feb Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 6 Apr 2022 16:12:07 -0500 Subject: [PATCH 063/529] fix up transcripts --- unison-src/transcripts-using-base/_base.md | 2 +- .../binary-encoding-nats.md | 27 ++++++++------- unison-src/transcripts-using-base/codeops.md | 3 +- unison-src/transcripts-using-base/hashing.md | 19 ++++++----- .../transcripts-using-base/hashing.output.md | 34 ++++++++++++++----- .../namespace-dependencies.md | 3 +- unison-src/transcripts/addupdatemessages.md | 10 +++--- unison-src/transcripts/delete.md | 8 ++--- unison-src/transcripts/diff-namespace.md | 4 +-- unison-src/transcripts/find-by-type.md | 10 +++--- unison-src/transcripts/fix2254.md | 8 +++++ unison-src/transcripts/merges.md | 3 +- unison-src/transcripts/merges.output.md | 12 +++---- unison-src/transcripts/name-selection.md | 4 +++ unison-src/transcripts/propagate.md | 4 +++ .../transcripts/sum-type-update-conflicts.md | 3 +- unison-src/transcripts/todo.md | 3 ++ unison-src/transcripts/todo.output.md | 2 ++ unison-src/transcripts/update-on-conflict.md | 3 +- 19 files changed, 102 insertions(+), 60 deletions(-) diff --git a/unison-src/transcripts-using-base/_base.md b/unison-src/transcripts-using-base/_base.md index bfbb0aa74f..a1eb67be2a 100644 --- a/unison-src/transcripts-using-base/_base.md +++ b/unison-src/transcripts-using-base/_base.md @@ -26,7 +26,7 @@ test> hex.tests.ex1 = checks let ``` ```ucm:hide -.scratch> test +.> test ``` Lets do some basic testing of our test harness to make sure its diff --git a/unison-src/transcripts-using-base/binary-encoding-nats.md b/unison-src/transcripts-using-base/binary-encoding-nats.md index c6daaa824d..bffda34dc5 100644 --- a/unison-src/transcripts-using-base/binary-encoding-nats.md +++ b/unison-src/transcripts-using-base/binary-encoding-nats.md @@ -1,10 +1,11 @@ -> + ```ucm:hide .> builtins.merge .> builtins.mergeio .> cd builtin .> load unison-src/transcripts-using-base/base.u .> add +.> find ``` ```unison @@ -22,19 +23,19 @@ testRoundTrip n = cases EncDec label enc dec -> encoded = enc n match dec encoded with - Some (n', remain) -> - if n == n' then + Some (n', remain) -> + if n == n' then emit (Ok ("successfully decoded " ++ (toText n) ++ " using " ++ label)) else emit (Fail ("decoded " ++ (toText n') ++ " instead of " ++ (toText n) ++ " using " ++ label)) - if (size remain) > 0 then + if (size remain) > 0 then emit (Fail ("unconsumed input using " ++ label)) else emit (Ok ("consumed all input")) None -> emit (Fail ("failed to decode " ++ (toText n) ++ " using " ++ label)) - + testNat : Nat -> '{IO, Stream Result} () -testNat n _ = +testNat n _ = if n >= (shiftLeft 1 32) then testRoundTrip n BE64 testRoundTrip n LE64 @@ -52,13 +53,13 @@ testNat n _ = testRoundTrip n LE16 -testABunchOfNats _ = - (runTest (testNat 0xFFFFFFFF)) ++ - (runTest (testNat 0x41000000)) ++ - (runTest (testNat 0x00410000)) ++ - (runTest (testNat 0x00004100)) ++ - (runTest (testNat 0x86753099)) ++ - (runTest (testNat 0x00000041)) ++ +testABunchOfNats _ = + (runTest (testNat 0xFFFFFFFF)) ++ + (runTest (testNat 0x41000000)) ++ + (runTest (testNat 0x00410000)) ++ + (runTest (testNat 0x00004100)) ++ + (runTest (testNat 0x86753099)) ++ + (runTest (testNat 0x00000041)) ++ (runTest (testNat 0)) ``` diff --git a/unison-src/transcripts-using-base/codeops.md b/unison-src/transcripts-using-base/codeops.md index 4a95e1e5a6..a7e7d524f8 100644 --- a/unison-src/transcripts-using-base/codeops.md +++ b/unison-src/transcripts-using-base/codeops.md @@ -3,7 +3,6 @@ Test for code serialization operations. ```ucm:hide .> builtins.merge -.> cd builtin ``` Define a function, serialize it, then deserialize it back to an actual @@ -175,7 +174,7 @@ badLoad _ = match Value.deserialize payload with Left t -> Fail "deserialize exception" Right a -> match Value.load a with - Left terms -> + Left terms -> bs = Value.serialize (Value.value terms) s = size bs Ok ("serialized" ++ toText s) diff --git a/unison-src/transcripts-using-base/hashing.md b/unison-src/transcripts-using-base/hashing.md index 43b5f8a2fb..46ef915886 100644 --- a/unison-src/transcripts-using-base/hashing.md +++ b/unison-src/transcripts-using-base/hashing.md @@ -8,7 +8,7 @@ Unison has cryptographic builtins for hashing and computing [HMACs](https://en.wikipedia.org/wiki/HMAC) (hash-based message authentication codes). This transcript shows their usage and has some test cases. ```ucm -.builtin> ls Bytes +.> ls builtin.Bytes ``` Notice the `fromBase16` and `toBase16` functions. Here's some convenience functions for converting `Bytes` to and from base-16 `Text`. @@ -49,11 +49,12 @@ And here's the full API: ```ucm .builtin.crypto> find +.> cd . ``` Note that the universal versions of `hash` and `hmac` are currently unimplemented and will bomb at runtime: -``` +```unison > crypto.hash Sha3_256 (fromHex "3849238492") ``` @@ -166,11 +167,11 @@ test> blake2b_512.tests.ex3 = ``` ```ucm:hide -.scratch> add +.> add ``` ```ucm -.scratch> test +.> test ``` ## HMAC tests @@ -181,9 +182,9 @@ These test vectors are taken from [RFC 4231](https://tools.ietf.org/html/rfc4231 ex' alg secret msg expected = checks [hmacBytes alg (fromHex secret) (ascii msg) == fromHex expected] test> hmac_sha2_256.tests.ex1 = - ex' Sha2_256 - "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b" - "Hi There" + ex' Sha2_256 + "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b" + "Hi There" "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" test> hmac_sha2_512.tests.ex1 = ex' Sha2_512 @@ -205,10 +206,10 @@ test> hmac_sha2_512.tests.ex2 = ``` ```ucm:hide -.scratch> add +.> add ``` ```ucm -.scratch> test +.> test ``` diff --git a/unison-src/transcripts-using-base/hashing.output.md b/unison-src/transcripts-using-base/hashing.output.md index 368227031b..7706681c5a 100644 --- a/unison-src/transcripts-using-base/hashing.output.md +++ b/unison-src/transcripts-using-base/hashing.output.md @@ -3,7 +3,7 @@ Unison has cryptographic builtins for hashing and computing [HMACs](https://en.wikipedia.org/wiki/HMAC) (hash-based message authentication codes). This transcript shows their usage and has some test cases. ```ucm -.builtin> ls Bytes +.> ls builtin.Bytes 1. ++ (Bytes -> Bytes -> Bytes) 2. at (Nat -> Bytes -> Optional Nat) @@ -87,6 +87,7 @@ ex5 = crypto.hmac Sha2_256 mysecret f |> hex ex4 : Text ex5 : Text f : x -> x + (also named id) mysecret : Bytes Now evaluating any watch expressions (lines starting with @@ -132,14 +133,29 @@ And here's the full API: 12. hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes +.> cd . + ``` Note that the universal versions of `hash` and `hmac` are currently unimplemented and will bomb at runtime: -``` +```unison > crypto.hash Sha3_256 (fromHex "3849238492") - ``` +```ucm + + โœ… + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > crypto.hash Sha3_256 (fromHex "3849238492") + โงฉ + 0xse34b43a163bed5ed9e6961b667be73232441d7c9608d8c06aa49df705a19400c + +``` ## Hashing tests Here are some test vectors (taken from [here](https://www.di-mgt.com.au/sha_testvectors.html) and [here](https://en.wikipedia.org/wiki/BLAKE_(hash_function))) for the various hashing algorithms: @@ -249,7 +265,7 @@ test> blake2b_512.tests.ex3 = ``` ```ucm -.scratch> test +.> test Cached test results (`help testcache` to learn more) @@ -288,9 +304,9 @@ These test vectors are taken from [RFC 4231](https://tools.ietf.org/html/rfc4231 ex' alg secret msg expected = checks [hmacBytes alg (fromHex secret) (ascii msg) == fromHex expected] test> hmac_sha2_256.tests.ex1 = - ex' Sha2_256 - "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b" - "Hi There" + ex' Sha2_256 + "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b" + "Hi There" "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" test> hmac_sha2_512.tests.ex1 = ex' Sha2_512 @@ -332,7 +348,7 @@ test> hmac_sha2_512.tests.ex2 = Now evaluating any watch expressions (lines starting with `>`)... Ctrl+C cancels. - 4 | ex' Sha2_256 + 4 | ex' Sha2_256 โœ… Passed Passed @@ -350,7 +366,7 @@ test> hmac_sha2_512.tests.ex2 = ``` ```ucm -.scratch> test +.> test Cached test results (`help testcache` to learn more) diff --git a/unison-src/transcripts-using-base/namespace-dependencies.md b/unison-src/transcripts-using-base/namespace-dependencies.md index 48bb2d626f..57f7e4e28c 100644 --- a/unison-src/transcripts-using-base/namespace-dependencies.md +++ b/unison-src/transcripts-using-base/namespace-dependencies.md @@ -10,6 +10,7 @@ myMetadata = "just some text" ```ucm:hide .metadata> add +.> cd . ``` ```unison:hide @@ -21,6 +22,6 @@ hasMetadata = 3 ```ucm .dependencies> add -.dependencies> link .metadata.myMetadata hasMetadata +.dependencies> link .metadata.myMetadata hasMetadata .dependencies> namespace.dependencies ``` diff --git a/unison-src/transcripts/addupdatemessages.md b/unison-src/transcripts/addupdatemessages.md index 671d923ac5..c644d921a0 100644 --- a/unison-src/transcripts/addupdatemessages.md +++ b/unison-src/transcripts/addupdatemessages.md @@ -17,7 +17,7 @@ structural type Y = Two Nat Nat Expected: `x` and `y`, `X`, and `Y` exist as above. UCM tells you this. ```ucm -.scratch> add +.> add ``` Let's add an alias for `1` and `One`: @@ -32,7 +32,7 @@ Expected: `z` is now `1`. UCM tells you that this definition is also called `x`. Also, `Z` is an alias for `X`. ```ucm -.scratch> add +.> add ``` Let's update something that has an alias (to a value that doesn't have a name already): @@ -45,7 +45,7 @@ structural type X = Three Nat Nat Nat Expected: `x` is now `3` and `X` has constructor `Three`. UCM tells you the old definitions were also called `z` and `Z` and these names have also been updated. ```ucm -.scratch> update +.> update ``` Update it to something that already exists with a different name: @@ -55,9 +55,9 @@ x = 2 structural type X = Two Nat Nat ``` -Expected: `x` is now `2` and `X` is `Two`. UCM says the old definition was also named `z/Z`, and was also updated. And it says the new definition is also named `y/Y`. +Expected: `x` is now `2` and `X` is `Two`. UCM says the old definition was also named `z/Z`, and was also updated. And it says the new definition is also named `y/Y`. ```ucm -.scratch> update +.> update ``` diff --git a/unison-src/transcripts/delete.md b/unison-src/transcripts/delete.md index b4a8b01ecf..3f6315dd89 100644 --- a/unison-src/transcripts/delete.md +++ b/unison-src/transcripts/delete.md @@ -18,7 +18,7 @@ unambiguous type. ```unison:hide foo = 1 -structural type Foo = Foo Nat +structural type Foo = Foo () ``` ```ucm @@ -60,7 +60,7 @@ A delete should remove both versions of the term. Let's repeat all that on a type, for completeness. ```unison:hide -structural type Foo = Foo Nat +structural type Foo = Foo () ``` ```ucm @@ -68,7 +68,7 @@ structural type Foo = Foo Nat ``` ```unison:hide -structural type Foo = Foo Boolean +structural type Foo = Foo ``` ```ucm @@ -88,7 +88,7 @@ Finally, let's try to delete a term and a type with the same name. ```unison:hide foo = 1 -structural type foo = Foo Nat +structural type foo = Foo () ``` ```ucm diff --git a/unison-src/transcripts/diff-namespace.md b/unison-src/transcripts/diff-namespace.md index ab91aeeb05..e7dfe3b938 100644 --- a/unison-src/transcripts/diff-namespace.md +++ b/unison-src/transcripts/diff-namespace.md @@ -40,8 +40,8 @@ bdependent = b c = 3 helloWorld = "Hello, world!" -structural type A a = A Nat -structural ability X a1 a2 where x : Nat +structural type A a = A () +structural ability X a1 a2 where x : () ``` ```ucm diff --git a/unison-src/transcripts/find-by-type.md b/unison-src/transcripts/find-by-type.md index efc3e2a6c1..009ad845e5 100644 --- a/unison-src/transcripts/find-by-type.md +++ b/unison-src/transcripts/find-by-type.md @@ -17,11 +17,11 @@ baz = cases ``` ```ucm -.example> add -.example> find : Text -> A -.example> find : A -> Text -.example> find : A +.> add +.> find : Text -> A +.> find : A -> Text +.> find : A ``` ```ucm:error -.example> find : Text +.> find : Text ``` diff --git a/unison-src/transcripts/fix2254.md b/unison-src/transcripts/fix2254.md index 95553d65b1..6074100e56 100644 --- a/unison-src/transcripts/fix2254.md +++ b/unison-src/transcripts/fix2254.md @@ -61,6 +61,10 @@ Let's do the update now, and verify that the definitions all look good and there .a2> todo ``` +```ucm:hide +.a2> builtins.merge +``` + ## Record updates Here's a test of updating a record: @@ -75,6 +79,10 @@ combine r = uno r + dos r .a3> add ``` +```ucm:hide +.a3> builtins.merge +``` + ```unison structural type Rec = { uno : Nat, dos : Nat, tres : Text } ``` diff --git a/unison-src/transcripts/merges.md b/unison-src/transcripts/merges.md index ca8478c369..225e7c4967 100644 --- a/unison-src/transcripts/merges.md +++ b/unison-src/transcripts/merges.md @@ -1,7 +1,8 @@ # Forking and merging namespaces in `ucm` ```ucm:hide -.> builtins.merge +.master> builtins.merge +.> cd . ``` The Unison namespace is a versioned tree of names that map to Unison definitions. You can change this namespace and fork and merge subtrees of it. Let's start by introducing a few definitions into a new namespace, `foo`: diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 55c929e70e..fe6045dd7e 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -125,13 +125,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #j1lsljjhdd + โŠ™ 1. #b9gio3o5vj - Deletes: feature1.y - โŠ™ 2. #r969k3jgve + โŠ™ 2. #qfnfjbucvb + Adds / updates: @@ -142,26 +142,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - โŠ™ 3. #0gi7v0d7tu + โŠ™ 3. #gf42o5nt01 + Adds / updates: feature1.y - โŠ™ 4. #2nqtlij18m + โŠ™ 4. #oualr1ftn5 > Moves: Original name New name x master.x - โŠ™ 5. #heict59ifr + โŠ™ 5. #kg9enostoi + Adds / updates: x - โ–ก 6. #pnv2a0gkq2 (start of history) + โ–ก 6. #lg8ma1pi6b (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/name-selection.md b/unison-src/transcripts/name-selection.md index 933a6b019b..e91cc06814 100644 --- a/unison-src/transcripts/name-selection.md +++ b/unison-src/transcripts/name-selection.md @@ -20,6 +20,7 @@ Will add `a` and `b` to the codebase and give `b` a longer (in terms of segment .a> add .a> alias.term b aaa.but.more.segments .a> view a +.> cd . ``` Next let's introduce a conflicting symbol and show that its hash qualified name isn't used when it has an unconflicted name: @@ -34,6 +35,9 @@ c = 1 d = c + 10 ``` +```ucm:hide +.a2> builtins.merge +``` ```ucm .a2> add .a2> alias.term c aaaa.tooManySegments diff --git a/unison-src/transcripts/propagate.md b/unison-src/transcripts/propagate.md index cb2a7cc314..d2f3b17511 100644 --- a/unison-src/transcripts/propagate.md +++ b/unison-src/transcripts/propagate.md @@ -39,6 +39,7 @@ and update the codebase to use the new type `Foo`... ```ucm .subpath> view fooToInt +.> cd . ``` ### Preserving user type variables @@ -60,6 +61,7 @@ Add that to the codebase: ```ucm .subpath.preserve> add +.> cd . ``` Let's now edit the dependency: @@ -75,6 +77,7 @@ Update... ```ucm .subpath.preserve> update +.> cd . ``` Now the type of `someTerm` should be `Optional x -> Optional x` and the @@ -110,6 +113,7 @@ We'll make two copies of this namespace. ```ucm .subpath.one> add .subpath> fork one two +.> cd . ``` Now let's edit one of the terms... diff --git a/unison-src/transcripts/sum-type-update-conflicts.md b/unison-src/transcripts/sum-type-update-conflicts.md index 6c9adb1155..b56c3e6fea 100644 --- a/unison-src/transcripts/sum-type-update-conflicts.md +++ b/unison-src/transcripts/sum-type-update-conflicts.md @@ -3,7 +3,7 @@ https://github.com/unisonweb/unison/issues/2786 ```ucm:hide -.builtins> builtins.mergeio +.> builtins.mergeio ``` First we add a sum-type to the codebase. @@ -14,6 +14,7 @@ structural type X = x ```ucm .ns> add +.> cd . ``` Now we update the type, changing the name of the constructors, _but_, we simultaneously diff --git a/unison-src/transcripts/todo.md b/unison-src/transcripts/todo.md index 99d231db64..98a6e87924 100644 --- a/unison-src/transcripts/todo.md +++ b/unison-src/transcripts/todo.md @@ -17,6 +17,7 @@ useMyType = match MyType 1 with ```ucm:hide .simple> add +.> cd . ``` Perform a type-changing update so dependents are added to our update frontier. @@ -30,6 +31,7 @@ structural type MyType = MyType Text ```ucm:error .simple> update .simple> todo +.> cd . ``` ## A merge with conflicting updates. @@ -55,6 +57,7 @@ structural type MyType = MyType Nat ```ucm:hide .mergeA> update +.> cd . ``` ```unison:hide diff --git a/unison-src/transcripts/todo.output.md b/unison-src/transcripts/todo.output.md index ff34e6f81f..165f9263d1 100644 --- a/unison-src/transcripts/todo.output.md +++ b/unison-src/transcripts/todo.output.md @@ -44,6 +44,8 @@ structural type MyType = MyType Text +.> cd . + ``` ## A merge with conflicting updates. diff --git a/unison-src/transcripts/update-on-conflict.md b/unison-src/transcripts/update-on-conflict.md index 30e1afe84d..3b9c750711 100644 --- a/unison-src/transcripts/update-on-conflict.md +++ b/unison-src/transcripts/update-on-conflict.md @@ -14,9 +14,10 @@ Cause a conflict: .> add .merged> merge .a .merged> merge .b +.> cd . ``` -Ideally we could just define the canonical `x` that we want, and update +Ideally we could just define the canonical `x` that we want, and update to accept it, but we can't: ```unison From bf71fd477af81a96b4fe09d3c5fd237fd83ae26c Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 6 Apr 2022 16:20:44 -0500 Subject: [PATCH 064/529] transcript refresh --- .../binary-encoding-nats.output.md | 26 +- .../transcripts-using-base/codeops.output.md | 2 +- .../namespace-dependencies.output.md | 26 +- .../transcripts/addupdatemessages.output.md | 12 +- unison-src/transcripts/delete.output.md | 36 +- ...ependents-dependencies-debugfile.output.md | 7 +- .../transcripts/diff-namespace.output.md | 4 +- .../transcripts/empty-namespaces.output.md | 6 + unison-src/transcripts/find-by-type.output.md | 12 +- .../transcripts/name-selection.output.md | 1004 ++++++++++++++++- unison-src/transcripts/propagate.output.md | 11 +- .../sum-type-update-conflicts.output.md | 8 +- .../transcripts/update-on-conflict.output.md | 11 +- 13 files changed, 1074 insertions(+), 91 deletions(-) diff --git a/unison-src/transcripts-using-base/binary-encoding-nats.output.md b/unison-src/transcripts-using-base/binary-encoding-nats.output.md index caf809fdf6..fe288b2fba 100644 --- a/unison-src/transcripts-using-base/binary-encoding-nats.output.md +++ b/unison-src/transcripts-using-base/binary-encoding-nats.output.md @@ -1,4 +1,4 @@ -> + ```unison unique type EncDec = EncDec Text (Nat -> Bytes) (Bytes -> Optional (Nat, Bytes)) @@ -14,19 +14,19 @@ testRoundTrip n = cases EncDec label enc dec -> encoded = enc n match dec encoded with - Some (n', remain) -> - if n == n' then + Some (n', remain) -> + if n == n' then emit (Ok ("successfully decoded " ++ (toText n) ++ " using " ++ label)) else emit (Fail ("decoded " ++ (toText n') ++ " instead of " ++ (toText n) ++ " using " ++ label)) - if (size remain) > 0 then + if (size remain) > 0 then emit (Fail ("unconsumed input using " ++ label)) else emit (Ok ("consumed all input")) None -> emit (Fail ("failed to decode " ++ (toText n) ++ " using " ++ label)) - + testNat : Nat -> '{IO, Stream Result} () -testNat n _ = +testNat n _ = if n >= (shiftLeft 1 32) then testRoundTrip n BE64 testRoundTrip n LE64 @@ -44,13 +44,13 @@ testNat n _ = testRoundTrip n LE16 -testABunchOfNats _ = - (runTest (testNat 0xFFFFFFFF)) ++ - (runTest (testNat 0x41000000)) ++ - (runTest (testNat 0x00410000)) ++ - (runTest (testNat 0x00004100)) ++ - (runTest (testNat 0x86753099)) ++ - (runTest (testNat 0x00000041)) ++ +testABunchOfNats _ = + (runTest (testNat 0xFFFFFFFF)) ++ + (runTest (testNat 0x41000000)) ++ + (runTest (testNat 0x00410000)) ++ + (runTest (testNat 0x00004100)) ++ + (runTest (testNat 0x86753099)) ++ + (runTest (testNat 0x00000041)) ++ (runTest (testNat 0)) ``` diff --git a/unison-src/transcripts-using-base/codeops.output.md b/unison-src/transcripts-using-base/codeops.output.md index fcd9467b60..8f96a96682 100644 --- a/unison-src/transcripts-using-base/codeops.output.md +++ b/unison-src/transcripts-using-base/codeops.output.md @@ -231,7 +231,7 @@ badLoad _ = match Value.deserialize payload with Left t -> Fail "deserialize exception" Right a -> match Value.load a with - Left terms -> + Left terms -> bs = Value.serialize (Value.value terms) s = size bs Ok ("serialized" ++ toText s) diff --git a/unison-src/transcripts-using-base/namespace-dependencies.output.md b/unison-src/transcripts-using-base/namespace-dependencies.output.md index 1d5e1e1806..3ed60630f7 100644 --- a/unison-src/transcripts-using-base/namespace-dependencies.output.md +++ b/unison-src/transcripts-using-base/namespace-dependencies.output.md @@ -23,7 +23,7 @@ hasMetadata = 3 dependsOnNat : Nat hasMetadata : Nat -.dependencies> link .metadata.myMetadata hasMetadata +.dependencies> link .metadata.myMetadata hasMetadata Updates: @@ -32,17 +32,17 @@ hasMetadata = 3 .dependencies> namespace.dependencies - External dependency Dependents in .dependencies - .builtin.Int dependsOnInt - - .builtin.Nat dependsOnIntAndNat - dependsOnNat - hasMetadata - - .builtin.Text hasMetadata - - .builtin.Nat.drop dependsOnIntAndNat - - .metadata.myMetadata hasMetadata + External dependency Dependents in .dependencies + ##Int dependsOnInt + + ##Nat dependsOnIntAndNat + dependsOnNat + hasMetadata + + ##Text hasMetadata + + ##Nat.drop dependsOnIntAndNat + + #23g06bfjvi hasMetadata ``` diff --git a/unison-src/transcripts/addupdatemessages.output.md b/unison-src/transcripts/addupdatemessages.output.md index ce3488b205..5e59153295 100644 --- a/unison-src/transcripts/addupdatemessages.output.md +++ b/unison-src/transcripts/addupdatemessages.output.md @@ -27,9 +27,7 @@ structural type Y = Two Nat Nat Expected: `x` and `y`, `X`, and `Y` exist as above. UCM tells you this. ```ucm - โ˜๏ธ The namespace .scratch is empty. - -.scratch> add +.> add โŸ I've added these definitions: @@ -65,7 +63,7 @@ Expected: `z` is now `1`. UCM tells you that this definition is also called `x`. Also, `Z` is an alias for `X`. ```ucm -.scratch> add +.> add โŸ I've added these definitions: @@ -102,7 +100,7 @@ structural type X = Three Nat Nat Nat Expected: `x` is now `3` and `X` has constructor `Three`. UCM tells you the old definitions were also called `z` and `Z` and these names have also been updated. ```ucm -.scratch> update +.> update โŸ I've updated these names to your new definition: @@ -140,10 +138,10 @@ structural type X = Two Nat Nat (The new definition is already named y as well.) ``` -Expected: `x` is now `2` and `X` is `Two`. UCM says the old definition was also named `z/Z`, and was also updated. And it says the new definition is also named `y/Y`. +Expected: `x` is now `2` and `X` is `Two`. UCM says the old definition was also named `z/Z`, and was also updated. And it says the new definition is also named `y/Y`. ```ucm -.scratch> update +.> update โŸ I've updated these names to your new definition: diff --git a/unison-src/transcripts/delete.output.md b/unison-src/transcripts/delete.output.md index bdd6a5b225..f577db35ca 100644 --- a/unison-src/transcripts/delete.output.md +++ b/unison-src/transcripts/delete.output.md @@ -18,7 +18,7 @@ unambiguous type. ```unison foo = 1 -structural type Foo = Foo Nat +structural type Foo = Foo () ``` ```ucm @@ -49,7 +49,7 @@ structural type Foo = Foo Nat Removed definitions: - 1. Foo.Foo : Nat -> #68k40ra7l7 + 1. Foo.Foo : '#089vmor9c5 Tip: You can use `undo` or `reflog` to undo this change. @@ -128,7 +128,7 @@ A delete should remove both versions of the term. Let's repeat all that on a type, for completeness. ```unison -structural type Foo = Foo Nat +structural type Foo = Foo () ``` ```ucm @@ -140,7 +140,7 @@ structural type Foo = Foo Nat ``` ```unison -structural type Foo = Foo Boolean +structural type Foo = Foo ``` ```ucm @@ -157,18 +157,18 @@ structural type Foo = Foo Boolean New name conflicts: - 1. structural type Foo#68k40ra7l7 + 1. structural type Foo#089vmor9c5 โ†“ - 2. โ”Œ structural type Foo#68k40ra7l7 + 2. โ”Œ structural type Foo#00nv2kob8f - 3. โ”” structural type Foo#cbdjc64ffs + 3. โ”” structural type Foo#089vmor9c5 - 4. Foo.Foo#68k40ra7l7#0 : Nat -> Foo#68k40ra7l7 + 4. Foo.Foo#089vmor9c5#0 : 'Foo#089vmor9c5 โ†“ - 5. โ”Œ Foo.Foo#68k40ra7l7#0 : Nat -> Foo#68k40ra7l7 - 6. โ”” Foo.Foo#cbdjc64ffs#0 : Boolean -> Foo#cbdjc64ffs + 5. โ”Œ Foo.Foo#00nv2kob8f#0 : () + 6. โ”” Foo.Foo#089vmor9c5#0 : 'Foo#089vmor9c5 Tip: You can use `todo` to see if this generated any work to do in this namespace and `test` to run the tests. Or you @@ -181,13 +181,14 @@ structural type Foo = Foo Boolean Removed definitions: - 1. structural type a.Foo#68k40ra7l7 + 1. structural type a.Foo#089vmor9c5 Name changes: Original Changes - 2. b.Foo โ” 3. a.Foo#cbdjc64ffs (removed) - 4. a.Foo#cbdjc64ffs โ”˜ + 2. b.Foo โ” 3. a.Foo#00nv2kob8f (removed) + 4. builtin.Unit โ”‚ + 5. a.Foo#00nv2kob8f โ”˜ Tip: You can use `undo` or `reflog` to undo this change. @@ -197,13 +198,14 @@ structural type Foo = Foo Boolean Removed definitions: - 1. a.Foo.Foo#68k40ra7l7#0 : Nat -> #68k40ra7l7 + 1. a.Foo.Foo#089vmor9c5#0 : '#089vmor9c5 Name changes: Original Changes - 2. b.Foo.Foo โ” 3. a.Foo.Foo#cbdjc64ffs#0 (removed) - 4. a.Foo.Foo#cbdjc64ffs#0 โ”˜ + 2. b.Foo.Foo โ” 3. a.Foo.Foo#00nv2kob8f#0 (removed) + 4. builtin.Unit.Unit โ”‚ + 5. a.Foo.Foo#00nv2kob8f#0 โ”˜ Tip: You can use `undo` or `reflog` to undo this change. @@ -212,7 +214,7 @@ Finally, let's try to delete a term and a type with the same name. ```unison foo = 1 -structural type foo = Foo Nat +structural type foo = Foo () ``` ```ucm diff --git a/unison-src/transcripts/dependents-dependencies-debugfile.output.md b/unison-src/transcripts/dependents-dependencies-debugfile.output.md index c77c384ec1..46e889f54e 100644 --- a/unison-src/transcripts/dependents-dependencies-debugfile.output.md +++ b/unison-src/transcripts/dependents-dependencies-debugfile.output.md @@ -88,8 +88,11 @@ But wait, there's more. I can check the dependencies and dependents of a defini Dependents of #ukd7tu6kds: - Reference Name - 1. #nkgohbke6n inside.r + Name Reference + 1. inside.r #nkgohbke6n + + Tip: Try `view 1` to see the source of any numbered item in + the above list. ``` We don't have an index for dependents of constructors, but iirc if you ask for that, it will show you dependents of the structural type that provided the constructor. diff --git a/unison-src/transcripts/diff-namespace.output.md b/unison-src/transcripts/diff-namespace.output.md index dd1caa555b..ad0f6905db 100644 --- a/unison-src/transcripts/diff-namespace.output.md +++ b/unison-src/transcripts/diff-namespace.output.md @@ -105,8 +105,8 @@ bdependent = b c = 3 helloWorld = "Hello, world!" -structural type A a = A Nat -structural ability X a1 a2 where x : Nat +structural type A a = A () +structural ability X a1 a2 where x : () ``` ```ucm diff --git a/unison-src/transcripts/empty-namespaces.output.md b/unison-src/transcripts/empty-namespaces.output.md index 4013086eb8..82da1fd157 100644 --- a/unison-src/transcripts/empty-namespaces.output.md +++ b/unison-src/transcripts/empty-namespaces.output.md @@ -18,6 +18,9 @@ The deleted namespace shouldn't appear in `ls` output. No results. Check your spelling, or try using tab completion to supply command arguments. + + `find.global` can be used to search outside the current + namespace. ``` ```ucm @@ -27,6 +30,9 @@ The deleted namespace shouldn't appear in `ls` output. No results. Check your spelling, or try using tab completion to supply command arguments. + + `find.global` can be used to search outside the current + namespace. ``` ## history diff --git a/unison-src/transcripts/find-by-type.output.md b/unison-src/transcripts/find-by-type.output.md index b473449bcf..916857b524 100644 --- a/unison-src/transcripts/find-by-type.output.md +++ b/unison-src/transcripts/find-by-type.output.md @@ -13,9 +13,7 @@ baz = cases ``` ```ucm - โ˜๏ธ The namespace .example is empty. - -.example> add +.> add โŸ I've added these definitions: @@ -24,25 +22,25 @@ baz = cases baz : A -> Text foo : A -.example> find : Text -> A +.> find : Text -> A 1. bar : Text -> A 2. A.A : Text -> A -.example> find : A -> Text +.> find : A -> Text 1. baz : A -> Text -.example> find : A +.> find : A 1. foo : A ``` ```ucm -.example> find : Text +.> find : Text โ˜๏ธ diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md index 297a17760f..281bbcf2e2 100644 --- a/unison-src/transcripts/name-selection.output.md +++ b/unison-src/transcripts/name-selection.output.md @@ -30,6 +30,8 @@ Will add `a` and `b` to the codebase and give `b` a longer (in terms of segment a : Nat a = b + 1 +.> cd . + ``` Next let's introduce a conflicting symbol and show that its hash qualified name isn't used when it has an unconflicted name: @@ -45,8 +47,6 @@ d = c + 10 ``` ```ucm - โ˜๏ธ The namespace .a2 is empty. - .a2> add โŸ I've added these definitions: @@ -80,20 +80,984 @@ d = c + 10 New name conflicts: - 1. c#dcgdua2lj6 : Nat - โ†“ - 2. โ”Œ c#dcgdua2lj6 : Nat - 3. โ”” c#gjmq673r1v : Nat + 1. c#dcgdua2lj6 : Nat + โ†“ + 2. โ”Œ c#dcgdua2lj6 : Nat + 3. โ”” c#gjmq673r1v : Nat - 4. d#9ivhgvhthc : Nat - โ†“ - 5. โ”Œ d#9ivhgvhthc : Nat - 6. โ”” d#ve16e6jmf6 : Nat + 4. d#9ivhgvhthc : Nat + โ†“ + 5. โ”Œ d#9ivhgvhthc : Nat + 6. โ”” d#ve16e6jmf6 : Nat Added definitions: - 7. โ”Œ c#gjmq673r1v : Nat - 8. โ”” aaaa.tooManySegments : Nat + 7. builtin type builtin.Any + 8. builtin type builtin.Boolean + 9. unique type builtin.io2.BufferMode + 10. builtin type builtin.Bytes + 11. builtin type builtin.Char + 12. builtin type builtin.io2.Tls.Cipher + 13. builtin type builtin.io2.Tls.ClientConfig + 14. builtin type builtin.Code + 15. unique type builtin.Doc + 16. structural type builtin.Either a b + 17. structural ability builtin.Exception + 18. unique type builtin.io2.Failure + 19. unique type builtin.io2.FileMode + 20. builtin type builtin.Float + 21. builtin type builtin.io2.Handle + 22. builtin type builtin.crypto.HashAlgorithm + 23. builtin ability builtin.io2.IO + 24. unique type builtin.io2.IOError + 25. unique type builtin.io2.IOFailure + 26. builtin type builtin.Int + 27. unique type builtin.IsPropagated + 28. unique type builtin.IsTest + 29. unique type builtin.Link + 30. builtin type builtin.List + 31. builtin type builtin.io2.MVar + 32. builtin type builtin.Nat + 33. structural type builtin.Optional a + 34. builtin type builtin.io2.Tls.PrivateKey + 35. builtin type builtin.Ref + 36. builtin type builtin.Request + 37. unique type builtin.Test.Result + 38. builtin ability builtin.io2.STM + 39. builtin ability builtin.Scope + 40. unique type builtin.io2.SeekMode + 41. structural type builtin.SeqView a b + 42. builtin type builtin.io2.Tls.ServerConfig + 43. builtin type builtin.io2.Tls.SignedCert + 44. builtin type builtin.io2.Socket + 45. unique type builtin.io2.StdHandle + 46. builtin type builtin.io2.TVar + 47. builtin type builtin.Link.Term + 48. builtin type builtin.Text + 49. builtin type builtin.io2.ThreadId + 50. builtin type builtin.io2.Tls + 51. unique type builtin.io2.TlsFailure + 52. structural type builtin.Tuple a b + 53. builtin type builtin.Link.Type + 54. structural type builtin.Unit + 55. builtin type builtin.Value + 56. builtin type builtin.io2.Tls.Version + 57. builtin.io2.SeekMode.AbsoluteSeek : SeekMode + 58. builtin.io2.IOError.AlreadyExists : IOError + 59. builtin.io2.FileMode.Append : FileMode + 60. builtin.Doc.Blob : Text + -> Doc + 61. builtin.io2.BufferMode.BlockBuffering : BufferMode + 62. builtin.Tuple.Cons : a + -> b + -> Tuple + a b + 63. builtin.io2.IOError.EOF : IOError + 64. builtin.Doc.Evaluate : Term + -> Doc + 65. builtin.Test.Result.Fail : Text + -> Result + 66. builtin.io2.Failure.Failure : Type + -> Text + -> Any + -> Failure + 67. builtin.io2.IOError.IllegalOperation : IOError + 68. builtin.IsPropagated.IsPropagated : IsPropagated + 69. builtin.IsTest.IsTest : IsTest + 70. builtin.Doc.Join : [Doc] + -> Doc + 71. builtin.Either.Left : a + -> Either + a b + 72. builtin.io2.BufferMode.LineBuffering : BufferMode + 73. builtin.Doc.Link : Link + -> Doc + 74. builtin.io2.BufferMode.NoBuffering : BufferMode + 75. builtin.io2.IOError.NoSuchThing : IOError + 76. builtin.Optional.None : Optional + a + 77. builtin.Test.Result.Ok : Text + -> Result + 78. builtin.io2.IOError.PermissionDenied : IOError + 79. builtin.io2.FileMode.Read : FileMode + 80. builtin.io2.FileMode.ReadWrite : FileMode + 81. builtin.io2.SeekMode.RelativeSeek : SeekMode + 82. builtin.io2.IOError.ResourceBusy : IOError + 83. builtin.io2.IOError.ResourceExhausted : IOError + 84. builtin.Either.Right : b + -> Either + a b + 85. builtin.io2.SeekMode.SeekFromEnd : SeekMode + 86. builtin.Doc.Signature : Term + -> Doc + 87. builtin.io2.BufferMode.SizedBlockBuffering : Nat + -> BufferMode + 88. builtin.Optional.Some : a + -> Optional + a + 89. builtin.Doc.Source : Link + -> Doc + 90. builtin.io2.StdHandle.StdErr : StdHandle + 91. builtin.io2.StdHandle.StdIn : StdHandle + 92. builtin.io2.StdHandle.StdOut : StdHandle + 93. builtin.Link.Term : Term + -> Link + 94. builtin.Link.Type : Type + -> Link + 95. builtin.Unit.Unit : () + 96. builtin.io2.IOError.UserError : IOError + 97. builtin.SeqView.VElem : a + -> b + -> SeqView + a b + 98. builtin.SeqView.VEmpty : SeqView + a b + 99. builtin.io2.FileMode.Write : FileMode + 100. builtin.Exception.raise : Failure + ->{Exception} x + 101. builtin.Text.!= : Text + -> Text + -> Boolean + 102. builtin.Float.* : Float + -> Float + -> Float + 103. builtin.Int.* : Int + -> Int + -> Int + 104. builtin.Nat.* : Nat + -> Nat + -> Nat + 105. builtin.Float.+ : Float + -> Float + -> Float + 106. builtin.Int.+ : Int + -> Int + -> Int + 107. builtin.Nat.+ : Nat + -> Nat + -> Nat + 108. builtin.Bytes.++ : Bytes + -> Bytes + -> Bytes + 109. builtin.List.++ : [a] + -> [a] + -> [a] + 110. builtin.Text.++ : Text + -> Text + -> Text + 111. โ”Œ builtin.List.+: : a + -> [a] + -> [a] + 112. โ”” builtin.List.cons : a + -> [a] + -> [a] + 113. builtin.Float.- : Float + -> Float + -> Float + 114. builtin.Int.- : Int + -> Int + -> Int + 115. builtin.Float./ : Float + -> Float + -> Float + 116. builtin.Int./ : Int + -> Int + -> Int + 117. builtin.Nat./ : Nat + -> Nat + -> Nat + 118. โ”Œ builtin.List.:+ : [a] + -> a + -> [a] + 119. โ”” builtin.List.snoc : [a] + -> a + -> [a] + 120. builtin.Universal.< : a + -> a + -> Boolean + 121. builtin.Universal.<= : a + -> a + -> Boolean + 122. builtin.Universal.== : a + -> a + -> Boolean + 123. builtin.Universal.> : a + -> a + -> Boolean + 124. builtin.Universal.>= : a + -> a + -> Boolean + 125. builtin.Any.Any : a + -> Any + 126. builtin.crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm + 127. builtin.crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm + 128. builtin.crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm + 129. builtin.crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 130. builtin.crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 131. builtin.crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 132. builtin.crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 133. builtin.Float.abs : Float + -> Float + 134. builtin.Float.acos : Float + -> Float + 135. builtin.Float.acosh : Float + -> Float + 136. builtin.Int.and : Int + -> Int + -> Int + 137. builtin.Nat.and : Nat + -> Nat + -> Nat + 138. builtin.Float.asin : Float + -> Float + 139. builtin.Float.asinh : Float + -> Float + 140. builtin.Bytes.at : Nat + -> Bytes + -> Optional + Nat + 141. builtin.List.at : Nat + -> [a] + -> Optional + a + 142. builtin.Float.atan : Float + -> Float + 143. builtin.Float.atan2 : Float + -> Float + -> Float + 144. builtin.Float.atanh : Float + -> Float + 145. builtin.io2.STM.atomically : '{STM} a + ->{IO} a + 146. builtin.bug : a -> b + 147. โ”Œ c#gjmq673r1v : Nat + 148. โ”” aaaa.tooManySegments : Nat + 149. builtin.Code.cache_ : [( Term, + Code)] + ->{IO} [Term] + 150. builtin.Float.ceiling : Float + -> Int + 151. builtin.unsafe.coerceAbilities : (a + ->{e1} b) + -> a + ->{e2} b + 152. builtin.Universal.compare : a + -> a + -> Int + 153. builtin.Int.complement : Int + -> Int + 154. builtin.Nat.complement : Nat + -> Nat + 155. builtin.Bytes.gzip.compress : Bytes + -> Bytes + 156. builtin.Bytes.zlib.compress : Bytes + -> Bytes + 157. builtin.Float.cos : Float + -> Float + 158. builtin.Float.cosh : Float + -> Float + 159. builtin.Bytes.decodeNat16be : Bytes + -> Optional + ( Nat, + Bytes) + 160. builtin.Bytes.decodeNat16le : Bytes + -> Optional + ( Nat, + Bytes) + 161. builtin.Bytes.decodeNat32be : Bytes + -> Optional + ( Nat, + Bytes) + 162. builtin.Bytes.decodeNat32le : Bytes + -> Optional + ( Nat, + Bytes) + 163. builtin.Bytes.decodeNat64be : Bytes + -> Optional + ( Nat, + Bytes) + 164. builtin.Bytes.decodeNat64le : Bytes + -> Optional + ( Nat, + Bytes) + 165. builtin.io2.Tls.decodePrivateKey : Bytes + -> [PrivateKey] + 166. builtin.Bytes.gzip.decompress : Bytes + -> Either + Text + Bytes + 167. builtin.Bytes.zlib.decompress : Bytes + -> Either + Text + Bytes + 168. builtin.io2.Tls.ClientConfig.default : Text + -> Bytes + -> ClientConfig + 169. builtin.io2.Tls.ServerConfig.default : [SignedCert] + -> PrivateKey + -> ServerConfig + 170. builtin.Code.dependencies : Code + -> [Term] + 171. builtin.Value.dependencies : Value + -> [Term] + 172. builtin.Code.deserialize : Bytes + -> Either + Text + Code + 173. builtin.Value.deserialize : Bytes + -> Either + Text + Value + 174. builtin.Code.display : Text + -> Code + -> Text + 175. builtin.Bytes.drop : Nat + -> Bytes + -> Bytes + 176. builtin.List.drop : Nat + -> [a] + -> [a] + 177. builtin.Nat.drop : Nat + -> Nat + -> Nat + 178. builtin.Text.drop : Nat + -> Text + -> Text + 179. builtin.Bytes.empty : Bytes + 180. builtin.List.empty : [a] + 181. builtin.Text.empty : Text + 182. builtin.io2.Tls.encodeCert : SignedCert + -> Bytes + 183. builtin.Bytes.encodeNat16be : Nat + -> Bytes + 184. builtin.Bytes.encodeNat16le : Nat + -> Bytes + 185. builtin.Bytes.encodeNat32be : Nat + -> Bytes + 186. builtin.Bytes.encodeNat32le : Nat + -> Bytes + 187. builtin.Bytes.encodeNat64be : Nat + -> Bytes + 188. builtin.Bytes.encodeNat64le : Nat + -> Bytes + 189. builtin.io2.Tls.encodePrivateKey : PrivateKey + -> Bytes + 190. builtin.Float.eq : Float + -> Float + -> Boolean + 191. builtin.Int.eq : Int + -> Int + -> Boolean + 192. builtin.Nat.eq : Nat + -> Nat + -> Boolean + 193. builtin.Text.eq : Text + -> Text + -> Boolean + 194. builtin.Float.exp : Float + -> Float + 195. builtin.Bytes.flatten : Bytes + -> Bytes + 196. builtin.Float.floor : Float + -> Int + 197. builtin.io2.IO.forkComp : '{IO} a + ->{IO} ThreadId + 198. builtin.Bytes.fromBase16 : Bytes + -> Either + Text + Bytes + 199. builtin.Bytes.fromBase32 : Bytes + -> Either + Text + Bytes + 200. builtin.Bytes.fromBase64 : Bytes + -> Either + Text + Bytes + 201. builtin.Bytes.fromBase64UrlUnpadded : Bytes + -> Either + Text + Bytes + 202. builtin.Text.fromCharList : [Char] + -> Text + 203. builtin.Bytes.fromList : [Nat] + -> Bytes + 204. builtin.Char.fromNat : Nat + -> Char + 205. builtin.Float.fromRepresentation : Nat + -> Float + 206. builtin.Int.fromRepresentation : Nat + -> Int + 207. builtin.Float.fromText : Text + -> Optional + Float + 208. builtin.Int.fromText : Text + -> Optional + Int + 209. builtin.Nat.fromText : Text + -> Optional + Nat + 210. builtin.Float.gt : Float + -> Float + -> Boolean + 211. builtin.Int.gt : Int + -> Int + -> Boolean + 212. builtin.Nat.gt : Nat + -> Nat + -> Boolean + 213. builtin.Text.gt : Text + -> Text + -> Boolean + 214. builtin.Float.gteq : Float + -> Float + -> Boolean + 215. builtin.Int.gteq : Int + -> Int + -> Boolean + 216. builtin.Nat.gteq : Nat + -> Nat + -> Boolean + 217. builtin.Text.gteq : Text + -> Text + -> Boolean + 218. builtin.crypto.hash : HashAlgorithm + -> a + -> Bytes + 219. builtin.crypto.hashBytes : HashAlgorithm + -> Bytes + -> Bytes + 220. builtin.crypto.hmac : HashAlgorithm + -> Bytes + -> a + -> Bytes + 221. builtin.crypto.hmacBytes : HashAlgorithm + -> Bytes + -> Bytes + -> Bytes + 222. builtin.io2.IO.clientSocket.impl : Text + -> Text + ->{IO} Either + Failure + Socket + 223. builtin.io2.IO.closeFile.impl : Handle + ->{IO} Either + Failure + () + 224. builtin.io2.IO.closeSocket.impl : Socket + ->{IO} Either + Failure + () + 225. builtin.io2.IO.createDirectory.impl : Text + ->{IO} Either + Failure + () + 226. builtin.io2.IO.createTempDirectory.impl : Text + ->{IO} Either + Failure + Text + 227. builtin.io2.Tls.decodeCert.impl : Bytes + -> Either + Failure + SignedCert + 228. builtin.io2.IO.delay.impl : Nat + ->{IO} Either + Failure + () + 229. builtin.io2.IO.directoryContents.impl : Text + ->{IO} Either + Failure + [Text] + 230. builtin.io2.IO.fileExists.impl : Text + ->{IO} Either + Failure + Boolean + 231. builtin.Text.fromUtf8.impl : Bytes + -> Either + Failure + Text + 232. builtin.io2.IO.getArgs.impl : '{IO} Either + Failure + [Text] + 233. builtin.io2.IO.getBuffering.impl : Handle + ->{IO} Either + Failure + BufferMode + 234. builtin.io2.IO.getBytes.impl : Handle + -> Nat + ->{IO} Either + Failure + Bytes + 235. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either + Failure + Text + 236. builtin.io2.IO.getEnv.impl : Text + ->{IO} Either + Failure + Text + 237. builtin.io2.IO.getFileSize.impl : Text + ->{IO} Either + Failure + Nat + 238. builtin.io2.IO.getFileTimestamp.impl : Text + ->{IO} Either + Failure + Nat + 239. builtin.io2.IO.getLine.impl : Handle + ->{IO} Either + Failure + Text + 240. builtin.io2.IO.getSomeBytes.impl : Handle + -> Nat + ->{IO} Either + Failure + Bytes + 241. builtin.io2.IO.getTempDirectory.impl : '{IO} Either + Failure + Text + 242. builtin.io2.IO.handlePosition.impl : Handle + ->{IO} Either + Failure + Nat + 243. builtin.io2.Tls.handshake.impl : Tls + ->{IO} Either + Failure + () + 244. builtin.io2.IO.isDirectory.impl : Text + ->{IO} Either + Failure + Boolean + 245. builtin.io2.IO.isFileEOF.impl : Handle + ->{IO} Either + Failure + Boolean + 246. builtin.io2.IO.isFileOpen.impl : Handle + ->{IO} Either + Failure + Boolean + 247. builtin.io2.IO.isSeekable.impl : Handle + ->{IO} Either + Failure + Boolean + 248. builtin.io2.IO.kill.impl : ThreadId + ->{IO} Either + Failure + () + 249. builtin.io2.IO.listen.impl : Socket + ->{IO} Either + Failure + () + 250. builtin.io2.Tls.newClient.impl : ClientConfig + -> Socket + ->{IO} Either + Failure + Tls + 251. builtin.io2.Tls.newServer.impl : ServerConfig + -> Socket + ->{IO} Either + Failure + Tls + 252. builtin.io2.IO.openFile.impl : Text + -> FileMode + ->{IO} Either + Failure + Handle + 253. builtin.io2.MVar.put.impl : MVar a + -> a + ->{IO} Either + Failure + () + 254. builtin.io2.IO.putBytes.impl : Handle + -> Bytes + ->{IO} Either + Failure + () + 255. builtin.io2.MVar.read.impl : MVar a + ->{IO} Either + Failure + a + 256. builtin.io2.Tls.receive.impl : Tls + ->{IO} Either + Failure + Bytes + 257. builtin.io2.IO.removeDirectory.impl : Text + ->{IO} Either + Failure + () + 258. builtin.io2.IO.removeFile.impl : Text + ->{IO} Either + Failure + () + 259. builtin.io2.IO.renameDirectory.impl : Text + -> Text + ->{IO} Either + Failure + () + 260. builtin.io2.IO.renameFile.impl : Text + -> Text + ->{IO} Either + Failure + () + 261. builtin.io2.IO.seekHandle.impl : Handle + -> SeekMode + -> Int + ->{IO} Either + Failure + () + 262. builtin.io2.Tls.send.impl : Tls + -> Bytes + ->{IO} Either + Failure + () + 263. builtin.io2.IO.serverSocket.impl : Optional + Text + -> Text + ->{IO} Either + Failure + Socket + 264. builtin.io2.IO.setBuffering.impl : Handle + -> BufferMode + ->{IO} Either + Failure + () + 265. builtin.io2.IO.setCurrentDirectory.impl : Text + ->{IO} Either + Failure + () + 266. builtin.io2.IO.socketAccept.impl : Socket + ->{IO} Either + Failure + Socket + 267. builtin.io2.IO.socketPort.impl : Socket + ->{IO} Either + Failure + Nat + 268. builtin.io2.IO.socketReceive.impl : Socket + -> Nat + ->{IO} Either + Failure + Bytes + 269. builtin.io2.IO.socketSend.impl : Socket + -> Bytes + ->{IO} Either + Failure + () + 270. builtin.io2.MVar.swap.impl : MVar a + -> a + ->{IO} Either + Failure + a + 271. builtin.io2.IO.systemTime.impl : '{IO} Either + Failure + Nat + 272. builtin.io2.MVar.take.impl : MVar a + ->{IO} Either + Failure + a + 273. builtin.io2.Tls.terminate.impl : Tls + ->{IO} Either + Failure + () + 274. builtin.io2.MVar.tryPut.impl : MVar a + -> a + ->{IO} Either + Failure + Boolean + 275. builtin.io2.MVar.tryRead.impl : MVar a + ->{IO} Either + Failure + (Optional + a) + 276. builtin.Int.increment : Int + -> Int + 277. builtin.Nat.increment : Nat + -> Nat + 278. builtin.io2.MVar.isEmpty : MVar a + ->{IO} Boolean + 279. builtin.Int.isEven : Int + -> Boolean + 280. builtin.Nat.isEven : Nat + -> Boolean + 281. builtin.Code.isMissing : Term + ->{IO} Boolean + 282. builtin.Int.isOdd : Int + -> Boolean + 283. builtin.Nat.isOdd : Nat + -> Boolean + 284. builtin.metadata.isPropagated : IsPropagated + 285. builtin.metadata.isTest : IsTest + 286. builtin.Int.leadingZeros : Int + -> Nat + 287. builtin.Nat.leadingZeros : Nat + -> Nat + 288. builtin.Value.load : Value + ->{IO} Either + [Term] + a + 289. builtin.Float.log : Float + -> Float + 290. builtin.Float.logBase : Float + -> Float + -> Float + 291. builtin.Code.lookup : Term + ->{IO} Optional + Code + 292. builtin.Float.lt : Float + -> Float + -> Boolean + 293. builtin.Int.lt : Int + -> Int + -> Boolean + 294. builtin.Nat.lt : Nat + -> Nat + -> Boolean + 295. builtin.Text.lt : Text + -> Text + -> Boolean + 296. builtin.Float.lteq : Float + -> Float + -> Boolean + 297. builtin.Int.lteq : Int + -> Int + -> Boolean + 298. builtin.Nat.lteq : Nat + -> Nat + -> Boolean + 299. builtin.Text.lteq : Text + -> Text + -> Boolean + 300. builtin.Float.max : Float + -> Float + -> Float + 301. builtin.Float.min : Float + -> Float + -> Float + 302. builtin.Int.mod : Int + -> Int + -> Int + 303. builtin.Nat.mod : Nat + -> Nat + -> Nat + 304. builtin.Int.negate : Int + -> Int + 305. builtin.io2.MVar.new : a + ->{IO} MVar + a + 306. builtin.io2.TVar.new : a + ->{STM} TVar + a + 307. builtin.io2.MVar.newEmpty : '{IO} MVar + a + 308. builtin.io2.TVar.newIO : a + ->{IO} TVar + a + 309. builtin.Boolean.not : Boolean + -> Boolean + 310. builtin.Int.or : Int + -> Int + -> Int + 311. builtin.Nat.or : Nat + -> Nat + -> Nat + 312. builtin.Int.popCount : Int + -> Nat + 313. builtin.Nat.popCount : Nat + -> Nat + 314. builtin.Float.pow : Float + -> Float + -> Float + 315. builtin.Int.pow : Int + -> Nat + -> Int + 316. builtin.Nat.pow : Nat + -> Nat + -> Nat + 317. builtin.Ref.read : Ref g a + ->{g} a + 318. builtin.io2.TVar.read : TVar a + ->{STM} a + 319. builtin.io2.TVar.readIO : TVar a + ->{IO} a + 320. builtin.io2.IO.ref : a + ->{IO} Ref + {IO} a + 321. builtin.Scope.ref : a + ->{Scope + s} Ref + {Scope + s} + a + 322. builtin.Text.repeat : Nat + -> Text + -> Text + 323. builtin.io2.STM.retry : '{STM} a + 324. builtin.Float.round : Float + -> Int + 325. builtin.Scope.run : (โˆ€ s. + '{g, + Scope s} r) + ->{g} r + 326. builtin.Code.serialize : Code + -> Bytes + 327. builtin.Value.serialize : Value + -> Bytes + 328. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] + -> ClientConfig + -> ClientConfig + 329. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] + -> ServerConfig + -> ServerConfig + 330. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] + -> ClientConfig + -> ClientConfig + 331. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] + -> ServerConfig + -> ServerConfig + 332. builtin.io2.Tls.ClientConfig.versions.set : [Version] + -> ClientConfig + -> ClientConfig + 333. builtin.io2.Tls.ServerConfig.versions.set : [Version] + -> ServerConfig + -> ServerConfig + 334. builtin.Int.shiftLeft : Int + -> Nat + -> Int + 335. builtin.Nat.shiftLeft : Nat + -> Nat + -> Nat + 336. builtin.Int.shiftRight : Int + -> Nat + -> Int + 337. builtin.Nat.shiftRight : Nat + -> Nat + -> Nat + 338. builtin.Int.signum : Int + -> Int + 339. builtin.Float.sin : Float + -> Float + 340. builtin.Float.sinh : Float + -> Float + 341. builtin.Bytes.size : Bytes + -> Nat + 342. builtin.List.size : [a] + -> Nat + 343. builtin.Text.size : Text + -> Nat + 344. builtin.Float.sqrt : Float + -> Float + 345. builtin.io2.IO.stdHandle : StdHandle + -> Handle + 346. builtin.Nat.sub : Nat + -> Nat + -> Int + 347. builtin.io2.TVar.swap : TVar a + -> a + ->{STM} a + 348. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int + 349. builtin.Bytes.take : Nat + -> Bytes + -> Bytes + 350. builtin.List.take : Nat + -> [a] + -> [a] + 351. builtin.Text.take : Nat + -> Text + -> Text + 352. builtin.Float.tan : Float + -> Float + 353. builtin.Float.tanh : Float + -> Float + 354. builtin.Bytes.toBase16 : Bytes + -> Bytes + 355. builtin.Bytes.toBase32 : Bytes + -> Bytes + 356. builtin.Bytes.toBase64 : Bytes + -> Bytes + 357. builtin.Bytes.toBase64UrlUnpadded : Bytes + -> Bytes + 358. builtin.Text.toCharList : Text + -> [Char] + 359. builtin.Int.toFloat : Int + -> Float + 360. builtin.Nat.toFloat : Nat + -> Float + 361. builtin.Nat.toInt : Nat + -> Int + 362. builtin.Bytes.toList : Bytes + -> [Nat] + 363. builtin.Char.toNat : Char + -> Nat + 364. builtin.Float.toRepresentation : Float + -> Nat + 365. builtin.Int.toRepresentation : Int + -> Nat + 366. builtin.Char.toText : Char + -> Text + 367. builtin.Float.toText : Float + -> Text + 368. builtin.Handle.toText : Handle + -> Text + 369. builtin.Int.toText : Int + -> Text + 370. builtin.Nat.toText : Nat + -> Text + 371. builtin.Socket.toText : Socket + -> Text + 372. builtin.Link.Term.toText : Term + -> Text + 373. builtin.ThreadId.toText : ThreadId + -> Text + 374. builtin.Text.toUtf8 : Text + -> Bytes + 375. builtin.todo : a -> b + 376. builtin.Debug.trace : Text + -> a + -> () + 377. builtin.Int.trailingZeros : Int + -> Nat + 378. builtin.Nat.trailingZeros : Nat + -> Nat + 379. builtin.Float.truncate : Float + -> Int + 380. builtin.Int.truncate0 : Int + -> Nat + 381. builtin.io2.MVar.tryTake : MVar a + ->{IO} Optional + a + 382. builtin.Text.uncons : Text + -> Optional + ( Char, + Text) + 383. builtin.Any.unsafeExtract : Any + -> a + 384. builtin.Text.unsnoc : Text + -> Optional + ( Text, + Char) + 385. builtin.Code.validate : [( Term, + Code)] + ->{IO} Optional + Failure + 386. builtin.io2.validateSandboxed : [Term] + -> a + -> Boolean + 387. builtin.Value.value : a + -> Value + 388. builtin.Debug.watch : Text + -> a + -> a + 389. builtin.Ref.write : Ref g a + -> a + ->{g} () + 390. builtin.io2.TVar.write : TVar a + -> a + ->{STM} () + 391. builtin.Int.xor : Int + -> Int + -> Int + 392. builtin.Nat.xor : Nat + -> Nat + -> Nat Tip: You can use `todo` to see if this generated any work to do in this namespace and `test` to run the tests. Or you @@ -107,21 +1071,29 @@ At this point, `a3` is conflicted for symbols `c` and `d`, but the original `a2` .> view a b c d a.a : Nat - a.a = b + 1 + a.a = + use Nat + + b + 1 a.b : Nat - a.b = 0 + 1 + a.b = + use Nat + + 0 + 1 a2.c : Nat a2.c = 1 a2.d : Nat - a2.d = a2.c + 10 + a2.d = + use Nat + + a2.c + 10 a3.c#dcgdua2lj6 : Nat a3.c#dcgdua2lj6 = 2 a3.d#9ivhgvhthc : Nat - a3.d#9ivhgvhthc = c#dcgdua2lj6 + 10 + a3.d#9ivhgvhthc = + use Nat + + c#dcgdua2lj6 + 10 ``` diff --git a/unison-src/transcripts/propagate.output.md b/unison-src/transcripts/propagate.output.md index dbde6ed973..475f75c08e 100644 --- a/unison-src/transcripts/propagate.output.md +++ b/unison-src/transcripts/propagate.output.md @@ -90,6 +90,8 @@ and update the codebase to use the new type `Foo`... fooToInt : Foo -> Int fooToInt _ = +42 +.> cd . + ``` ### Preserving user type variables @@ -130,6 +132,8 @@ Add that to the codebase: otherTerm : Optional baz -> Optional baz someTerm : Optional foo -> Optional foo +.> cd . + ``` Let's now edit the dependency: @@ -146,8 +150,7 @@ someTerm _ = None do an `add` or `update`, here's how your codebase would change: - โŸ These names already exist. You can `update` them to your - new definition: + โŸ These new definitions are ok to `add`: someTerm : Optional x -> Optional x @@ -161,6 +164,8 @@ Update... someTerm : Optional x -> Optional x +.> cd . + ``` Now the type of `someTerm` should be `Optional x -> Optional x` and the type of `otherTerm` should remain the same. @@ -238,6 +243,8 @@ We'll make two copies of this namespace. Done. +.> cd . + ``` Now let's edit one of the terms... diff --git a/unison-src/transcripts/sum-type-update-conflicts.output.md b/unison-src/transcripts/sum-type-update-conflicts.output.md index e99695c90b..960854fcc4 100644 --- a/unison-src/transcripts/sum-type-update-conflicts.output.md +++ b/unison-src/transcripts/sum-type-update-conflicts.output.md @@ -29,6 +29,8 @@ structural type X = x structural type X +.> cd . + ``` Now we update the type, changing the name of the constructors, _but_, we simultaneously add a new top-level term with the same name as the old constructor. @@ -50,13 +52,9 @@ dependsOnX = Text.size X.x โŸ These new definitions are ok to `add`: + structural type X X.x : Text dependsOnX : Nat - - โŸ These names already exist. You can `update` them to your - new definition: - - structural type X ``` This update should succeed since the conflicted constructor diff --git a/unison-src/transcripts/update-on-conflict.output.md b/unison-src/transcripts/update-on-conflict.output.md index 980148a39b..31ffb20b28 100644 --- a/unison-src/transcripts/update-on-conflict.output.md +++ b/unison-src/transcripts/update-on-conflict.output.md @@ -59,8 +59,10 @@ Cause a conflict: can use `undo` or `reflog` to undo the results of this merge. +.> cd . + ``` -Ideally we could just define the canonical `x` that we want, and update +Ideally we could just define the canonical `x` that we want, and update to accept it, but we can't: ```unison @@ -73,12 +75,9 @@ x = 1 + 2 do an `add` or `update`, here's how your codebase would change: - x These definitions would fail on `add` or `update`: - - Reason - conflicted x : Nat + โŸ These new definitions are ok to `add`: - Tip: Use `help filestatus` to learn more. + x : Nat ``` Update fails on conflicted `x`: From bebc3f17f0847678fc2e5aa5aeb9c1e87aca0009 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 6 Apr 2022 17:28:32 -0400 Subject: [PATCH 065/529] add some comments to sync code --- .../unison-codebase-sqlite.cabal | 1 + unison-cli/src/Unison/Share/Sync.hs | 147 +++++++++++------- 2 files changed, 95 insertions(+), 53 deletions(-) diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 06d552a9b9..ee5c7bf54f 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -10,6 +10,7 @@ homepage: https://github.com/unisonweb/unison#readme bug-reports: https://github.com/unisonweb/unison/issues build-type: Simple extra-source-files: + sql/001-temp-entity-tables.sql sql/create.sql source-repository head diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index f15eaab966..d3df70c5bc 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -9,6 +9,8 @@ module Unison.Share.Sync ) where +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as List.NonEmpty import qualified Data.Map.NonEmpty as NEMap import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) @@ -26,14 +28,12 @@ import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path -data GetCausalHashByPathResponse - = GetCausalHashByPathSuccess Share.HashJWT - | GetCausalHashByPathEmpty - | GetCausalHashByPathNoReadPermission - +-- | An error occurred when getting causal hash by path. data GetCausalHashByPathError - = GetCausalHashByPathErrorNoReadPermission + = -- | The user does not have permission to read this path. + GetCausalHashByPathErrorNoReadPermission +-- | Get the causal hash of a path hosted on Unison Share. getCausalHashByPath :: Share.RepoPath -> IO (Either GetCausalHashByPathError (Maybe Share.HashJWT)) getCausalHashByPath repoPath = _getCausalHashByPath (Share.GetCausalHashByPathRequest repoPath) <&> \case @@ -41,67 +41,91 @@ getCausalHashByPath repoPath = GetCausalHashByPathEmpty -> Right Nothing GetCausalHashByPathNoReadPermission -> Left GetCausalHashByPathErrorNoReadPermission -_getCausalHashByPath :: Share.GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse -_getCausalHashByPath = undefined - ------------------------------------------------------------------------------------------------------------------------ -- Push +-- | An error occurred while pushing code to Unison Share. data PushError = PushErrorServerMissingDependencies (NESet Share.Hash) | PushErrorHashMismatch Share.HashMismatch -_updatePath :: Share.UpdatePathRequest -> IO UpdatePathResponse -_updatePath = undefined - -_uploadEntities :: Share.UploadEntitiesRequest -> IO UploadEntitiesResponse -_uploadEntities = undefined - -push :: Connection -> Share.RepoPath -> Maybe Share.Hash -> CausalHash -> IO (Either PushError ()) +-- | Push a causal to Unison Share. +push :: + -- | SQLite connection, for reading entities to push. + Connection -> + -- | The repo+path to push to. + Share.RepoPath -> + -- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error. + -- This prevents accidentally pushing over data that we didn't know was there. + Maybe Share.Hash -> + -- | The hash of our local causal to push. + CausalHash -> + IO (Either PushError ()) push conn repoPath expectedHash causalHash = do - _updatePath request >>= \case + let theUpdatePathRequest :: Share.UpdatePathRequest + theUpdatePathRequest = + Share.UpdatePathRequest + { path = repoPath, + expectedHash = + expectedHash <&> \hash -> + Share.TypedHash + { hash, + entityType = Share.CausalType + }, + newHash = + Share.TypedHash + { hash = + causalHash + & unCausalHash + & Hash.toBase32Hex + & Base32Hex.toText + & Share.Hash, + entityType = Share.CausalType + } + } + + -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs + -- this causal (UpdatePathMissingDependencies). + _updatePath theUpdatePathRequest >>= \case UpdatePathSuccess -> pure (Right ()) UpdatePathHashMismatch mismatch -> pure (Left (PushErrorHashMismatch mismatch)) UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do + -- Upload the causal and all of its dependencies. upload conn (Share.RepoPath.repoName repoPath) dependencies - _updatePath request <&> \case + + -- After uploading the causal and all of its dependencies, try setting the remote path again. + _updatePath theUpdatePathRequest <&> \case UpdatePathSuccess -> Right () + -- Between the initial updatePath attempt and this one, someone else managed to update the path. That's ok; we + -- still managed to upload our causal, but the push has indeed failed overall. UpdatePathHashMismatch mismatch -> Left (PushErrorHashMismatch mismatch) + -- Unexpected, but possible: we thought we uploaded all we needed to, yet the server still won't accept our + -- causal. Bug in the client because we didn't upload enough? Bug in the server because we weren't told to + -- upload some dependency? Who knows. UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> Left (PushErrorServerMissingDependencies dependencies) - where - request = - Share.UpdatePathRequest - { path = repoPath, - expectedHash = - expectedHash <&> \hash -> - Share.TypedHash - { hash, - entityType = Share.CausalType - }, - newHash = - Share.TypedHash - { hash = - causalHash - & unCausalHash - & Hash.toBase32Hex - & Base32Hex.toText - & Share.Hash, - entityType = Share.CausalType - } - } upload :: Connection -> Share.RepoName -> NESet Share.Hash -> IO () -upload conn repoName dependencies = do - request <- do - entities <- - NEMap.fromAscList <$> traverse (\dep -> (dep,) <$> resolveHashToEntity conn dep) (NESet.toAscList dependencies) - pure Share.UploadEntitiesRequest {repoName, entities} +upload conn repoName = + loop + where + loop :: NESet Share.Hash -> IO () + loop (NESet.toAscList -> hashes) = do + -- Get each entity that the server is missing out of the database. + entities <- traverse (resolveHashToEntity conn) hashes + + let theUploadEntitiesRequest :: Share.UploadEntitiesRequest + theUploadEntitiesRequest = + Share.UploadEntitiesRequest + { entities = NEMap.fromAscList (List.NonEmpty.zip hashes entities), + repoName + } - _uploadEntities request >>= \case - UploadEntitiesNeedDependencies (Share.NeedDependencies dependencies) -> - upload conn repoName dependencies - UploadEntitiesSuccess -> pure () + -- Upload all of the entities we know the server needs, and if the server responds that it needs yet more, loop to + -- upload those too. + _uploadEntities theUploadEntitiesRequest >>= \case + UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> loop moreHashes + UploadEntitiesSuccess -> pure () ------------------------------------------------------------------------------------------------------------------------ -- Pull @@ -132,11 +156,6 @@ upload conn repoName dependencies = do ------------------------------------------------------------------------------------------------------------------------ -- -data UpdatePathResponse - = UpdatePathSuccess - | UpdatePathHashMismatch Share.HashMismatch - | UpdatePathMissingDependencies (Share.NeedDependencies Share.Hash) - data UploadEntitiesResponse = UploadEntitiesSuccess | UploadEntitiesNeedDependencies (Share.NeedDependencies Share.Hash) @@ -176,3 +195,25 @@ pull _conn _repoPath = undefined -- FIXME rename, etc resolveHashToEntity :: Connection -> Share.Hash -> IO (Share.Entity Text Share.Hash Share.Hash) resolveHashToEntity = undefined + +------------------------------------------------------------------------------------------------------------------------ +-- TODO these things come from servant-client / api types module(s) + +data GetCausalHashByPathResponse + = GetCausalHashByPathSuccess Share.HashJWT + | GetCausalHashByPathEmpty + | GetCausalHashByPathNoReadPermission + +data UpdatePathResponse + = UpdatePathSuccess + | UpdatePathHashMismatch Share.HashMismatch + | UpdatePathMissingDependencies (Share.NeedDependencies Share.Hash) + +_getCausalHashByPath :: Share.GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse +_getCausalHashByPath = undefined + +_updatePath :: Share.UpdatePathRequest -> IO UpdatePathResponse +_updatePath = undefined + +_uploadEntities :: Share.UploadEntitiesRequest -> IO UploadEntitiesResponse +_uploadEntities = undefined From 8c248b29bead509780d0458f30aaf4b68575c99f Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 6 Apr 2022 17:46:02 -0400 Subject: [PATCH 066/529] add comments to temp entities tables --- .../sql/001-temp-entity-tables.sql | 52 ++++++++++++------- 1 file changed, 32 insertions(+), 20 deletions(-) diff --git a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql index b48bc77a5b..8715d11704 100644 --- a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql +++ b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql @@ -1,40 +1,52 @@ -begin; create table temp_entity_type_description ( id integer primary key not null, description text unique not null ); -insert into temp_entity_type_description -values +insert into temp_entity_type_description values (0, 'Term Component'), (1, 'Decl Component'), (2, 'Namespace'), (3, 'Patch'), (4, 'Causal'); + +-- A "temp entity" is a term/decl/namespace/patch/causal that we cannot store in the database proper due to missing +-- dependencies. +-- +-- The existence of each `temp_entity` row implies the existence of one or more corresponding +-- `temp_entity_missing_dependency` rows: it does not make sense to make a `temp_entity` row for a thing that has no +-- missing dependencies! +-- +-- Similarly, each `temp_entity` row implies we do not have the entity in the database proper. When and if we *do* store +-- an entity proper (after storing all of its dependencies), we should always atomically delete the corresponding +-- `temp_entity` row, if any. create table temp_entity ( hash text primary key not null, blob bytes not null, type_id integer not null references temp_entity_type_description(id) ); + +-- A many-to-many relationship between `temp_entity` (entities we can't yet store due to missing dependencies), and the +-- non-empty set of hashes of each entity's dependencies. +-- +-- For example, if we wanted to store term #foo, but couldn't because it depends on term #bar which we don't have yet, +-- we would end up with the following rows. +-- +-- temp_entity +-- +------------------------+ +-- | hash | blob | type_id | +-- |========================| +-- | #foo | ... | 0 (term) | +-- +------------------------+ +-- +-- temp_entity_missing_dependency +-- +------------------------+ +-- | dependent | dependency | +-- +------------------------+ +-- | #foo | #bar | +-- +------------------------+ create table temp_entity_missing_dependency ( dependent text not null references temp_entity(hash), dependency text not null ); create index temp_entity_missing_dependency_ix_dependent on temp_entity_missing_dependency (dependent); create index temp_entity_missing_dependency_ix_dependency on temp_entity_missing_dependency (dependency); -select count(*) from object; -rollback; - -begin; -create table foo(a int); -create index foo on foo (a); -rollback; - -.schema hash - -.schema object - -.schema object_type_description - -select * from object_type_description; - -select 1; From 3aca147a826750891ad08a22dc6d95d75d880c19 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 6 Apr 2022 15:48:59 -0600 Subject: [PATCH 067/529] Implement sync http client --- parser-typechecker/package.yaml | 1 + .../src/Unison/Codebase/Editor/Git.hs | 2 +- .../unison-parser-typechecker.cabal | 1 + unison-cli/package.yaml | 4 +- unison-cli/src/Unison/Auth/HTTPClient.hs | 5 +- unison-cli/src/Unison/Sync/HTTP.hs | 55 +++++++++++++++++++ unison-cli/unison-cli.cabal | 16 ++++++ unison-share-api/src/Unison/Sync/API.hs | 10 +++- unison-share-api/src/Unison/Sync/Types.hs | 50 ++++++++++++++++- 9 files changed, 136 insertions(+), 8 deletions(-) create mode 100644 unison-cli/src/Unison/Sync/HTTP.hs diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 433342c5f6..57e22cdce2 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -50,6 +50,7 @@ library: - haskeline - http-types - http-media + - http-client - lens - ListLike - megaparsec >= 5.0.0 && < 7.0.0 diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs index 7d2432e933..a11ccbd142 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs @@ -56,7 +56,7 @@ encodeFileName s = go ('$' : rem) = "$$" <> go rem go (c : rem) | elem @[] c "/\\:*?\"<>|" || not (Char.isPrint c && Char.isAscii c) = - "$x" <> encodeHex [c] <> "$" <> go rem + "$x" <> encodeHex [c] <> "$" <> go rem | otherwise = c : go rem go [] = [] encodeHex :: String -> String diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index eb7c346e27..8091a5dde4 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -241,6 +241,7 @@ library , hashable , hashtables , haskeline + , http-client , http-media , http-types , lens diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 0abd6d0f6b..024f7d9b84 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -54,7 +54,9 @@ dependencies: - lock-file - jwt - either - + - unison-share-api + - servant-client + - servant library: source-dirs: src diff --git a/unison-cli/src/Unison/Auth/HTTPClient.hs b/unison-cli/src/Unison/Auth/HTTPClient.hs index cf9a401449..60f22db599 100644 --- a/unison-cli/src/Unison/Auth/HTTPClient.hs +++ b/unison-cli/src/Unison/Auth/HTTPClient.hs @@ -1,4 +1,4 @@ -module Unison.Auth.HTTPClient where +module Unison.Auth.HTTPClient (newAuthorizedHTTPClient, AuthorizedHttpClient(..)) where import qualified Data.Text.Encoding as Text import Network.HTTP.Client (Request) @@ -11,6 +11,9 @@ import Unison.Codebase.Editor.Command (UCMVersion) import Unison.Prelude import qualified Unison.Util.HTTP as HTTP +-- | Newtype to delineate HTTP Managers with access-token logic. +newtype AuthorizedHttpClient = AuthorizedHttpClient HTTP.Manager + -- | Returns a new http manager which applies the appropriate Authorization header to -- any hosts our UCM is authenticated with. newAuthorizedHTTPClient :: MonadIO m => CredentialManager -> UCMVersion -> m HTTP.Manager diff --git a/unison-cli/src/Unison/Sync/HTTP.hs b/unison-cli/src/Unison/Sync/HTTP.hs new file mode 100644 index 0000000000..da00125bd1 --- /dev/null +++ b/unison-cli/src/Unison/Sync/HTTP.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Sync.HTTP + ( getPathHandler, + updatePathHandler, + downloadEntitiesHandler, + uploadEntitiesHandler, + ) +where + +import Control.Monad.Reader +import Servant.API +import Servant.Client +import qualified Unison.Auth.HTTPClient as Auth +import Unison.Prelude +import qualified Unison.Sync.API as Sync +import Unison.Sync.Types + +data SyncError + = ClientErr ClientError + deriving stock (Show) + deriving anyclass (Exception) + +getPathHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse +updatePathHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> UpdatePathRequest -> IO UpdatePathResponse +downloadEntitiesHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> DownloadEntitiesRequest -> IO DownloadEntitiesResponse +uploadEntitiesHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> UploadEntitiesRequest -> IO UploadEntitiesResponse +( getPathHandler, + updatePathHandler, + downloadEntitiesHandler, + uploadEntitiesHandler + ) = + let ( getPathHandler + :<|> updatePathHandler + :<|> downloadEntitiesHandler + :<|> uploadEntitiesHandler + ) = hoistClient Sync.api hoist (client Sync.api) + in (uncurryReaderT getPathHandler, uncurryReaderT updatePathHandler, uncurryReaderT downloadEntitiesHandler, uncurryReaderT uploadEntitiesHandler) + where + hoist :: forall a. ClientM a -> ReaderT (Auth.AuthorizedHttpClient, BaseUrl) IO a + hoist m = do + (Auth.AuthorizedHttpClient manager, baseUrl) <- ask + let clientEnv = mkClientEnv manager baseUrl + resp <- liftIO . throwEitherMWith ClientErr $ (runClientM m clientEnv) + pure resp + + uncurryReaderT :: forall req resp. (req -> ReaderT (Auth.AuthorizedHttpClient, BaseUrl) IO resp) -> Auth.AuthorizedHttpClient -> BaseUrl -> req -> IO resp + uncurryReaderT f httpClient baseURL req = + runReaderT (f req) (httpClient, baseURL) diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 7264cb123c..8feab7b724 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -59,6 +59,7 @@ library Unison.CommandLine.Main Unison.CommandLine.OutputMessages Unison.CommandLine.Welcome + Unison.Sync.HTTP Unison.Util.HTTP other-modules: Paths_unison_cli @@ -118,6 +119,8 @@ library , random >=1.2.0 , regex-tdfa , semialign + , servant + , servant-client , stm , text , these @@ -128,6 +131,7 @@ library , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-share-api , unison-util , unison-util-relation , unliftio @@ -206,6 +210,8 @@ executable integration-tests , random >=1.2.0 , regex-tdfa , semialign + , servant + , servant-client , shellmet , stm , text @@ -217,6 +223,7 @@ executable integration-tests , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-share-api , unison-util , unison-util-relation , unliftio @@ -289,6 +296,8 @@ executable transcripts , random >=1.2.0 , regex-tdfa , semialign + , servant + , servant-client , shellmet , stm , text @@ -301,6 +310,7 @@ executable transcripts , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-share-api , unison-util , unison-util-relation , unliftio @@ -375,6 +385,8 @@ executable unison , random >=1.2.0 , regex-tdfa , semialign + , servant + , servant-client , shellmet , stm , template-haskell @@ -389,6 +401,7 @@ executable unison , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-share-api , unison-util , unison-util-relation , unliftio @@ -468,6 +481,8 @@ test-suite tests , random >=1.2.0 , regex-tdfa , semialign + , servant + , servant-client , shellmet , stm , temporary @@ -481,6 +496,7 @@ test-suite tests , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-share-api , unison-util , unison-util-relation , unliftio diff --git a/unison-share-api/src/Unison/Sync/API.hs b/unison-share-api/src/Unison/Sync/API.hs index 5eb6f23a78..a5eab3677e 100644 --- a/unison-share-api/src/Unison/Sync/API.hs +++ b/unison-share-api/src/Unison/Sync/API.hs @@ -1,10 +1,14 @@ {-# LANGUAGE DataKinds #-} -module Unison.Sync.API (API) where +module Unison.Sync.API (API, api) where +import Data.Proxy import Servant.API import Unison.Sync.Types +api :: Proxy API +api = Proxy + type API = "path" :> "get" :> GetCausalHashByPathEndpoint :<|> "path" :> "update" :> UpdatePathEndpoint @@ -17,7 +21,7 @@ type GetCausalHashByPathEndpoint = type UpdatePathEndpoint = ReqBody '[JSON] UpdatePathRequest - :> UVerb 'POST '[JSON] '[WithStatus 204 NoContent, WithStatus 404 (NeedDependencies HashJWT), WithStatus 412 HashMismatch] + :> Post '[JSON] UpdatePathResponse type DownloadEntitiesEndpoint = ReqBody '[JSON] DownloadEntitiesRequest @@ -25,4 +29,4 @@ type DownloadEntitiesEndpoint = type UploadEntitiesEndpoint = ReqBody '[JSON] UploadEntitiesRequest - :> UVerb 'POST '[JSON] '[WithStatus 200 NoContent, WithStatus 202 (NeedDependencies Hash)] + :> Post '[JSON] UploadEntitiesResponse diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 9032b623dc..6134470f85 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} module Unison.Sync.Types where @@ -10,6 +11,7 @@ import Data.Bifunctor import Data.Bitraversable import Data.ByteArray.Encoding (Base (Base64), convertFromBase, convertToBase) import Data.ByteString (ByteString) +import Data.Function ((&)) import Data.Map.NonEmpty (NEMap) import Data.Set (Set) import Data.Set.NonEmpty (NESet) @@ -154,6 +156,10 @@ instance ToJSON DownloadEntitiesResponse where [ "entities" .= entities ] +instance FromJSON DownloadEntitiesResponse where + parseJSON = Aeson.withObject "DownloadEntitiesResponse" $ \obj -> do + DownloadEntitiesResponse <$> obj .: "entities" + data UpdatePathRequest = UpdatePathRequest { path :: RepoPath, expectedHash :: Maybe TypedHash, -- Nothing requires empty history at destination @@ -176,12 +182,34 @@ instance FromJSON UpdatePathRequest where newHash <- obj .: "new_hash" pure UpdatePathRequest {..} --- | Not used in the servant API, but is a useful return type for clients to use. data UpdatePathResponse - = UpdatePathHashMismatch HashMismatch + = UpdatePathSuccess + | UpdatePathHashMismatch HashMismatch | UpdatePathMissingDependencies (NeedDependencies Hash) deriving stock (Show, Eq, Ord) +jsonUnion :: ToJSON a => Text -> a -> Value +jsonUnion typeName val = + Aeson.object + [ "type" .= String typeName, + "payload" .= val + ] + +instance ToJSON UpdatePathResponse where + toJSON = \case + UpdatePathSuccess -> jsonUnion "success" (Object mempty) + UpdatePathHashMismatch hm -> jsonUnion "hash_mismatch" hm + UpdatePathMissingDependencies md -> jsonUnion "missing_dependencies" md + +instance FromJSON UpdatePathResponse where + parseJSON v = + v & Aeson.withObject "UploadEntitiesResponse" \obj -> + obj .: "type" >>= Aeson.withText "type" \case + "success" -> pure UpdatePathSuccess + "hash_mismatch" -> UpdatePathHashMismatch <$> obj .: "payload" + "missing_dependencies" -> UpdatePathMissingDependencies <$> obj .: "payload" + _ -> fail "Unknown UpdatePathResponse type" + data NeedDependencies hash = NeedDependencies { missingDependencies :: NESet hash } @@ -237,6 +265,24 @@ instance FromJSON UploadEntitiesRequest where entities <- obj .: "entities" pure UploadEntitiesRequest {..} +data UploadEntitiesResponse + = UploadEntitiesSuccess + | UploadEntitiesNeedDependencies (NeedDependencies Hash) + deriving stock (Show, Eq, Ord) + +instance ToJSON UploadEntitiesResponse where + toJSON = \case + UploadEntitiesSuccess -> jsonUnion "success" (Object mempty) + UploadEntitiesNeedDependencies nd -> jsonUnion "need_dependencies" nd + +instance FromJSON UploadEntitiesResponse where + parseJSON v = + v & Aeson.withObject "UploadEntitiesResponse" \obj -> + obj .: "type" >>= Aeson.withText "type" \case + "need_dependencies" -> UploadEntitiesNeedDependencies <$> obj .: "payload" + "success" -> pure UploadEntitiesSuccess + _ -> fail "Unknown UploadEntitiesResponse type" + data Entity hash replacementHash text = TC (TermComponent hash text) | DC (DeclComponent hash text) From 37c55418a36bd85d4e89dfffbebf5ce66bcff500 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 6 Apr 2022 22:19:24 -0400 Subject: [PATCH 068/529] make lca just use the one connection --- .../U/Codebase/Sqlite/Operations.hs | 6 +++--- .../codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 10 ++++------ .../Unison/Codebase/SqliteCodebase/Operations.hs | 15 ++++----------- 3 files changed, 11 insertions(+), 20 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 537850925e..c4458b76a5 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -1135,11 +1135,11 @@ deserializePatchObject id = do when debug $ traceM $ "Operations.deserializePatchObject " ++ show id Q.expectPatchObject (Db.unPatchObjectId id) decodePatchFormat -lca :: CausalHash -> CausalHash -> Connection -> Connection -> Transaction (Maybe CausalHash) -lca h1 h2 c1 c2 = runMaybeT do +lca :: CausalHash -> CausalHash -> Transaction (Maybe CausalHash) +lca h1 h2 = runMaybeT do chId1 <- MaybeT $ Q.loadCausalHashIdByCausalHash h1 chId2 <- MaybeT $ Q.loadCausalHashIdByCausalHash h2 - chId3 <- MaybeT . idempotentIO $ Q.lca chId1 chId2 c1 c2 + chId3 <- MaybeT $ Q.lca chId1 chId2 lift (Q.expectCausalHash chId3) before :: CausalHash -> CausalHash -> Transaction (Maybe Bool) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 5b0f94f5b0..0c7bdd459e 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -157,7 +157,6 @@ import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash import Unison.Prelude import Unison.Sqlite -import qualified Unison.Sqlite.Connection as Connection -- * main squeeze @@ -878,11 +877,10 @@ before chId1 chId2 = queryOneCol sql (chId2, chId1) where sql = fromString $ "SELECT EXISTS (" ++ ancestorSql ++ " WHERE ancestor.id = ?)" --- | the `Connection` arguments come second to fit the shape of Exception.bracket + uncurry curry -lca :: CausalHashId -> CausalHashId -> Connection -> Connection -> IO (Maybe CausalHashId) -lca x y cx cy = - Connection.queryStreamCol cx sql (Only x) \nextX -> - Connection.queryStreamCol cy sql (Only y) \nextY -> do +lca :: CausalHashId -> CausalHashId -> Transaction (Maybe CausalHashId) +lca x y = + queryStreamCol sql (Only x) \nextX -> + queryStreamCol sql (Only y) \nextY -> do let getNext = (,) <$> nextX <*> nextY loop2 seenX seenY = getNext >>= \case diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 735cf447fb..b9b5e1d281 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -592,14 +592,7 @@ branchHashesByPrefix sh = do cs <- Ops.causalHashesByPrefix (Cv.sbh1to2 sh) pure $ Set.map (Causal.RawHash . Cv.hash2to1 . unCausalHash) cs -{- -sqlLca :: MonadIO m => Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash) -sqlLca h1 h2 = - liftIO $ - withConnection (debugName ++ ".lca.left") root $ \c1 -> do - withConnection (debugName ++ ".lca.right") root $ \c2 -> do - Sqlite.runDB conn - . (fmap . fmap) Cv.causalHash2to1 - $ Ops.lca (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) c1 c2 - --} +sqlLca :: Branch.Hash -> Branch.Hash -> Transaction (Maybe Branch.Hash) +sqlLca h1 h2 = do + h3 <- Ops.lca (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) + pure (Cv.causalHash2to1 <$> h3) From f9898f0b4daf71ccaaee860feeef812fca98d3df Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 6 Apr 2022 21:50:47 -0500 Subject: [PATCH 069/529] names and names.global commands --- .../src/Unison/Codebase/Editor/HandleInput.hs | 6 ++--- .../src/Unison/Codebase/Editor/Input.hs | 7 +++-- .../src/Unison/Codebase/Editor/Output.hs | 3 ++- .../src/Unison/CommandLine/InputPatterns.hs | 17 +++++++----- .../src/Unison/CommandLine/OutputMessages.hs | 26 +++++++++++++------ 5 files changed, 38 insertions(+), 21 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index b47e90ef53..2b58b0bf40 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -949,8 +949,8 @@ loop = do fixupOutput :: Path.HQSplit -> HQ.HashQualified Name fixupOutput = fmap Path.toName . HQ'.toHQ . Path.unsplitHQ - NamesI thing -> do - ns0 <- basicParseNames + NamesI global thing -> do + ns0 <- if global then pure basicPrettyPrintNames else basicParseNames let ns = NamesWithHistory ns0 mempty terms = NamesWithHistory.lookupHQTerm thing ns types = NamesWithHistory.lookupHQType thing ns @@ -963,7 +963,7 @@ loop = do types' = Set.map go types where go r = (r, NamesWithHistory.typeName hqLength r printNames) - respond $ ListNames hqLength (toList types') (toList terms') + respond $ ListNames global hqLength (toList types') (toList terms') LinkI mdValue srcs -> do manageLinks False srcs [mdValue] Metadata.insert syncRoot diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 90d596d1a1..da6d9cdde8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -11,6 +11,7 @@ module Unison.Codebase.Editor.Input Insistence (..), PullMode (..), OptionalPatch (..), + IsGlobal, ) where @@ -69,6 +70,8 @@ data PullMode | PullWithoutHistory deriving (Eq, Show) +type IsGlobal = Bool + data Input = -- names stuff: -- directory ops @@ -97,7 +100,7 @@ data Input -- > names .foo.bar -- > names .foo.bar#asdflkjsdf -- > names #sdflkjsdfhsdf - NamesI (HQ.HashQualified Name) + NamesI IsGlobal (HQ.HashQualified Name) | AliasTermI HashOrHQSplit' Path.Split' | AliasTypeI HashOrHQSplit' Path.Split' | AliasManyI [Path.HQSplit] Path' @@ -157,7 +160,7 @@ data Input | -- Display docs for provided terms. If list is empty, prompt a fuzzy search. DocsI [Path.HQSplit'] | -- other - FindI Bool Bool [String] -- SearchByName isVerbose global query + FindI Bool IsGlobal [String] -- FindI isVerbose global query | FindShallowI Path' | FindPatchI | -- Show provided definitions. If list is empty, prompt a fuzzy search. diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index b4c5782c3a..e986e0977b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -161,6 +161,7 @@ data Output v | DeleteEverythingConfirmation | DeletedEverything | ListNames + IsGlobal Int -- hq length to print References [(Reference, Set (HQ'.HashQualified Name))] -- type match, type names [(Referent, Set (HQ'.HashQualified Name))] -- term match, term names @@ -321,7 +322,7 @@ isFailure o = case o of DeleteBranchConfirmation {} -> False DeleteEverythingConfirmation -> False DeletedEverything -> False - ListNames _ tys tms -> null tms && null tys + ListNames _ _ tys tms -> null tms && null tys ListOfLinks _ ds -> null ds ListOfDefinitions _ _ ds -> null ds ListOfPatches s -> Set.null s diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 38799ba818..af71a86b8d 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1752,23 +1752,25 @@ unlink = _ -> Left (I.help unlink) ) -names :: InputPattern -names = +names :: Input.IsGlobal -> InputPattern +names isGlobal = InputPattern - "names" + cmdName [] I.Visible [(Required, definitionQueryArg)] - "`names foo` shows the hash and all known names for `foo`." + (P.wrap $ makeExample (names isGlobal) ["foo"] <> " shows the hash and all known names for `foo`.") ( \case [thing] -> case HQ.fromString thing of - Just hq -> Right $ Input.NamesI hq + Just hq -> Right $ Input.NamesI isGlobal hq Nothing -> Left $ "I was looking for one of these forms: " <> P.blue "foo .foo.bar foo#abc #abcde .foo.bar#asdf" - _ -> Left (I.help names) + _ -> Left (I.help (names isGlobal)) ) + where + cmdName = if isGlobal then "names.global" else "names" dependents, dependencies :: InputPattern dependents = @@ -2046,7 +2048,8 @@ validInputs = squashMerge, previewMergeLocal, diffNamespace, - names, + names True, -- names.global + names False, -- names push, pushCreate, pull, diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 9449022e47..eb57305396 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -839,15 +839,25 @@ notifyUser dir o = case o of listOfDefinitions ppe detailed results ListOfLinks ppe results -> listOfLinks ppe [(name, tm) | (name, _ref, tm) <- results] - ListNames _len [] [] -> - pure . P.callout "๐Ÿ˜ถ" $ - P.wrap "I couldn't find anything by that name." - ListNames len types terms -> - pure . P.sepNonEmpty "\n\n" $ - [ formatTypes types, - formatTerms terms - ] + ListNames global len types terms -> + if null types && null terms + then + pure . P.callout "๐Ÿ˜ถ" $ + P.sepNonEmpty "\n\n" $ + [ P.wrap "I couldn't find anything by that name.", + globalTip + ] + else + pure . P.sepNonEmpty "\n\n" $ + [ formatTypes types, + formatTerms terms, + globalTip + ] where + globalTip = + if global + then mempty + else (tip $ "Try " <> IP.makeExample (IP.names global) ["#abc123"] <> " to see more results.") formatTerms tms = P.lines . P.nonEmpty $ P.plural tms (P.blue "Term") : (go <$> tms) where From 4b9608b66f0a5cfbec43c313376927ee5bd9ec26 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 7 Apr 2022 00:20:17 -0400 Subject: [PATCH 070/529] more work towards transactional layer underneath codebase abstraction --- .../U/Codebase/Sqlite/Sync22.hs | 6 +- lib/unison-sqlite/package.yaml | 1 + lib/unison-sqlite/src/Unison/Sqlite.hs | 2 + .../src/Unison/Sqlite/Transaction.hs | 22 +- lib/unison-sqlite/unison-sqlite.cabal | 1 + .../src/Unison/Codebase/SqliteCodebase.hs | 739 +++++------------- .../Codebase/SqliteCodebase/Operations.hs | 41 +- 7 files changed, 269 insertions(+), 543 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs index b78927237c..dd7e649bbd 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs @@ -39,7 +39,7 @@ import qualified U.Codebase.WatchKind as WK import U.Util.Cache (Cache) import qualified U.Util.Cache as Cache import Unison.Prelude -import Unison.Sqlite (Connection, Transaction, runTransaction) +import Unison.Sqlite (Connection, Transaction, unsafeUnTransaction) data Entity = O ObjectId @@ -415,5 +415,5 @@ runSrc, (MonadIO m, MonadReader Env m) => Transaction a -> m a -runSrc ma = Reader.reader srcDB >>= flip runTransaction ma -runDest ma = Reader.reader destDB >>= flip runTransaction ma +runSrc ma = Reader.reader srcDB >>= liftIO . unsafeUnTransaction ma +runDest ma = Reader.reader destDB >>= liftIO . unsafeUnTransaction ma diff --git a/lib/unison-sqlite/package.yaml b/lib/unison-sqlite/package.yaml index 094e72421e..3186443490 100644 --- a/lib/unison-sqlite/package.yaml +++ b/lib/unison-sqlite/package.yaml @@ -47,6 +47,7 @@ default-extensions: - NumericUnderscores - OverloadedStrings - PatternSynonyms + - RankNTypes - ScopedTypeVariables - TupleSections - TypeApplications diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index 16143b3d3d..219b0f5ad5 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -18,6 +18,8 @@ module Unison.Sqlite -- * Transaction interface Transaction, runTransaction, + runTransactionWithAbort, + unsafeUnTransaction, savepoint, idempotentIO, diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index aede5392df..347d2c82e7 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -2,6 +2,8 @@ module Unison.Sqlite.Transaction ( -- * Transaction management Transaction, runTransaction, + runTransactionWithAbort, + unsafeUnTransaction, savepoint, idempotentIO, @@ -74,10 +76,6 @@ newtype Transaction a -- Omit MonadThrow instance so we always throw SqliteException (via *Check) with lots of context deriving (Applicative, Functor, Monad) via (ReaderT Connection IO) -unTransaction :: Transaction a -> Connection -> IO a -unTransaction (Transaction action) = - action - -- | Run a transaction on the given connection. runTransaction :: MonadIO m => Connection -> Transaction a -> m a runTransaction conn (Transaction f) = liftIO do @@ -110,6 +108,20 @@ runTransaction conn (Transaction f) = liftIO do ignoringExceptions action = action `catchAny` \_ -> pure () +-- | TODO document this +runTransactionWithAbort :: + MonadIO m => + Connection -> + ((forall e x. Exception e => e -> Transaction x) -> Transaction a) -> + m a +runTransactionWithAbort conn action = + runTransaction conn (action \exception -> idempotentIO (throwIO exception)) + +-- | Unwrap the transaction newtype, throwing away the sending of BEGIN/COMMIT + automatic retry. +unsafeUnTransaction :: Transaction a -> Connection -> IO a +unsafeUnTransaction (Transaction action) = + action + -- | Perform an atomic sub-computation within a transaction; if it returns 'Left', it's rolled back. savepoint :: Transaction (Either a a) -> Transaction a savepoint (Transaction action) = do @@ -158,7 +170,7 @@ queryStreamRow :: queryStreamRow s params callback = Transaction \conn -> Connection.queryStreamRow conn s params \next -> - unTransaction (callback (idempotentIO next)) conn + unsafeUnTransaction (callback (idempotentIO next)) conn queryStreamCol :: forall a b r. diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 8c1aae765a..11025e81b8 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -48,6 +48,7 @@ library NumericUnderscores OverloadedStrings PatternSynonyms + RankNTypes ScopedTypeVariables TupleSections TypeApplications diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 13e7f44714..0ae9010adb 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -22,6 +22,7 @@ import Data.Bifunctor (Bifunctor (bimap), second) import Data.Bitraversable (bitraverse) import qualified Data.Char as Char import Data.Either.Extra () +import Data.IORef import qualified Data.List as List import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1) import qualified Data.Map as Map @@ -66,6 +67,7 @@ import qualified Unison.Codebase.SqliteCodebase.Branch.Dependencies as BD import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import qualified Unison.Codebase.SqliteCodebase.GitError as GitError import Unison.Codebase.SqliteCodebase.Migrations (ensureCodebaseIsUpToDate) +import qualified Unison.Codebase.SqliteCodebase.Operations as Ops2 import Unison.Codebase.SqliteCodebase.Paths import qualified Unison.Codebase.SqliteCodebase.SyncEphemeral as SyncEphemeral import Unison.Codebase.SyncMode (SyncMode) @@ -96,7 +98,7 @@ import Unison.Type (Type) import qualified Unison.Type as Type import qualified Unison.Util.Set as Set import qualified Unison.WatchKind as UF -import UnliftIO (catchIO, finally, throwIO, try) +import UnliftIO (UnliftIO (..), catchIO, finally, throwIO, try) import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import UnliftIO.Exception (catch) import UnliftIO.STM @@ -147,19 +149,20 @@ createCodebaseOrError :: m (Either Codebase1.CreateCodebaseError r) createCodebaseOrError debugName path action = do undefined - -- ifM - -- (doesFileExist $ makeCodebasePath path) - -- (pure $ Left Codebase1.CreateCodebaseAlreadyExists) - -- do - -- createDirectoryIfMissing True (makeCodebaseDirPath path) - -- withConnection (debugName ++ ".createSchema") path $ - -- runReaderT do - -- Q.createSchema - -- void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty - - -- sqliteCodebase debugName path Local action >>= \case - -- Left schemaVersion -> error ("Failed to open codebase with schema version: " ++ show schemaVersion ++ ", which is unexpected because I just created this codebase.") - -- Right result -> pure (Right result) + +-- ifM +-- (doesFileExist $ makeCodebasePath path) +-- (pure $ Left Codebase1.CreateCodebaseAlreadyExists) +-- do +-- createDirectoryIfMissing True (makeCodebaseDirPath path) +-- withConnection (debugName ++ ".createSchema") path $ +-- runReaderT do +-- Q.createSchema +-- void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty + +-- sqliteCodebase debugName path Local action >>= \case +-- Left schemaVersion -> error ("Failed to open codebase with schema version: " ++ show schemaVersion ++ ", which is unexpected because I just created this codebase.") +-- Right result -> pure (Right result) -- | Use the codebase in the provided path. -- The codebase is automatically closed when the action completes or throws an exception. @@ -179,10 +182,11 @@ withCodebaseOrError debugName dir action = do initSchemaIfNotExist :: MonadIO m => FilePath -> m () initSchemaIfNotExist path = liftIO do undefined - -- unlessM (doesDirectoryExist $ makeCodebaseDirPath path) $ - -- createDirectoryIfMissing True (makeCodebaseDirPath path) - -- unlessM (doesFileExist $ makeCodebasePath path) $ - -- withConnection "initSchemaIfNotExist" path $ runReaderT Q.createSchema + +-- unlessM (doesDirectoryExist $ makeCodebaseDirPath path) $ +-- createDirectoryIfMissing True (makeCodebaseDirPath path) +-- unlessM (doesFileExist $ makeCodebasePath path) $ +-- withConnection "initSchemaIfNotExist" path $ runReaderT Q.createSchema -- 1) buffer up the component -- 2) in the event that the component is complete, then what? @@ -190,49 +194,6 @@ initSchemaIfNotExist path = liftIO do -- if dependency not complete, -- register yourself to be written when that dependency is complete --- an entry for a single hash -data BufferEntry a = BufferEntry - { -- First, you are waiting for the cycle to fill up with all elements - -- Then, you check: are all dependencies of the cycle in the db? - -- If yes: write yourself to database and trigger check of dependents - -- If no: just wait, do nothing - beComponentTargetSize :: Maybe Word64, - beComponent :: Map Reference.Pos a, - beMissingDependencies :: Set Hash, - beWaitingDependents :: Set Hash - } - deriving (Eq, Show) - -prettyBufferEntry :: Show a => Hash -> BufferEntry a -> String -prettyBufferEntry (h :: Hash) BufferEntry {..} = - "BufferEntry " ++ show h ++ "\n" - ++ " { beComponentTargetSize = " - ++ show beComponentTargetSize - ++ "\n" - ++ " , beComponent = " - ++ if Map.size beComponent < 2 - then show $ Map.toList beComponent - else - mkString (Map.toList beComponent) (Just "\n [ ") " , " (Just "]\n") - ++ " , beMissingDependencies =" - ++ if Set.size beMissingDependencies < 2 - then show $ Set.toList beMissingDependencies - else - mkString (Set.toList beMissingDependencies) (Just "\n [ ") " , " (Just "]\n") - ++ " , beWaitingDependents =" - ++ if Set.size beWaitingDependents < 2 - then show $ Set.toList beWaitingDependents - else - mkString (Set.toList beWaitingDependents) (Just "\n [ ") " , " (Just "]\n") - ++ " }" - where - mkString :: (Foldable f, Show a) => f a -> Maybe String -> String -> Maybe String -> String - mkString as start middle end = fromMaybe "" start ++ List.intercalate middle (show <$> toList as) ++ fromMaybe "" end - -type TermBufferEntry = BufferEntry (Term Symbol Ann, Type Symbol Ann) - -type DeclBufferEntry = BufferEntry (Decl Symbol Ann) - -- | Run an action with a connection to the codebase, closing the connection on completion or -- failure. withConnection :: @@ -256,66 +217,51 @@ sqliteCodebase :: ((Codebase m Symbol Ann, Connection) -> m r) -> m (Either Codebase1.OpenCodebaseError r) sqliteCodebase debugName root localOrRemote action = do - undefined -{- - Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root + -- Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root withConnection debugName root $ \conn -> do termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable - typeOfTermCache <- Cache.semispaceCache 8192 declCache <- Cache.semispaceCache 1024 + typeOfTermCache <- Cache.semispaceCache 8192 + declCache <- Cache.semispaceCache 1024 rootBranchCache <- newTVarIO Nothing -- The v1 codebase interface has operations to read and write individual definitions -- whereas the v2 codebase writes them as complete components. These two fields buffer -- the individual definitions until a complete component has been written. - termBuffer :: TVar (Map Hash TermBufferEntry) <- newTVarIO Map.empty - declBuffer :: TVar (Map Hash DeclBufferEntry) <- newTVarIO Map.empty + termBuffer :: TVar (Map Hash Ops2.TermBufferEntry) <- newTVarIO Map.empty + declBuffer :: TVar (Map Hash Ops2.DeclBufferEntry) <- newTVarIO Map.empty declTypeCache <- Cache.semispaceCache 2048 - let getTerm :: MonadUnliftIO m => Reference.Id -> m (Maybe (Term Symbol Ann)) - getTerm (Reference.Id h1@(Cv.hash1to2 -> h2) i) = - runDB' conn do - term2 <- Ops.loadTermByReference (C.Reference.Id h2 i) - Cv.term2to1 h1 getDeclType term2 - - getDeclType :: forall m. DB m => C.Reference.Reference -> m CT.ConstructorType - getDeclType = Cache.apply declTypeCache \case - C.Reference.ReferenceBuiltin t -> - let err = - error $ - "I don't know about the builtin type ##" - ++ show t - ++ ", but I've been asked for it's ConstructorType." - in pure . fromMaybe err $ - Map.lookup (Reference.Builtin t) Builtins.builtinConstructorType - C.Reference.ReferenceDerived i -> expectDeclTypeById i + let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann)) + getTerm id = + Sqlite.runTransaction conn (Ops2.getTerm (Sqlite.idempotentIO . getDeclTypeIO) id) + + getDeclType :: C.Reference.Reference -> m CT.ConstructorType + getDeclType = + liftIO . getDeclTypeIO - expectDeclTypeById :: forall m. DB m => C.Reference.Id -> m CT.ConstructorType - expectDeclTypeById = fmap Cv.decltype2to1 . Ops.expectDeclTypeById + getDeclTypeIO :: C.Reference.Reference -> IO CT.ConstructorType + getDeclTypeIO = + Cache.apply declTypeCache \ref -> + Sqlite.runTransaction conn (Ops2.getDeclType ref) - getTypeOfTermImpl :: MonadIO m => Reference.Id -> m (Maybe (Type Symbol Ann)) + getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann)) getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined - getTypeOfTermImpl (Reference.Id (Cv.hash1to2 -> h2) i) = - runDB' conn do - type2 <- Ops.loadTypeOfTermByTermReference (C.Reference.Id h2 i) - pure $ Cv.ttype2to1 type2 - - getTermComponentWithTypes :: MonadIO m => Hash -> m (Maybe [(Term Symbol Ann, Type Symbol Ann)]) - getTermComponentWithTypes h1@(Cv.hash1to2 -> h2) = - runDB' conn $ do - tms <- Ops.loadTermComponent h2 - for tms (bitraverse (Cv.term2to1 h1 getDeclType) (pure . Cv.ttype2to1)) - - getTypeDeclaration :: MonadIO m => Reference.Id -> m (Maybe (Decl Symbol Ann)) - getTypeDeclaration (Reference.Id h1@(Cv.hash1to2 -> h2) i) = - runDB' conn do - decl2 <- Ops.loadDeclByReference (C.Reference.Id h2 i) - pure $ Cv.decl2to1 h1 decl2 - - getDeclComponent :: MonadIO m => Hash -> m (Maybe [Decl Symbol Ann]) - getDeclComponent h1@(Cv.hash1to2 -> h2) = - runDB' conn $ map (Cv.decl2to1 h1) <$> Ops.loadDeclComponent h2 - - getCycleLength :: MonadIO m => Hash -> m (Maybe Reference.CycleSize) - getCycleLength (Cv.hash1to2 -> h2) = - Sqlite.runDB conn $ Ops.getCycleLen h2 + getTypeOfTermImpl id = + Sqlite.runTransaction conn (Ops2.getTypeOfTermImpl id) + + getTermComponentWithTypes :: Hash -> m (Maybe [(Term Symbol Ann, Type Symbol Ann)]) + getTermComponentWithTypes h = + Sqlite.runTransaction conn (Ops2.getTermComponentWithTypes (Sqlite.idempotentIO . getDeclTypeIO) h) + + getTypeDeclaration :: Reference.Id -> m (Maybe (Decl Symbol Ann)) + getTypeDeclaration id = + Sqlite.runTransaction conn (Ops2.getTypeDeclaration id) + + getDeclComponent :: Hash -> m (Maybe [Decl Symbol Ann]) + getDeclComponent h = + Sqlite.runTransaction conn (Ops2.getDeclComponent h) + + getCycleLength :: Hash -> m (Maybe Reference.CycleSize) + getCycleLength h = + Sqlite.runTransaction conn (Ops2.getCycleLength h) -- putTermComponent :: MonadIO m => Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> m () -- putTerms :: MonadIO m => Map Reference.Id (Term Symbol Ann, Type Symbol Ann) -> m () -- dies horribly if missing dependencies? @@ -324,210 +270,28 @@ sqliteCodebase debugName root localOrRemote action = do -- option 2: switch codebase interface from putTerm to putTerms -- buffering can be local to the function -- option 3: switch from putTerm to putTermComponent -- needs to buffer dependencies non-locally (or require application to manage + die horribly) - putTerm :: MonadUnliftIO m => Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m () + putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m () putTerm id tm tp | debug && trace (show "SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined - putTerm (Reference.Id h@(Cv.hash1to2 -> h2) i) tm tp = - Sqlite.runDB conn do - Sqlite.withSavepoint "putTerm" \_rollback -> do - unlessM - (Ops.objectExistsForHash h2 >>= if debug then \b -> do traceM $ "objectExistsForHash " ++ show h2 ++ " = " ++ show b; pure b else pure) - ( withBuffer termBuffer h \be@(BufferEntry size comp missing waiting) -> do - Monad.when debug $ traceM $ "adding to BufferEntry" ++ show be - let termDependencies = Set.toList $ Term.termDependencies tm - -- update the component target size if we encounter any higher self-references - let size' = max size (Just $ biggestSelfReference + 1) - where - biggestSelfReference = - maximum1 $ - i :| [i' | Reference.Derived h' i' <- termDependencies, h == h'] - let comp' = Map.insert i (tm, tp) comp - -- for the component element that's been passed in, add its dependencies to missing' - missingTerms' <- - filterM - (fmap not . Ops.objectExistsForHash . Cv.hash1to2) - [h | Reference.Derived h _i <- termDependencies] - missingTypes' <- - filterM (fmap not . Ops.objectExistsForHash . Cv.hash1to2) $ - [h | Reference.Derived h _i <- Set.toList $ Term.typeDependencies tm] - ++ [h | Reference.Derived h _i <- Set.toList $ Type.dependencies tp] - let missing' = missing <> Set.fromList (missingTerms' <> missingTypes') - -- notify each of the dependencies that h depends on them. - traverse (addBufferDependent h termBuffer) missingTerms' - traverse (addBufferDependent h declBuffer) missingTypes' - putBuffer termBuffer h (BufferEntry size' comp' missing' waiting) - tryFlushTermBuffer h - ) - - putBuffer :: forall a m. (MonadIO m, Show a) => TVar (Map Hash (BufferEntry a)) -> Hash -> BufferEntry a -> m () - putBuffer tv h e = do - Monad.when debug $ traceM $ "putBuffer " ++ prettyBufferEntry h e - atomically $ modifyTVar tv (Map.insert h e) - - withBuffer :: forall a b m. (MonadIO m, Show a) => TVar (Map Hash (BufferEntry a)) -> Hash -> (BufferEntry a -> m b) -> m b - withBuffer tv h f = do - Monad.when debug $ readTVarIO tv >>= \tv -> traceM $ "tv = " ++ show tv - Map.lookup h <$> readTVarIO tv >>= \case - Just e -> do - Monad.when debug $ traceM $ "SqliteCodebase.withBuffer " ++ prettyBufferEntry h e - f e - Nothing -> do - Monad.when debug $ traceM $ "SqliteCodebase.with(new)Buffer " ++ show h - f (BufferEntry Nothing Map.empty Set.empty Set.empty) - - removeBuffer :: forall a m. (MonadIO m, Show a) => TVar (Map Hash (BufferEntry a)) -> Hash -> m () - removeBuffer _tv h | debug && trace ("removeBuffer " ++ show h) False = undefined - removeBuffer tv h = do - Monad.when debug $ readTVarIO tv >>= \tv -> traceM $ "before delete: " ++ show tv - atomically $ modifyTVar tv (Map.delete h) - Monad.when debug $ readTVarIO tv >>= \tv -> traceM $ "after delete: " ++ show tv - - addBufferDependent :: forall a m. (MonadIO m, Show a) => Hash -> TVar (Map Hash (BufferEntry a)) -> Hash -> m () - addBufferDependent dependent tv dependency = withBuffer tv dependency \be -> do - putBuffer tv dependency be {beWaitingDependents = Set.insert dependent $ beWaitingDependents be} - tryFlushBuffer :: - forall a m. - (DB m, Show a) => - TVar (Map Hash (BufferEntry a)) -> - (H2.Hash -> [a] -> m ()) -> - (Hash -> m ()) -> - Hash -> - m () - tryFlushBuffer _ _ _ h | debug && trace ("tryFlushBuffer " ++ show h) False = undefined - tryFlushBuffer buf saveComponent tryWaiting h@(Cv.hash1to2 -> h2) = - -- skip if it has already been flushed - unlessM (Ops.objectExistsForHash h2) $ withBuffer buf h try - where - try (BufferEntry size comp (Set.delete h -> missing) waiting) = case size of - Just size -> do - missing' <- - filterM - (fmap not . Ops.objectExistsForHash . Cv.hash1to2) - (toList missing) - Monad.when debug do - traceM $ "tryFlushBuffer.missing' = " ++ show missing' - traceM $ "tryFlushBuffer.size = " ++ show size - traceM $ "tryFlushBuffer.length comp = " ++ show (length comp) - if null missing' && size == fromIntegral (length comp) - then do - saveComponent h2 (toList comp) - removeBuffer buf h - Monad.when debug $ traceM $ "tryFlushBuffer.notify waiting " ++ show waiting - traverse_ tryWaiting waiting - else -- update - - putBuffer buf h $ - BufferEntry (Just size) comp (Set.fromList missing') waiting - Nothing -> - -- it's never even been added, so there's nothing to do. - pure () - - addTermComponentTypeIndex :: forall m. DB m => ObjectId -> [Type Symbol Ann] -> m () - addTermComponentTypeIndex oId types = for_ (types `zip` [0 ..]) \(tp, i) -> do - let self = C.Referent.RefId (C.Reference.Id oId i) - typeForIndexing = Hashing.typeToReference tp - typeMentionsForIndexing = Hashing.typeToReferenceMentions tp - Ops.addTypeToIndexForTerm self (Cv.reference1to2 typeForIndexing) - Ops.addTypeMentionsToIndexForTerm self (Set.map Cv.reference1to2 typeMentionsForIndexing) - - addDeclComponentTypeIndex :: forall m. DB m => ObjectId -> [[Type Symbol Ann]] -> m () - addDeclComponentTypeIndex oId ctorss = - for_ (ctorss `zip` [0 ..]) \(ctors, i) -> - for_ (ctors `zip` [0 ..]) \(tp, j) -> do - let self = C.Referent.ConId (C.Reference.Id oId i) j - typeForIndexing = Hashing.typeToReference tp - typeMentionsForIndexing = Hashing.typeToReferenceMentions tp - Ops.addTypeToIndexForTerm self (Cv.reference1to2 typeForIndexing) - Ops.addTypeMentionsToIndexForTerm self (Set.map Cv.reference1to2 typeMentionsForIndexing) - - tryFlushTermBuffer :: forall m. DB m => Hash -> m () - tryFlushTermBuffer h | debug && trace ("tryFlushTermBuffer " ++ show h) False = undefined - tryFlushTermBuffer h = - tryFlushBuffer - termBuffer - ( \h2 component -> do - oId <- - Ops.saveTermComponent h2 $ - fmap (bimap (Cv.term1to2 h) Cv.ttype1to2) component - addTermComponentTypeIndex oId (fmap snd component) - ) - tryFlushTermBuffer - h - - tryFlushDeclBuffer :: forall m. DB m => Hash -> m () - tryFlushDeclBuffer h | debug && trace ("tryFlushDeclBuffer " ++ show h) False = undefined - tryFlushDeclBuffer h = - tryFlushBuffer - declBuffer - ( \h2 component -> do - oId <- Ops.saveDeclComponent h2 $ fmap (Cv.decl1to2 h) component - addDeclComponentTypeIndex oId $ - fmap (map snd . Decl.constructors . Decl.asDataDecl) component - ) - (\h -> tryFlushTermBuffer h >> tryFlushDeclBuffer h) - h - - putTypeDeclaration :: MonadUnliftIO m => Reference.Id -> Decl Symbol Ann -> m () - putTypeDeclaration (Reference.Id h@(Cv.hash1to2 -> h2) i) decl = - Sqlite.runDB conn do - Sqlite.withSavepoint "putTypeDeclaration" \_rollback -> do - unlessM - (Ops.objectExistsForHash h2) - ( withBuffer declBuffer h \(BufferEntry size comp missing waiting) -> do - let declDependencies = Set.toList $ Decl.declDependencies decl - let size' = max size (Just $ biggestSelfReference + 1) - where - biggestSelfReference = - maximum1 $ - i :| [i' | Reference.Derived h' i' <- declDependencies, h == h'] - let comp' = Map.insert i decl comp - moreMissing <- - filterM (fmap not . Ops.objectExistsForHash . Cv.hash1to2) $ - [h | Reference.Derived h _i <- declDependencies] - let missing' = missing <> Set.fromList moreMissing - traverse (addBufferDependent h declBuffer) moreMissing - putBuffer declBuffer h (BufferEntry size' comp' missing' waiting) - tryFlushDeclBuffer h - ) - - getRootBranch :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, Branch m)) -> m (Branch m) + putTerm id tm tp = + Sqlite.runTransaction conn (Ops2.putTerm termBuffer declBuffer id tm tp) + + putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> m () + putTypeDeclaration id decl = + Sqlite.runTransaction conn (Ops2.putTypeDeclaration termBuffer declBuffer id decl) + + getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> m (Branch m) getRootBranch rootBranchCache = - readTVarIO rootBranchCache >>= \case - Nothing -> forceReload - Just (v, b) -> do - -- check to see if root namespace hash has been externally modified - -- and reload it if necessary - v' <- Sqlite.Transaction.runTransaction conn Sqlite.getDataVersion - if v == v' - then pure b - else do - newRootHash <- Sqlite.runDB conn Ops.expectRootCausalHash - if Branch.headHash b == Cv.branchHash2to1 newRootHash - then pure b - else do - traceM $ "database was externally modified (" ++ show v ++ " -> " ++ show v' ++ ")" - forceReload - where - forceReload = time "Get root branch" do - b <- - Sqlite.runDB conn - . fmap (Branch.transform (Sqlite.runDB conn)) - $ Cv.causalbranch2to1 getDeclType =<< Ops.expectRootCausal - v <- Sqlite.Transaction.runTransaction conn Sqlite.getDataVersion - atomically (writeTVar rootBranchCache (Just (v, b))) - pure b - - getRootBranchExists :: MonadIO m => m Bool + Branch.transform (Sqlite.runTransaction conn) <$> Sqlite.runTransaction conn (Ops2.getRootBranch (Sqlite.idempotentIO . getDeclTypeIO) rootBranchCache) + + getRootBranchExists :: m Bool getRootBranchExists = - isJust <$> Sqlite.runDB conn (Ops.loadRootCausalHash) + Sqlite.runTransaction conn Ops2.getRootBranchExists - putRootBranch :: MonadUnliftIO m => TVar (Maybe (Sqlite.DataVersion, Branch m)) -> Branch m -> m () + putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> Branch m -> m () putRootBranch rootBranchCache branch1 = - -- todo: check to see if root namespace hash has been externally modified - -- and do something (merge?) it if necessary. But for now, we just overwrite it. - Sqlite.runDB conn do - Sqlite.withSavepoint "putRootBranch" \_rollback -> do - void (Ops.saveRootBranch (Cv.causalbranch1to2 (Branch.transform lift branch1))) - atomically $ modifyTVar rootBranchCache (fmap . second $ const branch1) + withRunInIO \runInIO -> + Sqlite.runTransaction conn do + Ops2.putRootBranch rootBranchCache (Branch.transform (Sqlite.idempotentIO . runInIO) branch1) rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.Hash)) rootBranchUpdates _rootBranchCache = do @@ -570,94 +334,69 @@ sqliteCodebase debugName root localOrRemote action = do -- if this blows up on cromulent hashes, then switch from `hashToHashId` -- to one that returns Maybe. - getBranchForHash :: MonadIO m => Branch.Hash -> m (Maybe (Branch m)) - getBranchForHash h = Sqlite.runDB conn do - Ops.loadCausalBranchByCausalHash (Cv.branchHash1to2 h) >>= \case - Just b -> - pure . Just . Branch.transform (Sqlite.runDB conn) - =<< Cv.causalbranch2to1 getDeclType b - Nothing -> pure Nothing - - putBranch :: MonadUnliftIO m => Branch m -> m () + getBranchForHash :: Branch.Hash -> m (Maybe (Branch m)) + getBranchForHash h = + fmap (Branch.transform (Sqlite.runTransaction conn)) <$> Sqlite.runTransaction conn (Ops2.getBranchForHash (Sqlite.idempotentIO . getDeclTypeIO) h) + + putBranch :: Branch m -> m () putBranch branch = - Sqlite.runDB conn do - Sqlite.withSavepoint "putBranch" \_rollback -> - putBranch' branch + withRunInIO \runInIO -> + Sqlite.runTransaction conn (Ops2.putBranch (Branch.transform (Sqlite.idempotentIO . runInIO) branch)) - isCausalHash :: MonadIO m => Branch.Hash -> m Bool - isCausalHash = Sqlite.runDB conn . isCausalHash' + isCausalHash :: Branch.Hash -> m Bool + isCausalHash h = + Sqlite.runTransaction conn (Ops2.isCausalHash h) - getPatch :: MonadIO m => Branch.EditHash -> m (Maybe Patch) + getPatch :: Branch.EditHash -> m (Maybe Patch) getPatch h = - Sqlite.runDB conn . runMaybeT $ - MaybeT (Q.loadPatchObjectIdForPrimaryHash (Cv.patchHash1to2 h)) - >>= Ops.expectPatch - <&> Cv.patch2to1 + Sqlite.runTransaction conn (Ops2.getPatch h) - putPatch :: MonadUnliftIO m => Branch.EditHash -> Patch -> m () + putPatch :: Branch.EditHash -> Patch -> m () putPatch h p = - Sqlite.runDB conn do - Sqlite.withSavepoint "putPatch" \_rollback -> do - void $ Ops.savePatch (Cv.patchHash1to2 h) (Cv.patch1to2 p) + Sqlite.runTransaction conn (Ops2.putPatch h p) - patchExists :: MonadIO m => Branch.EditHash -> m Bool - patchExists = Sqlite.runDB conn . patchExists' + patchExists :: Branch.EditHash -> m Bool + patchExists h = + Sqlite.runTransaction conn (Ops2.patchExists h) - dependentsImpl :: MonadIO m => Reference -> m (Set Reference.Id) + dependentsImpl :: Reference -> m (Set Reference.Id) dependentsImpl r = - Sqlite.runDB conn $ - Set.map Cv.referenceid2to1 - <$> Ops.dependents (Cv.reference1to2 r) + Sqlite.runTransaction conn (Ops2.dependentsImpl r) - dependentsOfComponentImpl :: MonadIO m => Hash -> m (Set Reference.Id) + dependentsOfComponentImpl :: Hash -> m (Set Reference.Id) dependentsOfComponentImpl h = - Sqlite.runDB conn $ - Set.map Cv.referenceid2to1 - <$> Ops.dependentsOfComponent (Cv.hash1to2 h) + Sqlite.runTransaction conn (Ops2.dependentsOfComponentImpl h) - syncFromDirectory :: MonadUnliftIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m () + syncFromDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m () syncFromDirectory srcRoot _syncMode b = do withConnection (debugName ++ ".sync.src") srcRoot $ \srcConn -> do - flip State.evalStateT emptySyncProgressState $ do - syncInternal syncProgress srcConn conn $ Branch.transform lift b + progressStateRef <- liftIO (newIORef emptySyncProgressState) + syncInternal (syncProgress progressStateRef) srcConn conn b - syncToDirectory :: MonadUnliftIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m () + syncToDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m () syncToDirectory destRoot _syncMode b = - withConnection (debugName ++ ".sync.dest") destRoot $ \destConn -> - flip State.evalStateT emptySyncProgressState $ do - initSchemaIfNotExist destRoot - syncInternal syncProgress conn destConn $ Branch.transform lift b + withConnection (debugName ++ ".sync.dest") destRoot $ \destConn -> do + progressStateRef <- liftIO (newIORef emptySyncProgressState) + initSchemaIfNotExist destRoot + syncInternal (syncProgress progressStateRef) conn destConn b - watches :: MonadIO m => UF.WatchKind -> m [Reference.Id] + watches :: UF.WatchKind -> m [Reference.Id] watches w = - Sqlite.runDB conn $ - Ops.listWatches (Cv.watchKind1to2 w) - <&> fmap Cv.referenceid2to1 - - getWatch :: MonadIO m => UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann)) - getWatch k r@(Reference.Id h _i) - | elem k standardWatchKinds = - runDB' conn $ - Ops.loadWatch (Cv.watchKind1to2 k) (Cv.referenceid1to2 r) - >>= Cv.term2to1 h getDeclType - getWatch _unknownKind _ = pure Nothing - - standardWatchKinds = [UF.RegularWatch, UF.TestWatch] - - putWatch :: MonadUnliftIO m => UF.WatchKind -> Reference.Id -> Term Symbol Ann -> m () - putWatch k r@(Reference.Id h _i) tm - | elem k standardWatchKinds = - Sqlite.runDB conn $ - Ops.saveWatch - (Cv.watchKind1to2 k) - (Cv.referenceid1to2 r) - (Cv.term1to2 h tm) - putWatch _unknownKind _ _ = pure () - - clearWatches :: MonadIO m => m () - clearWatches = Sqlite.runDB conn Ops.clearWatches - - getReflog :: MonadIO m => m [Reflog.Entry Branch.Hash] + Sqlite.runTransaction conn (Ops2.watches w) + + getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann)) + getWatch k r = + Sqlite.runTransaction conn (Ops2.getWatch (Sqlite.idempotentIO . getDeclTypeIO) k r) + + putWatch :: UF.WatchKind -> Reference.Id -> Term Symbol Ann -> m () + putWatch k r tm = + Sqlite.runTransaction conn (Ops2.putWatch k r tm) + + clearWatches :: m () + clearWatches = + Sqlite.runTransaction conn Ops2.clearWatches + + getReflog :: m [Reflog.Entry Branch.Hash] getReflog = liftIO $ ( do @@ -674,7 +413,7 @@ sqliteCodebase debugName root localOrRemote action = do "I couldn't understand this line in " ++ reflogPath root ++ "\n\n" ++ Text.unpack t - appendReflog :: MonadIO m => Text -> Branch m -> Branch m -> m () + appendReflog :: Text -> Branch m -> Branch m -> m () appendReflog reason old new = liftIO $ TextIO.appendFile (reflogPath root) (t <> "\n") where @@ -683,71 +422,41 @@ sqliteCodebase debugName root localOrRemote action = do reflogPath :: CodebasePath -> FilePath reflogPath root = root "reflog" - termsOfTypeImpl :: MonadIO m => Reference -> m (Set Referent.Id) + termsOfTypeImpl :: Reference -> m (Set Referent.Id) termsOfTypeImpl r = - Sqlite.runDB conn $ - Ops.termsHavingType (Cv.reference1to2 r) - >>= Set.traverse (Cv.referentid2to1 getDeclType) + Sqlite.runTransaction conn (Ops2.termsOfTypeImpl (Sqlite.idempotentIO . getDeclTypeIO) r) - termsMentioningTypeImpl :: MonadIO m => Reference -> m (Set Referent.Id) + termsMentioningTypeImpl :: Reference -> m (Set Referent.Id) termsMentioningTypeImpl r = - Sqlite.runDB conn $ - Ops.termsMentioningType (Cv.reference1to2 r) - >>= Set.traverse (Cv.referentid2to1 getDeclType) - - hashLength :: Applicative m => m Int - hashLength = pure 10 - - branchHashLength :: Applicative m => m Int - branchHashLength = pure 10 - - defnReferencesByPrefix :: MonadIO m => OT.ObjectType -> ShortHash -> m (Set Reference.Id) - defnReferencesByPrefix _ (ShortHash.Builtin _) = pure mempty - defnReferencesByPrefix ot (ShortHash.ShortHash prefix (fmap Cv.shortHashSuffix1to2 -> cycle) _cid) = - Monoid.fromMaybe <$> runDB' conn do - refs <- do - Ops.componentReferencesByPrefix ot prefix cycle - >>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId) - >>= pure . Set.fromList - - pure $ Set.map Cv.referenceid2to1 refs - - termReferencesByPrefix :: MonadIO m => ShortHash -> m (Set Reference.Id) - termReferencesByPrefix = defnReferencesByPrefix OT.TermComponent - - declReferencesByPrefix :: MonadIO m => ShortHash -> m (Set Reference.Id) - declReferencesByPrefix = defnReferencesByPrefix OT.DeclComponent - - referentsByPrefix :: MonadIO m => ShortHash -> m (Set Referent.Id) - referentsByPrefix SH.Builtin {} = pure mempty - referentsByPrefix (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to2 -> cycle) cid) = Sqlite.runDB conn do - termReferents <- - Ops.termReferentsByPrefix prefix cycle - >>= traverse (Cv.referentid2to1 getDeclType) - declReferents' <- Ops.declReferentsByPrefix prefix cycle (read . Text.unpack <$> cid) - let declReferents = - [ Referent.ConId (ConstructorReference (Reference.Id (Cv.hash2to1 h) pos) (fromIntegral cid)) (Cv.decltype2to1 ct) - | (h, pos, ct, cids) <- declReferents', - cid <- cids - ] - pure . Set.fromList $ termReferents <> declReferents - - branchHashesByPrefix :: MonadIO m => ShortBranchHash -> m (Set Branch.Hash) - branchHashesByPrefix sh = Sqlite.runDB conn do - -- given that a Branch is shallow, it's really `CausalHash` that you'd - -- refer to to specify a full namespace w/ history. - -- but do we want to be able to refer to a namespace without its history? - cs <- Ops.causalHashesByPrefix (Cv.sbh1to2 sh) - pure $ Set.map (Causal.RawHash . Cv.hash2to1 . unCausalHash) cs - - sqlLca :: MonadIO m => Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash) + Sqlite.runTransaction conn (Ops2.termsMentioningTypeImpl (Sqlite.idempotentIO . getDeclTypeIO) r) + + hashLength :: m Int + hashLength = + Sqlite.runTransaction conn Ops2.hashLength + + branchHashLength :: m Int + branchHashLength = + Sqlite.runTransaction conn Ops2.branchHashLength + + termReferencesByPrefix :: ShortHash -> m (Set Reference.Id) + termReferencesByPrefix sh = + Sqlite.runTransaction conn (Ops2.termReferencesByPrefix sh) + + declReferencesByPrefix :: ShortHash -> m (Set Reference.Id) + declReferencesByPrefix sh = + Sqlite.runTransaction conn (Ops2.declReferencesByPrefix sh) + + referentsByPrefix :: ShortHash -> m (Set Referent.Id) + referentsByPrefix sh = + Sqlite.runTransaction conn (Ops2.referentsByPrefix (Sqlite.idempotentIO . getDeclTypeIO) sh) + + branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.Hash) + branchHashesByPrefix sh = + Sqlite.runTransaction conn (Ops2.branchHashesByPrefix sh) + + sqlLca :: Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash) sqlLca h1 h2 = - liftIO $ - withConnection (debugName ++ ".lca.left") root $ \c1 -> do - withConnection (debugName ++ ".lca.right") root $ \c2 -> do - Sqlite.runDB conn - . (fmap . fmap) Cv.causalHash2to1 - $ Ops.lca (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) c1 c2 + Sqlite.runTransaction conn (Ops2.sqlLca h1 h2) let codebase = C.Codebase (Cache.applyDefined termCache getTerm) @@ -790,8 +499,7 @@ sqliteCodebase debugName root localOrRemote action = do branchHashLength branchHashesByPrefix (Just sqlLca) - (Just \l r -> Sqlite.runDB conn $ fromJust <$> before l r) - + (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> Ops2.before l r) let finalizer :: MonadIO m => m () finalizer = do decls <- readTVarIO declBuffer @@ -810,43 +518,23 @@ sqliteCodebase debugName root localOrRemote action = do Left err -> pure $ Left err Right () -> Right <$> action (codebase, conn) --- well one or the other. :zany_face: the thinking being that they wouldn't hash-collide -termExists', declExists' :: MonadIO m => Hash -> ReaderT Connection m Bool -termExists' = fmap isJust . Q.loadObjectIdForPrimaryHash . Cv.hash1to2 -declExists' = termExists' - -patchExists' :: MonadIO m => Branch.EditHash -> ReaderT Connection m Bool -patchExists' h = fmap isJust $ Q.loadPatchObjectIdForPrimaryHash (Cv.patchHash1to2 h) - -putBranch' :: MonadIO m => Branch m -> ReaderT Connection m () -putBranch' branch1 = - void . Ops.saveBranch . Cv.causalbranch1to2 $ - Branch.transform lift branch1 - -isCausalHash' :: MonadIO m => Branch.Hash -> ReaderT Connection m Bool -isCausalHash' (Causal.RawHash h) = - Q.loadHashIdByHash (Cv.hash1to2 h) >>= \case - Nothing -> pure False - Just hId -> Q.isCausalHash hId - -before :: (MonadIO m, DB m) => Branch.Hash -> Branch.Hash -> m (Maybe Bool) -before h1 h2 = - Ops.before (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) - syncInternal :: forall m. - MonadIO m => + MonadUnliftIO m => Sync.Progress m Sync22.Entity -> Connection -> Connection -> Branch m -> m () syncInternal progress srcConn destConn b = time "syncInternal" do + UnliftIO runInIO <- askUnliftIO + -- We start a savepoint on the src connection because it seemed to speed things up. -- Mitchell says: that doesn't sound right... why would that be the case? -- TODO: look into this; this connection should be used only for reads. liftIO (Sqlite.Connection.savepoint srcConn "sync") liftIO (Sqlite.Connection.savepoint destConn "sync") + -- FIXME don't savepoint above, instead BEGIN result <- runExceptT do let syncEnv = Sync22.Env srcConn destConn (16 * 1024 * 1024) -- we want to use sync22 wherever possible @@ -859,8 +547,6 @@ syncInternal progress srcConn destConn b = time "syncInternal" do let r :: forall m a. (ReaderT Sync22.Env m a -> m a) r = flip runReaderT syncEnv processBranches :: - forall m. - MonadIO m => Sync.Sync (ReaderT Sync22.Env (ExceptT Sync22.Error m)) Sync22.Entity -> Sync.Progress (ReaderT Sync22.Env (ExceptT Sync22.Error m)) Sync22.Entity -> [Entity m] -> @@ -871,14 +557,14 @@ syncInternal progress srcConn destConn b = time "syncInternal" do traceM $ "processBranches " ++ show b0 traceM $ " queue: " ++ show rest ifM @(ExceptT Sync22.Error m) - (lift . Sqlite.runDB destConn $ isCausalHash' h) + (liftIO (Sqlite.unsafeUnTransaction (Ops2.isCausalHash h) destConn)) do when debugProcessBranches $ traceM $ " " ++ show b0 ++ " already exists in dest db" processBranches sync progress rest do when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in dest db" let h2 = CausalHash . Cv.hash1to2 $ Causal.unRawHash h - lift (Sqlite.runDB srcConn (Q.loadCausalHashIdByCausalHash h2)) >>= \case + liftIO (Sqlite.unsafeUnTransaction (Q.loadCausalHashIdByCausalHash h2) srcConn) >>= \case Just chId -> do when debugProcessBranches $ traceM $ " " ++ show b0 ++ " exists in source db, so delegating to direct sync" r $ Sync.sync' sync progress [Sync22.C chId] @@ -892,29 +578,32 @@ syncInternal progress srcConn destConn b = time "syncInternal" do traceM $ " terms: " ++ show ts traceM $ " decls: " ++ show ds traceM $ " edits: " ++ show es - (cs, es, ts, ds) <- lift $ Sqlite.runDB destConn do - cs <- filterM (fmap not . isCausalHash' . fst) branchDeps - es <- filterM (fmap not . patchExists') es - ts <- filterM (fmap not . termExists') ts - ds <- filterM (fmap not . declExists') ds + (cs, es, ts, ds) <- liftIO $ flip Sqlite.unsafeUnTransaction destConn do + cs <- filterM (fmap not . Ops2.isCausalHash . fst) branchDeps + es <- filterM (fmap not . Ops2.patchExists) es + ts <- filterM (fmap not . Ops2.termExists) ts + ds <- filterM (fmap not . Ops2.declExists) ds pure (cs, es, ts, ds) if null cs && null es && null ts && null ds then do - lift . Sqlite.runDB destConn $ putBranch' b - processBranches @m sync progress rest + liftIO (Sqlite.unsafeUnTransaction (Ops2.putBranch (Branch.transform (Sqlite.idempotentIO . runInIO) b)) destConn) + processBranches sync progress rest else do let bs = map (uncurry B) cs os = map O (es <> ts <> ds) - processBranches @m sync progress (os ++ bs ++ b0 : rest) + processBranches sync progress (os ++ bs ++ b0 : rest) processBranches sync progress (O h : rest) = do when debugProcessBranches $ traceM $ "processBranches O " ++ take 10 (show h) - oId <- Sqlite.runDB srcConn (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId) + oId <- + liftIO do + Sqlite.unsafeUnTransaction (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId) srcConn r $ Sync.sync' sync progress [Sync22.O oId] processBranches sync progress rest sync <- se . r $ Sync22.sync22 let progress' = Sync.transformProgress (lift . lift) progress bHash = Branch.headHash b se $ time "SyncInternal.processBranches" $ processBranches sync progress' [B bHash (pure b)] + -- FIXME COMMIT/ROLLBACK here, no savepoint so no release let onSuccess a = do liftIO (Sqlite.Connection.release destConn "sync") pure a @@ -930,9 +619,6 @@ syncInternal progress srcConn destConn b = time "syncInternal" do liftIO (Sqlite.Connection.release srcConn "sync") either onFailure onSuccess result -runDB' :: MonadIO m => Connection -> MaybeT (ReaderT Connection m) a -> m (Maybe a) -runDB' conn = Sqlite.runDB conn . runMaybeT - data Entity m = B Branch.Hash (m (Branch m)) | O Hash @@ -950,8 +636,8 @@ data SyncProgressState = SyncProgressState emptySyncProgressState :: SyncProgressState emptySyncProgressState = SyncProgressState (Just mempty) (Right mempty) (Right mempty) -syncProgress :: (MonadIO m, MonadState SyncProgressState m) => Sync.Progress m Sync22.Entity -syncProgress = Sync.Progress need done warn allDone +syncProgress :: forall m. MonadIO m => IORef SyncProgressState -> Sync.Progress m Sync22.Entity +syncProgress progressStateRef = Sync.Progress (liftIO . need) (liftIO . done) (liftIO . warn) (liftIO allDone) where quiet = False maxTrackedHashCount = 1024 * 1024 @@ -961,51 +647,50 @@ syncProgress = Sync.Progress need done warn allDone SyncProgressState (Just need) (Right done) (Right warn) -> Set.size need + Set.size done + Set.size warn SyncProgressState _ _ _ -> undefined - need, done, warn :: (MonadState SyncProgressState m, MonadIO m) => Sync22.Entity -> m () + need, done, warn :: Sync22.Entity -> IO () need h = do - unless quiet $ Monad.whenM (State.gets size <&> (== 0)) $ liftIO $ putStr "\n" - State.get >>= \case + unless quiet $ Monad.whenM (readIORef progressStateRef <&> (== 0) . size) $ putStr "\n" + readIORef progressStateRef >>= \case SyncProgressState Nothing Left {} Left {} -> pure () SyncProgressState (Just need) (Right done) (Right warn) -> if Set.size need + Set.size done + Set.size warn > maxTrackedHashCount - then State.put $ SyncProgressState Nothing (Left $ Set.size done) (Left $ Set.size warn) + then writeIORef progressStateRef $ SyncProgressState Nothing (Left $ Set.size done) (Left $ Set.size warn) else if Set.member h done || Set.member h warn then pure () - else State.put $ SyncProgressState (Just $ Set.insert h need) (Right done) (Right warn) + else writeIORef progressStateRef $ SyncProgressState (Just $ Set.insert h need) (Right done) (Right warn) SyncProgressState _ _ _ -> undefined unless quiet printSynced done h = do - unless quiet $ Monad.whenM (State.gets size <&> (== 0)) $ liftIO $ putStr "\n" - State.get >>= \case + unless quiet $ Monad.whenM (readIORef progressStateRef <&> (== 0) . size) $ putStr "\n" + readIORef progressStateRef >>= \case SyncProgressState Nothing (Left done) warn -> - State.put $ SyncProgressState Nothing (Left (done + 1)) warn + writeIORef progressStateRef $ SyncProgressState Nothing (Left (done + 1)) warn SyncProgressState (Just need) (Right done) warn -> - State.put $ SyncProgressState (Just $ Set.delete h need) (Right $ Set.insert h done) warn + writeIORef progressStateRef $ SyncProgressState (Just $ Set.delete h need) (Right $ Set.insert h done) warn SyncProgressState _ _ _ -> undefined unless quiet printSynced warn h = do - unless quiet $ Monad.whenM (State.gets size <&> (== 0)) $ liftIO $ putStr "\n" - State.get >>= \case + unless quiet $ Monad.whenM (readIORef progressStateRef <&> (== 0) . size) $ putStr "\n" + readIORef progressStateRef >>= \case SyncProgressState Nothing done (Left warn) -> - State.put $ SyncProgressState Nothing done (Left $ warn + 1) + writeIORef progressStateRef $ SyncProgressState Nothing done (Left $ warn + 1) SyncProgressState (Just need) done (Right warn) -> - State.put $ SyncProgressState (Just $ Set.delete h need) done (Right $ Set.insert h warn) + writeIORef progressStateRef $ SyncProgressState (Just $ Set.delete h need) done (Right $ Set.insert h warn) SyncProgressState _ _ _ -> undefined unless quiet printSynced allDone = do - State.get >>= liftIO . putStrLn . renderState (" " ++ "Done syncing ") + readIORef progressStateRef >>= putStrLn . renderState (" " ++ "Done syncing ") - printSynced :: (MonadState SyncProgressState m, MonadIO m) => m () + printSynced :: IO () printSynced = - State.get >>= \s -> - liftIO $ - finally - do ANSI.hideCursor; putStr . renderState (" " ++ "Synced ") $ s - ANSI.showCursor + readIORef progressStateRef >>= \s -> + finally + do ANSI.hideCursor; putStr . renderState (" " ++ "Synced ") $ s + ANSI.showCursor renderState :: String -> SyncProgressState -> String renderState prefix = \case @@ -1107,31 +792,37 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift Left e -> pure $ Left e Right newBranch -> do Sqlite.Connection.withSavepoint destConn "push" \_rollback -> - throwExceptT $ doSync codebaseStatus (Git.gitDirToPath pushStaging) srcConn destConn newBranch + doSync codebaseStatus (Git.gitDirToPath pushStaging) srcConn destConn newBranch pure (Right newBranch) for newBranchOrErr $ push pushStaging repo pure newBranchOrErr where readRepo :: ReadRepo readRepo = writeToRead repo - doSync :: CodebaseStatus -> FilePath -> Connection -> Connection -> Branch m -> ExceptT C.GitError m () + doSync :: CodebaseStatus -> FilePath -> Connection -> Connection -> Branch m -> m () doSync codebaseStatus remotePath srcConn destConn newBranch = do - _ <- - flip State.execStateT emptySyncProgressState $ - syncInternal syncProgress srcConn destConn (Branch.transform (lift . lift) newBranch) - when setRoot $ overwriteRoot codebaseStatus remotePath destConn newBranch - overwriteRoot :: forall n. MonadIO n => CodebaseStatus -> FilePath -> Connection -> Branch m -> ExceptT C.GitError n () - overwriteRoot codebaseStatus remotePath destConn newBranch = do + progressStateRef <- liftIO (newIORef emptySyncProgressState) + _ <- syncInternal (syncProgress progressStateRef) srcConn destConn newBranch + when setRoot . liftIO $ + Sqlite.runTransactionWithAbort + destConn + (\abort -> overwriteRoot abort codebaseStatus remotePath newBranch) + overwriteRoot :: + (forall e x. Exception e => e -> Sqlite.Transaction x) -> + CodebaseStatus -> + FilePath -> + Branch m -> + Sqlite.Transaction () + overwriteRoot abort codebaseStatus remotePath newBranch = do let newBranchHash = Branch.headHash newBranch case codebaseStatus of ExistingCodebase -> do -- the call to runDB "handles" the possible DB error by bombing - maybeOldRootHash <- fmap Cv.branchHash2to1 <$> Sqlite.runDB destConn Ops.loadRootCausalHash + maybeOldRootHash <- fmap Cv.branchHash2to1 <$> Ops.loadRootCausalHash case maybeOldRootHash of - Nothing -> Sqlite.runDB destConn $ do - setRepoRoot newBranchHash - Just oldRootHash -> Sqlite.runDB destConn $ do - before oldRootHash newBranchHash >>= \case + Nothing -> setRepoRoot newBranchHash + Just oldRootHash -> do + Ops2.before oldRootHash newBranchHash >>= \case Nothing -> error $ "I couldn't find the hash " ++ show newBranchHash @@ -1140,14 +831,13 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift ++ " in " ++ show remotePath ++ "." - Just False -> do - lift . throwError . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo + Just False -> + abort . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo Just True -> pure () CreatedCodebase -> pure () - Sqlite.runDB destConn $ setRepoRoot newBranchHash - + setRepoRoot newBranchHash repoString = Text.unpack $ printWriteRepo repo - setRepoRoot :: forall m. DB m => Branch.Hash -> m () + setRepoRoot :: Branch.Hash -> Sqlite.Transaction () setRepoRoot h = do let h2 = Cv.causalHash1to2 h err = error $ "Called SqliteCodebase.setNamespaceRoot on unknown causal hash " ++ show h2 @@ -1234,4 +924,3 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift (successful, _stdout, stderr) <- gitInCaptured remotePath $ ["push", "--quiet", url] ++ maybe [] (pure @[]) mayGitBranch when (not successful) . throwIO $ GitError.PushException repo (Text.unpack stderr) pure True --} diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index b9b5e1d281..fcd2edd92e 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -539,15 +539,23 @@ standardWatchKinds = [UF.RegularWatch, UF.TestWatch] clearWatches :: Transaction () clearWatches = Ops.clearWatches -termsOfTypeImpl :: Reference -> Transaction (Set Referent.Id) -termsOfTypeImpl r = +termsOfTypeImpl :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Transaction CT.ConstructorType) -> + Reference -> + Transaction (Set Referent.Id) +termsOfTypeImpl doGetDeclType r = Ops.termsHavingType (Cv.reference1to2 r) - >>= Set.traverse (Cv.referentid2to1 getDeclType) + >>= Set.traverse (Cv.referentid2to1 doGetDeclType) -termsMentioningTypeImpl :: Reference -> Transaction (Set Referent.Id) -termsMentioningTypeImpl r = +termsMentioningTypeImpl :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Transaction CT.ConstructorType) -> + Reference -> + Transaction (Set Referent.Id) +termsMentioningTypeImpl doGetDeclType r = Ops.termsMentioningType (Cv.reference1to2 r) - >>= Set.traverse (Cv.referentid2to1 getDeclType) + >>= Set.traverse (Cv.referentid2to1 doGetDeclType) hashLength :: Transaction Int hashLength = pure 10 @@ -570,12 +578,16 @@ termReferencesByPrefix = defnReferencesByPrefix OT.TermComponent declReferencesByPrefix :: ShortHash -> Transaction (Set Reference.Id) declReferencesByPrefix = defnReferencesByPrefix OT.DeclComponent -referentsByPrefix :: ShortHash -> Transaction (Set Referent.Id) -referentsByPrefix SH.Builtin {} = pure mempty -referentsByPrefix (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to2 -> cycle) cid) = do +referentsByPrefix :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Transaction CT.ConstructorType) -> + ShortHash -> + Transaction (Set Referent.Id) +referentsByPrefix _doGetDeclType SH.Builtin {} = pure mempty +referentsByPrefix doGetDeclType (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to2 -> cycle) cid) = do termReferents <- Ops.termReferentsByPrefix prefix cycle - >>= traverse (Cv.referentid2to1 getDeclType) + >>= traverse (Cv.referentid2to1 doGetDeclType) declReferents' <- Ops.declReferentsByPrefix prefix cycle (read . Text.unpack <$> cid) let declReferents = [ Referent.ConId (ConstructorReference (Reference.Id (Cv.hash2to1 h) pos) (fromIntegral cid)) (Cv.decltype2to1 ct) @@ -596,3 +608,12 @@ sqlLca :: Branch.Hash -> Branch.Hash -> Transaction (Maybe Branch.Hash) sqlLca h1 h2 = do h3 <- Ops.lca (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) pure (Cv.causalHash2to1 <$> h3) + +-- well one or the other. :zany_face: the thinking being that they wouldn't hash-collide +termExists, declExists :: Hash -> Transaction Bool +termExists = fmap isJust . Q.loadObjectIdForPrimaryHash . Cv.hash1to2 +declExists = termExists + +before :: Branch.Hash -> Branch.Hash -> Transaction (Maybe Bool) +before h1 h2 = + Ops.before (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) From 2a47fdfa09751c94f3eed25b30c63d0e55237d19 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Thu, 7 Apr 2022 00:42:59 -0500 Subject: [PATCH 071/529] lib segment ranking --- .../src/Unison/CommandLine/OutputMessages.hs | 2 +- unison-core/src/Unison/Name.hs | 30 +++++++ unison-core/src/Unison/Names.hs | 2 +- unison-core/src/Unison/NamesWithHistory.hs | 4 +- unison-core/src/Unison/Term.hs | 2 +- .../transcripts/resolution-failures.output.md | 2 +- unison-src/transcripts/suffixes.md | 33 +++++++ unison-src/transcripts/suffixes.output.md | 89 +++++++++++++++++++ 8 files changed, 158 insertions(+), 6 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index eb57305396..a208f0d190 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -857,7 +857,7 @@ notifyUser dir o = case o of globalTip = if global then mempty - else (tip $ "Try " <> IP.makeExample (IP.names global) ["#abc123"] <> " to see more results.") + else (tip $ "Try " <> IP.makeExample (IP.names True) ["#abc123"] <> " to see more results.") formatTerms tms = P.lines . P.nonEmpty $ P.plural tms (P.blue "Term") : (go <$> tms) where diff --git a/unison-core/src/Unison/Name.hs b/unison-core/src/Unison/Name.hs index ca99afecfe..3c419b3140 100644 --- a/unison-core/src/Unison/Name.hs +++ b/unison-core/src/Unison/Name.hs @@ -37,6 +37,7 @@ module Unison.Name sortNamed, sortByText, searchBySuffix, + searchByRankedSuffix, suffixFrom, shortestUniqueSuffix, toString, @@ -58,6 +59,7 @@ import qualified Data.List as List import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as List.NonEmpty +import qualified Data.Map as Map import qualified Data.RFC5051 as RFC5051 import qualified Data.Set as Set import qualified Data.Text as Text @@ -69,6 +71,7 @@ import qualified Unison.NameSegment as NameSegment import Unison.Position (Position (..)) import Unison.Prelude import Unison.Util.Alphabetical (Alphabetical, compareAlphabetical) +import qualified Unison.Util.List as List import qualified Unison.Util.Relation as R import Unison.Var (Var) import qualified Unison.Var as Var @@ -287,6 +290,33 @@ searchBySuffix suffix rel = where orElse s1 s2 = if Set.null s1 then s2 else s1 +-- Like `searchBySuffix`, but prefers names that have fewer +-- segments equal to "lib". This is used to prefer "local" +-- names rather than names coming from libraries, which +-- are traditionally placed under a "lib" subnamespace. +-- +-- Example: foo.bar shadows lib.foo.bar +-- Example: lib.foo.bar shadows lib.blah.lib.foo.bar +searchByRankedSuffix :: (Ord r) => Name -> R.Relation Name r -> Set r +searchByRankedSuffix suffix rel = case searchBySuffix suffix rel of + rs | Set.size rs <= 1 -> rs + rs -> case Map.lookup 0 byDepth <|> Map.lookup 1 byDepth of + -- anything with more than one lib in it is treated the same + Nothing -> rs + Just rs -> Set.fromList rs + where + byDepth = + List.multimap + [ (minLibs ns, r) + | r <- toList rs, + ns <- [filter ok (toList (R.lookupRan r rel))] + ] + lib = NameSegment "lib" + libCount = length . filter (== lib) . toList . reverseSegments + minLibs [] = 0 + minLibs ns = minimum (map libCount ns) + ok name = compareSuffix suffix name == EQ + -- | Return the name segments of a name. -- -- >>> segments "a.b.c" diff --git a/unison-core/src/Unison/Names.hs b/unison-core/src/Unison/Names.hs index e56a3e63a6..bf2de39810 100644 --- a/unison-core/src/Unison/Names.hs +++ b/unison-core/src/Unison/Names.hs @@ -434,7 +434,7 @@ importing shortToLongName ns = (foldl' go (types ns) shortToLongName) where go :: (Ord r) => Relation Name r -> (Name, Name) -> Relation Name r - go m (shortname, qname) = case Name.searchBySuffix qname m of + go m (shortname, qname) = case Name.searchByRankedSuffix qname m of s | Set.null s -> m | otherwise -> R.insertManyRan shortname s (R.deleteDom shortname m) diff --git a/unison-core/src/Unison/NamesWithHistory.hs b/unison-core/src/Unison/NamesWithHistory.hs index d3a4e82121..581b4ee622 100644 --- a/unison-core/src/Unison/NamesWithHistory.hs +++ b/unison-core/src/Unison/NamesWithHistory.hs @@ -185,12 +185,12 @@ lookupHQRef :: Set r lookupHQRef which isPrefixOf hq NamesWithHistory {currentNames, oldNames} = case hq of - HQ.NameOnly n -> Name.searchBySuffix n currentRefs + HQ.NameOnly n -> Name.searchByRankedSuffix n currentRefs HQ.HashQualified n sh -> matches currentRefs `orIfEmpty` matches oldRefs where matches :: Relation Name r -> Set r matches ns = - Set.filter (isPrefixOf sh) (Name.searchBySuffix n ns) + Set.filter (isPrefixOf sh) (Name.searchByRankedSuffix n ns) HQ.HashOnly sh -> matches currentRefs `orIfEmpty` matches oldRefs where matches :: Relation Name r -> Set r diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index df66124739..c200a18fd8 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -212,7 +212,7 @@ bindSomeNames avoid ns e = bindNames (avoid <> varsToTDNR) ns e -- (if a free variable is being used as a typed hole). varsToTDNR = Set.filter notFound (freeVars e) notFound var = - Set.size (Name.searchBySuffix (Name.unsafeFromVar var) (Names.terms ns)) /= 1 + Set.size (Name.searchByRankedSuffix (Name.unsafeFromVar var) (Names.terms ns)) /= 1 -- Prepare a term for type-directed name resolution by replacing -- any remaining free variables with blanks to be resolved by TDNR diff --git a/unison-src/transcripts/resolution-failures.output.md b/unison-src/transcripts/resolution-failures.output.md index d73736df04..76e81657c7 100644 --- a/unison-src/transcripts/resolution-failures.output.md +++ b/unison-src/transcripts/resolution-failures.output.md @@ -110,7 +110,7 @@ useAmbiguousTerm = ambiguousTerm 1 | useAmbiguousTerm = ambiguousTerm - There are no constraints on its type.I found some terms in scope that have matching names and types. Maybe you meant one of these: + There are no constraints on its type. I found some terms in scope that have matching names and types. Maybe you meant one of these: - one.ambiguousTerm : ##Text - two.ambiguousTerm : ##Text diff --git a/unison-src/transcripts/suffixes.md b/unison-src/transcripts/suffixes.md index 757ed6f098..5bf6eba60b 100644 --- a/unison-src/transcripts/suffixes.md +++ b/unison-src/transcripts/suffixes.md @@ -39,6 +39,39 @@ Type-based search also benefits from this, we can just say `Nat` rather than `.b .> find : Nat -> [a] -> [a] ``` +## Preferring names not in `lib` + +Suffix-based resolution prefers names with fewer name segments that are equal to "lib". This +has the effect of preferring names defined in your project to names from dependencies of your project, and names from indirect dependencies have even lower weight. + +```unison +cool.abra.cadabra = "my project" +lib.distributed.abra.cadabra = "direct dependency 1" +lib.distributed.baz.qux = "direct dependency 2" +lib.distributed.lib.baz.qux = "indirect dependency" +``` + +```ucm +.> add +``` + +```unison +> abra.cadabra +> baz.qux +``` + +```ucm +.> view abra.cadabra +.> view baz.qux +``` + +Note that we can always still view indirect dependencies by using more name segments: + +```ucm +.> view distributed.abra.cadabra +.> names distributed.lib.baz.qux +``` + ## Corner cases If a definition is given in a scratch file, its suffixes shadow existing definitions that exist in the codebase with the same suffixes. For example: diff --git a/unison-src/transcripts/suffixes.output.md b/unison-src/transcripts/suffixes.output.md index 033b333413..6230dce9b7 100644 --- a/unison-src/transcripts/suffixes.output.md +++ b/unison-src/transcripts/suffixes.output.md @@ -56,6 +56,95 @@ Type-based search also benefits from this, we can just say `Nat` rather than `.b 2. builtin.List.take : Nat -> [a] -> [a] +``` +## Preferring names not in `lib` + +Suffix-based resolution prefers names with fewer name segments that are equal to "lib". This +has the effect of preferring names defined in your project to names from dependencies of your project, and names from indirect dependencies have even lower weight. + +```unison +cool.abra.cadabra = "my project" +lib.distributed.abra.cadabra = "direct dependency 1" +lib.distributed.baz.qux = "direct dependency 2" +lib.distributed.lib.baz.qux = "indirect dependency" +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + cool.abra.cadabra : Text + lib.distributed.abra.cadabra : Text + lib.distributed.baz.qux : Text + lib.distributed.lib.baz.qux : Text + +``` +```ucm +.> add + + โŸ I've added these definitions: + + cool.abra.cadabra : Text + lib.distributed.abra.cadabra : Text + lib.distributed.baz.qux : Text + lib.distributed.lib.baz.qux : Text + +``` +```unison +> abra.cadabra +> baz.qux +``` + +```ucm + + โœ… + + scratch.u changed. + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 1 | > abra.cadabra + โงฉ + "my project" + + 2 | > baz.qux + โงฉ + "direct dependency 2" + +``` +```ucm +.> view abra.cadabra + + cool.abra.cadabra : Text + cool.abra.cadabra = "my project" + +.> view baz.qux + + lib.distributed.baz.qux : Text + lib.distributed.baz.qux = "direct dependency 2" + +``` +Note that we can always still view indirect dependencies by using more name segments: + +```ucm +.> view distributed.abra.cadabra + + lib.distributed.abra.cadabra : Text + lib.distributed.abra.cadabra = "direct dependency 1" + +.> names distributed.lib.baz.qux + + Term + Hash: #nhup096n2s + Names: lib.distributed.lib.baz.qux + + Tip: Try `names.global #abc123` to see more results. + ``` ## Corner cases From b8a688aac4818f84c3605d4b4167f7eb85f1521d Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Thu, 7 Apr 2022 00:48:53 -0500 Subject: [PATCH 072/529] tweak output messages + refresh transcripts --- parser-typechecker/src/Unison/PrintError.hs | 2 +- unison-cli/src/Unison/CommandLine/OutputMessages.hs | 2 +- .../transcripts/ability-order-doesnt-affect-hash.output.md | 2 ++ unison-src/transcripts/fix1334.output.md | 4 ++++ unison-src/transcripts/names.output.md | 4 ++++ 5 files changed, 12 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 58e31ecc16..0578b01fe0 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -500,7 +500,7 @@ renderTypeError e env src = case e of "\n\n", annotatedAsErrorSite src termSite, case expectedType of - Type.Var' (TypeVar.Existential {}) -> "\nThere are no constraints on its type." + Type.Var' (TypeVar.Existential {}) -> "\nThere are no constraints on its type. " _ -> "\nWhatever it is, it has a type that conforms to " <> style Type1 (renderType' env expectedType) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index a208f0d190..588468780c 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -857,7 +857,7 @@ notifyUser dir o = case o of globalTip = if global then mempty - else (tip $ "Try " <> IP.makeExample (IP.names True) ["#abc123"] <> " to see more results.") + else (tip $ "Use " <> IP.makeExample (IP.names True) [] <> " to see more results.") formatTerms tms = P.lines . P.nonEmpty $ P.plural tms (P.blue "Term") : (go <$> tms) where diff --git a/unison-src/transcripts/ability-order-doesnt-affect-hash.output.md b/unison-src/transcripts/ability-order-doesnt-affect-hash.output.md index 6a606cd992..fd8ddfe35a 100644 --- a/unison-src/transcripts/ability-order-doesnt-affect-hash.output.md +++ b/unison-src/transcripts/ability-order-doesnt-affect-hash.output.md @@ -43,5 +43,7 @@ term2 _ = () Term Hash: #8hum58rlih Names: term1 term2 + + Tip: Use `names.global` to see more results. ``` diff --git a/unison-src/transcripts/fix1334.output.md b/unison-src/transcripts/fix1334.output.md index da9af85c3a..64ec7445f3 100644 --- a/unison-src/transcripts/fix1334.output.md +++ b/unison-src/transcripts/fix1334.output.md @@ -62,6 +62,8 @@ We used to have to know the full hash for a definition to be able to use the `re Term Hash: #vcfbbslncd Names: g + + Tip: Use `names.global` to see more results. .> replace f g @@ -72,6 +74,8 @@ We used to have to know the full hash for a definition to be able to use the `re Term Hash: #vcfbbslncd Names: f g + + Tip: Use `names.global` to see more results. .> view.patch diff --git a/unison-src/transcripts/names.output.md b/unison-src/transcripts/names.output.md index 18c157f075..26d9e553d1 100644 --- a/unison-src/transcripts/names.output.md +++ b/unison-src/transcripts/names.output.md @@ -22,11 +22,15 @@ intTriple = IntTriple(+1, +1, +1) Term Hash: #cp7a2qo5du#0 Names: IntTriple.IntTriple + + Tip: Use `names.global` to see more results. .> names intTriple Term Hash: #6nuu8h1ib1 Names: intTriple namespc.another.tripleInt + + Tip: Use `names.global` to see more results. ``` From ce37178aa46dc2572ea1f809b24b9d6ea7602fd9 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Thu, 7 Apr 2022 00:53:34 -0500 Subject: [PATCH 073/529] refresh a transcript --- unison-src/transcripts/suffixes.output.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-src/transcripts/suffixes.output.md b/unison-src/transcripts/suffixes.output.md index 6230dce9b7..a2804c70cd 100644 --- a/unison-src/transcripts/suffixes.output.md +++ b/unison-src/transcripts/suffixes.output.md @@ -143,7 +143,7 @@ Note that we can always still view indirect dependencies by using more name segm Hash: #nhup096n2s Names: lib.distributed.lib.baz.qux - Tip: Try `names.global #abc123` to see more results. + Tip: Use `names.global` to see more results. ``` ## Corner cases From 1d2432c77b1982125e93f7faa55b2ef8a7d205e8 Mon Sep 17 00:00:00 2001 From: Sgeo Date: Thu, 7 Apr 2022 02:25:50 -0400 Subject: [PATCH 074/529] Fix move.namespace documentation --- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index da2605a06d..f21e2eb88e 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -874,7 +874,7 @@ renameBranch = ["rename.namespace"] I.Visible [(Required, namespaceArg), (Required, newNameArg)] - "`move.namespace foo bar` renames the path `bar` to `foo`." + "`move.namespace foo bar` renames the path `foo` to `bar`." ( \case [".", dest] -> first fromString $ do dest <- Path.parseSplit' Path.definitionNameSegment dest From e3168ee30bd60a5c843564842df2d6c8522bff54 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 7 Apr 2022 10:16:13 -0600 Subject: [PATCH 075/529] Use stack test suites (#2656) * Give tests independent names and use stack test suites * Update parser-typechecker tests in ci * Update testing instructions and check.sh --- .github/workflows/ci.yaml | 6 +++--- README.md | 2 +- development.markdown | 12 ++++++++++-- lib/unison-util-relation/package.yaml | 2 +- lib/unison-util-relation/unison-util-relation.cabal | 2 +- parser-typechecker/package.yaml | 4 ++-- parser-typechecker/unison-parser-typechecker.cabal | 3 ++- scripts/check.sh | 5 +---- scripts/test.sh | 2 +- unison-cli/package.yaml | 4 ++-- unison-cli/unison-cli.cabal | 4 ++-- 11 files changed, 26 insertions(+), 20 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index c2cb6822a0..74c3c6045a 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -123,7 +123,7 @@ jobs: - name: unison-cli tests run: stack --no-terminal build --fast --test unison-cli - name: unison-parser-typechecker tests - run: stack --no-terminal exec tests + run: stack --no-terminal build --fast --test unison-parser-typechecker - name: unison-util-relation tests run: stack --no-terminal build --fast --test unison-util-relation - name: transcripts @@ -135,5 +135,5 @@ jobs: git diff --cached --ignore-cr-at-eol --exit-code - name: prettyprint-round-trip run: stack --no-terminal exec unison transcript unison-src/transcripts-round-trip/main.md - - name: integration-tests - run: stack --no-terminal exec integration-tests + - name: cli-integration-tests + run: stack --no-terminal exec cli-integration-tests diff --git a/README.md b/README.md index ba1dc55da1..b7c57806ba 100644 --- a/README.md +++ b/README.md @@ -33,7 +33,7 @@ The build uses [Stack](http://docs.haskellstack.org/). If you don't already have $ git clone https://github.com/unisonweb/unison.git $ cd unison $ stack --version # we'll want to know this version if you run into trouble -$ stack build && stack exec tests && stack exec unison +$ stack build --fast --test && stack exec unison ``` To run a local codebase-ui while building from source, you can use the `/dev-ui-install.sh` script. It will download the latest release of the codebase-ui and put it in the expected location for the unison executable created by `stack build`. When you start unison, you'll see a url where the codebase-ui is running. diff --git a/development.markdown b/development.markdown index a0ef54eaf2..3ccf07ef72 100644 --- a/development.markdown +++ b/development.markdown @@ -18,12 +18,20 @@ On startup, Unison prints a url for the codebase UI. If you did step 3 above, th ## Running Tests -* `stack exec tests` runs the tests +* `stack test --fast` builds and runs most test suites, see below for exceptions to this (e.g. transcript tests). + +Most test suites support selecting a specific test to run by passing a prefix as a test argument: + +* `stack test parser-typechecker --fast --test-arguments my-test-prefix` builds and runs most test suites, see below for exceptions to this (e.g. transcript tests). + +Some tests are executables instead: + * `stack exec transcripts` runs the transcripts-related integration tests, found in `unison-src/transcripts`. You can add more tests to this directory. +* `stack exec transcripts -- prefix-of-filename` runs only transcript tests with a matching filename prefix. * `stack exec integration-tests` runs the additional integration tests for cli. These tests are not triggered by `tests` or `trancscripts`. -* `stack exec tests -- prefix-of-test` and `stack exec transcripts -- prefix-of-test` only run tests with a matching prefix. * `stack exec unison -- transcript unison-src/transcripts-round-trip/main.md` runs the pretty-printing round trip tests + ### What if you want a profiled build? Do: diff --git a/lib/unison-util-relation/package.yaml b/lib/unison-util-relation/package.yaml index 346f10b4ea..678c2bf123 100644 --- a/lib/unison-util-relation/package.yaml +++ b/lib/unison-util-relation/package.yaml @@ -6,7 +6,7 @@ library: source-dirs: src tests: - tests: + util-relation-tests: dependencies: - code-page - easytest diff --git a/lib/unison-util-relation/unison-util-relation.cabal b/lib/unison-util-relation/unison-util-relation.cabal index 0c7e69849b..99530e8ccd 100644 --- a/lib/unison-util-relation/unison-util-relation.cabal +++ b/lib/unison-util-relation/unison-util-relation.cabal @@ -48,7 +48,7 @@ library , unison-prelude default-language: Haskell2010 -test-suite tests +test-suite util-relation-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 433342c5f6..604275cb24 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -121,8 +121,8 @@ library: - uri-encode - generic-lens -executables: - tests: +tests: + parser-typechecker-tests: source-dirs: tests main: Suite.hs ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index eb7c346e27..6530fe8de4 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -312,7 +312,8 @@ library ghc-options: -funbox-strict-fields -O2 default-language: Haskell2010 -executable tests +test-suite parser-typechecker-tests + type: exitcode-stdio-1.0 main-is: Suite.hs other-modules: Unison.Core.Test.Name diff --git a/scripts/check.sh b/scripts/check.sh index 3846e28cb1..9832d7d4fb 100755 --- a/scripts/check.sh +++ b/scripts/check.sh @@ -2,10 +2,7 @@ # eventually: ormolu -c `find . -name '*.hs'` true \ - && stack build --fast --no-run-tests --test \ - && stack test unison-cli \ - && stack exec tests \ - && stack test unison-util-relation \ + && stack build --fast --test \ && stack exec transcripts \ && stack exec unison transcript unison-src/transcripts-round-trip/main.md \ && stack exec integration-tests diff --git a/scripts/test.sh b/scripts/test.sh index 53277f3497..b89a29470c 100755 --- a/scripts/test.sh +++ b/scripts/test.sh @@ -1,2 +1,2 @@ #!/bin/sh -stack build && stack exec tests +stack build --fast --test diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 0abd6d0f6b..bdd10f790b 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -63,7 +63,7 @@ library: dependencies: unix tests: - tests: + cli-tests: dependencies: - code-page - easytest @@ -98,7 +98,7 @@ executables: - shellmet - unison-cli - integration-tests: + cli-integration-tests: source-dirs: integration-tests main: Suite.hs ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 7264cb123c..a8c1b79a02 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -140,7 +140,7 @@ library unix default-language: Haskell2010 -executable integration-tests +executable cli-integration-tests main-is: Suite.hs other-modules: IntegrationTests.ArgumentParsing @@ -398,7 +398,7 @@ executable unison ghc-options: -O2 -funbox-strict-fields default-language: Haskell2010 -test-suite tests +test-suite cli-tests type: exitcode-stdio-1.0 main-is: Main.hs other-modules: From fd839e4fa457e23c1611e349468d2b76373337ec Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 7 Apr 2022 13:57:35 -0400 Subject: [PATCH 076/529] work on ooo-sync downloading entities --- .../unison-prelude}/src/Unison/Util/Monoid.hs | 0 lib/unison-prelude/src/Unison/Util/Set.hs | 10 ++ lib/unison-prelude/unison-prelude.cabal | 1 + unison-cli/src/Unison/Share/Sync.hs | 104 ++++++++++++++++-- unison-core/unison-core1.cabal | 1 - 5 files changed, 105 insertions(+), 11 deletions(-) rename {unison-core => lib/unison-prelude}/src/Unison/Util/Monoid.hs (100%) diff --git a/unison-core/src/Unison/Util/Monoid.hs b/lib/unison-prelude/src/Unison/Util/Monoid.hs similarity index 100% rename from unison-core/src/Unison/Util/Monoid.hs rename to lib/unison-prelude/src/Unison/Util/Monoid.hs diff --git a/lib/unison-prelude/src/Unison/Util/Set.hs b/lib/unison-prelude/src/Unison/Util/Set.hs index 838299dcaf..7aba2786bf 100644 --- a/lib/unison-prelude/src/Unison/Util/Set.hs +++ b/lib/unison-prelude/src/Unison/Util/Set.hs @@ -4,12 +4,15 @@ module Unison.Util.Set symmetricDifference, Unison.Util.Set.traverse, flatMap, + filterM, ) where +import Data.Functor ((<&>)) import qualified Data.Maybe as Maybe import Data.Set (Set) import qualified Data.Set as Set +import Unison.Util.Monoid (foldMapM) -- | Set difference, but return @Nothing@ if the difference is empty. difference1 :: Ord a => Set a -> Set a -> Maybe (Set a) @@ -29,3 +32,10 @@ traverse f = fmap Set.fromList . Prelude.traverse f . Set.toList flatMap :: Ord b => (a -> Set b) -> Set a -> Set b flatMap f = Set.unions . fmap f . Set.toList + +filterM :: (Ord a, Monad m) => (a -> m Bool) -> Set a -> m (Set a) +filterM p = + foldMapM \x -> + p x <&> \case + False -> Set.empty + True -> Set.singleton x diff --git a/lib/unison-prelude/unison-prelude.cabal b/lib/unison-prelude/unison-prelude.cabal index 8bb82595b2..48053ebb4f 100644 --- a/lib/unison-prelude/unison-prelude.cabal +++ b/lib/unison-prelude/unison-prelude.cabal @@ -20,6 +20,7 @@ library Unison.Debug Unison.Prelude Unison.Util.Map + Unison.Util.Monoid Unison.Util.Set other-modules: Paths_unison_prelude diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index d3df70c5bc..43824e26d4 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -24,6 +24,8 @@ import qualified U.Util.Hash as Hash import Unison.Prelude import qualified Unison.Sync.Types as Share import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) +import Unison.Util.Monoid (foldMapM) +import qualified Unison.Util.Set as Set ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path @@ -130,18 +132,101 @@ upload conn repoName = ------------------------------------------------------------------------------------------------------------------------ -- Pull +pull :: Connection -> Share.RepoPath -> IO (Either PullError CausalHash) +pull _conn _repoPath = undefined + +download :: Connection -> Share.RepoName -> NESet Share.HashJWT -> IO () +download conn repoName = + let loop :: NESet Share.HashJWT -> IO () + loop hashes0 = do + let elaborateHashes :: Set Share.HashJWT -> Set Share.HashJWT -> IO (Maybe (NESet Share.HashJWT)) + elaborateHashes hashes outputs = + case Set.minView hashes of + Nothing -> pure (NESet.nonEmptySet outputs) + Just (hash, hashes') -> + let inMainStorage = undefined + inTempStorage = undefined + directDepsOf = undefined + in inMainStorage hash >>= \case + False -> + inTempStorage hash >>= \case + False -> elaborateHashes hashes' (Set.insert hash outputs) + True -> elaborateHashes (Set.union (directDepsOf hash) hashes') outputs + True -> elaborateHashes hashes' outputs + + elaborateHashes (NESet.toSet hashes0) Set.empty >>= \case + Nothing -> pure () + Just hashes1 -> do + Share.DownloadEntitiesResponse entities <- + _downloadEntities + Share.DownloadEntitiesRequest + { repoName, + hashes = hashes1 + } + + missingDependencies0 <- + NEMap.toList entities & foldMapM \(hash, entity) -> do + let inMainStorage = undefined + let inTempStorage = undefined + let putInMainStorage hash entity = undefined + let putInTempStorage hash entity = undefined + let insertMissingDependencies = undefined + -- select dependency + -- from temp_entity_missing_dependency + -- where dependent = + let getTempEntityMissingDependencies = undefined + let directDepsOf :: Share.Entity Text Share.Hash Share.HashJWT -> Set Share.HashJWT + directDepsOf = undefined + + inMainStorage hash >>= \case + True -> pure Set.empty + False -> + inTempStorage entity >>= \case + True -> getTempEntityMissingDependencies entity + False -> do + missingDependencies <- Set.filterM inMainStorage (directDepsOf entity) + if Set.null missingDependencies + then putInMainStorage hash entity + else do + putInTempStorage hash entity + insertMissingDependencies hash missingDependencies + pure missingDependencies + + case NESet.nonEmptySet missingDependencies0 of + Nothing -> pure () + Just missingDependencies -> loop missingDependencies + in loop + +-- Do this at the top of the procedure. +-- +-- deps0 = hashes we kinda-maybe think we should request +-- deps1 = hashes we will request +-- +-- frobnicate : Set Hash -> Set Hash ->{IO} Set Hash +-- frobnicate deps0 deps1 = +-- case deps0 of +-- Nothing -> deps1 +-- Just (dep0, deps0) -> +-- cases +-- inMainStorage dep0 -> frobnicate deps0 deps1 +-- inTempStorage dep0 -> frobnicate (deps0 + directDepsOf dep0) deps1 +-- otherwise -> frobnicate deps0 (deps1 + {dep0}) +-- -- If we just got #thing from the server, -- If we already have the entity in the main database, we're done. -- - This should't happen, why would the server have sent us this? -- --- Otherwise, if we already have the entity in temp_entity, ??? +-- Otherwise, if we already have the entity in temp_entity, +-- 1. Add to our work queue requesting all of its deps that we don't have in main storage -- -- Otherwise (if we don't have it at all), --- 1. Extract dependencies #dep1, #dep2, #dep3 from #thing blob. --- 2. Filter down to just the dependencies we don't have. <-- "have" means in either real/temp storage. --- 3. If that's {}, then store it in the main table. --- 4. If that's (say) {#dep1, #dep2}, --- 1. Add (#thing, #dep1), (#thing, #dep2) to temp_entity_missing_dependency +-- 1. Deserialize blob and extract dependencies #dep1, #dep2, #dep3 from #thing blob. +-- 2. If the {set of dependencies we don't have in the object/causal table} is empty, then store in object/causal. +-- 3. Otherwise, +-- - Insert into temp_entity +-- - For each #dependency in the {set of dependencies we don't have in the object/causal table} +-- insert each (#thing, #dependency) into temp_entity_missing_dependency +-- - Add to our work queue requesting {set of dependencies we don't have in object/causal} -- -- Note: beef up insert_entity procedure to flush temp_entity table -- 1. When inserting object #foo, @@ -151,7 +236,6 @@ upload conn repoName = -- 3. Delete #foo from temp_entity (if it's there) -- 4. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, -- insert_entity them. --- ------------------------------------------------------------------------------------------------------------------------ -- @@ -189,9 +273,6 @@ type Transaction a = () expectHash :: HashId -> Transaction Hash.Hash expectHash = undefined -pull :: Connection -> Share.RepoPath -> IO (Either PullError CausalHash) -pull _conn _repoPath = undefined - -- FIXME rename, etc resolveHashToEntity :: Connection -> Share.Hash -> IO (Share.Entity Text Share.Hash Share.Hash) resolveHashToEntity = undefined @@ -215,5 +296,8 @@ _getCausalHashByPath = undefined _updatePath :: Share.UpdatePathRequest -> IO UpdatePathResponse _updatePath = undefined +_downloadEntities :: Share.DownloadEntitiesRequest -> IO Share.DownloadEntitiesResponse +_downloadEntities = undefined + _uploadEntities :: Share.UploadEntitiesRequest -> IO UploadEntitiesResponse _uploadEntities = undefined diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index 1975f49c30..8739a9938e 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -56,7 +56,6 @@ library Unison.Util.Alphabetical Unison.Util.Components Unison.Util.List - Unison.Util.Monoid Unison.Var Unison.Var.RefNamed Unison.WatchKind From 85770e12f4cf35d2b4ba6d39aea4eeb888dff4f0 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 7 Apr 2022 16:51:34 -0500 Subject: [PATCH 077/529] more work on ooo-sync downloading entities --- unison-cli/src/Unison/Share/Sync.hs | 115 +++++++++++++++++----- unison-share-api/src/Unison/Sync/Types.hs | 6 ++ 2 files changed, 95 insertions(+), 26 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 43824e26d4..2b91252a8d 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -9,16 +9,13 @@ module Unison.Share.Sync ) where -import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as List.NonEmpty import qualified Data.Map.NonEmpty as NEMap import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import U.Codebase.HashTags (CausalHash (unCausalHash)) -import U.Codebase.Sqlite.Causal (DbCausal, GDbCausal (..)) -import qualified U.Codebase.Sqlite.Causal as Sqlite.Causal (GDbCausal (..)) -import U.Codebase.Sqlite.DbId (CausalHashId (..), HashId) +import U.Codebase.Sqlite.DbId (HashId) import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as Hash import Unison.Prelude @@ -135,24 +132,41 @@ upload conn repoName = pull :: Connection -> Share.RepoPath -> IO (Either PullError CausalHash) pull _conn _repoPath = undefined +decodedHashJWTHash :: Share.DecodedHashJWT -> Share.Hash +decodedHashJWTHash = undefined + +decodeHashJWT :: Share.HashJWT -> Share.DecodedHashJWT +decodeHashJWT = undefined + download :: Connection -> Share.RepoName -> NESet Share.HashJWT -> IO () -download conn repoName = - let loop :: NESet Share.HashJWT -> IO () +download conn repoName = do + let inMainStorage :: Share.Hash -> IO Bool + inMainStorage = undefined + let inTempStorage :: Share.Hash -> IO Bool + inTempStorage = undefined + let directDepsOfEntity :: Share.Entity Text Share.Hash Share.HashJWT -> Set Share.DecodedHashJWT + directDepsOfEntity = undefined + let directDepsOfHash :: Share.Hash -> Set Share.DecodedHashJWT + directDepsOfHash = undefined + let loop :: NESet Share.DecodedHashJWT -> IO () loop hashes0 = do - let elaborateHashes :: Set Share.HashJWT -> Set Share.HashJWT -> IO (Maybe (NESet Share.HashJWT)) + let elaborateHashes :: Set Share.DecodedHashJWT -> Set Share.HashJWT -> IO (Maybe (NESet Share.HashJWT)) elaborateHashes hashes outputs = case Set.minView hashes of Nothing -> pure (NESet.nonEmptySet outputs) - Just (hash, hashes') -> - let inMainStorage = undefined - inTempStorage = undefined - directDepsOf = undefined - in inMainStorage hash >>= \case + Just (Share.DecodedHashJWT (Share.HashJWTClaims {hash}) jwt, hashes') -> + inMainStorage hash >>= \case + False -> + inTempStorage hash >>= \case False -> - inTempStorage hash >>= \case - False -> elaborateHashes hashes' (Set.insert hash outputs) - True -> elaborateHashes (Set.union (directDepsOf hash) hashes') outputs - True -> elaborateHashes hashes' outputs + -- we need the entity, it's not in main or temp storage + elaborateHashes hashes' (Set.insert jwt outputs) + True -> + -- entity already in temp storage + elaborateHashes (Set.union (directDepsOfHash hash) hashes') outputs + True -> + -- hash already in main storage + elaborateHashes hashes' outputs elaborateHashes (NESet.toSet hashes0) Set.empty >>= \case Nothing -> pure () @@ -166,25 +180,24 @@ download conn repoName = missingDependencies0 <- NEMap.toList entities & foldMapM \(hash, entity) -> do - let inMainStorage = undefined - let inTempStorage = undefined - let putInMainStorage hash entity = undefined - let putInTempStorage hash entity = undefined + let putInMainStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> IO () + putInMainStorage _hash _entity = undefined + let putInTempStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> IO () + putInTempStorage _hash _entity = undefined let insertMissingDependencies = undefined -- select dependency -- from temp_entity_missing_dependency -- where dependent = - let getTempEntityMissingDependencies = undefined - let directDepsOf :: Share.Entity Text Share.Hash Share.HashJWT -> Set Share.HashJWT - directDepsOf = undefined + let getTempEntityMissingDependencies :: Share.Entity Text Share.Hash Share.HashJWT -> IO (Set Share.DecodedHashJWT) + getTempEntityMissingDependencies = undefined inMainStorage hash >>= \case True -> pure Set.empty False -> - inTempStorage entity >>= \case + inTempStorage hash >>= \case True -> getTempEntityMissingDependencies entity False -> do - missingDependencies <- Set.filterM inMainStorage (directDepsOf entity) + missingDependencies <- Set.filterM (inMainStorage . decodedHashJWTHash) (directDepsOfEntity entity) if Set.null missingDependencies then putInMainStorage hash entity else do @@ -195,8 +208,58 @@ download conn repoName = case NESet.nonEmptySet missingDependencies0 of Nothing -> pure () Just missingDependencies -> loop missingDependencies - in loop + in loop . NESet.map decodeHashJWT + +--------- + +-- * we need hashjwts to make subsequent requests to the server + +-- * when look up missing dependencies, it's because we anticipate making a subsequent request to the server for them, + +-- so they should also be hashjwts + +-- * before making a subsequent request to the server, we elaborate the request set, + +-- which requires knowing hashjwts for the dependencies of the request set; +-- so we need some way of looking up missing dependency hashjwts from a hash or hashjwt + +-- * one way of looking these up would be to include dependency hashjwts in the temp-entity-missing-dependency table +-- (dependent -> (dependency, dependencyjwt)) + +-- * we need `hash` to find entity in temp or main storage + +-- * different entities may arrive with different variations on the same dependency jwts + +-- * we need dependency hash (not only hashjwt) in temp-entity-missing-dependency so that we can also look up dependents + +-- of a hash without knowing which hashjwt was stored for it + +-- Mitchell is on team: add a column to temp-entity-missing-dependency that includes the jwt + +{- +server sqlite db + -> sqlite object bytes + -> U.Codebase.Sqlite.decomposedComponent [(LocalIds' TextId ObjectId, ByteString)] + -> Sync.Types.Entity.TermComponent + -> cbor bytes + -> network + -> cbor bytes + -> Sync.Types.Entity.TermComponent + |-> temp_entity_missing_dependencies + | + |-> U.Codebase.Sqlite.decomposedComponent [(LocalIds' Text HashJWT, ByteString)] + (not Unison.Sync.Types.LocallyIndexedComponent) + -> serialize -> temp_entity (bytes) + -> time to move to MAIN table!!!! + -> deserialize -> U.Codebase.Sqlite.decomposedComponent [(LocalIds' Text HashJWT, ByteString)] + -> traverse -> U.Codebase.Sqlite.decomposedComponent [(LocalIds' TextId ObjectId, ByteString)] + -> serialize -> sqlite object bytes + +-- if we just have a hash for the localids (as opposed to a TypedHash) + +-} +--------- -- Do this at the top of the procedure. -- -- deps0 = hashes we kinda-maybe think we should request diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index f3ba83c71a..54f931fad2 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -32,6 +32,12 @@ newtype RepoName = RepoName Text newtype HashJWT = HashJWT Text deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) +data DecodedHashJWT = DecodedHashJWT + { claims :: HashJWTClaims, + hashJWT :: HashJWT + } + deriving (Eq, Ord, Show) + data HashJWTClaims = HashJWTClaims { hash :: Hash, entityType :: EntityType From ff89287e90c6007e0f1889c665bc5e11d9f8a1a7 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 7 Apr 2022 19:11:44 -0400 Subject: [PATCH 078/529] add runWriteTransaction --- .../src/Unison/Sqlite/Connection.hs | 40 +++++++++++-- .../src/Unison/Sqlite/Transaction.hs | 57 ++++++++++++------- .../src/Unison/Codebase/SqliteCodebase.hs | 4 +- 3 files changed, 73 insertions(+), 28 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index f412b9571c..a9eb9ecb40 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -55,10 +55,18 @@ module Unison.Sqlite.Connection vacuumInto, -- * Low-level operations + + -- ** Transaction + begin, + beginImmediate, + commit, + rollback, + + -- ** Savepoint withSavepoint, withSavepointIO, savepoint, - rollback, + rollbackTo, release, -- * Exceptions @@ -464,6 +472,26 @@ vacuumInto conn file = -- Low-level +-- | @BEGIN@ +begin :: Connection -> IO () +begin conn = + execute_ conn "BEGIN" + +-- | @BEGIN IMMEDIATE@ +beginImmediate :: Connection -> IO () +beginImmediate conn = + execute_ conn "BEGIN IMMEDIATE" + +-- | @COMMIT@ +commit :: Connection -> IO () +commit conn = + execute_ conn "COMMIT" + +-- | @ROLLBACK@ +rollback :: Connection -> IO () +rollback conn = + execute_ conn "ROLLBACK" + -- | Perform an action within a named savepoint. The action is provided a rollback action. withSavepoint :: MonadUnliftIO m => Connection -> Text -> (m () -> m a) -> m a withSavepoint conn name action = @@ -476,13 +504,13 @@ withSavepointIO conn name action = do uninterruptibleMask \restore -> do savepoint conn name result <- - restore (action doRollback) `onException` do - doRollback + restore (action doRollbackTo) `onException` do + doRollbackTo doRelease doRelease pure result where - doRollback = rollback conn name + doRollbackTo = rollbackTo conn name doRelease = release conn name -- | @SAVEPOINT@ @@ -491,8 +519,8 @@ savepoint conn name = execute_ conn (Sql ("SAVEPOINT " <> name)) -- | @ROLLBACK TO@ -rollback :: Connection -> Text -> IO () -rollback conn name = +rollbackTo :: Connection -> Text -> IO () +rollbackTo conn name = execute_ conn (Sql ("ROLLBACK TO " <> name)) -- | @RELEASE@ diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 347d2c82e7..8f6d7eb73d 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -3,6 +3,7 @@ module Unison.Sqlite.Transaction Transaction, runTransaction, runTransactionWithAbort, + runWriteTransaction, unsafeUnTransaction, savepoint, idempotentIO, @@ -80,35 +81,22 @@ newtype Transaction a runTransaction :: MonadIO m => Connection -> Transaction a -> m a runTransaction conn (Transaction f) = liftIO do uninterruptibleMask \restore -> do - Connection.execute_ conn "BEGIN" + Connection.begin conn result <- -- Catch all exceptions (sync or async), because we want to ROLLBACK the BEGIN no matter what. trySyncOrAsync @_ @SomeException (restore (f conn)) >>= \case Left exception -> do - ignoringExceptions rollback + ignoringExceptions (Connection.rollback conn) case fromException exception of - Just SqliteBusyException -> - let loop microseconds = do - restore (threadDelay microseconds) - try @_ @SqliteQueryException (Connection.execute_ conn "BEGIN IMMEDIATE") >>= \case - Left SqliteBusyException -> loop (microseconds * 2) - Left exception -> throwIO exception - Right () -> restore (f conn) `onException` ignoringExceptions rollback - in loop 100_000 + Just SqliteBusyException -> do + restore (threadDelay 100_000) + runWriteTransaction_ restore 200_000 conn f _ -> throwIO exception Right result -> pure result - Connection.execute_ conn "COMMIT" + Connection.commit conn pure result - where - rollback :: IO () - rollback = - Connection.execute_ conn "ROLLBACK" - ignoringExceptions :: IO () -> IO () - ignoringExceptions action = - action `catchAny` \_ -> pure () - --- | TODO document this +-- | Run a transaction with a function that aborts the transaction with an exception. runTransactionWithAbort :: MonadIO m => Connection -> @@ -117,6 +105,35 @@ runTransactionWithAbort :: runTransactionWithAbort conn action = runTransaction conn (action \exception -> idempotentIO (throwIO exception)) +-- | Run a transaction that is known to perform at least one write. +-- +-- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. +runWriteTransaction :: Connection -> ((forall x. IO x -> Transaction x) -> Transaction a) -> IO a +runWriteTransaction conn f = + uninterruptibleMask \restore -> + runWriteTransaction_ restore 100_000 conn (unsafeUnTransaction (f idempotentIO)) + +runWriteTransaction_ :: (forall x. IO x -> IO x) -> Int -> Connection -> (Connection -> IO a) -> IO a +runWriteTransaction_ restore microseconds conn transaction = do + keepTryingToBeginImmediate restore conn microseconds + restore (transaction conn) `onException` ignoringExceptions (Connection.rollback conn) + +-- @BEGIN IMMEDIATE@ until success. +keepTryingToBeginImmediate :: (forall x. IO x -> IO x) -> Connection -> Int -> IO () +keepTryingToBeginImmediate restore conn = + let loop microseconds = + try @_ @SqliteQueryException (Connection.beginImmediate conn) >>= \case + Left SqliteBusyException -> do + restore (threadDelay microseconds) + loop (microseconds * 2) + Left exception -> throwIO exception + Right () -> pure () + in loop + +ignoringExceptions :: IO () -> IO () +ignoringExceptions action = + action `catchAny` \_ -> pure () + -- | Unwrap the transaction newtype, throwing away the sending of BEGIN/COMMIT + automatic retry. unsafeUnTransaction :: Transaction a -> Connection -> IO a unsafeUnTransaction (Transaction action) = diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 0ae9010adb..e9601c4f6f 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -611,11 +611,11 @@ syncInternal progress srcConn destConn b = time "syncInternal" do if debugCommitFailedTransaction then Sqlite.Connection.release destConn "sync" else do - Sqlite.Connection.rollback destConn "sync" + Sqlite.Connection.rollbackTo destConn "sync" Sqlite.Connection.release destConn "sync" error (show e) -- (we don't write to the src anyway) - liftIO (Sqlite.Connection.rollback srcConn "sync") + liftIO (Sqlite.Connection.rollbackTo srcConn "sync") liftIO (Sqlite.Connection.release srcConn "sync") either onFailure onSuccess result From 4c66cc7bc42606d8cd1f8e19d8a1daca2dd064eb Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 7 Apr 2022 19:32:47 -0400 Subject: [PATCH 079/529] more runTransaction variants --- .../src/Unison/Sqlite/Transaction.hs | 52 +++++++++++++++++-- 1 file changed, 47 insertions(+), 5 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 8f6d7eb73d..2ee758b923 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -3,7 +3,10 @@ module Unison.Sqlite.Transaction Transaction, runTransaction, runTransactionWithAbort, + runReadOnlyTransaction, + runReadOnlyTransactionIO, runWriteTransaction, + runWriteTransactionIO, unsafeUnTransaction, savepoint, idempotentIO, @@ -69,7 +72,7 @@ import Unison.Sqlite.Connection (Connection (..)) import qualified Unison.Sqlite.Connection as Connection import Unison.Sqlite.Exception (SqliteExceptionReason, SqliteQueryException, pattern SqliteBusyException) import Unison.Sqlite.Sql -import UnliftIO.Exception (catchAny, trySyncOrAsync, uninterruptibleMask) +import UnliftIO.Exception (bracketOnError_, catchAny, trySyncOrAsync, uninterruptibleMask) newtype Transaction a = Transaction (Connection -> IO a) @@ -90,7 +93,7 @@ runTransaction conn (Transaction f) = liftIO do case fromException exception of Just SqliteBusyException -> do restore (threadDelay 100_000) - runWriteTransaction_ restore 200_000 conn f + runWriteTransaction_ restore 200_000 conn (f conn) _ -> throwIO exception Right result -> pure result Connection.commit conn @@ -105,18 +108,57 @@ runTransactionWithAbort :: runTransactionWithAbort conn action = runTransaction conn (action \exception -> idempotentIO (throwIO exception)) +-- | Run a transaction that is known to only perform reads. +-- +-- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. +-- +-- If the transaction does attempt a write and gets SQLITE_BUSY, it's your fault! +runReadOnlyTransaction :: Connection -> ((forall x. IO x -> Transaction x) -> Transaction a) -> IO a +runReadOnlyTransaction conn f = + runReadOnlyTransaction_ conn (unsafeUnTransaction (f idempotentIO) conn) + +-- | A variant of 'runReadOnlyTransaction' that may be more convenient for actions that perform more interleaved IO +-- calls than database calls, because the transaction action itself is in IO. +-- +-- The action is provided a function that peels off the 'Transaction' newtype without sending the corresponding +-- BEGIN/COMMIT statements. +runReadOnlyTransactionIO :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a +runReadOnlyTransactionIO conn f = + runReadOnlyTransaction_ conn (f (\transaction -> unsafeUnTransaction transaction conn)) + +runReadOnlyTransaction_ :: Connection -> IO a -> IO a +runReadOnlyTransaction_ conn action = do + bracketOnError_ + (Connection.begin conn) + (ignoringExceptions (Connection.rollback conn)) + ( do + result <- action + Connection.commit conn + pure result + ) + -- | Run a transaction that is known to perform at least one write. -- -- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. runWriteTransaction :: Connection -> ((forall x. IO x -> Transaction x) -> Transaction a) -> IO a runWriteTransaction conn f = uninterruptibleMask \restore -> - runWriteTransaction_ restore 100_000 conn (unsafeUnTransaction (f idempotentIO)) + runWriteTransaction_ restore 100_000 conn (unsafeUnTransaction (f idempotentIO) conn) + +-- | A variant of 'runWriteTransaction' that may be more convenient for actions that perform more interleaved IO calls +-- than database calls, because the transaction action itself is in IO. +-- +-- The action is provided a function that peels off the 'Transaction' newtype without sending the corresponding +-- BEGIN/COMMIT statements. +runWriteTransactionIO :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a +runWriteTransactionIO conn f = + uninterruptibleMask \restore -> + runWriteTransaction_ restore 100_000 conn (f (\transaction -> unsafeUnTransaction transaction conn)) -runWriteTransaction_ :: (forall x. IO x -> IO x) -> Int -> Connection -> (Connection -> IO a) -> IO a +runWriteTransaction_ :: (forall x. IO x -> IO x) -> Int -> Connection -> IO a -> IO a runWriteTransaction_ restore microseconds conn transaction = do keepTryingToBeginImmediate restore conn microseconds - restore (transaction conn) `onException` ignoringExceptions (Connection.rollback conn) + restore transaction `onException` ignoringExceptions (Connection.rollback conn) -- @BEGIN IMMEDIATE@ until success. keepTryingToBeginImmediate :: (forall x. IO x -> IO x) -> Connection -> Int -> IO () From af9be6743cd2e13bdd1e46116256f75d3a43d046 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 7 Apr 2022 21:50:33 -0400 Subject: [PATCH 080/529] generalize --- .../src/Unison/Sqlite/Transaction.hs | 38 ++++++++++++++----- 1 file changed, 28 insertions(+), 10 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 2ee758b923..86c8e87c9b 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -98,6 +98,7 @@ runTransaction conn (Transaction f) = liftIO do Right result -> pure result Connection.commit conn pure result +{-# SPECIALIZE runTransaction :: Connection -> Transaction a -> IO a #-} -- | Run a transaction with a function that aborts the transaction with an exception. runTransactionWithAbort :: @@ -107,24 +108,33 @@ runTransactionWithAbort :: m a runTransactionWithAbort conn action = runTransaction conn (action \exception -> idempotentIO (throwIO exception)) +{-# SPECIALIZE runTransactionWithAbort :: + Connection -> + ((forall e x. Exception e => e -> Transaction x) -> Transaction a) -> + IO a + #-} -- | Run a transaction that is known to only perform reads. -- -- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. -- -- If the transaction does attempt a write and gets SQLITE_BUSY, it's your fault! -runReadOnlyTransaction :: Connection -> ((forall x. IO x -> Transaction x) -> Transaction a) -> IO a +runReadOnlyTransaction :: MonadUnliftIO m => Connection -> ((forall x. m x -> Transaction x) -> Transaction a) -> m a runReadOnlyTransaction conn f = - runReadOnlyTransaction_ conn (unsafeUnTransaction (f idempotentIO) conn) + withRunInIO \runInIO -> + runReadOnlyTransaction_ conn (unsafeUnTransaction (f (idempotentIO . runInIO)) conn) +{-# SPECIALIZE runReadOnlyTransaction :: Connection -> ((forall x. IO x -> Transaction x) -> Transaction a) -> IO a #-} -- | A variant of 'runReadOnlyTransaction' that may be more convenient for actions that perform more interleaved IO -- calls than database calls, because the transaction action itself is in IO. -- -- The action is provided a function that peels off the 'Transaction' newtype without sending the corresponding -- BEGIN/COMMIT statements. -runReadOnlyTransactionIO :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a +runReadOnlyTransactionIO :: MonadUnliftIO m => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a runReadOnlyTransactionIO conn f = - runReadOnlyTransaction_ conn (f (\transaction -> unsafeUnTransaction transaction conn)) + withRunInIO \runInIO -> + runReadOnlyTransaction_ conn (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn)))) +{-# SPECIALIZE runReadOnlyTransactionIO :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-} runReadOnlyTransaction_ :: Connection -> IO a -> IO a runReadOnlyTransaction_ conn action = do @@ -140,20 +150,28 @@ runReadOnlyTransaction_ conn action = do -- | Run a transaction that is known to perform at least one write. -- -- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. -runWriteTransaction :: Connection -> ((forall x. IO x -> Transaction x) -> Transaction a) -> IO a +runWriteTransaction :: MonadUnliftIO m => Connection -> ((forall x. m x -> Transaction x) -> Transaction a) -> m a runWriteTransaction conn f = - uninterruptibleMask \restore -> - runWriteTransaction_ restore 100_000 conn (unsafeUnTransaction (f idempotentIO) conn) + withRunInIO \runInIO -> + uninterruptibleMask \restore -> + runWriteTransaction_ restore 100_000 conn (unsafeUnTransaction (f (idempotentIO . runInIO)) conn) +{-# SPECIALIZE runWriteTransaction :: Connection -> ((forall x. IO x -> Transaction x) -> Transaction a) -> IO a #-} -- | A variant of 'runWriteTransaction' that may be more convenient for actions that perform more interleaved IO calls -- than database calls, because the transaction action itself is in IO. -- -- The action is provided a function that peels off the 'Transaction' newtype without sending the corresponding -- BEGIN/COMMIT statements. -runWriteTransactionIO :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a +runWriteTransactionIO :: MonadUnliftIO m => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a runWriteTransactionIO conn f = - uninterruptibleMask \restore -> - runWriteTransaction_ restore 100_000 conn (f (\transaction -> unsafeUnTransaction transaction conn)) + withRunInIO \runInIO -> + uninterruptibleMask \restore -> + runWriteTransaction_ + restore + 100_000 + conn + (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn)))) +{-# SPECIALIZE runWriteTransactionIO :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-} runWriteTransaction_ :: (forall x. IO x -> IO x) -> Int -> Connection -> IO a -> IO a runWriteTransaction_ restore microseconds conn transaction = do From 186b76530a65a4c29735bf6113906e6f652473de Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 7 Apr 2022 22:19:10 -0400 Subject: [PATCH 081/529] refactor syncInternal to use transaction tech --- .../U/Codebase/Sqlite/Sync22.hs | 65 ++++---- lib/unison-sqlite/src/Unison/Sqlite.hs | 4 + parser-typechecker/package.yaml | 1 + .../src/Unison/Codebase/SqliteCodebase.hs | 156 ++++++++---------- .../Codebase/SqliteCodebase/SyncEphemeral.hs | 7 +- .../unison-parser-typechecker.cabal | 2 + 6 files changed, 109 insertions(+), 126 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs index dd7e649bbd..34896bf155 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs @@ -10,8 +10,6 @@ module U.Codebase.Sqlite.Sync22 where import Control.Monad.Except (MonadError (throwError)) -import Control.Monad.RWS (MonadReader) -import qualified Control.Monad.Reader as Reader import Control.Monad.Validate (ValidateT, runValidateT) import qualified Control.Monad.Validate as Validate import Data.Bifunctor (bimap) @@ -39,7 +37,7 @@ import qualified U.Codebase.WatchKind as WK import U.Util.Cache (Cache) import qualified U.Util.Cache as Cache import Unison.Prelude -import Unison.Sqlite (Connection, Transaction, unsafeUnTransaction) +import Unison.Sqlite (Transaction) data Entity = O ObjectId @@ -47,8 +45,6 @@ data Entity | W WK.WatchKind Sqlite.Reference.IdH deriving (Eq, Ord, Show) -data DbTag = SrcDb | DestDb - data DecodeError = ErrTermComponent | ErrDeclComponent @@ -67,41 +63,50 @@ data Error | SourceDbNotExist deriving (Show) -data Env = Env - { srcDB :: Connection, - destDB :: Connection, +data Env m = Env + { runSrc :: forall a. Transaction a -> m a, + runDest :: forall a. Transaction a -> m a, -- | there are three caches of this size idCacheSize :: Word } +mapEnv :: (forall x. m x -> n x) -> Env m -> Env n +mapEnv f Env {runSrc, runDest, idCacheSize} = + Env + { runSrc = f . runSrc, + runDest = f . runDest, + idCacheSize + } + debug :: Bool debug = False -- data Mappings sync22 :: ( MonadIO m, - MonadError Error m, - MonadReader Env m + MonadError Error m ) => + Env m -> m (Sync m Entity) -sync22 = do - size <- Reader.reader idCacheSize +sync22 Env {runSrc, runDest, idCacheSize = size} = do tCache <- Cache.semispaceCache size hCache <- Cache.semispaceCache size oCache <- Cache.semispaceCache size cCache <- Cache.semispaceCache size - pure $ Sync (trySync tCache hCache oCache cCache) + pure $ Sync (trySync runSrc runDest tCache hCache oCache cCache) trySync :: forall m. - (MonadIO m, MonadError Error m, MonadReader Env m) => + (MonadIO m, MonadError Error m) => + (forall a. Transaction a -> m a) -> + (forall a. Transaction a -> m a) -> Cache TextId TextId -> Cache HashId HashId -> Cache ObjectId ObjectId -> Cache CausalHashId CausalHashId -> Entity -> m (TrySyncResult Entity) -trySync tCache hCache oCache cCache = \case +trySync runSrc runDest tCache hCache oCache cCache = \case -- for causals, we need to get the value_hash_id of the thingo -- - maybe enqueue their parents -- - enqueue the self_ and value_ hashes @@ -111,14 +116,14 @@ trySync tCache hCache oCache cCache = \case Just {} -> pure Sync.PreviouslyDone Nothing -> do result <- runValidateT @(Set Entity) @m @() do - bhId <- runSrc $ Q.expectCausalValueHashId chId - mayBoId <- runSrc . Q.loadObjectIdForAnyHashId $ unBranchHashId bhId + bhId <- lift . runSrc $ Q.expectCausalValueHashId chId + mayBoId <- lift . runSrc . Q.loadObjectIdForAnyHashId $ unBranchHashId bhId traverse_ syncLocalObjectId mayBoId parents' :: [CausalHashId] <- findParents' chId bhId' <- lift $ syncBranchHashId bhId chId' <- lift $ syncCausalHashId chId - runDest do + (lift . runDest) do Q.saveCausal chId' bhId' Q.saveCausalParents chId' parents' @@ -157,7 +162,7 @@ trySync tCache hCache oCache cCache = \case let bytes' = runPutS $ putWord8 fmt >> S.recomposeComponent (zip localIds' bytes) - oId' <- runDest $ Q.saveObject hId' objType bytes' + oId' <- lift . runDest $ Q.saveObject hId' objType bytes' lift do -- copy reference-specific stuff for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do @@ -188,7 +193,7 @@ trySync tCache hCache oCache cCache = \case runPutS $ putWord8 fmt >> S.recomposeComponent (zip localIds' declBytes) - oId' <- runDest $ Q.saveObject hId' objType bytes' + oId' <- lift . runDest $ Q.saveObject hId' objType bytes' lift do -- copy per-element-of-the-component stuff for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do @@ -202,26 +207,26 @@ trySync tCache hCache oCache cCache = \case Right (BL.SyncFull ids body) -> do ids' <- syncBranchLocalIds ids let bytes' = runPutS $ S.recomposeBranchFormat (BL.SyncFull ids' body) - oId' <- runDest $ Q.saveObject hId' objType bytes' + oId' <- lift . runDest $ Q.saveObject hId' objType bytes' pure oId' Right (BL.SyncDiff boId ids body) -> do boId' <- syncBranchObjectId boId ids' <- syncBranchLocalIds ids let bytes' = runPutS $ S.recomposeBranchFormat (BL.SyncDiff boId' ids' body) - oId' <- runDest $ Q.saveObject hId' objType bytes' + oId' <- lift . runDest $ Q.saveObject hId' objType bytes' pure oId' Left s -> throwError $ DecodeError ErrBranchFormat bytes s OT.Patch -> case flip runGetS bytes S.decomposePatchFormat of Right (PL.SyncFull ids body) -> do ids' <- syncPatchLocalIds ids let bytes' = runPutS $ S.recomposePatchFormat (PL.SyncFull ids' body) - oId' <- runDest $ Q.saveObject hId' objType bytes' + oId' <- lift . runDest $ Q.saveObject hId' objType bytes' pure oId' Right (PL.SyncDiff poId ids body) -> do poId' <- syncPatchObjectId poId ids' <- syncPatchLocalIds ids let bytes' = runPutS $ S.recomposePatchFormat (PL.SyncDiff poId' ids' body) - oId' <- runDest $ Q.saveObject hId' objType bytes' + oId' <- lift . runDest $ Q.saveObject hId' objType bytes' pure oId' Left s -> throwError $ DecodeError ErrPatchFormat bytes s case result of @@ -273,7 +278,7 @@ trySync tCache hCache oCache cCache = \case -- workaround for requiring components to compute component lengths for references. -- this line requires objects in the destination for any hashes referenced in the source, -- (making those objects dependencies of this patch). See Sync21.filter{Term,Type}Edit - traverse_ syncLocalObjectId =<< traverse (runSrc . Q.expectObjectIdForAnyHashId) hIds + traverse_ syncLocalObjectId =<< traverse (lift . runSrc . Q.expectObjectIdForAnyHashId) hIds pure $ PL.LocalIds tIds' hIds' oIds' @@ -355,7 +360,7 @@ trySync tCache hCache oCache cCache = \case findParents' :: CausalHashId -> ValidateT (Set Entity) m [CausalHashId] findParents' chId = do - srcParents <- runSrc $ Q.loadCausalParents chId + srcParents <- lift . runSrc $ Q.loadCausalParents chId traverse syncCausal srcParents -- Sync any watches of the given kinds to the dest if and only if watches of those kinds @@ -409,11 +414,3 @@ trySync tCache hCache oCache cCache = \case (runDest $ Q.isCausalHash hId') (pure . Just $ CausalHashId hId') (pure Nothing) - -runSrc, - runDest :: - (MonadIO m, MonadReader Env m) => - Transaction a -> - m a -runSrc ma = Reader.reader srcDB >>= liftIO . unsafeUnTransaction ma -runDest ma = Reader.reader destDB >>= liftIO . unsafeUnTransaction ma diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index 219b0f5ad5..5ef23cc49d 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -19,6 +19,10 @@ module Unison.Sqlite Transaction, runTransaction, runTransactionWithAbort, + runReadOnlyTransaction, + runReadOnlyTransactionIO, + runWriteTransaction, + runWriteTransactionIO, unsafeUnTransaction, savepoint, idempotentIO, diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 1c72170910..d28a2261fc 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -163,6 +163,7 @@ default-extensions: - ApplicativeDo - BangPatterns - BlockArguments + - DeriveAnyClass - DeriveFunctor - DeriveGeneric - DeriveTraversable diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index e9601c4f6f..00d8a5dbb4 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -529,95 +529,75 @@ syncInternal :: syncInternal progress srcConn destConn b = time "syncInternal" do UnliftIO runInIO <- askUnliftIO - -- We start a savepoint on the src connection because it seemed to speed things up. - -- Mitchell says: that doesn't sound right... why would that be the case? - -- TODO: look into this; this connection should be used only for reads. - liftIO (Sqlite.Connection.savepoint srcConn "sync") - liftIO (Sqlite.Connection.savepoint destConn "sync") - -- FIXME don't savepoint above, instead BEGIN - result <- runExceptT do - let syncEnv = Sync22.Env srcConn destConn (16 * 1024 * 1024) - -- we want to use sync22 wherever possible - -- so for each source branch, we'll check if it exists in the destination codebase - -- or if it exists in the source codebase, then we can sync22 it - -- if it doesn't exist in the dest or source branch, - -- then just use putBranch to the dest - let se :: forall m a. Functor m => (ExceptT Sync22.Error m a -> ExceptT SyncEphemeral.Error m a) - se = Except.withExceptT SyncEphemeral.Sync22Error - let r :: forall m a. (ReaderT Sync22.Env m a -> m a) - r = flip runReaderT syncEnv - processBranches :: - Sync.Sync (ReaderT Sync22.Env (ExceptT Sync22.Error m)) Sync22.Entity -> - Sync.Progress (ReaderT Sync22.Env (ExceptT Sync22.Error m)) Sync22.Entity -> - [Entity m] -> - ExceptT Sync22.Error m () - processBranches _ _ [] = pure () - processBranches sync progress (b0@(B h mb) : rest) = do - when debugProcessBranches do - traceM $ "processBranches " ++ show b0 - traceM $ " queue: " ++ show rest - ifM @(ExceptT Sync22.Error m) - (liftIO (Sqlite.unsafeUnTransaction (Ops2.isCausalHash h) destConn)) - do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " already exists in dest db" - processBranches sync progress rest - do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in dest db" - let h2 = CausalHash . Cv.hash1to2 $ Causal.unRawHash h - liftIO (Sqlite.unsafeUnTransaction (Q.loadCausalHashIdByCausalHash h2) srcConn) >>= \case - Just chId -> do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " exists in source db, so delegating to direct sync" - r $ Sync.sync' sync progress [Sync22.C chId] + Sqlite.runReadOnlyTransactionIO srcConn \runSrc -> do + Sqlite.runWriteTransactionIO destConn \runDest -> do + throwExceptT do + let syncEnv = Sync22.Env runSrc runDest (16 * 1024 * 1024) + -- we want to use sync22 wherever possible + -- so for each source branch, we'll check if it exists in the destination codebase + -- or if it exists in the source codebase, then we can sync22 it + -- if it doesn't exist in the dest or source branch, + -- then just use putBranch to the dest + let se :: forall m a. Functor m => (ExceptT Sync22.Error m a -> ExceptT SyncEphemeral.Error m a) + se = Except.withExceptT SyncEphemeral.Sync22Error + let r :: forall a. (ReaderT (Sync22.Env m) m a -> m a) + r = flip runReaderT syncEnv + processBranches :: + Sync.Sync (ExceptT Sync22.Error m) Sync22.Entity -> + Sync.Progress (ExceptT Sync22.Error m) Sync22.Entity -> + [Entity m] -> + ExceptT Sync22.Error m () + processBranches _ _ [] = pure () + processBranches sync progress (b0@(B h mb) : rest) = do + when debugProcessBranches do + traceM $ "processBranches " ++ show b0 + traceM $ " queue: " ++ show rest + ifM @(ExceptT Sync22.Error m) + (lift (runDest (Ops2.isCausalHash h))) + do + when debugProcessBranches $ traceM $ " " ++ show b0 ++ " already exists in dest db" processBranches sync progress rest - Nothing -> - lift mb >>= \b -> do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in either db, so delegating to Codebase.putBranch" - let (branchDeps, BD.to' -> BD.Dependencies' es ts ds) = BD.fromBranch b - when debugProcessBranches do - traceM $ " branchDeps: " ++ show (fst <$> branchDeps) - traceM $ " terms: " ++ show ts - traceM $ " decls: " ++ show ds - traceM $ " edits: " ++ show es - (cs, es, ts, ds) <- liftIO $ flip Sqlite.unsafeUnTransaction destConn do - cs <- filterM (fmap not . Ops2.isCausalHash . fst) branchDeps - es <- filterM (fmap not . Ops2.patchExists) es - ts <- filterM (fmap not . Ops2.termExists) ts - ds <- filterM (fmap not . Ops2.declExists) ds - pure (cs, es, ts, ds) - if null cs && null es && null ts && null ds - then do - liftIO (Sqlite.unsafeUnTransaction (Ops2.putBranch (Branch.transform (Sqlite.idempotentIO . runInIO) b)) destConn) - processBranches sync progress rest - else do - let bs = map (uncurry B) cs - os = map O (es <> ts <> ds) - processBranches sync progress (os ++ bs ++ b0 : rest) - processBranches sync progress (O h : rest) = do - when debugProcessBranches $ traceM $ "processBranches O " ++ take 10 (show h) - oId <- - liftIO do - Sqlite.unsafeUnTransaction (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId) srcConn - r $ Sync.sync' sync progress [Sync22.O oId] - processBranches sync progress rest - sync <- se . r $ Sync22.sync22 - let progress' = Sync.transformProgress (lift . lift) progress - bHash = Branch.headHash b - se $ time "SyncInternal.processBranches" $ processBranches sync progress' [B bHash (pure b)] - -- FIXME COMMIT/ROLLBACK here, no savepoint so no release - let onSuccess a = do - liftIO (Sqlite.Connection.release destConn "sync") - pure a - onFailure e = liftIO do - if debugCommitFailedTransaction - then Sqlite.Connection.release destConn "sync" - else do - Sqlite.Connection.rollbackTo destConn "sync" - Sqlite.Connection.release destConn "sync" - error (show e) - -- (we don't write to the src anyway) - liftIO (Sqlite.Connection.rollbackTo srcConn "sync") - liftIO (Sqlite.Connection.release srcConn "sync") - either onFailure onSuccess result + do + when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in dest db" + let h2 = CausalHash . Cv.hash1to2 $ Causal.unRawHash h + lift (runSrc (Q.loadCausalHashIdByCausalHash h2)) >>= \case + Just chId -> do + when debugProcessBranches $ traceM $ " " ++ show b0 ++ " exists in source db, so delegating to direct sync" + Sync.sync' sync progress [Sync22.C chId] + processBranches sync progress rest + Nothing -> + lift mb >>= \b -> do + when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in either db, so delegating to Codebase.putBranch" + let (branchDeps, BD.to' -> BD.Dependencies' es ts ds) = BD.fromBranch b + when debugProcessBranches do + traceM $ " branchDeps: " ++ show (fst <$> branchDeps) + traceM $ " terms: " ++ show ts + traceM $ " decls: " ++ show ds + traceM $ " edits: " ++ show es + (cs, es, ts, ds) <- + (lift . runDest) do + cs <- filterM (fmap not . Ops2.isCausalHash . fst) branchDeps + es <- filterM (fmap not . Ops2.patchExists) es + ts <- filterM (fmap not . Ops2.termExists) ts + ds <- filterM (fmap not . Ops2.declExists) ds + pure (cs, es, ts, ds) + if null cs && null es && null ts && null ds + then do + lift (runDest (Ops2.putBranch (Branch.transform (Sqlite.idempotentIO . runInIO) b))) + processBranches sync progress rest + else do + let bs = map (uncurry B) cs + os = map O (es <> ts <> ds) + processBranches sync progress (os ++ bs ++ b0 : rest) + processBranches sync progress (O h : rest) = do + when debugProcessBranches $ traceM $ "processBranches O " ++ take 10 (show h) + oId <- lift (runSrc (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId)) + Sync.sync' sync progress [Sync22.O oId] + processBranches sync progress rest + sync <- se (Sync22.sync22 (Sync22.mapEnv lift syncEnv)) + let progress' = Sync.transformProgress lift progress + bHash = Branch.headHash b + se $ time "SyncInternal.processBranches" $ processBranches sync progress' [B bHash (pure b)] data Entity m = B Branch.Hash (m (Branch m)) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs index 2218eab77c..58620334f5 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs @@ -1,12 +1,10 @@ -{-# LANGUAGE ScopedTypeVariables #-} - module Unison.Codebase.SqliteCodebase.SyncEphemeral where -import Data.Set (Set) import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.DbId (SchemaVersion) import qualified U.Codebase.Sqlite.Sync22 as Sync22 import Unison.Hash (Hash) +import Unison.Prelude data Dependencies = Dependencies { definitions :: Set Hash, @@ -18,4 +16,5 @@ data Error | SrcWrongSchema SchemaVersion | DestWrongSchema SchemaVersion | DisappearingBranch CausalHash - deriving (Show) + deriving stock (Show) + deriving anyclass (Exception) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 1595218690..02da24c642 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -187,6 +187,7 @@ library ApplicativeDo BangPatterns BlockArguments + DeriveAnyClass DeriveFunctor DeriveGeneric DeriveTraversable @@ -353,6 +354,7 @@ executable tests ApplicativeDo BangPatterns BlockArguments + DeriveAnyClass DeriveFunctor DeriveGeneric DeriveTraversable From bcf5d15e0b8e5a88e60166ec35347da1615f3b34 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 7 Apr 2022 22:40:23 -0400 Subject: [PATCH 082/529] simplify processBranches --- .../U/Codebase/Sqlite/Sync22.hs | 2 +- .../src/Unison/Codebase/SqliteCodebase.hs | 81 +++++++++---------- 2 files changed, 39 insertions(+), 44 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs index 34896bf155..f99a3139eb 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs @@ -87,7 +87,7 @@ sync22 :: MonadError Error m ) => Env m -> - m (Sync m Entity) + IO (Sync m Entity) sync22 Env {runSrc, runDest, idCacheSize = size} = do tCache <- Cache.semispaceCache size hCache <- Cache.semispaceCache size diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 00d8a5dbb4..7737fd3e8e 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -531,42 +531,40 @@ syncInternal progress srcConn destConn b = time "syncInternal" do Sqlite.runReadOnlyTransactionIO srcConn \runSrc -> do Sqlite.runWriteTransactionIO destConn \runDest -> do - throwExceptT do - let syncEnv = Sync22.Env runSrc runDest (16 * 1024 * 1024) - -- we want to use sync22 wherever possible - -- so for each source branch, we'll check if it exists in the destination codebase - -- or if it exists in the source codebase, then we can sync22 it - -- if it doesn't exist in the dest or source branch, - -- then just use putBranch to the dest - let se :: forall m a. Functor m => (ExceptT Sync22.Error m a -> ExceptT SyncEphemeral.Error m a) - se = Except.withExceptT SyncEphemeral.Sync22Error - let r :: forall a. (ReaderT (Sync22.Env m) m a -> m a) - r = flip runReaderT syncEnv - processBranches :: - Sync.Sync (ExceptT Sync22.Error m) Sync22.Entity -> - Sync.Progress (ExceptT Sync22.Error m) Sync22.Entity -> - [Entity m] -> - ExceptT Sync22.Error m () - processBranches _ _ [] = pure () - processBranches sync progress (b0@(B h mb) : rest) = do + let syncEnv = Sync22.Env runSrc runDest (16 * 1024 * 1024) + -- we want to use sync22 wherever possible + -- so for each source branch, we'll check if it exists in the destination codebase + -- or if it exists in the source codebase, then we can sync22 it + -- if it doesn't exist in the dest or source branch, + -- then just use putBranch to the dest + sync <- liftIO (Sync22.sync22 (Sync22.mapEnv lift syncEnv)) + let doSync :: [Sync22.Entity] -> m () + doSync = + throwExceptT + . Except.withExceptT SyncEphemeral.Sync22Error + . Sync.sync' sync (Sync.transformProgress lift progress) + let processBranches :: [Entity m] -> m () + processBranches = \case + [] -> pure () + b0@(B h mb) : rest -> do when debugProcessBranches do traceM $ "processBranches " ++ show b0 traceM $ " queue: " ++ show rest - ifM @(ExceptT Sync22.Error m) - (lift (runDest (Ops2.isCausalHash h))) + ifM + (runDest (Ops2.isCausalHash h)) do when debugProcessBranches $ traceM $ " " ++ show b0 ++ " already exists in dest db" - processBranches sync progress rest + processBranches rest do when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in dest db" let h2 = CausalHash . Cv.hash1to2 $ Causal.unRawHash h - lift (runSrc (Q.loadCausalHashIdByCausalHash h2)) >>= \case + runSrc (Q.loadCausalHashIdByCausalHash h2) >>= \case Just chId -> do when debugProcessBranches $ traceM $ " " ++ show b0 ++ " exists in source db, so delegating to direct sync" - Sync.sync' sync progress [Sync22.C chId] - processBranches sync progress rest + doSync [Sync22.C chId] + processBranches rest Nothing -> - lift mb >>= \b -> do + mb >>= \b -> do when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in either db, so delegating to Codebase.putBranch" let (branchDeps, BD.to' -> BD.Dependencies' es ts ds) = BD.fromBranch b when debugProcessBranches do @@ -574,30 +572,27 @@ syncInternal progress srcConn destConn b = time "syncInternal" do traceM $ " terms: " ++ show ts traceM $ " decls: " ++ show ds traceM $ " edits: " ++ show es - (cs, es, ts, ds) <- - (lift . runDest) do - cs <- filterM (fmap not . Ops2.isCausalHash . fst) branchDeps - es <- filterM (fmap not . Ops2.patchExists) es - ts <- filterM (fmap not . Ops2.termExists) ts - ds <- filterM (fmap not . Ops2.declExists) ds - pure (cs, es, ts, ds) + (cs, es, ts, ds) <- runDest do + cs <- filterM (fmap not . Ops2.isCausalHash . fst) branchDeps + es <- filterM (fmap not . Ops2.patchExists) es + ts <- filterM (fmap not . Ops2.termExists) ts + ds <- filterM (fmap not . Ops2.declExists) ds + pure (cs, es, ts, ds) if null cs && null es && null ts && null ds then do - lift (runDest (Ops2.putBranch (Branch.transform (Sqlite.idempotentIO . runInIO) b))) - processBranches sync progress rest + runDest (Ops2.putBranch (Branch.transform (Sqlite.idempotentIO . runInIO) b)) + processBranches rest else do let bs = map (uncurry B) cs os = map O (es <> ts <> ds) - processBranches sync progress (os ++ bs ++ b0 : rest) - processBranches sync progress (O h : rest) = do + processBranches (os ++ bs ++ b0 : rest) + O h : rest -> do when debugProcessBranches $ traceM $ "processBranches O " ++ take 10 (show h) - oId <- lift (runSrc (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId)) - Sync.sync' sync progress [Sync22.O oId] - processBranches sync progress rest - sync <- se (Sync22.sync22 (Sync22.mapEnv lift syncEnv)) - let progress' = Sync.transformProgress lift progress - bHash = Branch.headHash b - se $ time "SyncInternal.processBranches" $ processBranches sync progress' [B bHash (pure b)] + oId <- runSrc (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId) + doSync [Sync22.O oId] + processBranches rest + let bHash = Branch.headHash b + time "SyncInternal.processBranches" $ processBranches [B bHash (pure b)] data Entity m = B Branch.Hash (m (Branch m)) From dce743aa6131bc490ffe313bc0484cf32c97a024 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 7 Apr 2022 22:47:34 -0400 Subject: [PATCH 083/529] fix the undefineds in SqliteCodebase.hs --- .../src/Unison/Codebase/SqliteCodebase.hs | 111 +++++++----------- 1 file changed, 41 insertions(+), 70 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 7737fd3e8e..10e71e4ca3 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -12,19 +12,12 @@ module Unison.Codebase.SqliteCodebase where import qualified Control.Concurrent -import Control.Monad.Except (ExceptT, runExceptT, throwError) import qualified Control.Monad.Except as Except import qualified Control.Monad.Extra as Monad -import Control.Monad.Reader (ReaderT (runReaderT)) -import Control.Monad.State (MonadState) -import qualified Control.Monad.State as State -import Data.Bifunctor (Bifunctor (bimap), second) -import Data.Bitraversable (bitraverse) +import Data.Bifunctor (Bifunctor (bimap)) import qualified Data.Char as Char import Data.Either.Extra () import Data.IORef -import qualified Data.List as List -import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1) import qualified Data.Map as Map import Data.Maybe (fromJust) import qualified Data.Set as Set @@ -34,20 +27,15 @@ import qualified System.Console.ANSI as ANSI import System.FilePath (()) import qualified System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix -import U.Codebase.HashTags (CausalHash (CausalHash, unCausalHash)) +import U.Codebase.HashTags (CausalHash (CausalHash)) import qualified U.Codebase.Reference as C.Reference -import qualified U.Codebase.Referent as C.Referent -import U.Codebase.Sqlite.DbId (ObjectId) -import qualified U.Codebase.Sqlite.ObjectType as OT import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Q import qualified U.Codebase.Sqlite.Sync22 as Sync22 import qualified U.Codebase.Sync as Sync import qualified U.Util.Cache as Cache import qualified U.Util.Hash as H2 -import qualified U.Util.Monoid as Monoid import U.Util.Timing (time) -import qualified Unison.Builtin as Builtins import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase1 import Unison.Codebase.Branch (Branch (..)) @@ -73,40 +61,29 @@ import qualified Unison.Codebase.SqliteCodebase.SyncEphemeral as SyncEphemeral import Unison.Codebase.SyncMode (SyncMode) import Unison.Codebase.Type (LocalOrRemote (..), PushGitBranchOpts (..)) import qualified Unison.Codebase.Type as C -import Unison.ConstructorReference (GConstructorReference (..)) import qualified Unison.ConstructorType as CT import Unison.DataDeclaration (Decl) -import qualified Unison.DataDeclaration as Decl import Unison.Hash (Hash) -import qualified Unison.Hashing.V2.Convert as Hashing import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Reference (Reference) import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent import Unison.ShortHash (ShortHash) -import qualified Unison.ShortHash as SH -import qualified Unison.ShortHash as ShortHash -import Unison.Sqlite (Connection) import qualified Unison.Sqlite as Sqlite import qualified Unison.Sqlite.Connection as Sqlite.Connection -import qualified Unison.Sqlite.Transaction as Sqlite.Transaction import Unison.Symbol (Symbol) import Unison.Term (Term) -import qualified Unison.Term as Term import Unison.Type (Type) -import qualified Unison.Type as Type -import qualified Unison.Util.Set as Set import qualified Unison.WatchKind as UF import UnliftIO (UnliftIO (..), catchIO, finally, throwIO, try) import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) import UnliftIO.Exception (catch) import UnliftIO.STM -debug, debugProcessBranches, debugCommitFailedTransaction :: Bool +debug, debugProcessBranches :: Bool debug = False debugProcessBranches = False -debugCommitFailedTransaction = False init :: HasCallStack => (MonadUnliftIO m) => Codebase.Init m Symbol Ann init = @@ -130,7 +107,7 @@ withOpenOrCreateCodebase :: Codebase.DebugName -> CodebasePath -> LocalOrRemote -> - ((CodebaseStatus, Codebase m Symbol Ann, Connection) -> m r) -> + ((CodebaseStatus, Codebase m Symbol Ann, Sqlite.Connection) -> m r) -> m (Either Codebase1.OpenCodebaseError r) withOpenOrCreateCodebase debugName codebasePath localOrRemote action = do createCodebaseOrError debugName codebasePath (action' CreatedCodebase) >>= \case @@ -145,24 +122,22 @@ createCodebaseOrError :: (MonadUnliftIO m) => Codebase.DebugName -> CodebasePath -> - ((Codebase m Symbol Ann, Connection) -> m r) -> + ((Codebase m Symbol Ann, Sqlite.Connection) -> m r) -> m (Either Codebase1.CreateCodebaseError r) createCodebaseOrError debugName path action = do - undefined - --- ifM --- (doesFileExist $ makeCodebasePath path) --- (pure $ Left Codebase1.CreateCodebaseAlreadyExists) --- do --- createDirectoryIfMissing True (makeCodebaseDirPath path) --- withConnection (debugName ++ ".createSchema") path $ --- runReaderT do --- Q.createSchema --- void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty - --- sqliteCodebase debugName path Local action >>= \case --- Left schemaVersion -> error ("Failed to open codebase with schema version: " ++ show schemaVersion ++ ", which is unexpected because I just created this codebase.") --- Right result -> pure (Right result) + ifM + (doesFileExist $ makeCodebasePath path) + (pure $ Left Codebase1.CreateCodebaseAlreadyExists) + do + createDirectoryIfMissing True (makeCodebaseDirPath path) + Sqlite.withConnection (debugName ++ ".createSchema") path \conn -> + Sqlite.runTransaction conn do + Q.createSchema + void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty + + sqliteCodebase debugName path Local action >>= \case + Left schemaVersion -> error ("Failed to open codebase with schema version: " ++ show schemaVersion ++ ", which is unexpected because I just created this codebase.") + Right result -> pure (Right result) -- | Use the codebase in the provided path. -- The codebase is automatically closed when the action completes or throws an exception. @@ -181,12 +156,11 @@ withCodebaseOrError debugName dir action = do initSchemaIfNotExist :: MonadIO m => FilePath -> m () initSchemaIfNotExist path = liftIO do - undefined - --- unlessM (doesDirectoryExist $ makeCodebaseDirPath path) $ --- createDirectoryIfMissing True (makeCodebaseDirPath path) --- unlessM (doesFileExist $ makeCodebasePath path) $ --- withConnection "initSchemaIfNotExist" path $ runReaderT Q.createSchema + unlessM (doesDirectoryExist $ makeCodebaseDirPath path) $ + createDirectoryIfMissing True (makeCodebaseDirPath path) + unlessM (doesFileExist $ makeCodebasePath path) $ + withConnection "initSchemaIfNotExist" path \conn -> + Sqlite.runTransaction conn Q.createSchema -- 1) buffer up the component -- 2) in the event that the component is complete, then what? @@ -200,7 +174,7 @@ withConnection :: MonadUnliftIO m => Codebase.DebugName -> CodebasePath -> - (Connection -> m a) -> + (Sqlite.Connection -> m a) -> m a withConnection name root action = Sqlite.withConnection name (makeCodebasePath root) \conn -> do @@ -214,7 +188,7 @@ sqliteCodebase :: CodebasePath -> -- | When local, back up the existing codebase before migrating, in case there's a catastrophic bug in the migration. LocalOrRemote -> - ((Codebase m Symbol Ann, Connection) -> m r) -> + ((Codebase m Symbol Ann, Sqlite.Connection) -> m r) -> m (Either Codebase1.OpenCodebaseError r) sqliteCodebase debugName root localOrRemote action = do -- Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root @@ -231,16 +205,11 @@ sqliteCodebase debugName root localOrRemote action = do declTypeCache <- Cache.semispaceCache 2048 let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann)) getTerm id = - Sqlite.runTransaction conn (Ops2.getTerm (Sqlite.idempotentIO . getDeclTypeIO) id) + Sqlite.runTransaction conn (Ops2.getTerm getDeclType id) - getDeclType :: C.Reference.Reference -> m CT.ConstructorType + getDeclType :: C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType getDeclType = - liftIO . getDeclTypeIO - - getDeclTypeIO :: C.Reference.Reference -> IO CT.ConstructorType - getDeclTypeIO = - Cache.apply declTypeCache \ref -> - Sqlite.runTransaction conn (Ops2.getDeclType ref) + Sqlite.idempotentIO . Cache.apply declTypeCache (Sqlite.runTransaction conn . Ops2.getDeclType) getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann)) getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined @@ -249,7 +218,7 @@ sqliteCodebase debugName root localOrRemote action = do getTermComponentWithTypes :: Hash -> m (Maybe [(Term Symbol Ann, Type Symbol Ann)]) getTermComponentWithTypes h = - Sqlite.runTransaction conn (Ops2.getTermComponentWithTypes (Sqlite.idempotentIO . getDeclTypeIO) h) + Sqlite.runTransaction conn (Ops2.getTermComponentWithTypes getDeclType h) getTypeDeclaration :: Reference.Id -> m (Maybe (Decl Symbol Ann)) getTypeDeclaration id = @@ -281,7 +250,8 @@ sqliteCodebase debugName root localOrRemote action = do getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> m (Branch m) getRootBranch rootBranchCache = - Branch.transform (Sqlite.runTransaction conn) <$> Sqlite.runTransaction conn (Ops2.getRootBranch (Sqlite.idempotentIO . getDeclTypeIO) rootBranchCache) + Branch.transform (Sqlite.runTransaction conn) + <$> Sqlite.runTransaction conn (Ops2.getRootBranch getDeclType rootBranchCache) getRootBranchExists :: m Bool getRootBranchExists = @@ -336,7 +306,8 @@ sqliteCodebase debugName root localOrRemote action = do -- to one that returns Maybe. getBranchForHash :: Branch.Hash -> m (Maybe (Branch m)) getBranchForHash h = - fmap (Branch.transform (Sqlite.runTransaction conn)) <$> Sqlite.runTransaction conn (Ops2.getBranchForHash (Sqlite.idempotentIO . getDeclTypeIO) h) + fmap (Branch.transform (Sqlite.runTransaction conn)) + <$> Sqlite.runTransaction conn (Ops2.getBranchForHash getDeclType h) putBranch :: Branch m -> m () putBranch branch = @@ -386,7 +357,7 @@ sqliteCodebase debugName root localOrRemote action = do getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann)) getWatch k r = - Sqlite.runTransaction conn (Ops2.getWatch (Sqlite.idempotentIO . getDeclTypeIO) k r) + Sqlite.runTransaction conn (Ops2.getWatch getDeclType k r) putWatch :: UF.WatchKind -> Reference.Id -> Term Symbol Ann -> m () putWatch k r tm = @@ -424,11 +395,11 @@ sqliteCodebase debugName root localOrRemote action = do termsOfTypeImpl :: Reference -> m (Set Referent.Id) termsOfTypeImpl r = - Sqlite.runTransaction conn (Ops2.termsOfTypeImpl (Sqlite.idempotentIO . getDeclTypeIO) r) + Sqlite.runTransaction conn (Ops2.termsOfTypeImpl getDeclType r) termsMentioningTypeImpl :: Reference -> m (Set Referent.Id) termsMentioningTypeImpl r = - Sqlite.runTransaction conn (Ops2.termsMentioningTypeImpl (Sqlite.idempotentIO . getDeclTypeIO) r) + Sqlite.runTransaction conn (Ops2.termsMentioningTypeImpl getDeclType r) hashLength :: m Int hashLength = @@ -448,7 +419,7 @@ sqliteCodebase debugName root localOrRemote action = do referentsByPrefix :: ShortHash -> m (Set Referent.Id) referentsByPrefix sh = - Sqlite.runTransaction conn (Ops2.referentsByPrefix (Sqlite.idempotentIO . getDeclTypeIO) sh) + Sqlite.runTransaction conn (Ops2.referentsByPrefix getDeclType sh) branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.Hash) branchHashesByPrefix sh = @@ -522,8 +493,8 @@ syncInternal :: forall m. MonadUnliftIO m => Sync.Progress m Sync22.Entity -> - Connection -> - Connection -> + Sqlite.Connection -> + Sqlite.Connection -> Branch m -> m () syncInternal progress srcConn destConn b = time "syncInternal" do @@ -734,7 +705,7 @@ viewRemoteBranch' (repo, sbh, path) gitBranchBehavior action = UnliftIO.try $ do pushGitBranch :: forall m e. (MonadUnliftIO m) => - Connection -> + Sqlite.Connection -> WriteRepo -> PushGitBranchOpts -> -- An action which accepts the current root branch on the remote and computes a new branch. @@ -774,7 +745,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift where readRepo :: ReadRepo readRepo = writeToRead repo - doSync :: CodebaseStatus -> FilePath -> Connection -> Connection -> Branch m -> m () + doSync :: CodebaseStatus -> FilePath -> Sqlite.Connection -> Sqlite.Connection -> Branch m -> m () doSync codebaseStatus remotePath srcConn destConn newBranch = do progressStateRef <- liftIO (newIORef emptySyncProgressState) _ <- syncInternal (syncProgress progressStateRef) srcConn destConn newBranch From e2b6dd36d8d855a110d625a0449618e3bc86ca01 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 7 Apr 2022 23:41:31 -0400 Subject: [PATCH 084/529] work on migrating migrations --- .../Migrations/MigrateSchema1To2.hs | 1573 ++++++++--------- .../Migrations/MigrateSchema2To3.hs | 27 +- .../Codebase/SqliteCodebase/Operations.hs | 45 +- 3 files changed, 800 insertions(+), 845 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 3890f7aa00..45c572d417 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -10,6 +10,7 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 ) where +import Control.Concurrent.STM (TVar) import Control.Lens import Control.Monad.Except (runExceptT) import Control.Monad.Reader (ReaderT (runReaderT), ask) @@ -27,6 +28,7 @@ import qualified Data.Zip as Zip import System.Environment (lookupEnv) import System.IO.Unsafe (unsafePerformIO) import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) +import qualified U.Codebase.Reference as C.Reference import qualified U.Codebase.Reference as UReference import qualified U.Codebase.Referent as UReferent import qualified U.Codebase.Sqlite.Branch.Full as S @@ -59,14 +61,17 @@ import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import Unison.Codebase.SqliteCodebase.Migrations.Errors (MigrationError) import qualified Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers as Hashing +import qualified Unison.Codebase.SqliteCodebase.Operations as Ops2 import Unison.Codebase.Type (Codebase (Codebase)) import qualified Unison.ConstructorReference as ConstructorReference +import qualified Unison.ConstructorType as CT import qualified Unison.DataDeclaration as DD import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.Hash (Hash) import qualified Unison.Hash as Unison import qualified Unison.Hashing.V2.Causal as Hashing import qualified Unison.Hashing.V2.Convert as Convert +import Unison.Parser.Ann (Ann) import Unison.Pattern (Pattern) import qualified Unison.Pattern as Pattern import Unison.Prelude @@ -74,6 +79,7 @@ import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent import qualified Unison.Referent' as Referent' import qualified Unison.Sqlite as Sqlite +import Unison.Symbol (Symbol) import qualified Unison.Term as Term import Unison.Type (Type) import qualified Unison.Type as Type @@ -105,800 +111,779 @@ import Unison.Var (Var) -- * [x] Update the schema version in the database after migrating so we only migrate -- once. --- verboseOutput :: Bool --- verboseOutput = --- isJust (unsafePerformIO (lookupEnv "UNISON_MIGRATION_DEBUG")) --- {-# NOINLINE verboseOutput #-} +verboseOutput :: Bool +verboseOutput = + isJust (unsafePerformIO (lookupEnv "UNISON_MIGRATION_DEBUG")) +{-# NOINLINE verboseOutput #-} migrateSchema1To2 :: forall a m v. (MonadUnliftIO m, Var v) => Sqlite.Connection -> Codebase m v a -> m (Either MigrationError ()) migrateSchema1To2 = undefined --- migrateSchema1To2 conn codebase = --- Sqlite.runDB conn do --- Sqlite.withSavepoint "MIGRATESCHEMA12" \_rollback -> do --- liftIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" --- corruptedCausals <- Q.getCausalsWithoutBranchObjects --- when (not . null $ corruptedCausals) $ do --- liftIO $ putStrLn $ "โš ๏ธ I detected " <> show (length corruptedCausals) <> " corrupted namespace(s) in the history of the codebase." --- liftIO $ putStrLn $ "This is due to a bug in a previous version of ucm." --- liftIO $ putStrLn $ "This only affects the history of your codebase, the most up-to-date iteration will remain intact." --- liftIO $ putStrLn $ "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." - --- liftIO $ putStrLn $ "Updating Namespace Root..." --- rootCausalHashId <- Q.expectNamespaceRoot --- numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] --- v2EmptyBranchHashInfo <- saveV2EmptyBranch --- watches <- --- lift do --- foldMapM --- (\watchKind -> map (W watchKind) <$> Codebase.watches codebase (Cv.watchKind2to1 watchKind)) --- [WK.RegularWatch, WK.TestWatch] --- migrationState <- --- lift do --- (Sync.sync @_ @Entity migrationSync (progress numEntitiesToMigrate) (CausalE rootCausalHashId : watches)) --- `runReaderT` Env {db = conn, codebase} --- `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo --- let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId --- liftIO $ putStrLn $ "Updating Namespace Root..." --- Q.setNamespaceRoot newRootCausalHashId --- liftIO $ putStrLn $ "Rewriting old object IDs..." --- ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do --- Q.recordObjectRehash oldObjId newObjId --- liftIO $ putStrLn $ "Garbage collecting orphaned objects..." --- Q.garbageCollectObjectsWithoutHashes --- liftIO $ putStrLn $ "Garbage collecting orphaned watches..." --- Q.garbageCollectWatchesWithoutObjects --- liftIO $ putStrLn $ "Updating Schema Version..." --- Q.setSchemaVersion 2 --- pure $ Right () --- where --- progress :: Int -> Sync.Progress (ReaderT (Env m v a) (StateT MigrationState m)) Entity --- progress numToMigrate = --- let incrementProgress :: ReaderT (Env m v a) (StateT MigrationState m) () --- incrementProgress = do --- numDone <- field @"numMigrated" <+= 1 --- liftIO $ putStr $ "\r ๐Ÿ— " <> show numDone <> " / ~" <> show numToMigrate <> " entities migrated. ๐Ÿšง" --- need :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () --- need e = when verboseOutput $ liftIO $ putStrLn $ "Need: " ++ show e --- done :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () --- done e = do --- when verboseOutput $ liftIO $ putStrLn $ "Done: " ++ show e --- incrementProgress --- errorHandler :: Entity -> ReaderT (Env m v a) (StateT MigrationState m) () --- errorHandler e = do --- case e of --- -- We expect non-fatal errors when migrating watches. --- W {} -> pure () --- e -> liftIO $ putStrLn $ "Error: " ++ show e --- incrementProgress --- allDone :: ReaderT (Env m v a) (StateT MigrationState m) () --- allDone = liftIO $ putStrLn $ "\nFinished migrating, initiating cleanup." --- in Sync.Progress {need, done, error = errorHandler, allDone} - --- type Old a = a - --- type New a = a - --- type ConstructorName v = v - --- type DeclName v = v - --- data MigrationState = MigrationState --- -- Mapping between old cycle-position -> new cycle-position for a given Decl object. --- { referenceMapping :: Map (Old SomeReferenceId) (New SomeReferenceId), --- causalMapping :: Map (Old CausalHashId) (New (CausalHash, CausalHashId)), --- -- We also store the old hash for this object ID since we need a way to --- -- convert Object Reference IDs into Hash Reference IDs so we can use the referenceMapping. --- objLookup :: Map (Old ObjectId) (New ObjectId, New HashId, New Hash, Old Hash), --- -- Remember the hashes of term/decls that we have already migrated to avoid migrating them twice. --- migratedDefnHashes :: Set (Old Hash), --- numMigrated :: Int, --- v2EmptyBranchHashInfo :: (BranchHashId, Hash) --- } --- deriving (Generic) - --- data Entity --- = TermComponent Unison.Hash --- | DeclComponent Unison.Hash --- | CausalE CausalHashId --- | BranchE ObjectId --- | PatchE ObjectId --- | W WK.WatchKind Reference.Id --- deriving (Eq, Ord, Show) - --- data Env m v a = Env {db :: Sqlite.Connection, codebase :: Codebase m v a} - --- migrationSync :: --- (MonadIO m, Var v) => --- Sync (ReaderT (Env m v a) (StateT MigrationState m)) Entity --- migrationSync = Sync \case --- TermComponent hash -> do --- Env {codebase, db} <- ask --- lift (migrateTermComponent db codebase hash) --- DeclComponent hash -> do --- Env {codebase, db} <- ask --- lift (migrateDeclComponent db codebase hash) --- BranchE objectId -> do --- Env {db} <- ask --- lift (migrateBranch db objectId) --- CausalE causalHashId -> do --- Env {db} <- ask --- lift (migrateCausal db causalHashId) --- PatchE objectId -> do --- Env {db} <- ask --- lift (migratePatch db (PatchObjectId objectId)) --- W watchKind watchId -> do --- Env {codebase} <- ask --- lift (migrateWatch codebase watchKind watchId) - --- migrateCausal :: MonadIO m => Sqlite.Connection -> CausalHashId -> StateT MigrationState m (Sync.TrySyncResult Entity) --- migrateCausal conn oldCausalHashId = fmap (either id id) . runExceptT $ do --- whenM (Map.member oldCausalHashId <$> use (field @"causalMapping")) (throwE Sync.PreviouslyDone) - --- oldBranchHashId <- Sqlite.runDB conn $ Q.expectCausalValueHashId oldCausalHashId --- oldCausalParentHashIds <- Sqlite.runDB conn $ Q.loadCausalParents oldCausalHashId - --- maybeOldBranchObjId <- --- Sqlite.runDB conn $ --- Q.loadObjectIdForAnyHashId (unBranchHashId oldBranchHashId) --- migratedObjIds <- gets objLookup --- -- If the branch for this causal hasn't been migrated, migrate it first. --- let unmigratedBranch = --- case maybeOldBranchObjId of --- Just branchObjId | branchObjId `Map.notMember` migratedObjIds -> [BranchE branchObjId] --- _ -> [] - --- migratedCausals <- gets causalMapping --- let unmigratedParents = --- oldCausalParentHashIds --- & filter (`Map.notMember` migratedCausals) --- & fmap CausalE --- let unmigratedEntities = unmigratedBranch <> unmigratedParents --- when (not . null $ unmigratedParents <> unmigratedBranch) (throwE $ Sync.Missing unmigratedEntities) - --- (newBranchHashId, newBranchHash) <- case maybeOldBranchObjId of --- -- Some codebases are corrupted, likely due to interrupted save operations. --- -- It's unfortunate, but rather than fail the whole migration we'll just replace them --- -- with an empty branch. --- Nothing -> use (field @"v2EmptyBranchHashInfo") --- Just branchObjId -> do --- let (_, newBranchHashId, newBranchHash, _) = migratedObjIds ^?! ix branchObjId --- pure (BranchHashId newBranchHashId, newBranchHash) - --- let (newParentHashes, newParentHashIds) = --- oldCausalParentHashIds --- & fmap --- (\oldParentHashId -> migratedCausals ^?! ix oldParentHashId) --- & unzip --- & bimap (Set.fromList . map unCausalHash) Set.fromList - --- let newCausalHash :: CausalHash --- newCausalHash = --- CausalHash . Cv.hash1to2 $ --- Hashing.hashCausal --- ( Hashing.Causal --- { branchHash = newBranchHash, --- parents = Set.mapMonotonic Cv.hash2to1 newParentHashes --- } --- ) --- newCausalHashId <- Sqlite.runDB conn (Q.saveCausalHash newCausalHash) --- let newCausal = --- DbCausal --- { selfHash = newCausalHashId, --- valueHash = newBranchHashId, --- parents = newParentHashIds --- } --- Sqlite.runDB conn do --- Q.saveCausal (SC.selfHash newCausal) (SC.valueHash newCausal) --- Q.saveCausalParents (SC.selfHash newCausal) (Set.toList $ SC.parents newCausal) - --- field @"causalMapping" %= Map.insert oldCausalHashId (newCausalHash, newCausalHashId) - --- pure Sync.Done - --- migrateBranch :: MonadIO m => Sqlite.Connection -> ObjectId -> StateT MigrationState m (Sync.TrySyncResult Entity) --- migrateBranch conn oldObjectId = fmap (either id id) . runExceptT $ do --- whenM (Map.member oldObjectId <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone) - --- oldBranch <- Sqlite.runDB conn (Ops.expectDbBranch (BranchObjectId oldObjectId)) --- oldHash <- fmap Cv.hash2to1 . Sqlite.runDB conn $ Q.expectPrimaryHashByObjectId oldObjectId --- oldBranchWithHashes <- Sqlite.runDB conn (traverseOf S.branchHashes_ (fmap Cv.hash2to1 . Q.expectPrimaryHashByObjectId) oldBranch) --- migratedRefs <- gets referenceMapping --- migratedObjects <- gets objLookup --- migratedCausals <- gets causalMapping --- let allMissingTypesAndTerms :: [Entity] --- allMissingTypesAndTerms = --- oldBranchWithHashes --- ^.. branchSomeRefs_ --- . uRefIdAsRefId_ --- . filtered (`Map.notMember` migratedRefs) --- . to someReferenceIdToEntity - --- let allMissingPatches :: [Entity] = --- oldBranch --- ^.. S.patches_ --- . to unPatchObjectId --- . filtered (`Map.notMember` migratedObjects) --- . to PatchE - --- let allMissingChildBranches :: [Entity] = --- oldBranch --- ^.. S.childrenHashes_ --- . _1 --- . to unBranchObjectId --- . filtered (`Map.notMember` migratedObjects) --- . to BranchE - --- let allMissingChildCausals :: [Entity] = --- oldBranch --- ^.. S.childrenHashes_ --- . _2 --- . filtered (`Map.notMember` migratedCausals) --- . to CausalE - --- -- Identify dependencies and bail out if they aren't all built --- let allMissingReferences :: [Entity] --- allMissingReferences = --- allMissingTypesAndTerms --- ++ allMissingPatches --- ++ allMissingChildBranches --- ++ allMissingChildCausals - --- when (not . null $ allMissingReferences) $ --- throwE $ Sync.Missing allMissingReferences - --- let remapPatchObjectId patchObjId = case Map.lookup (unPatchObjectId patchObjId) migratedObjects of --- Nothing -> error $ "Expected patch: " <> show patchObjId <> " to be migrated" --- Just (newPatchObjId, _, _, _) -> PatchObjectId newPatchObjId --- let remapCausalHashId causalHashId = case Map.lookup causalHashId migratedCausals of --- Nothing -> error $ "Expected causal hash id: " <> show causalHashId <> " to be migrated" --- Just (_, newCausalHashId) -> newCausalHashId --- let remapBranchObjectId objId = case Map.lookup (unBranchObjectId objId) migratedObjects of --- Nothing -> error $ "Expected object: " <> show objId <> " to be migrated" --- Just (newBranchObjId, _, _, _) -> BranchObjectId newBranchObjId - --- let newBranch :: S.DbBranch --- newBranch = --- oldBranch --- & branchSomeRefs_ %~ remapObjIdRefs migratedObjects migratedRefs --- & S.patches_ %~ remapPatchObjectId --- & S.childrenHashes_ %~ (remapBranchObjectId *** remapCausalHashId) - --- let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch newBranch --- newHash <- Sqlite.runDB conn (Hashing.dbBranchHash newBranch) --- newHashId <- Sqlite.runDB conn (Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash))) --- newObjectId <- Sqlite.runDB conn (Ops.saveBranchObject newHashId localBranchIds localBranch) --- field @"objLookup" %= Map.insert oldObjectId (unBranchObjectId newObjectId, unBranchHashId newHashId, newHash, oldHash) --- pure Sync.Done - --- migratePatch :: --- forall m. --- MonadIO m => --- Sqlite.Connection -> --- Old PatchObjectId -> --- StateT MigrationState m (Sync.TrySyncResult Entity) --- migratePatch conn oldObjectId = fmap (either id id) . runExceptT $ do --- whenM (Map.member (unPatchObjectId oldObjectId) <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone) - --- oldHash <- fmap Cv.hash2to1 . Sqlite.runDB conn $ Q.expectPrimaryHashByObjectId (unPatchObjectId oldObjectId) --- oldPatch <- Sqlite.runDB conn (Ops.expectDbPatch oldObjectId) --- let hydrateHashes :: forall m. Sqlite.DB m => HashId -> m Hash --- hydrateHashes hashId = do --- Cv.hash2to1 <$> Q.expectHash hashId --- let hydrateObjectIds :: forall m. Sqlite.DB m => ObjectId -> m Hash --- hydrateObjectIds objId = do --- Cv.hash2to1 <$> Q.expectPrimaryHashByObjectId objId - --- oldPatchWithHashes :: S.Patch' TextId Hash Hash <- --- Sqlite.runDB conn do --- (oldPatch & S.patchH_ %%~ hydrateHashes) --- >>= (S.patchO_ %%~ hydrateObjectIds) - --- migratedRefs <- gets referenceMapping --- let isUnmigratedRef ref = Map.notMember ref migratedRefs --- -- 2. Determine whether all things the patch refers to are built. --- let unmigratedDependencies :: [Entity] --- unmigratedDependencies = --- oldPatchWithHashes ^.. patchSomeRefsH_ . uRefIdAsRefId_ . filtered isUnmigratedRef . to someReferenceIdToEntity --- <> oldPatchWithHashes ^.. patchSomeRefsO_ . uRefIdAsRefId_ . filtered isUnmigratedRef . to someReferenceIdToEntity --- when (not . null $ unmigratedDependencies) (throwE (Sync.Missing unmigratedDependencies)) - --- let hashToHashId :: forall m. Sqlite.DB m => Hash -> m HashId --- hashToHashId h = --- fromMaybe (error $ "expected hashId for hash: " <> show h) <$> (Q.loadHashIdByHash (Cv.hash1to2 h)) --- let hashToObjectId :: forall m. Sqlite.DB m => Hash -> m ObjectId --- hashToObjectId = hashToHashId >=> Q.expectObjectIdForPrimaryHashId - --- migratedReferences <- gets referenceMapping --- let remapRef :: SomeReferenceId -> SomeReferenceId --- remapRef ref = Map.findWithDefault ref ref migratedReferences - --- let newPatch = --- oldPatchWithHashes --- & patchSomeRefsH_ . uRefIdAsRefId_ %~ remapRef --- & patchSomeRefsO_ . uRefIdAsRefId_ %~ remapRef - --- newPatchWithIds :: S.Patch <- --- Sqlite.runDB conn $ do --- (newPatch & S.patchH_ %%~ hashToHashId) --- >>= (S.patchO_ %%~ hashToObjectId) - --- let (localPatchIds, localPatch) = S.LocalizeObject.localizePatch newPatchWithIds --- newHash <- Sqlite.runDB conn (Hashing.dbPatchHash newPatchWithIds) --- newObjectId <- Sqlite.runDB conn (Ops.saveDbPatch (PatchHash (Cv.hash1to2 newHash)) (S.Patch.Format.Full localPatchIds localPatch)) --- newHashId <- Sqlite.runDB conn (Q.expectHashIdByHash (Cv.hash1to2 newHash)) --- field @"objLookup" %= Map.insert (unPatchObjectId oldObjectId) (unPatchObjectId newObjectId, newHashId, newHash, oldHash) --- pure Sync.Done - --- -- | PLAN --- -- * --- -- NOTE: this implementation assumes that watches will be migrated AFTER everything else is finished. --- -- This is because it's difficult for us to know otherwise whether a reference refers to something which doesn't exist, or just --- -- something that hasn't been migrated yet. If we do it last, we know that missing references are indeed just missing from the codebase. --- migrateWatch :: --- forall m v a. --- (MonadIO m, Ord v) => --- Codebase m v a -> --- WatchKind -> --- Reference.Id -> --- StateT MigrationState m (Sync.TrySyncResult Entity) --- migrateWatch Codebase {getWatch, putWatch} watchKind oldWatchId = fmap (either id id) . runExceptT $ do --- let watchKindV1 = Cv.watchKind2to1 watchKind --- watchResultTerm <- --- (lift . lift) (getWatch watchKindV1 oldWatchId) >>= \case --- -- The hash which we're watching doesn't exist in the codebase, throw out this watch. --- Nothing -> throwE Sync.Done --- Just term -> pure term --- migratedReferences <- gets referenceMapping --- newWatchId <- case Map.lookup (TermReference oldWatchId) migratedReferences of --- (Just (TermReference newRef)) -> pure newRef --- _ -> throwE Sync.NonFatalError --- let maybeRemappedTerm :: Maybe (Term.Term v a) --- maybeRemappedTerm = --- watchResultTerm --- & termReferences_ %%~ \someRef -> Map.lookup someRef migratedReferences --- case maybeRemappedTerm of --- -- One or more references in the result didn't exist in our codebase. --- Nothing -> pure Sync.NonFatalError --- Just remappedTerm -> do --- lift . lift $ putWatch watchKindV1 newWatchId remappedTerm --- pure Sync.Done - --- uRefIdAsRefId_ :: Iso' (SomeReference (UReference.Id' Hash)) SomeReferenceId --- uRefIdAsRefId_ = mapping uRefAsRef_ - --- uRefAsRef_ :: Iso' (UReference.Id' Hash) Reference.Id --- uRefAsRef_ = iso intoRef intoURef --- where --- intoRef (UReference.Id hash pos) = Reference.Id hash pos --- intoURef (Reference.Id hash pos) = UReference.Id hash pos - --- -- Project an S.Referent'' into its SomeReferenceObjId's --- someReferent_ :: --- forall t h. --- (forall ref. Traversal' ref (SomeReference ref)) -> --- Traversal' (S.Branch.Full.Referent'' t h) (SomeReference (UReference.Id' h)) --- someReferent_ typeOrTermTraversal_ = --- (UReferent._Ref . someReference_ typeOrTermTraversal_) --- `failing` ( UReferent._Con --- . asPair_ -- Need to unpack the embedded reference AND remap between mismatched Constructor ID types. --- . asConstructorReference_ --- ) --- where --- asPair_ f (UReference.ReferenceDerived id', conId) = --- f (ConstructorReference.ConstructorReference id' (fromIntegral conId)) --- <&> \(ConstructorReference.ConstructorReference newId newConId) -> --- (UReference.ReferenceDerived newId, fromIntegral newConId) --- asPair_ _ (UReference.ReferenceBuiltin x, conId) = pure (UReference.ReferenceBuiltin x, conId) - --- -- asPair_ f (UReference.ReferenceDerived id', conId) = --- -- f (id', fromIntegral conId) --- -- <&> \(newId, newConId) -> (UReference.ReferenceDerived newId, fromIntegral newConId) --- -- asPair_ _ (UReference.ReferenceBuiltin x, conId) = pure (UReference.ReferenceBuiltin x, conId) - --- someReference_ :: --- (forall ref. Traversal' ref (SomeReference ref)) -> --- Traversal' (UReference.Reference' t h) (SomeReference (UReference.Id' h)) --- someReference_ typeOrTermTraversal_ = UReference._ReferenceDerived . typeOrTermTraversal_ - --- someMetadataSetFormat_ :: --- (Ord t, Ord h) => --- (forall ref. Traversal' ref (SomeReference ref)) -> --- Traversal' (S.Branch.Full.MetadataSetFormat' t h) (SomeReference (UReference.Id' h)) --- someMetadataSetFormat_ typeOrTermTraversal_ = --- S.Branch.Full.metadataSetFormatReferences_ . someReference_ typeOrTermTraversal_ - --- someReferenceMetadata_ :: --- (Ord k, Ord t, Ord h) => --- Traversal' k (SomeReference (UReference.Id' h)) -> --- Traversal' --- (Map k (S.Branch.Full.MetadataSetFormat' t h)) --- (SomeReference (UReference.Id' h)) --- someReferenceMetadata_ keyTraversal_ f m = --- Map.toList m --- & traversed . beside keyTraversal_ (someMetadataSetFormat_ asTermReference_) %%~ f --- <&> Map.fromList - --- branchSomeRefs_ :: (Ord t, Ord h) => Traversal' (S.Branch' t h p c) (SomeReference (UReference.Id' h)) --- branchSomeRefs_ f S.Branch.Full.Branch {children, patches, terms, types} = do --- let newTypesMap = types & traversed . someReferenceMetadata_ (someReference_ asTypeReference_) %%~ f --- let newTermsMap = terms & traversed . someReferenceMetadata_ (someReferent_ asTermReference_) %%~ f --- S.Branch.Full.Branch <$> newTermsMap <*> newTypesMap <*> pure patches <*> pure children - --- patchSomeRefsH_ :: (Ord t, Ord h) => Traversal (S.Patch' t h o) (S.Patch' t h o) (SomeReference (UReference.Id' h)) (SomeReference (UReference.Id' h)) --- patchSomeRefsH_ f S.Patch {termEdits, typeEdits} = do --- newTermEdits <- Map.fromList <$> (Map.toList termEdits & traversed . _1 . (someReferent_ asTermReference_) %%~ f) --- newTypeEdits <- Map.fromList <$> (Map.toList typeEdits & traversed . _1 . (someReference_ asTypeReference_) %%~ f) --- pure S.Patch {termEdits = newTermEdits, typeEdits = newTypeEdits} - --- patchSomeRefsO_ :: (Ord t, Ord h, Ord o) => Traversal' (S.Patch' t h o) (SomeReference (UReference.Id' o)) --- patchSomeRefsO_ f S.Patch {termEdits, typeEdits} = do --- newTermEdits <- (termEdits & traversed . Set.traverse . termEditRefs_ %%~ f) --- newTypeEdits <- (typeEdits & traversed . Set.traverse . typeEditRefs_ %%~ f) --- pure (S.Patch {termEdits = newTermEdits, typeEdits = newTypeEdits}) - --- termEditRefs_ :: Traversal' (TermEdit.TermEdit' t h) (SomeReference (UReference.Id' h)) --- termEditRefs_ f (TermEdit.Replace ref typing) = --- TermEdit.Replace <$> (ref & someReferent_ asTermReference_ %%~ f) <*> pure typing --- termEditRefs_ _f (TermEdit.Deprecate) = pure TermEdit.Deprecate - --- typeEditRefs_ :: Traversal' (TypeEdit.TypeEdit' t h) (SomeReference (UReference.Id' h)) --- typeEditRefs_ f (TypeEdit.Replace ref) = --- TypeEdit.Replace <$> (ref & someReference_ asTypeReference_ %%~ f) --- typeEditRefs_ _f (TypeEdit.Deprecate) = pure TypeEdit.Deprecate - --- migrateTermComponent :: --- forall m v a. --- (Ord v, Var v, Monad m, MonadIO m) => --- Sqlite.Connection -> --- Codebase m v a -> --- Unison.Hash -> --- StateT MigrationState m (Sync.TrySyncResult Entity) --- migrateTermComponent conn Codebase {..} oldHash = fmap (either id id) . runExceptT $ do --- whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone) - --- oldComponent <- --- (lift . lift $ getTermComponentWithTypes oldHash) >>= \case --- Nothing -> error $ "Hash was missing from codebase: " <> show oldHash --- Just c -> pure c - --- let componentIDMap :: Map (Old Reference.Id) (Term.Term v a, Type v a) --- componentIDMap = Map.fromList $ Reference.componentFor oldHash oldComponent --- let unhashed :: Map (Old Reference.Id) (v, Term.Term v a) --- unhashed = Term.unhashComponent (fst <$> componentIDMap) --- let vToOldReferenceMapping :: Map v (Old Reference.Id) --- vToOldReferenceMapping = --- unhashed --- & Map.toList --- & fmap (\(refId, (v, _trm)) -> (v, refId)) --- & Map.fromList - --- referencesMap <- gets referenceMapping - --- let allMissingReferences :: [Old SomeReferenceId] --- allMissingReferences = --- let missingTermRefs = --- unhashed & foldSetter (traversed . _2 . termReferences_) --- missingTypeRefs = --- componentIDMap --- & foldSetter (traversed . _2 . typeReferences_) --- in filter (`Map.notMember` referencesMap) (missingTermRefs <> missingTypeRefs) - --- when (not . null $ allMissingReferences) $ --- throwE $ Sync.Missing . nubOrd $ (someReferenceIdToEntity <$> allMissingReferences) - --- let getMigratedReference :: Old SomeReferenceId -> New SomeReferenceId --- getMigratedReference ref = --- Map.findWithDefault (error $ "unmigrated reference" <> show ref) ref referencesMap - --- let remappedReferences :: Map (Old Reference.Id) (v, Term.Term v a, Type v a) = --- Zip.zipWith --- ( \(v, trm) (_, typ) -> --- ( v, --- trm & termReferences_ %~ getMigratedReference, --- typ & typeReferences_ %~ getMigratedReference --- ) --- ) --- unhashed --- componentIDMap - --- let newTermComponents :: Map v (New Reference.Id, Term.Term v a, Type v a) --- newTermComponents = --- remappedReferences --- & Map.elems --- & fmap (\(v, trm, typ) -> (v, (trm, typ))) --- & Map.fromList --- & Convert.hashTermComponents - --- ifor newTermComponents $ \v (newReferenceId, trm, typ) -> do --- let oldReferenceId = vToOldReferenceMapping ^?! ix v --- field @"referenceMapping" %= Map.insert (TermReference oldReferenceId) (TermReference newReferenceId) --- lift . lift $ putTerm newReferenceId trm typ - --- -- Need to get one of the new references to grab its hash, doesn't matter which one since --- -- all hashes in the component are the same. --- case newTermComponents ^? traversed . _1 . to Reference.idToHash of --- Nothing -> pure () --- Just newHash -> insertObjectMappingForHash conn oldHash newHash - --- field @"migratedDefnHashes" %= Set.insert oldHash --- pure Sync.Done - --- migrateDeclComponent :: --- forall m v a. --- (Ord v, Var v, Monad m, MonadIO m) => --- Sqlite.Connection -> --- Codebase m v a -> --- Unison.Hash -> --- StateT MigrationState m (Sync.TrySyncResult Entity) --- migrateDeclComponent conn Codebase {..} oldHash = fmap (either id id) . runExceptT $ do --- whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone) - --- declComponent :: [DD.Decl v a] <- --- (lift . lift $ getDeclComponent oldHash) >>= \case --- Nothing -> error $ "Expected decl component for hash:" <> show oldHash --- Just dc -> pure dc - --- let componentIDMap :: Map (Old Reference.Id) (DD.Decl v a) --- componentIDMap = Map.fromList $ Reference.componentFor oldHash declComponent - --- let unhashed :: Map (Old Reference.Id) (DeclName v, DD.Decl v a) --- unhashed = DD.unhashComponent componentIDMap - --- let allTypes :: [Type v a] --- allTypes = --- unhashed --- ^.. traversed --- . _2 --- . beside DD.asDataDecl_ id --- . to DD.constructors' --- . traversed --- . _3 - --- migratedReferences <- gets referenceMapping --- let unmigratedRefIds :: [SomeReferenceId] --- unmigratedRefIds = --- allTypes --- & foldSetter --- ( traversed -- Every type in the list --- . typeReferences_ --- . filtered (`Map.notMember` migratedReferences) --- ) - --- when (not . null $ unmigratedRefIds) do --- throwE (Sync.Missing (nubOrd . fmap someReferenceIdToEntity $ unmigratedRefIds)) - --- -- At this point we know we have all the required mappings from old references to new ones. --- let remapTerm :: Type v a -> Type v a --- remapTerm = typeReferences_ %~ \ref -> Map.findWithDefault (error "unmigrated reference") ref migratedReferences - --- let remappedReferences :: Map (Old Reference.Id) (DeclName v, DD.Decl v a) --- remappedReferences = --- unhashed --- & traversed -- Traverse map of reference IDs --- . _2 -- Select the DataDeclaration --- . beside DD.asDataDecl_ id -- Unpack effect decls --- . DD.constructors_ -- Get the data constructors --- . traversed -- traverse the list of them --- . _3 -- Select the Type term. --- %~ remapTerm - --- let declNameToOldReference :: Map (DeclName v) (Old Reference.Id) --- declNameToOldReference = Map.fromList . fmap swap . Map.toList . fmap fst $ remappedReferences - --- let newComponent :: [(DeclName v, Reference.Id, DD.Decl v a)] --- newComponent = --- remappedReferences --- & Map.elems --- & Map.fromList --- & Convert.hashDecls --- & fromRight (error "unexpected resolution error") - --- for_ newComponent $ \(declName, newReferenceId, dd) -> do --- let oldReferenceId = declNameToOldReference ^?! ix declName --- field @"referenceMapping" %= Map.insert (TypeReference oldReferenceId) (TypeReference newReferenceId) - --- let oldConstructorIds :: Map (ConstructorName v) (Old ConstructorId) --- oldConstructorIds = --- (componentIDMap ^?! ix oldReferenceId) --- & DD.asDataDecl --- & DD.constructors' --- & imap (\constructorId (_ann, constructorName, _type) -> (constructorName, fromIntegral constructorId)) --- & Map.fromList - --- ifor_ (DD.constructors' (DD.asDataDecl dd)) \(fromIntegral -> newConstructorId) (_ann, constructorName, _type) -> do --- field @"referenceMapping" --- %= Map.insert --- (ConstructorReference oldReferenceId (oldConstructorIds ^?! ix constructorName)) --- (ConstructorReference newReferenceId newConstructorId) - --- lift . lift $ putTypeDeclaration newReferenceId dd - --- -- Need to get one of the new references to grab its hash, doesn't matter which one since --- -- all hashes in the component are the same. --- case newComponent ^? traversed . _2 . to Reference.idToHash of --- Nothing -> pure () --- Just newHash -> insertObjectMappingForHash conn oldHash newHash --- field @"migratedDefnHashes" %= Set.insert oldHash - --- pure Sync.Done - --- insertObjectMappingForHash :: --- (MonadIO m, MonadState MigrationState m) => --- Sqlite.Connection -> --- Old Hash -> --- New Hash -> --- m () --- insertObjectMappingForHash conn oldHash newHash = do --- (oldObjectId, newHashId, newObjectId) <- Sqlite.runDB conn $ do --- oldHashId <- Q.expectHashIdByHash . Cv.hash1to2 $ oldHash --- oldObjectId <- Q.expectObjectIdForPrimaryHashId $ oldHashId --- newHashId <- Q.expectHashIdByHash . Cv.hash1to2 $ newHash --- newObjectId <- Q.expectObjectIdForPrimaryHashId $ newHashId --- pure (oldObjectId, newHashId, newObjectId) --- field @"objLookup" %= Map.insert oldObjectId (newObjectId, newHashId, newHash, oldHash) - --- typeReferences_ :: (Monad m, Ord v) => LensLike' m (Type v a) SomeReferenceId --- typeReferences_ = --- ABT.rewriteDown_ -- Focus all terms --- . ABT.baseFunctor_ -- Focus Type.F --- . Type._Ref -- Only the Ref constructor has references --- . Reference._DerivedId --- . asTypeReference_ - --- termReferences_ :: (Monad m, Ord v) => LensLike' m (Term.Term v a) SomeReferenceId --- termReferences_ = --- ABT.rewriteDown_ -- Focus all terms --- . ABT.baseFunctor_ -- Focus Term.F --- . termFReferences_ - --- termFReferences_ :: (Ord tv, Monad m) => LensLike' m (Term.F tv ta pa a) SomeReferenceId --- termFReferences_ f t = --- (t & Term._Ref . Reference._DerivedId . asTermReference_ %%~ f) --- >>= Term._Constructor . someRefCon_ %%~ f --- >>= Term._Request . someRefCon_ %%~ f --- >>= Term._Ann . _2 . typeReferences_ %%~ f --- >>= Term._Match . _2 . traversed . Term.matchPattern_ . patternReferences_ %%~ f --- >>= Term._TermLink . referentAsSomeTermReference_ %%~ f --- >>= Term._TypeLink . Reference._DerivedId . asTypeReference_ %%~ f - --- -- | Build a SomeConstructorReference --- someRefCon_ :: Traversal' ConstructorReference.ConstructorReference SomeReferenceId --- someRefCon_ = refConPair_ . asConstructorReference_ --- where --- refConPair_ :: Traversal' ConstructorReference.ConstructorReference ConstructorReference.ConstructorReferenceId --- refConPair_ f s = --- case s of --- ConstructorReference.ConstructorReference (Reference.Builtin _) _ -> pure s --- ConstructorReference.ConstructorReference (Reference.DerivedId n) c -> --- ( \(ConstructorReference.ConstructorReference n' c') -> --- ConstructorReference.ConstructorReference (Reference.DerivedId n') c' --- ) --- <$> f (ConstructorReference.ConstructorReference n c) - --- patternReferences_ :: Traversal' (Pattern loc) SomeReferenceId --- patternReferences_ f = \case --- p@(Pattern.Unbound {}) -> pure p --- p@(Pattern.Var {}) -> pure p --- p@(Pattern.Boolean {}) -> pure p --- p@(Pattern.Int {}) -> pure p --- p@(Pattern.Nat {}) -> pure p --- p@(Pattern.Float {}) -> pure p --- p@(Pattern.Text {}) -> pure p --- p@(Pattern.Char {}) -> pure p --- (Pattern.Constructor loc ref patterns) -> --- (\newRef newPatterns -> Pattern.Constructor loc newRef newPatterns) --- <$> (ref & someRefCon_ %%~ f) --- <*> (patterns & traversed . patternReferences_ %%~ f) --- (Pattern.As loc pat) -> Pattern.As loc <$> patternReferences_ f pat --- (Pattern.EffectPure loc pat) -> Pattern.EffectPure loc <$> patternReferences_ f pat --- (Pattern.EffectBind loc ref patterns pat) -> --- do --- (\newRef newPatterns newPat -> Pattern.EffectBind loc newRef newPatterns newPat) --- <$> (ref & someRefCon_ %%~ f) --- <*> (patterns & traversed . patternReferences_ %%~ f) --- <*> (patternReferences_ f pat) --- (Pattern.SequenceLiteral loc patterns) -> --- Pattern.SequenceLiteral loc <$> (patterns & traversed . patternReferences_ %%~ f) --- Pattern.SequenceOp loc pat seqOp pat2 -> do --- Pattern.SequenceOp loc <$> patternReferences_ f pat <*> pure seqOp <*> patternReferences_ f pat2 - --- referentAsSomeTermReference_ :: Traversal' Referent.Referent SomeReferenceId --- referentAsSomeTermReference_ f = \case --- (Referent'.Ref' (Reference.DerivedId refId)) -> do --- newRefId <- refId & asTermReference_ %%~ f --- pure (Referent'.Ref' (Reference.DerivedId newRefId)) --- (Referent'.Con' (ConstructorReference.ConstructorReference (Reference.DerivedId refId) conId) conType) -> --- (ConstructorReference.ConstructorReference refId conId & asConstructorReference_ %%~ f) --- <&> \(ConstructorReference.ConstructorReference newRefId newConId) -> --- Referent'.Con' --- (ConstructorReference.ConstructorReference (Reference.DerivedId newRefId) newConId) --- conType --- r -> pure r - --- type SomeReferenceId = SomeReference Reference.Id - --- type SomeReferenceObjId = SomeReference (UReference.Id' ObjectId) - --- remapObjIdRefs :: --- (Map (Old ObjectId) (New ObjectId, New HashId, New Hash, Old Hash)) -> --- (Map SomeReferenceId SomeReferenceId) -> --- SomeReferenceObjId -> --- SomeReferenceObjId --- remapObjIdRefs objMapping refMapping someObjIdRef = newSomeObjId --- where --- oldObjId :: ObjectId --- oldObjId = someObjIdRef ^. someRef_ . UReference.idH --- (newObjId, _, _, oldHash) = --- case Map.lookup oldObjId objMapping of --- Nothing -> error $ "Expected object mapping for ID: " <> show oldObjId --- Just found -> found --- oldSomeRefId :: SomeReferenceId --- oldSomeRefId = (someObjIdRef & someRef_ . UReference.idH .~ oldHash) ^. uRefIdAsRefId_ --- newSomeRefId :: SomeReferenceId --- newSomeRefId = case Map.lookup oldSomeRefId refMapping of --- Nothing -> error $ "Expected reference mapping for ID: " <> show oldSomeRefId --- Just r -> r --- newSomeObjId :: SomeReference (UReference.Id' (New ObjectId)) --- newSomeObjId = (newSomeRefId ^. from uRefIdAsRefId_) & someRef_ . UReference.idH .~ newObjId - --- data SomeReference ref --- = TermReference ref --- | TypeReference ref --- | ConstructorReference ref ConstructorId --- deriving (Eq, Functor, Generic, Ord, Show, Foldable, Traversable) - --- someRef_ :: Lens (SomeReference ref) (SomeReference ref') ref ref' --- someRef_ = lens getter setter --- where --- setter (TermReference _) r = TermReference r --- setter (TypeReference _) r = TypeReference r --- setter (ConstructorReference _ conId) r = (ConstructorReference r conId) --- getter = \case --- TermReference r -> r --- TypeReference r -> r --- ConstructorReference r _ -> r - --- _TermReference :: Prism' (SomeReference ref) ref --- _TermReference = _Ctor @"TermReference" - --- -- | This is only safe as long as you don't change the constructor of your SomeReference --- asTermReference_ :: Traversal' ref (SomeReference ref) --- asTermReference_ f ref = --- f (TermReference ref) <&> \case --- TermReference ref' -> ref' --- _ -> error "asTermReference_: SomeReferenceId constructor was changed." - --- -- | This is only safe as long as you don't change the constructor of your SomeReference --- asTypeReference_ :: Traversal' ref (SomeReference ref) --- asTypeReference_ f ref = --- f (TypeReference ref) <&> \case --- TypeReference ref' -> ref' --- _ -> error "asTypeReference_: SomeReferenceId constructor was changed." - --- -- | This is only safe as long as you don't change the constructor of your SomeReference --- asConstructorReference_ :: Traversal' (ConstructorReference.GConstructorReference ref) (SomeReference ref) --- asConstructorReference_ f (ConstructorReference.ConstructorReference ref cId) = --- f (ConstructorReference ref cId) <&> \case --- ConstructorReference ref' cId -> ConstructorReference.ConstructorReference ref' cId --- _ -> error "asConstructorReference_: SomeReferenceId constructor was changed." - --- someReferenceIdToEntity :: SomeReferenceId -> Entity --- someReferenceIdToEntity = \case --- (TermReference ref) -> TermComponent (Reference.idToHash ref) --- (TypeReference ref) -> DeclComponent (Reference.idToHash ref) --- -- Constructors are migrated by their decl component. --- (ConstructorReference ref _conId) -> DeclComponent (Reference.idToHash ref) - --- foldSetter :: LensLike (Writer [a]) s t a a -> s -> [a] --- foldSetter t s = execWriter (s & t %%~ \a -> tell [a] *> pure a) - --- -- | Save an empty branch and get its new hash to use when replacing --- -- branches which are missing due to database corruption. --- saveV2EmptyBranch :: Sqlite.DB m => m (BranchHashId, Hash) --- saveV2EmptyBranch = do --- let branch = S.emptyBranch --- let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch branch --- newHash <- Hashing.dbBranchHash branch --- newHashId <- Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash)) --- _ <- Ops.saveBranchObject newHashId localBranchIds localBranch --- pure (newHashId, newHash) + +migrateSchema1To2' :: + MonadIO m => + Sqlite.Connection -> + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> + TVar (Map Hash Ops2.TermBufferEntry) -> + TVar (Map Hash Ops2.DeclBufferEntry) -> + m () +migrateSchema1To2' conn getDeclType termBuffer declBuffer = do + liftIO do + Sqlite.runWriteTransaction conn \runIO -> do + runIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" + corruptedCausals <- Q.getCausalsWithoutBranchObjects + when (not . null $ corruptedCausals) $ + runIO $ do + putStrLn $ "โš ๏ธ I detected " <> show (length corruptedCausals) <> " corrupted namespace(s) in the history of the codebase." + putStrLn $ "This is due to a bug in a previous version of ucm." + putStrLn $ "This only affects the history of your codebase, the most up-to-date iteration will remain intact." + putStrLn $ "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." + + runIO $ putStrLn $ "Updating Namespace Root..." + rootCausalHashId <- Q.expectNamespaceRoot + numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] + v2EmptyBranchHashInfo <- saveV2EmptyBranch + watches <- + foldMapM + (\watchKind -> map (W watchKind) <$> Ops2.watches (Cv.watchKind2to1 watchKind)) + [WK.RegularWatch, WK.TestWatch] + migrationState <- + Sync.sync @_ @Entity (migrationSync getDeclType termBuffer declBuffer) (progress runIO numEntitiesToMigrate) (CausalE rootCausalHashId : watches) + `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo + let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId + runIO $ putStrLn $ "Updating Namespace Root..." + Q.setNamespaceRoot newRootCausalHashId + runIO $ putStrLn $ "Rewriting old object IDs..." + ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do + Q.recordObjectRehash oldObjId newObjId + runIO $ putStrLn $ "Garbage collecting orphaned objects..." + Q.garbageCollectObjectsWithoutHashes + runIO $ putStrLn $ "Garbage collecting orphaned watches..." + Q.garbageCollectWatchesWithoutObjects + runIO $ putStrLn $ "Updating Schema Version..." + Q.setSchemaVersion 2 + where + progress :: (forall a. IO a -> Sqlite.Transaction a) -> Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) Entity + progress runIO numToMigrate = + let incrementProgress :: StateT MigrationState Sqlite.Transaction () + incrementProgress = do + numDone <- field @"numMigrated" <+= 1 + lift $ runIO $ putStr $ "\r ๐Ÿ— " <> show numDone <> " / ~" <> show numToMigrate <> " entities migrated. ๐Ÿšง" + need :: Entity -> StateT MigrationState Sqlite.Transaction () + need e = when verboseOutput $ lift $ runIO $ putStrLn $ "Need: " ++ show e + done :: Entity -> StateT MigrationState Sqlite.Transaction () + done e = do + when verboseOutput $ lift $ runIO $ putStrLn $ "Done: " ++ show e + incrementProgress + errorHandler :: Entity -> StateT MigrationState Sqlite.Transaction () + errorHandler e = do + case e of + -- We expect non-fatal errors when migrating watches. + W {} -> pure () + e -> lift $ runIO $ putStrLn $ "Error: " ++ show e + incrementProgress + allDone :: StateT MigrationState Sqlite.Transaction () + allDone = lift $ runIO $ putStrLn $ "\nFinished migrating, initiating cleanup." + in Sync.Progress {need, done, error = errorHandler, allDone} + +type Old a = a + +type New a = a + +type ConstructorName v = v + +type DeclName v = v + +data MigrationState = MigrationState + -- Mapping between old cycle-position -> new cycle-position for a given Decl object. + { referenceMapping :: Map (Old SomeReferenceId) (New SomeReferenceId), + causalMapping :: Map (Old CausalHashId) (New (CausalHash, CausalHashId)), + -- We also store the old hash for this object ID since we need a way to + -- convert Object Reference IDs into Hash Reference IDs so we can use the referenceMapping. + objLookup :: Map (Old ObjectId) (New ObjectId, New HashId, New Hash, Old Hash), + -- Remember the hashes of term/decls that we have already migrated to avoid migrating them twice. + migratedDefnHashes :: Set (Old Hash), + numMigrated :: Int, + v2EmptyBranchHashInfo :: (BranchHashId, Hash) + } + deriving (Generic) + +data Entity + = TermComponent Unison.Hash + | DeclComponent Unison.Hash + | CausalE CausalHashId + | BranchE ObjectId + | PatchE ObjectId + | W WK.WatchKind Reference.Id + deriving (Eq, Ord, Show) + +migrationSync :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> + TVar (Map Hash Ops2.TermBufferEntry) -> + TVar (Map Hash Ops2.DeclBufferEntry) -> + Sync (StateT MigrationState Sqlite.Transaction) Entity +migrationSync getDeclType termBuffer declBuffer = Sync \case + TermComponent hash -> migrateTermComponent getDeclType termBuffer declBuffer hash + DeclComponent hash -> migrateDeclComponent termBuffer declBuffer hash + BranchE objectId -> migrateBranch objectId + -- CausalE causalHashId -> do + -- Env {db} <- ask + -- lift (migrateCausal db causalHashId) + PatchE objectId -> migratePatch (PatchObjectId objectId) + W watchKind watchId -> migrateWatch getDeclType watchKind watchId + +migrateCausal :: CausalHashId -> StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) +migrateCausal oldCausalHashId = fmap (either id id) . runExceptT $ do + whenM (Map.member oldCausalHashId <$> use (field @"causalMapping")) (throwE Sync.PreviouslyDone) + + oldBranchHashId <- lift . lift $ Q.expectCausalValueHashId oldCausalHashId + oldCausalParentHashIds <- lift . lift $ Q.loadCausalParents oldCausalHashId + + maybeOldBranchObjId <- + lift . lift $ + Q.loadObjectIdForAnyHashId (unBranchHashId oldBranchHashId) + migratedObjIds <- gets objLookup + -- If the branch for this causal hasn't been migrated, migrate it first. + let unmigratedBranch = + case maybeOldBranchObjId of + Just branchObjId | branchObjId `Map.notMember` migratedObjIds -> [BranchE branchObjId] + _ -> [] + + migratedCausals <- gets causalMapping + let unmigratedParents = + oldCausalParentHashIds + & filter (`Map.notMember` migratedCausals) + & fmap CausalE + let unmigratedEntities = unmigratedBranch <> unmigratedParents + when (not . null $ unmigratedParents <> unmigratedBranch) (throwE $ Sync.Missing unmigratedEntities) + + (newBranchHashId, newBranchHash) <- case maybeOldBranchObjId of + -- Some codebases are corrupted, likely due to interrupted save operations. + -- It's unfortunate, but rather than fail the whole migration we'll just replace them + -- with an empty branch. + Nothing -> use (field @"v2EmptyBranchHashInfo") + Just branchObjId -> do + let (_, newBranchHashId, newBranchHash, _) = migratedObjIds ^?! ix branchObjId + pure (BranchHashId newBranchHashId, newBranchHash) + + let (newParentHashes, newParentHashIds) = + oldCausalParentHashIds + & fmap + (\oldParentHashId -> migratedCausals ^?! ix oldParentHashId) + & unzip + & bimap (Set.fromList . map unCausalHash) Set.fromList + + let newCausalHash :: CausalHash + newCausalHash = + CausalHash . Cv.hash1to2 $ + Hashing.hashCausal + ( Hashing.Causal + { branchHash = newBranchHash, + parents = Set.mapMonotonic Cv.hash2to1 newParentHashes + } + ) + newCausalHashId <- lift . lift $ Q.saveCausalHash newCausalHash + let newCausal = + DbCausal + { selfHash = newCausalHashId, + valueHash = newBranchHashId, + parents = newParentHashIds + } + (lift . lift) do + Q.saveCausal (SC.selfHash newCausal) (SC.valueHash newCausal) + Q.saveCausalParents (SC.selfHash newCausal) (Set.toList $ SC.parents newCausal) + + field @"causalMapping" %= Map.insert oldCausalHashId (newCausalHash, newCausalHashId) + + pure Sync.Done + +migrateBranch :: ObjectId -> StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) +migrateBranch oldObjectId = fmap (either id id) . runExceptT $ do + whenM (Map.member oldObjectId <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone) + + oldBranch <- lift . lift $ Ops.expectDbBranch (BranchObjectId oldObjectId) + oldHash <- lift . lift $ fmap Cv.hash2to1 $ Q.expectPrimaryHashByObjectId oldObjectId + oldBranchWithHashes <- lift . lift $ traverseOf S.branchHashes_ (fmap Cv.hash2to1 . Q.expectPrimaryHashByObjectId) oldBranch + migratedRefs <- gets referenceMapping + migratedObjects <- gets objLookup + migratedCausals <- gets causalMapping + let allMissingTypesAndTerms :: [Entity] + allMissingTypesAndTerms = + oldBranchWithHashes + ^.. branchSomeRefs_ + . uRefIdAsRefId_ + . filtered (`Map.notMember` migratedRefs) + . to someReferenceIdToEntity + + let allMissingPatches :: [Entity] = + oldBranch + ^.. S.patches_ + . to unPatchObjectId + . filtered (`Map.notMember` migratedObjects) + . to PatchE + + let allMissingChildBranches :: [Entity] = + oldBranch + ^.. S.childrenHashes_ + . _1 + . to unBranchObjectId + . filtered (`Map.notMember` migratedObjects) + . to BranchE + + let allMissingChildCausals :: [Entity] = + oldBranch + ^.. S.childrenHashes_ + . _2 + . filtered (`Map.notMember` migratedCausals) + . to CausalE + + -- Identify dependencies and bail out if they aren't all built + let allMissingReferences :: [Entity] + allMissingReferences = + allMissingTypesAndTerms + ++ allMissingPatches + ++ allMissingChildBranches + ++ allMissingChildCausals + + when (not . null $ allMissingReferences) $ + throwE $ Sync.Missing allMissingReferences + + let remapPatchObjectId patchObjId = case Map.lookup (unPatchObjectId patchObjId) migratedObjects of + Nothing -> error $ "Expected patch: " <> show patchObjId <> " to be migrated" + Just (newPatchObjId, _, _, _) -> PatchObjectId newPatchObjId + let remapCausalHashId causalHashId = case Map.lookup causalHashId migratedCausals of + Nothing -> error $ "Expected causal hash id: " <> show causalHashId <> " to be migrated" + Just (_, newCausalHashId) -> newCausalHashId + let remapBranchObjectId objId = case Map.lookup (unBranchObjectId objId) migratedObjects of + Nothing -> error $ "Expected object: " <> show objId <> " to be migrated" + Just (newBranchObjId, _, _, _) -> BranchObjectId newBranchObjId + + let newBranch :: S.DbBranch + newBranch = + oldBranch + & branchSomeRefs_ %~ remapObjIdRefs migratedObjects migratedRefs + & S.patches_ %~ remapPatchObjectId + & S.childrenHashes_ %~ (remapBranchObjectId *** remapCausalHashId) + + let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch newBranch + newHash <- lift . lift $ Hashing.dbBranchHash newBranch + newHashId <- lift . lift $ Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash)) + newObjectId <- lift . lift $ Ops.saveBranchObject newHashId localBranchIds localBranch + field @"objLookup" %= Map.insert oldObjectId (unBranchObjectId newObjectId, unBranchHashId newHashId, newHash, oldHash) + pure Sync.Done + +migratePatch :: Old PatchObjectId -> StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) +migratePatch oldObjectId = fmap (either id id) . runExceptT $ do + whenM (Map.member (unPatchObjectId oldObjectId) <$> use (field @"objLookup")) (throwE Sync.PreviouslyDone) + + oldHash <- lift . lift $ fmap Cv.hash2to1 $ Q.expectPrimaryHashByObjectId (unPatchObjectId oldObjectId) + oldPatch <- lift . lift $ Ops.expectDbPatch oldObjectId + let hydrateHashes :: HashId -> Sqlite.Transaction Hash + hydrateHashes hashId = do + Cv.hash2to1 <$> Q.expectHash hashId + let hydrateObjectIds :: ObjectId -> Sqlite.Transaction Hash + hydrateObjectIds objId = do + Cv.hash2to1 <$> Q.expectPrimaryHashByObjectId objId + + oldPatchWithHashes :: S.Patch' TextId Hash Hash <- + lift . lift $ + (oldPatch & S.patchH_ %%~ hydrateHashes) + >>= (S.patchO_ %%~ hydrateObjectIds) + + migratedRefs <- gets referenceMapping + let isUnmigratedRef ref = Map.notMember ref migratedRefs + -- 2. Determine whether all things the patch refers to are built. + let unmigratedDependencies :: [Entity] + unmigratedDependencies = + oldPatchWithHashes ^.. patchSomeRefsH_ . uRefIdAsRefId_ . filtered isUnmigratedRef . to someReferenceIdToEntity + <> oldPatchWithHashes ^.. patchSomeRefsO_ . uRefIdAsRefId_ . filtered isUnmigratedRef . to someReferenceIdToEntity + when (not . null $ unmigratedDependencies) (throwE (Sync.Missing unmigratedDependencies)) + + let hashToHashId :: Hash -> Sqlite.Transaction HashId + hashToHashId h = + fromMaybe (error $ "expected hashId for hash: " <> show h) <$> (Q.loadHashIdByHash (Cv.hash1to2 h)) + let hashToObjectId :: Hash -> Sqlite.Transaction ObjectId + hashToObjectId = hashToHashId >=> Q.expectObjectIdForPrimaryHashId + + migratedReferences <- gets referenceMapping + let remapRef :: SomeReferenceId -> SomeReferenceId + remapRef ref = Map.findWithDefault ref ref migratedReferences + + let newPatch = + oldPatchWithHashes + & patchSomeRefsH_ . uRefIdAsRefId_ %~ remapRef + & patchSomeRefsO_ . uRefIdAsRefId_ %~ remapRef + + newPatchWithIds :: S.Patch <- + lift . lift $ + (newPatch & S.patchH_ %%~ hashToHashId) + >>= (S.patchO_ %%~ hashToObjectId) + + let (localPatchIds, localPatch) = S.LocalizeObject.localizePatch newPatchWithIds + newHash <- lift . lift $ Hashing.dbPatchHash newPatchWithIds + newObjectId <- lift . lift $ Ops.saveDbPatch (PatchHash (Cv.hash1to2 newHash)) (S.Patch.Format.Full localPatchIds localPatch) + newHashId <- lift . lift $ Q.expectHashIdByHash (Cv.hash1to2 newHash) + field @"objLookup" %= Map.insert (unPatchObjectId oldObjectId) (unPatchObjectId newObjectId, newHashId, newHash, oldHash) + pure Sync.Done + +-- | PLAN +-- * +-- NOTE: this implementation assumes that watches will be migrated AFTER everything else is finished. +-- This is because it's difficult for us to know otherwise whether a reference refers to something which doesn't exist, or just +-- something that hasn't been migrated yet. If we do it last, we know that missing references are indeed just missing from the codebase. +migrateWatch :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> + WatchKind -> + Reference.Id -> + StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) +migrateWatch getDeclType watchKind oldWatchId = fmap (either id id) . runExceptT $ do + let watchKindV1 = Cv.watchKind2to1 watchKind + watchResultTerm <- + (lift . lift) (Ops2.getWatch getDeclType watchKindV1 oldWatchId) >>= \case + -- The hash which we're watching doesn't exist in the codebase, throw out this watch. + Nothing -> throwE Sync.Done + Just term -> pure term + migratedReferences <- gets referenceMapping + newWatchId <- case Map.lookup (TermReference oldWatchId) migratedReferences of + (Just (TermReference newRef)) -> pure newRef + _ -> throwE Sync.NonFatalError + let maybeRemappedTerm :: Maybe (Term.Term Symbol Ann) + maybeRemappedTerm = + watchResultTerm + & termReferences_ %%~ \someRef -> Map.lookup someRef migratedReferences + case maybeRemappedTerm of + -- One or more references in the result didn't exist in our codebase. + Nothing -> pure Sync.NonFatalError + Just remappedTerm -> do + lift . lift $ Ops2.putWatch watchKindV1 newWatchId remappedTerm + pure Sync.Done + +uRefIdAsRefId_ :: Iso' (SomeReference (UReference.Id' Hash)) SomeReferenceId +uRefIdAsRefId_ = mapping uRefAsRef_ + +uRefAsRef_ :: Iso' (UReference.Id' Hash) Reference.Id +uRefAsRef_ = iso intoRef intoURef + where + intoRef (UReference.Id hash pos) = Reference.Id hash pos + intoURef (Reference.Id hash pos) = UReference.Id hash pos + +-- Project an S.Referent'' into its SomeReferenceObjId's +someReferent_ :: + forall t h. + (forall ref. Traversal' ref (SomeReference ref)) -> + Traversal' (S.Branch.Full.Referent'' t h) (SomeReference (UReference.Id' h)) +someReferent_ typeOrTermTraversal_ = + (UReferent._Ref . someReference_ typeOrTermTraversal_) + `failing` ( UReferent._Con + . asPair_ -- Need to unpack the embedded reference AND remap between mismatched Constructor ID types. + . asConstructorReference_ + ) + where + asPair_ f (UReference.ReferenceDerived id', conId) = + f (ConstructorReference.ConstructorReference id' (fromIntegral conId)) + <&> \(ConstructorReference.ConstructorReference newId newConId) -> + (UReference.ReferenceDerived newId, fromIntegral newConId) + asPair_ _ (UReference.ReferenceBuiltin x, conId) = pure (UReference.ReferenceBuiltin x, conId) + +someReference_ :: + (forall ref. Traversal' ref (SomeReference ref)) -> + Traversal' (UReference.Reference' t h) (SomeReference (UReference.Id' h)) +someReference_ typeOrTermTraversal_ = UReference._ReferenceDerived . typeOrTermTraversal_ + +someMetadataSetFormat_ :: + (Ord t, Ord h) => + (forall ref. Traversal' ref (SomeReference ref)) -> + Traversal' (S.Branch.Full.MetadataSetFormat' t h) (SomeReference (UReference.Id' h)) +someMetadataSetFormat_ typeOrTermTraversal_ = + S.Branch.Full.metadataSetFormatReferences_ . someReference_ typeOrTermTraversal_ + +someReferenceMetadata_ :: + (Ord k, Ord t, Ord h) => + Traversal' k (SomeReference (UReference.Id' h)) -> + Traversal' + (Map k (S.Branch.Full.MetadataSetFormat' t h)) + (SomeReference (UReference.Id' h)) +someReferenceMetadata_ keyTraversal_ f m = + Map.toList m + & traversed . beside keyTraversal_ (someMetadataSetFormat_ asTermReference_) %%~ f + <&> Map.fromList + +branchSomeRefs_ :: (Ord t, Ord h) => Traversal' (S.Branch' t h p c) (SomeReference (UReference.Id' h)) +branchSomeRefs_ f S.Branch.Full.Branch {children, patches, terms, types} = do + let newTypesMap = types & traversed . someReferenceMetadata_ (someReference_ asTypeReference_) %%~ f + let newTermsMap = terms & traversed . someReferenceMetadata_ (someReferent_ asTermReference_) %%~ f + S.Branch.Full.Branch <$> newTermsMap <*> newTypesMap <*> pure patches <*> pure children + +patchSomeRefsH_ :: (Ord t, Ord h) => Traversal (S.Patch' t h o) (S.Patch' t h o) (SomeReference (UReference.Id' h)) (SomeReference (UReference.Id' h)) +patchSomeRefsH_ f S.Patch {termEdits, typeEdits} = do + newTermEdits <- Map.fromList <$> (Map.toList termEdits & traversed . _1 . (someReferent_ asTermReference_) %%~ f) + newTypeEdits <- Map.fromList <$> (Map.toList typeEdits & traversed . _1 . (someReference_ asTypeReference_) %%~ f) + pure S.Patch {termEdits = newTermEdits, typeEdits = newTypeEdits} + +patchSomeRefsO_ :: (Ord t, Ord h, Ord o) => Traversal' (S.Patch' t h o) (SomeReference (UReference.Id' o)) +patchSomeRefsO_ f S.Patch {termEdits, typeEdits} = do + newTermEdits <- (termEdits & traversed . Set.traverse . termEditRefs_ %%~ f) + newTypeEdits <- (typeEdits & traversed . Set.traverse . typeEditRefs_ %%~ f) + pure (S.Patch {termEdits = newTermEdits, typeEdits = newTypeEdits}) + +termEditRefs_ :: Traversal' (TermEdit.TermEdit' t h) (SomeReference (UReference.Id' h)) +termEditRefs_ f (TermEdit.Replace ref typing) = + TermEdit.Replace <$> (ref & someReferent_ asTermReference_ %%~ f) <*> pure typing +termEditRefs_ _f (TermEdit.Deprecate) = pure TermEdit.Deprecate + +typeEditRefs_ :: Traversal' (TypeEdit.TypeEdit' t h) (SomeReference (UReference.Id' h)) +typeEditRefs_ f (TypeEdit.Replace ref) = + TypeEdit.Replace <$> (ref & someReference_ asTypeReference_ %%~ f) +typeEditRefs_ _f (TypeEdit.Deprecate) = pure TypeEdit.Deprecate + +migrateTermComponent :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> + TVar (Map Hash Ops2.TermBufferEntry) -> + TVar (Map Hash Ops2.DeclBufferEntry) -> + Unison.Hash -> + StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) +migrateTermComponent getDeclType termBuffer declBuffer oldHash = fmap (either id id) . runExceptT $ do + whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone) + + oldComponent <- + (lift . lift $ Ops2.getTermComponentWithTypes getDeclType oldHash) >>= \case + Nothing -> error $ "Hash was missing from codebase: " <> show oldHash + Just c -> pure c + + let componentIDMap :: Map (Old Reference.Id) (Term.Term Symbol Ann, Type Symbol Ann) + componentIDMap = Map.fromList $ Reference.componentFor oldHash oldComponent + let unhashed :: Map (Old Reference.Id) (Symbol, Term.Term Symbol Ann) + unhashed = Term.unhashComponent (fst <$> componentIDMap) + let vToOldReferenceMapping :: Map Symbol (Old Reference.Id) + vToOldReferenceMapping = + unhashed + & Map.toList + & fmap (\(refId, (v, _trm)) -> (v, refId)) + & Map.fromList + + referencesMap <- gets referenceMapping + + let allMissingReferences :: [Old SomeReferenceId] + allMissingReferences = + let missingTermRefs = + unhashed & foldSetter (traversed . _2 . termReferences_) + missingTypeRefs = + componentIDMap + & foldSetter (traversed . _2 . typeReferences_) + in filter (`Map.notMember` referencesMap) (missingTermRefs <> missingTypeRefs) + + when (not . null $ allMissingReferences) $ + throwE $ Sync.Missing . nubOrd $ (someReferenceIdToEntity <$> allMissingReferences) + + let getMigratedReference :: Old SomeReferenceId -> New SomeReferenceId + getMigratedReference ref = + Map.findWithDefault (error $ "unmigrated reference" <> show ref) ref referencesMap + + let remappedReferences :: Map (Old Reference.Id) (Symbol, Term.Term Symbol Ann, Type Symbol Ann) = + Zip.zipWith + ( \(v, trm) (_, typ) -> + ( v, + trm & termReferences_ %~ getMigratedReference, + typ & typeReferences_ %~ getMigratedReference + ) + ) + unhashed + componentIDMap + + let newTermComponents :: Map Symbol (New Reference.Id, Term.Term Symbol Ann, Type Symbol Ann) + newTermComponents = + remappedReferences + & Map.elems + & fmap (\(v, trm, typ) -> (v, (trm, typ))) + & Map.fromList + & Convert.hashTermComponents + + ifor newTermComponents $ \v (newReferenceId, trm, typ) -> do + let oldReferenceId = vToOldReferenceMapping ^?! ix v + field @"referenceMapping" %= Map.insert (TermReference oldReferenceId) (TermReference newReferenceId) + lift . lift $ Ops2.putTerm termBuffer declBuffer newReferenceId trm typ + + -- Need to get one of the new references to grab its hash, doesn't matter which one since + -- all hashes in the component are the same. + case newTermComponents ^? traversed . _1 . to Reference.idToHash of + Nothing -> pure () + Just newHash -> lift (insertObjectMappingForHash oldHash newHash) + + field @"migratedDefnHashes" %= Set.insert oldHash + pure Sync.Done + +migrateDeclComponent :: + TVar (Map Hash Ops2.TermBufferEntry) -> + TVar (Map Hash Ops2.DeclBufferEntry) -> + Unison.Hash -> + StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) +migrateDeclComponent termBuffer declBuffer oldHash = fmap (either id id) . runExceptT $ do + whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone) + + declComponent :: [DD.Decl v a] <- + (lift . lift $ Ops2.getDeclComponent oldHash) >>= \case + Nothing -> error $ "Expected decl component for hash:" <> show oldHash + Just dc -> pure dc + + let componentIDMap :: Map (Old Reference.Id) (DD.Decl v a) + componentIDMap = Map.fromList $ Reference.componentFor oldHash declComponent + + let unhashed :: Map (Old Reference.Id) (DeclName v, DD.Decl v a) + unhashed = DD.unhashComponent componentIDMap + + let allTypes :: [Type v a] + allTypes = + unhashed + ^.. traversed + . _2 + . beside DD.asDataDecl_ id + . to DD.constructors' + . traversed + . _3 + + migratedReferences <- gets referenceMapping + let unmigratedRefIds :: [SomeReferenceId] + unmigratedRefIds = + allTypes + & foldSetter + ( traversed -- Every type in the list + . typeReferences_ + . filtered (`Map.notMember` migratedReferences) + ) + + when (not . null $ unmigratedRefIds) do + throwE (Sync.Missing (nubOrd . fmap someReferenceIdToEntity $ unmigratedRefIds)) + + -- At this point we know we have all the required mappings from old references to new ones. + let remapTerm :: Type v a -> Type v a + remapTerm = typeReferences_ %~ \ref -> Map.findWithDefault (error "unmigrated reference") ref migratedReferences + + let remappedReferences :: Map (Old Reference.Id) (DeclName v, DD.Decl v a) + remappedReferences = + unhashed + & traversed -- Traverse map of reference IDs + . _2 -- Select the DataDeclaration + . beside DD.asDataDecl_ id -- Unpack effect decls + . DD.constructors_ -- Get the data constructors + . traversed -- traverse the list of them + . _3 -- Select the Type term. + %~ remapTerm + + let declNameToOldReference :: Map (DeclName v) (Old Reference.Id) + declNameToOldReference = Map.fromList . fmap swap . Map.toList . fmap fst $ remappedReferences + + let newComponent :: [(DeclName v, Reference.Id, DD.Decl v a)] + newComponent = + remappedReferences + & Map.elems + & Map.fromList + & Convert.hashDecls + & fromRight (error "unexpected resolution error") + + for_ newComponent $ \(declName, newReferenceId, dd) -> do + let oldReferenceId = declNameToOldReference ^?! ix declName + field @"referenceMapping" %= Map.insert (TypeReference oldReferenceId) (TypeReference newReferenceId) + + let oldConstructorIds :: Map (ConstructorName v) (Old ConstructorId) + oldConstructorIds = + (componentIDMap ^?! ix oldReferenceId) + & DD.asDataDecl + & DD.constructors' + & imap (\constructorId (_ann, constructorName, _type) -> (constructorName, fromIntegral constructorId)) + & Map.fromList + + ifor_ (DD.constructors' (DD.asDataDecl dd)) \(fromIntegral -> newConstructorId) (_ann, constructorName, _type) -> do + field @"referenceMapping" + %= Map.insert + (ConstructorReference oldReferenceId (oldConstructorIds ^?! ix constructorName)) + (ConstructorReference newReferenceId newConstructorId) + + lift . lift $ Ops2.putTypeDeclaration termBuffer declBuffer newReferenceId dd + + -- Need to get one of the new references to grab its hash, doesn't matter which one since + -- all hashes in the component are the same. + case newComponent ^? traversed . _2 . to Reference.idToHash of + Nothing -> pure () + Just newHash -> lift (insertObjectMappingForHash oldHash newHash) + field @"migratedDefnHashes" %= Set.insert oldHash + + pure Sync.Done + +insertObjectMappingForHash :: Old Hash -> New Hash -> StateT MigrationState Sqlite.Transaction () +insertObjectMappingForHash oldHash newHash = do + (oldObjectId, newHashId, newObjectId) <- lift do + oldHashId <- Q.expectHashIdByHash . Cv.hash1to2 $ oldHash + oldObjectId <- Q.expectObjectIdForPrimaryHashId $ oldHashId + newHashId <- Q.expectHashIdByHash . Cv.hash1to2 $ newHash + newObjectId <- Q.expectObjectIdForPrimaryHashId $ newHashId + pure (oldObjectId, newHashId, newObjectId) + field @"objLookup" %= Map.insert oldObjectId (newObjectId, newHashId, newHash, oldHash) + +typeReferences_ :: (Monad m, Ord v) => LensLike' m (Type v a) SomeReferenceId +typeReferences_ = + ABT.rewriteDown_ -- Focus all terms + . ABT.baseFunctor_ -- Focus Type.F + . Type._Ref -- Only the Ref constructor has references + . Reference._DerivedId + . asTypeReference_ + +termReferences_ :: (Monad m, Ord v) => LensLike' m (Term.Term v a) SomeReferenceId +termReferences_ = + ABT.rewriteDown_ -- Focus all terms + . ABT.baseFunctor_ -- Focus Term.F + . termFReferences_ + +termFReferences_ :: (Ord tv, Monad m) => LensLike' m (Term.F tv ta pa a) SomeReferenceId +termFReferences_ f t = + (t & Term._Ref . Reference._DerivedId . asTermReference_ %%~ f) + >>= Term._Constructor . someRefCon_ %%~ f + >>= Term._Request . someRefCon_ %%~ f + >>= Term._Ann . _2 . typeReferences_ %%~ f + >>= Term._Match . _2 . traversed . Term.matchPattern_ . patternReferences_ %%~ f + >>= Term._TermLink . referentAsSomeTermReference_ %%~ f + >>= Term._TypeLink . Reference._DerivedId . asTypeReference_ %%~ f + +-- | Build a SomeConstructorReference +someRefCon_ :: Traversal' ConstructorReference.ConstructorReference SomeReferenceId +someRefCon_ = refConPair_ . asConstructorReference_ + where + refConPair_ :: Traversal' ConstructorReference.ConstructorReference ConstructorReference.ConstructorReferenceId + refConPair_ f s = + case s of + ConstructorReference.ConstructorReference (Reference.Builtin _) _ -> pure s + ConstructorReference.ConstructorReference (Reference.DerivedId n) c -> + ( \(ConstructorReference.ConstructorReference n' c') -> + ConstructorReference.ConstructorReference (Reference.DerivedId n') c' + ) + <$> f (ConstructorReference.ConstructorReference n c) + +patternReferences_ :: Traversal' (Pattern loc) SomeReferenceId +patternReferences_ f = \case + p@(Pattern.Unbound {}) -> pure p + p@(Pattern.Var {}) -> pure p + p@(Pattern.Boolean {}) -> pure p + p@(Pattern.Int {}) -> pure p + p@(Pattern.Nat {}) -> pure p + p@(Pattern.Float {}) -> pure p + p@(Pattern.Text {}) -> pure p + p@(Pattern.Char {}) -> pure p + (Pattern.Constructor loc ref patterns) -> + (\newRef newPatterns -> Pattern.Constructor loc newRef newPatterns) + <$> (ref & someRefCon_ %%~ f) + <*> (patterns & traversed . patternReferences_ %%~ f) + (Pattern.As loc pat) -> Pattern.As loc <$> patternReferences_ f pat + (Pattern.EffectPure loc pat) -> Pattern.EffectPure loc <$> patternReferences_ f pat + (Pattern.EffectBind loc ref patterns pat) -> + do + (\newRef newPatterns newPat -> Pattern.EffectBind loc newRef newPatterns newPat) + <$> (ref & someRefCon_ %%~ f) + <*> (patterns & traversed . patternReferences_ %%~ f) + <*> (patternReferences_ f pat) + (Pattern.SequenceLiteral loc patterns) -> + Pattern.SequenceLiteral loc <$> (patterns & traversed . patternReferences_ %%~ f) + Pattern.SequenceOp loc pat seqOp pat2 -> do + Pattern.SequenceOp loc <$> patternReferences_ f pat <*> pure seqOp <*> patternReferences_ f pat2 + +referentAsSomeTermReference_ :: Traversal' Referent.Referent SomeReferenceId +referentAsSomeTermReference_ f = \case + (Referent'.Ref' (Reference.DerivedId refId)) -> do + newRefId <- refId & asTermReference_ %%~ f + pure (Referent'.Ref' (Reference.DerivedId newRefId)) + (Referent'.Con' (ConstructorReference.ConstructorReference (Reference.DerivedId refId) conId) conType) -> + (ConstructorReference.ConstructorReference refId conId & asConstructorReference_ %%~ f) + <&> \(ConstructorReference.ConstructorReference newRefId newConId) -> + Referent'.Con' + (ConstructorReference.ConstructorReference (Reference.DerivedId newRefId) newConId) + conType + r -> pure r + +type SomeReferenceId = SomeReference Reference.Id + +type SomeReferenceObjId = SomeReference (UReference.Id' ObjectId) + +remapObjIdRefs :: + (Map (Old ObjectId) (New ObjectId, New HashId, New Hash, Old Hash)) -> + (Map SomeReferenceId SomeReferenceId) -> + SomeReferenceObjId -> + SomeReferenceObjId +remapObjIdRefs objMapping refMapping someObjIdRef = newSomeObjId + where + oldObjId :: ObjectId + oldObjId = someObjIdRef ^. someRef_ . UReference.idH + (newObjId, _, _, oldHash) = + case Map.lookup oldObjId objMapping of + Nothing -> error $ "Expected object mapping for ID: " <> show oldObjId + Just found -> found + oldSomeRefId :: SomeReferenceId + oldSomeRefId = (someObjIdRef & someRef_ . UReference.idH .~ oldHash) ^. uRefIdAsRefId_ + newSomeRefId :: SomeReferenceId + newSomeRefId = case Map.lookup oldSomeRefId refMapping of + Nothing -> error $ "Expected reference mapping for ID: " <> show oldSomeRefId + Just r -> r + newSomeObjId :: SomeReference (UReference.Id' (New ObjectId)) + newSomeObjId = (newSomeRefId ^. from uRefIdAsRefId_) & someRef_ . UReference.idH .~ newObjId + +data SomeReference ref + = TermReference ref + | TypeReference ref + | ConstructorReference ref ConstructorId + deriving (Eq, Functor, Generic, Ord, Show, Foldable, Traversable) + +someRef_ :: Lens (SomeReference ref) (SomeReference ref') ref ref' +someRef_ = lens getter setter + where + setter (TermReference _) r = TermReference r + setter (TypeReference _) r = TypeReference r + setter (ConstructorReference _ conId) r = (ConstructorReference r conId) + getter = \case + TermReference r -> r + TypeReference r -> r + ConstructorReference r _ -> r + +_TermReference :: Prism' (SomeReference ref) ref +_TermReference = _Ctor @"TermReference" + +-- | This is only safe as long as you don't change the constructor of your SomeReference +asTermReference_ :: Traversal' ref (SomeReference ref) +asTermReference_ f ref = + f (TermReference ref) <&> \case + TermReference ref' -> ref' + _ -> error "asTermReference_: SomeReferenceId constructor was changed." + +-- | This is only safe as long as you don't change the constructor of your SomeReference +asTypeReference_ :: Traversal' ref (SomeReference ref) +asTypeReference_ f ref = + f (TypeReference ref) <&> \case + TypeReference ref' -> ref' + _ -> error "asTypeReference_: SomeReferenceId constructor was changed." + +-- | This is only safe as long as you don't change the constructor of your SomeReference +asConstructorReference_ :: Traversal' (ConstructorReference.GConstructorReference ref) (SomeReference ref) +asConstructorReference_ f (ConstructorReference.ConstructorReference ref cId) = + f (ConstructorReference ref cId) <&> \case + ConstructorReference ref' cId -> ConstructorReference.ConstructorReference ref' cId + _ -> error "asConstructorReference_: SomeReferenceId constructor was changed." + +someReferenceIdToEntity :: SomeReferenceId -> Entity +someReferenceIdToEntity = \case + (TermReference ref) -> TermComponent (Reference.idToHash ref) + (TypeReference ref) -> DeclComponent (Reference.idToHash ref) + -- Constructors are migrated by their decl component. + (ConstructorReference ref _conId) -> DeclComponent (Reference.idToHash ref) + +foldSetter :: LensLike (Writer [a]) s t a a -> s -> [a] +foldSetter t s = execWriter (s & t %%~ \a -> tell [a] *> pure a) + +-- | Save an empty branch and get its new hash to use when replacing +-- branches which are missing due to database corruption. +saveV2EmptyBranch :: Sqlite.Transaction (BranchHashId, Hash) +saveV2EmptyBranch = do + let branch = S.emptyBranch + let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch branch + newHash <- Hashing.dbBranchHash branch + newHashId <- Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash)) + _ <- Ops.saveBranchObject newHashId localBranchIds localBranch + pure (newHashId, newHash) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs index bf19122521..212455a360 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs @@ -5,9 +5,9 @@ import U.Codebase.Sqlite.DbId (HashVersion (..), SchemaVersion (..)) import qualified U.Codebase.Sqlite.Queries as Q import Unison.Codebase (Codebase) import Unison.Codebase.SqliteCodebase.Migrations.Errors (MigrationError (IncorrectStartingSchemaVersion)) +import Unison.Prelude import qualified Unison.Sqlite as Sqlite import Unison.Var (Var) -import Unison.Prelude import qualified UnliftIO -- | The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this @@ -26,10 +26,21 @@ import qualified UnliftIO -- This migration drops all the v1 hash objects to avoid this issue, since these hash objects -- weren't being used for anything anyways. migrateSchema2To3 :: forall a m v. (MonadUnliftIO m, Var v) => Sqlite.Connection -> Codebase m v a -> m (Either MigrationError ()) -migrateSchema2To3 conn _ = UnliftIO.try . flip runReaderT conn $ - undefined - -- Sqlite.withSavepoint "MIGRATE_SCHEMA_2_TO_3" $ \_rollback -> do - -- version <- Q.schemaVersion - -- when (version /= 2) $ UnliftIO.throwIO (IncorrectStartingSchemaVersion version) - -- Q.removeHashObjectsByHashingVersion (HashVersion 1) - -- Q.setSchemaVersion (SchemaVersion 3) +migrateSchema2To3 conn _ = + UnliftIO.try . flip runReaderT conn $ + undefined + +-- Sqlite.withSavepoint "MIGRATE_SCHEMA_2_TO_3" $ \_rollback -> do +-- version <- Q.schemaVersion +-- when (version /= 2) $ UnliftIO.throwIO (IncorrectStartingSchemaVersion version) +-- Q.removeHashObjectsByHashingVersion (HashVersion 1) +-- Q.setSchemaVersion (SchemaVersion 3) + +migrateSchema2To3' :: MonadUnliftIO m => Sqlite.Connection -> m (Either MigrationError ()) +migrateSchema2To3' conn = + UnliftIO.try do + Sqlite.runTransactionWithAbort conn \abort -> do + version <- Q.schemaVersion + when (version /= 2) $ abort (IncorrectStartingSchemaVersion version) + Q.removeHashObjectsByHashingVersion (HashVersion 1) + Q.setSchemaVersion (SchemaVersion 3) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index fcd2edd92e..2e070eb54e 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -7,66 +7,29 @@ -- are unified with non-sqlite operations in the Codebase interface, like 'appendReflog'. module Unison.Codebase.SqliteCodebase.Operations where -import qualified Control.Concurrent -import Control.Monad.Except (ExceptT, runExceptT, throwError) -import qualified Control.Monad.Except as Except -import qualified Control.Monad.Extra as Monad -import Control.Monad.Reader (ReaderT (runReaderT)) -import Control.Monad.State (MonadState) -import qualified Control.Monad.State as State import Data.Bifunctor (Bifunctor (bimap), second) import Data.Bitraversable (bitraverse) -import qualified Data.Char as Char import Data.Either.Extra () import qualified Data.List as List import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1) import qualified Data.Map as Map -import Data.Maybe (fromJust) import qualified Data.Set as Set import qualified Data.Text as Text -import qualified Data.Text.IO as TextIO -import qualified System.Console.ANSI as ANSI -import System.FilePath (()) -import qualified System.FilePath as FilePath -import qualified System.FilePath.Posix as FilePath.Posix -import U.Codebase.HashTags (CausalHash (CausalHash, unCausalHash)) +import U.Codebase.HashTags (CausalHash (unCausalHash)) import qualified U.Codebase.Reference as C.Reference import qualified U.Codebase.Referent as C.Referent import U.Codebase.Sqlite.DbId (ObjectId) import qualified U.Codebase.Sqlite.ObjectType as OT import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Q -import qualified U.Codebase.Sqlite.Sync22 as Sync22 -import qualified U.Codebase.Sync as Sync -import qualified U.Util.Cache as Cache import qualified U.Util.Hash as H2 -import qualified U.Util.Monoid as Monoid -import U.Util.Timing (time) import qualified Unison.Builtin as Builtins -import Unison.Codebase (Codebase, CodebasePath) -import qualified Unison.Codebase as Codebase1 import Unison.Codebase.Branch (Branch (..)) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Causal.Type as Causal -import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo) -import qualified Unison.Codebase.Editor.Git as Git -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo (..), printWriteRepo, writeToRead) -import qualified Unison.Codebase.GitError as GitError -import qualified Unison.Codebase.Init as Codebase -import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1 -import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase1 import Unison.Codebase.Patch (Patch) -import qualified Unison.Codebase.Reflog as Reflog import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import qualified Unison.Codebase.SqliteCodebase.Branch.Dependencies as BD import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv -import qualified Unison.Codebase.SqliteCodebase.GitError as GitError -import Unison.Codebase.SqliteCodebase.Migrations (ensureCodebaseIsUpToDate) -import Unison.Codebase.SqliteCodebase.Paths -import qualified Unison.Codebase.SqliteCodebase.SyncEphemeral as SyncEphemeral -import Unison.Codebase.SyncMode (SyncMode) -import Unison.Codebase.Type (LocalOrRemote (..), PushGitBranchOpts (..)) -import qualified Unison.Codebase.Type as C import Unison.ConstructorReference (GConstructorReference (..)) import qualified Unison.ConstructorType as CT import Unison.DataDeclaration (Decl) @@ -81,9 +44,8 @@ import qualified Unison.Referent as Referent import Unison.ShortHash (ShortHash) import qualified Unison.ShortHash as SH import qualified Unison.ShortHash as ShortHash -import Unison.Sqlite (Connection, Transaction) +import Unison.Sqlite (Transaction) import qualified Unison.Sqlite as Sqlite -import qualified Unison.Sqlite.Connection as Sqlite.Connection import Unison.Symbol (Symbol) import Unison.Term (Term) import qualified Unison.Term as Term @@ -91,9 +53,6 @@ import Unison.Type (Type) import qualified Unison.Type as Type import qualified Unison.Util.Set as Set import qualified Unison.WatchKind as UF -import UnliftIO (catchIO, finally, throwIO, try) -import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) -import UnliftIO.Exception (catch) import UnliftIO.STM ------------------------------------------------------------------------------------------------------------------------ From 19f917beea364ce07096670e22782a5704a76f7c Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 8 Apr 2022 16:03:18 -0500 Subject: [PATCH 085/529] broken TempEntityFormat stuff --- .../U/Codebase/Sqlite/Patch/Format.hs | 23 +++++--- .../U/Codebase/Sqlite/Queries.hs | 35 ++++++++++++ .../U/Codebase/Sqlite/Sync22.hs | 2 + .../U/Codebase/Sqlite/TempEntity.hs | 18 ++++++ .../U/Codebase/Sqlite/Term/Format.hs | 12 +++- .../sql/001-temp-entity-tables.sql | 21 +++++-- .../unison-codebase-sqlite.cabal | 1 + codebase2/codebase/U/Codebase/TempEntity.hs | 14 +++++ codebase2/codebase/unison-codebase.cabal | 3 +- unison-cli/src/Unison/Share/Sync.hs | 57 +++++++++++++++---- 10 files changed, 159 insertions(+), 27 deletions(-) create mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs create mode 100644 codebase2/codebase/U/Codebase/TempEntity.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs index 05b3ab2b22..36657c8fbb 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs @@ -1,7 +1,8 @@ module U.Codebase.Sqlite.Patch.Format ( PatchFormat (..), PatchLocalIds (..), - SyncPatchFormat (..), + SyncPatchFormat, + SyncPatchFormat' (..), applyPatchDiffs, localPatchToPatch, localPatchDiffToPatchDiff, @@ -24,15 +25,21 @@ data PatchFormat = Full PatchLocalIds LocalPatch | Diff PatchObjectId PatchLocalIds LocalPatchDiff -data PatchLocalIds = LocalIds - { patchTextLookup :: Vector TextId, - patchHashLookup :: Vector HashId, - patchDefnLookup :: Vector ObjectId +type PatchLocalIds = PatchLocalIds' TextId HashId ObjectId + +data PatchLocalIds' t h d = LocalIds + { patchTextLookup :: Vector t, + patchHashLookup :: Vector h, + patchDefnLookup :: Vector d } -data SyncPatchFormat - = SyncFull PatchLocalIds ByteString - | SyncDiff PatchObjectId PatchLocalIds ByteString +type SyncPatchFormat = SyncPatchFormat' PatchObjectId TextId HashId ObjectId + +data SyncPatchFormat' p t h d + = SyncFull (PatchLocalIds t h d) ByteString + -- | p is the identity of the thing that the diff is relative to + | SyncDiff p (PatchLocalIds t h d) ByteString + -- | Apply a list of patch diffs to a patch, left to right. applyPatchDiffs :: Patch -> [PatchDiff] -> Patch diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 24238a28f4..f6f7b36abe 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -53,6 +53,7 @@ module U.Codebase.Sqlite.Queries -- * object table saveObject, + isObjectHash, loadObjectById, loadPrimaryHashByObjectId, loadObjectWithTypeById, @@ -124,6 +125,11 @@ module U.Codebase.Sqlite.Queries garbageCollectObjectsWithoutHashes, garbageCollectWatchesWithoutObjects, + -- * sync temp entities + getMissingDependencyJwtsForTempEntity, + tempEntityExists, + insertTempEntity, + -- * db misc createSchema, schemaVersion, @@ -411,6 +417,12 @@ maybeObjectIdForAnyHashId h = queryAtom sql (Only h) where sql = [here| SELECT object_id FROM hash_object WHERE hash_id = ? |] +-- | Does a hash correspond to an object? +isObjectHash :: DB m => HashId -> m Bool +isObjectHash h = queryOne $ queryAtom sql (Only h) where sql = [here| + SELECT EXISTS (SELECT 1 FROM object WHERE primary_hash_id = ?) +|] + -- |All objects have corresponding hashes. loadPrimaryHashByObjectId :: EDB m => ObjectId -> m Base32Hex loadPrimaryHashByObjectId oId = queryAtom sql (Only oId) >>= orError (UnknownObjectId oId) @@ -933,6 +945,29 @@ ancestorSql = SELECT * FROM ancestor |] +-- * share sync / temp entities + +getMissingDependencyJwtsForTempEntity :: DB m => Base32Hex -> m [Text] +getMissingDependencyJwtsForTempEntity h = + queryAtoms + [here| + SELECT jwt FROM temp_entity_missing_dependency + WHERE dependent = ? + |] + (Only h) + +tempEntityExists :: DB m => Base32Hex -> m Bool +tempEntityExists h = queryOne $ queryAtom sql (Only h) + where + sql = + [here| + SELECT EXISTS ( + SELECT 1 + FROM temp_entity + WHERE hash = ? + ) + |] + -- * helper functions -- | composite input, atomic List output diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs index a635b08a5c..d1cfb526ad 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs @@ -143,6 +143,8 @@ trySync tCache hCache oCache cCache = \case -- revisited when there are more formats. -- (or maybe i'll learn something by implementing sync for patches and namespaces, -- which have two formats already) + -- + -- todo: replace all this with something that de/serializes to SyncTermFormat (fmt, unzip -> (localIds, bytes)) <- lift case flip runGetS bytes do tag <- getWord8 diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs new file mode 100644 index 0000000000..c4da4efe0d --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -0,0 +1,18 @@ +module U.Codebase.Sqlite.TempEntity where + +data TempEntity text noSyncHash hash + = TC (TermFormat' text hash) + | DC (DeclComponent text hash) + | P (Patch text noSyncHash hash) + | N (Namespace text hash) + | C (Causal hash) + deriving stock (Show, Eq, Ord) + +type TempTermFormat text hash = + TermFormat + +data TempDeclFormat text hash + = Decl [(LocalIds' text hash, ByteString)] + +type TempPatchFormat text noSyncHash hash = + SyncPatchFormat' hash text noSyncHash hash diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs index ecb595fb13..8d62ba11f5 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs @@ -42,6 +42,9 @@ newtype LocallyIndexedComponent' t d = LocallyIndexedComponent (Vector (LocalIds' t d, Term, Type)) deriving (Show) +newtype SyncLocallyIndexedComponent' t d + = SyncLocallyIndexedComponent (Vector (LocalIds' t d, ByteString)) + {- message = "hello, world" -> ABT { ... { Term.F.Text "hello, world" } } -> hashes to (#abc, 0) program = printLine message -> ABT { ... { Term.F.App (ReferenceBuiltin ##io.PrintLine) (Reference #abc 0) } } -> hashes to (#def, 0) @@ -109,8 +112,13 @@ type FTT = Type.F' Sqlite.Reference type TypeOfTerm = ABT.Term FTT Symbol () -data TermFormat - = Term LocallyIndexedComponent +type TermFormat = TermFormat' TextId ObjectId + +data TermFormat' t d = Term (LocallyIndexedComponent' t d) + +type SyncTermFormat = SyncLocallyIndexedComponent' TextId ObjectId + +data SyncTermFormat' t d = SyncTerm (SyncLocallyIndexedComponent' t d) data WatchResultFormat = WatchResult WatchLocalIds Term diff --git a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql index 8715d11704..be9446f1bd 100644 --- a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql +++ b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql @@ -28,6 +28,13 @@ create table temp_entity ( -- A many-to-many relationship between `temp_entity` (entities we can't yet store due to missing dependencies), and the -- non-empty set of hashes of each entity's dependencies. -- +-- We store with each missing dependency the JWT that Unison Share provided us to download that dependency. For +-- downloading a particular dependency #bar, we only need one JWT, even if it's in the table multiple times. (In fact, +-- in this case, there is one "best" JWT - the one with the latest expiry time). +-- +-- The JWTs are also encoded in the local ids part of entity itself (`temp_entity.blob`), but we don't want to have to +-- keep going back there there to decode during a pull. +-- -- For example, if we wanted to store term #foo, but couldn't because it depends on term #bar which we don't have yet, -- we would end up with the following rows. -- @@ -39,14 +46,16 @@ create table temp_entity ( -- +------------------------+ -- -- temp_entity_missing_dependency --- +------------------------+ --- | dependent | dependency | --- +------------------------+ --- | #foo | #bar | --- +------------------------+ +-- +-----------------------------------+ +-- | dependent | dependency | jwt | +-- |===================================| +-- | #foo | #bar | aT.Eb.cx | +-- +-----------------------------------+ create table temp_entity_missing_dependency ( dependent text not null references temp_entity(hash), - dependency text not null + dependency text not null, + jwt text not null, + unique (dependent, dependency) ); create index temp_entity_missing_dependency_ix_dependent on temp_entity_missing_dependency (dependent); create index temp_entity_missing_dependency_ix_dependency on temp_entity_missing_dependency (dependency); diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index ee5c7bf54f..087ac81ff2 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -42,6 +42,7 @@ library U.Codebase.Sqlite.Serialization U.Codebase.Sqlite.Symbol U.Codebase.Sqlite.Sync22 + U.Codebase.Sqlite.TempEntity U.Codebase.Sqlite.Term.Format other-modules: Paths_unison_codebase_sqlite diff --git a/codebase2/codebase/U/Codebase/TempEntity.hs b/codebase2/codebase/U/Codebase/TempEntity.hs new file mode 100644 index 0000000000..643181ac14 --- /dev/null +++ b/codebase2/codebase/U/Codebase/TempEntity.hs @@ -0,0 +1,14 @@ +module U.Codebase.TempEntity where + +-- data TempEntity text noSyncHash hash +-- = TC (TermFormat' text hash) +-- | DC (DeclComponent text hash) +-- | P (Patch text noSyncHash hash) +-- | N (Namespace text hash) +-- | C (Causal hash) +-- deriving stock (Show, Eq, Ord) + +-- data TempTermFormat text hash = Term [(LocalIds' text hash, ByteString)] +-- data TempDeclFormat text hash = Decl [(LocalIds' text hash, ByteString)] +-- type TempPatchFormat text noSyncHash hash = +-- SyncPatchFormat' hash text noSyncHash hash diff --git a/codebase2/codebase/unison-codebase.cabal b/codebase2/codebase/unison-codebase.cabal index d0f15314e2..a4be8e0e62 100644 --- a/codebase2/codebase/unison-codebase.cabal +++ b/codebase2/codebase/unison-codebase.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: b4d3c77715f39c915cacffccf179f1ed62bce29ba013cecc3a25c847f5851233 +-- hash: 27799cc371607e70caa5319a1f3002fa135ac262ab2378a58ac5ca391e5d3034 name: unison-codebase version: 0.0.0 @@ -27,6 +27,7 @@ library U.Codebase.Referent U.Codebase.Reflog U.Codebase.ShortHash + U.Codebase.TempEntity U.Codebase.Term U.Codebase.TermEdit U.Codebase.Type diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 2b91252a8d..82cb095f64 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -9,17 +9,24 @@ module Unison.Share.Sync ) where +import Control.Monad.Extra ((||^)) +import Control.Monad.Reader (ReaderT, runReaderT) import qualified Data.List.NonEmpty as List.NonEmpty import qualified Data.Map.NonEmpty as NEMap import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import U.Codebase.HashTags (CausalHash (unCausalHash)) +import U.Codebase.Sqlite.Connection (Connection) import U.Codebase.Sqlite.DbId (HashId) +import qualified U.Codebase.Sqlite.Queries as Q import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as Hash +import qualified Data.Set.Lens as Lens (setOf) +import Data.Generics.Product.Typed (typed) import Unison.Prelude import qualified Unison.Sync.Types as Share +import qualified Unison.Sync.Types as Share.LocalIds (LocalIds (..)) import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set @@ -140,14 +147,39 @@ decodeHashJWT = undefined download :: Connection -> Share.RepoName -> NESet Share.HashJWT -> IO () download conn repoName = do + let runDB :: ReaderT Connection IO a -> IO a + runDB action = runReaderT action conn let inMainStorage :: Share.Hash -> IO Bool - inMainStorage = undefined + inMainStorage (Share.Hash b32) = runDB do + -- first get hashId if exists + Q.loadHashId (Base32Hex.UnsafeFromText b32) >>= \case + Nothing -> pure False + -- then check if is causal hash or if object exists for hash id + Just hashId -> Q.isCausalHash hashId ||^ Q.isObjectHash hashId let inTempStorage :: Share.Hash -> IO Bool - inTempStorage = undefined + inTempStorage (Share.Hash b32) = runDB $ Q.tempEntityExists (Base32Hex.UnsafeFromText b32) let directDepsOfEntity :: Share.Entity Text Share.Hash Share.HashJWT -> Set Share.DecodedHashJWT - directDepsOfEntity = undefined - let directDepsOfHash :: Share.Hash -> Set Share.DecodedHashJWT - directDepsOfHash = undefined + directDepsOfEntity = + Set.map decodeHashJWT . \case + Share.TC (Share.TermComponent terms) -> flip foldMap terms \(localIds, _term) -> + Set.fromList (Share.LocalIds.hashes localIds) + Share.DC (Share.DeclComponent terms) -> flip foldMap terms \(localIds, _term) -> + Set.fromList (Share.LocalIds.hashes localIds) + Share.P (Share.Patch {newHashLookup}) -> + Set.fromList newHashLookup + Share.N (Share.Namespace {defnLookup, patchLookup, childLookup}) -> + Set.fromList defnLookup <> Set.fromList patchLookup <> Set.fromList childLookup + Share.C (Share.Causal {parents}) -> parents + {- + let directDepsOfEntity2 :: Share.Entity Text Share.Hash Share.HashJWT -> Set Share.DecodedHashJWT + directDepsOfEntity2 = + Lens.setOf (typed @Share.HashJWT) -} + + let directDepsOfHash :: Share.Hash -> IO (Set Share.DecodedHashJWT) + directDepsOfHash (Share.Hash b32) = do + jwts <- runDB (Q.getMissingDependencyJwtsForTempEntity (Base32Hex.UnsafeFromText b32)) + let decode = decodeHashJWT . Share.HashJWT + pure (Set.fromList (map decode jwts)) let loop :: NESet Share.DecodedHashJWT -> IO () loop hashes0 = do let elaborateHashes :: Set Share.DecodedHashJWT -> Set Share.HashJWT -> IO (Maybe (NESet Share.HashJWT)) @@ -161,9 +193,10 @@ download conn repoName = do False -> -- we need the entity, it's not in main or temp storage elaborateHashes hashes' (Set.insert jwt outputs) - True -> + True -> do -- entity already in temp storage - elaborateHashes (Set.union (directDepsOfHash hash) hashes') outputs + deps <- directDepsOfHash hash + elaborateHashes (Set.union deps hashes') outputs True -> -- hash already in main storage elaborateHashes hashes' outputs @@ -183,7 +216,13 @@ download conn repoName = do let putInMainStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> IO () putInMainStorage _hash _entity = undefined let putInTempStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> IO () - putInTempStorage _hash _entity = undefined + putInTempStorage _hash _entity = let + bytes = case _entity of + + -- convert the blob to the data type we have a serializer for + -- serialize the blob + -- insert the blob + undefined let insertMissingDependencies = undefined -- select dependency -- from temp_entity_missing_dependency @@ -329,8 +368,6 @@ data PullError -- -- newtype Transaction a = Transaction { unsafeUnTransaction :: Connection -> IO a } -type Connection = () - type Transaction a = () expectHash :: HashId -> Transaction Hash.Hash From 278ed8b232cb7e71a2aa6632808bf9bfae325196 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 8 Apr 2022 17:40:13 -0400 Subject: [PATCH 086/529] get code compiling and do a wee bit of work on TempEntity --- .../U/Codebase/Sqlite/Decl/Format.hs | 20 +++++++++++--- .../U/Codebase/Sqlite/Patch/Format.hs | 10 +++---- .../U/Codebase/Sqlite/Queries.hs | 2 +- .../U/Codebase/Sqlite/TempEntity.hs | 26 +++++++++---------- .../U/Codebase/Sqlite/Term/Format.hs | 2 +- codebase2/codebase/U/Codebase/TempEntity.hs | 14 ---------- codebase2/codebase/unison-codebase.cabal | 3 +-- 7 files changed, 38 insertions(+), 39 deletions(-) delete mode 100644 codebase2/codebase/U/Codebase/TempEntity.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs index 858bfdc262..b8b4c6bf84 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs @@ -5,10 +5,12 @@ module U.Codebase.Sqlite.Decl.Format where import Data.Vector (Vector) import U.Codebase.Decl (DeclR) import U.Codebase.Reference (Reference') -import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalIds, LocalTextId) +import U.Codebase.Sqlite.DbId (ObjectId, TextId) +import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalIds', LocalTextId) import U.Codebase.Sqlite.Symbol (Symbol) import qualified U.Codebase.Type as Type import qualified U.Core.ABT as ABT +import Unison.Prelude -- | Add new formats here data DeclFormat = Decl LocallyIndexedComponent @@ -16,10 +18,22 @@ data DeclFormat = Decl LocallyIndexedComponent -- | V1: Decls included `Hash`es inline -- V2: Instead of `Hash`, we use a smaller index. -newtype LocallyIndexedComponent - = LocallyIndexedComponent (Vector (LocalIds, Decl Symbol)) +type LocallyIndexedComponent = + LocallyIndexedComponent' TextId ObjectId + +newtype LocallyIndexedComponent' t d + = LocallyIndexedComponent (Vector (LocalIds' t d, Decl Symbol)) deriving (Show) +type SyncDeclFormat = + SyncDeclFormat' TextId ObjectId + +data SyncDeclFormat' t d + = SyncTerm (SyncLocallyIndexedComponent' t d) + +newtype SyncLocallyIndexedComponent' t d + = SyncLocallyIndexedComponent (Vector (LocalIds' t d, ByteString)) + -- [OldDecl] ==map==> [NewDecl] ==number==> [(NewDecl, Int)] ==sort==> [(NewDecl, Int)] ==> permutation is map snd of that -- type List a = Nil | Cons (List a) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs index 36657c8fbb..208f005e76 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs @@ -1,6 +1,7 @@ module U.Codebase.Sqlite.Patch.Format ( PatchFormat (..), - PatchLocalIds (..), + PatchLocalIds, + PatchLocalIds' (..), SyncPatchFormat, SyncPatchFormat' (..), applyPatchDiffs, @@ -36,10 +37,9 @@ data PatchLocalIds' t h d = LocalIds type SyncPatchFormat = SyncPatchFormat' PatchObjectId TextId HashId ObjectId data SyncPatchFormat' p t h d - = SyncFull (PatchLocalIds t h d) ByteString - -- | p is the identity of the thing that the diff is relative to - | SyncDiff p (PatchLocalIds t h d) ByteString - + = SyncFull (PatchLocalIds' t h d) ByteString + | -- | p is the identity of the thing that the diff is relative to + SyncDiff p (PatchLocalIds' t h d) ByteString -- | Apply a list of patch diffs to a patch, left to right. applyPatchDiffs :: Patch -> [PatchDiff] -> Patch diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index f6f7b36abe..c915c08cc8 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -128,7 +128,7 @@ module U.Codebase.Sqlite.Queries -- * sync temp entities getMissingDependencyJwtsForTempEntity, tempEntityExists, - insertTempEntity, + -- insertTempEntity, -- * db misc createSchema, diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index c4da4efe0d..3cc5b8fe81 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -1,18 +1,18 @@ module U.Codebase.Sqlite.TempEntity where -data TempEntity text noSyncHash hash - = TC (TermFormat' text hash) - | DC (DeclComponent text hash) - | P (Patch text noSyncHash hash) - | N (Namespace text hash) - | C (Causal hash) - deriving stock (Show, Eq, Ord) +import qualified U.Codebase.Sqlite.Decl.Format as Decl +import qualified U.Codebase.Sqlite.Patch.Format as Patch +import qualified U.Codebase.Sqlite.Term.Format as Term +import U.Util.Base32Hex (Base32Hex) +import Unison.Prelude -type TempTermFormat text hash = - TermFormat +-- should just newtype this somewhere +type HashJWT = Text -data TempDeclFormat text hash - = Decl [(LocalIds' text hash, ByteString)] +data TempEntity + = TC (Term.SyncTermFormat' Text HashJWT) + | DC (Decl.SyncDeclFormat' Text HashJWT) + | P (Patch.SyncPatchFormat' HashJWT Text Base32Hex HashJWT) -type TempPatchFormat text noSyncHash hash = - SyncPatchFormat' hash text noSyncHash hash +-- | N (Namespace text hash) +-- | C (Causal hash) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs index 8d62ba11f5..dd2d086ffe 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs @@ -116,7 +116,7 @@ type TermFormat = TermFormat' TextId ObjectId data TermFormat' t d = Term (LocallyIndexedComponent' t d) -type SyncTermFormat = SyncLocallyIndexedComponent' TextId ObjectId +type SyncTermFormat = SyncTermFormat' TextId ObjectId data SyncTermFormat' t d = SyncTerm (SyncLocallyIndexedComponent' t d) diff --git a/codebase2/codebase/U/Codebase/TempEntity.hs b/codebase2/codebase/U/Codebase/TempEntity.hs deleted file mode 100644 index 643181ac14..0000000000 --- a/codebase2/codebase/U/Codebase/TempEntity.hs +++ /dev/null @@ -1,14 +0,0 @@ -module U.Codebase.TempEntity where - --- data TempEntity text noSyncHash hash --- = TC (TermFormat' text hash) --- | DC (DeclComponent text hash) --- | P (Patch text noSyncHash hash) --- | N (Namespace text hash) --- | C (Causal hash) --- deriving stock (Show, Eq, Ord) - --- data TempTermFormat text hash = Term [(LocalIds' text hash, ByteString)] --- data TempDeclFormat text hash = Decl [(LocalIds' text hash, ByteString)] --- type TempPatchFormat text noSyncHash hash = --- SyncPatchFormat' hash text noSyncHash hash diff --git a/codebase2/codebase/unison-codebase.cabal b/codebase2/codebase/unison-codebase.cabal index a4be8e0e62..d0f15314e2 100644 --- a/codebase2/codebase/unison-codebase.cabal +++ b/codebase2/codebase/unison-codebase.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 27799cc371607e70caa5319a1f3002fa135ac262ab2378a58ac5ca391e5d3034 +-- hash: b4d3c77715f39c915cacffccf179f1ed62bce29ba013cecc3a25c847f5851233 name: unison-codebase version: 0.0.0 @@ -27,7 +27,6 @@ library U.Codebase.Referent U.Codebase.Reflog U.Codebase.ShortHash - U.Codebase.TempEntity U.Codebase.Term U.Codebase.TermEdit U.Codebase.Type From 65ee941b0e5eb28a22a3891b4264fe1880235e30 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 8 Apr 2022 22:28:50 -0400 Subject: [PATCH 087/529] migration work --- .../src/Unison/Codebase/SqliteCodebase.hs | 3 +- .../Codebase/SqliteCodebase/Migrations.hs | 90 +++++++++------ .../Migrations/MigrateSchema1To2.hs | 103 ++++++------------ 3 files changed, 94 insertions(+), 102 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 10e71e4ca3..8517b99a92 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -430,6 +430,7 @@ sqliteCodebase debugName root localOrRemote action = do Sqlite.runTransaction conn (Ops2.sqlLca h1 h2) let codebase = C.Codebase + -- FIXME urgh these caches :| (Cache.applyDefined termCache getTerm) (Cache.applyDefined typeOfTermCache getTypeOfTermImpl) (Cache.applyDefined declCache getTypeDeclaration) @@ -485,7 +486,7 @@ sqliteCodebase debugName root localOrRemote action = do flip finally finalizer $ do -- Migrate if necessary. - ensureCodebaseIsUpToDate localOrRemote root conn codebase >>= \case + ensureCodebaseIsUpToDate localOrRemote root undefined undefined undefined conn >>= \case Left err -> pure $ Left err Right () -> Right <$> action (codebase, conn) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index ff9ad4e9ef..c2fe54e1fe 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -1,10 +1,12 @@ module Unison.Codebase.SqliteCodebase.Migrations where +import Control.Concurrent.STM (TVar) import Control.Monad.Reader import qualified Data.Map as Map import Data.Time.Clock.POSIX (getPOSIXTime) import System.Directory (copyFile) import System.FilePath (()) +import qualified U.Codebase.Reference as C.Reference import U.Codebase.Sqlite.DbId (SchemaVersion (..)) import qualified U.Codebase.Sqlite.Queries as Q import Unison.Codebase (CodebasePath) @@ -13,56 +15,76 @@ import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase import Unison.Codebase.SqliteCodebase.Migrations.Errors (MigrationError) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3 (migrateSchema2To3) +import qualified Unison.Codebase.SqliteCodebase.Operations as Ops2 import Unison.Codebase.SqliteCodebase.Paths import Unison.Codebase.Type (Codebase, LocalOrRemote (..)) +import qualified Unison.ConstructorType as CT +import Unison.Hash (Hash) import Unison.Prelude import qualified Unison.Sqlite as Sqlite +import qualified Unison.Sqlite.Connection as Sqlite.Connection import Unison.Symbol (Symbol) import Unison.Var (Var) import qualified UnliftIO -type Migration m a v = Sqlite.Connection -> Codebase m v a -> m (Either MigrationError ()) - --- | The highest schema that this ucm knows how to migrate to. -currentSchemaVersion :: SchemaVersion -currentSchemaVersion = fst . head $ Map.toDescList (migrations @IO @Symbol @()) - -- | Mapping from schema version to the migration required to get there. -- Each migration may only be run on a schema of its immediate predecessor, -- E.g. The migration at index 2 must be run on a codebase at version 1. -migrations :: forall m v a. (MonadUnliftIO m, Var v) => Map SchemaVersion (Migration m a v) -migrations = +migrations :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> + TVar (Map Hash Ops2.TermBufferEntry) -> + TVar (Map Hash Ops2.DeclBufferEntry) -> + (forall x. IO x -> Sqlite.Transaction x) -> + Map SchemaVersion (Sqlite.Transaction ()) +migrations getDeclType termBuffer declBuffer runIO = Map.fromList - [ (2, migrateSchema1To2), - (3, migrateSchema2To3) + [ (2, migrateSchema1To2 getDeclType termBuffer declBuffer runIO) + -- (3, migrateSchema2To3) ] -- | Migrates a codebase up to the most recent version known to ucm. -- This is a No-op if it's up to date -- Returns an error if the schema version is newer than this ucm knows about. -ensureCodebaseIsUpToDate :: (MonadUnliftIO m, Var v) => LocalOrRemote -> CodebasePath -> Sqlite.Connection -> Codebase m v a -> m (Either Codebase.OpenCodebaseError ()) -ensureCodebaseIsUpToDate localOrRemote root conn codebase = UnliftIO.try do - schemaVersion <- undefined -- runReaderT Q.schemaVersion conn - when (schemaVersion > currentSchemaVersion) $ UnliftIO.throwIO $ OpenCodebaseUnknownSchemaVersion (fromIntegral schemaVersion) - let migrationsToRun = - Map.filterWithKey (\v _ -> v > schemaVersion) migrations - when (localOrRemote == Local && (not . null) migrationsToRun) $ backupCodebase root - for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do - liftIO . putStrLn $ "๐Ÿ”จ Migrating codebase to version " <> show v <> "..." - migration conn codebase - when ((not . null) migrationsToRun) $ do - -- Vacuum once now that any migrations have taken place. - liftIO $ putStrLn $ "Cleaning up..." - undefined -- liftIO . flip runReaderT conn $ Q.vacuum - liftIO . putStrLn $ "๐Ÿ Migration complete. ๐Ÿ" +ensureCodebaseIsUpToDate :: + MonadUnliftIO m => + LocalOrRemote -> + CodebasePath -> + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> + TVar (Map Hash Ops2.TermBufferEntry) -> + TVar (Map Hash Ops2.DeclBufferEntry) -> + Sqlite.Connection -> + m (Either Codebase.OpenCodebaseError ()) +ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer conn = + UnliftIO.try do + liftIO do + ranMigrations <- + Sqlite.runWriteTransaction conn \runIO -> do + schemaVersion <- Q.schemaVersion + let migs = migrations getDeclType termBuffer declBuffer runIO + -- The highest schema that this ucm knows how to migrate to. + let currentSchemaVersion = fst . head $ Map.toDescList migs + when (schemaVersion > currentSchemaVersion) $ runIO $ UnliftIO.throwIO $ OpenCodebaseUnknownSchemaVersion (fromIntegral schemaVersion) + let migrationsToRun = + Map.filterWithKey (\v _ -> v > schemaVersion) migs + when (localOrRemote == Local && (not . null) migrationsToRun) $ runIO $ backupCodebase root + for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do + runIO . putStrLn $ "๐Ÿ”จ Migrating codebase to version " <> show v <> "..." + migration + pure (not (null migrationsToRun)) + when ranMigrations do + -- Vacuum once now that any migrations have taken place. + putStrLn $ "Cleaning up..." + Sqlite.Connection.vacuum conn + putStrLn $ "๐Ÿ Migration complete. ๐Ÿ" -- | Copy the sqlite database to a new file with a unique name based on current time. -backupCodebase :: CodebasePath -> MonadIO m => m () -backupCodebase root = - liftIO do - backupPath <- backupCodebasePath <$> getPOSIXTime - copyFile (root codebasePath) (root backupPath) - putStrLn ("๐Ÿ“‹ I backed up your codebase to " ++ (root backupPath)) - putStrLn "โš ๏ธ Please close all other ucm processes and wait for the migration to complete before interacting with your codebase." - putStrLn "Press to start the migration once all other ucm processes are shutdown..." - void $ liftIO getLine +backupCodebase :: CodebasePath -> IO () +backupCodebase root = do + backupPath <- backupCodebasePath <$> getPOSIXTime + copyFile (root codebasePath) (root backupPath) + putStrLn ("๐Ÿ“‹ I backed up your codebase to " ++ (root backupPath)) + putStrLn "โš ๏ธ Please close all other ucm processes and wait for the migration to complete before interacting with your codebase." + putStrLn "Press to start the migration once all other ucm processes are shutdown..." + void $ liftIO getLine diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 45c572d417..46418a2e97 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -86,82 +86,51 @@ import qualified Unison.Type as Type import qualified Unison.Util.Set as Set import Unison.Var (Var) --- todo: --- * write a harness to call & seed algorithm --- * [x] embed migration in a transaction/savepoint and ensure that we never leave the codebase in a --- weird state even if we crash. --- * [x] may involve writing a `Progress` --- * raw DB things: --- * [x] write new namespace root after migration. --- * [x] overwrite object_id column in hash_object table to point at new objects --- * [x] delete references to old objects in index tables (where else?) --- * [x] delete old objects --- --- * refer to github megaticket https://github.com/unisonweb/unison/issues/2471 --- โ˜ข๏ธ [x] incorporate type signature into hash of term <- chris/arya have started โ˜ข๏ธ --- [x] store type annotation in the term --- * [x] Refactor Causal helper functions to use V2 hashing --- * [x] I guess move Hashable to V2.Hashing pseudo-package --- * [x] Delete V1 Hashing to ensure it's unused --- * [x] Salt V2 hashes with version number --- * [x] confirm that pulls are handled ok --- * [x] Make a backup of the v1 codebase before migrating, in a temp directory. --- Include a message explaining where we put it. --- * [x] Improved error message (don't crash) if loading a codebase newer than your ucm --- * [x] Update the schema version in the database after migrating so we only migrate --- once. - verboseOutput :: Bool verboseOutput = isJust (unsafePerformIO (lookupEnv "UNISON_MIGRATION_DEBUG")) {-# NOINLINE verboseOutput #-} -migrateSchema1To2 :: forall a m v. (MonadUnliftIO m, Var v) => Sqlite.Connection -> Codebase m v a -> m (Either MigrationError ()) -migrateSchema1To2 = undefined - -migrateSchema1To2' :: - MonadIO m => - Sqlite.Connection -> +migrateSchema1To2 :: -- | A 'getDeclType'-like lookup, possibly backed by a cache. (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> TVar (Map Hash Ops2.TermBufferEntry) -> TVar (Map Hash Ops2.DeclBufferEntry) -> - m () -migrateSchema1To2' conn getDeclType termBuffer declBuffer = do - liftIO do - Sqlite.runWriteTransaction conn \runIO -> do - runIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" - corruptedCausals <- Q.getCausalsWithoutBranchObjects - when (not . null $ corruptedCausals) $ - runIO $ do - putStrLn $ "โš ๏ธ I detected " <> show (length corruptedCausals) <> " corrupted namespace(s) in the history of the codebase." - putStrLn $ "This is due to a bug in a previous version of ucm." - putStrLn $ "This only affects the history of your codebase, the most up-to-date iteration will remain intact." - putStrLn $ "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." - - runIO $ putStrLn $ "Updating Namespace Root..." - rootCausalHashId <- Q.expectNamespaceRoot - numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] - v2EmptyBranchHashInfo <- saveV2EmptyBranch - watches <- - foldMapM - (\watchKind -> map (W watchKind) <$> Ops2.watches (Cv.watchKind2to1 watchKind)) - [WK.RegularWatch, WK.TestWatch] - migrationState <- - Sync.sync @_ @Entity (migrationSync getDeclType termBuffer declBuffer) (progress runIO numEntitiesToMigrate) (CausalE rootCausalHashId : watches) - `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo - let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId - runIO $ putStrLn $ "Updating Namespace Root..." - Q.setNamespaceRoot newRootCausalHashId - runIO $ putStrLn $ "Rewriting old object IDs..." - ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do - Q.recordObjectRehash oldObjId newObjId - runIO $ putStrLn $ "Garbage collecting orphaned objects..." - Q.garbageCollectObjectsWithoutHashes - runIO $ putStrLn $ "Garbage collecting orphaned watches..." - Q.garbageCollectWatchesWithoutObjects - runIO $ putStrLn $ "Updating Schema Version..." - Q.setSchemaVersion 2 + (forall x. IO x -> Sqlite.Transaction x) -> + Sqlite.Transaction () +migrateSchema1To2 getDeclType termBuffer declBuffer runIO = do + runIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" + corruptedCausals <- Q.getCausalsWithoutBranchObjects + when (not . null $ corruptedCausals) $ + runIO $ do + putStrLn $ "โš ๏ธ I detected " <> show (length corruptedCausals) <> " corrupted namespace(s) in the history of the codebase." + putStrLn $ "This is due to a bug in a previous version of ucm." + putStrLn $ "This only affects the history of your codebase, the most up-to-date iteration will remain intact." + putStrLn $ "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." + + runIO $ putStrLn $ "Updating Namespace Root..." + rootCausalHashId <- Q.expectNamespaceRoot + numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] + v2EmptyBranchHashInfo <- saveV2EmptyBranch + watches <- + foldMapM + (\watchKind -> map (W watchKind) <$> Ops2.watches (Cv.watchKind2to1 watchKind)) + [WK.RegularWatch, WK.TestWatch] + migrationState <- + Sync.sync @_ @Entity (migrationSync getDeclType termBuffer declBuffer) (progress runIO numEntitiesToMigrate) (CausalE rootCausalHashId : watches) + `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo + let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId + runIO $ putStrLn $ "Updating Namespace Root..." + Q.setNamespaceRoot newRootCausalHashId + runIO $ putStrLn $ "Rewriting old object IDs..." + ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do + Q.recordObjectRehash oldObjId newObjId + runIO $ putStrLn $ "Garbage collecting orphaned objects..." + Q.garbageCollectObjectsWithoutHashes + runIO $ putStrLn $ "Garbage collecting orphaned watches..." + Q.garbageCollectWatchesWithoutObjects + runIO $ putStrLn $ "Updating Schema Version..." + Q.setSchemaVersion 2 where progress :: (forall a. IO a -> Sqlite.Transaction a) -> Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) Entity progress runIO numToMigrate = From 8f63d5d1c3b10fc07b62956bcbe57d8690b29d59 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 11 Apr 2022 09:55:14 -0500 Subject: [PATCH 088/529] added namespace TempEntity --- .../U/Codebase/Sqlite/Branch/Format.hs | 57 +++++++++++++++---- .../U/Codebase/Sqlite/Patch/Format.hs | 6 +- .../U/Codebase/Sqlite/TempEntity.hs | 3 +- 3 files changed, 52 insertions(+), 14 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs index 9b2a525fdb..f6fba19ae9 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs @@ -1,7 +1,9 @@ module U.Codebase.Sqlite.Branch.Format ( BranchFormat (..), - BranchLocalIds (..), - SyncBranchFormat (..), + BranchLocalIds, + BranchLocalIds' (..), + SyncBranchFormat, + SyncBranchFormat' (..), localToDbBranch, localToDbDiff, -- dbToLocalDiff, @@ -35,17 +37,52 @@ data BranchFormat -- -- For example, a @branchTextLookup@ vector of @[50, 74]@ means "local id 0 corresponds to database text id 50, and -- local id 1 corresponds to database text id 74". -data BranchLocalIds = LocalIds - { branchTextLookup :: Vector TextId, - branchDefnLookup :: Vector ObjectId, - branchPatchLookup :: Vector PatchObjectId, - branchChildLookup :: Vector (BranchObjectId, CausalHashId) +type BranchLocalIds = BranchLocalIds' TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId) + +-- temp_entity +-- branch #foo +-- +-- temp_entity_missing_dependency +-- #foo depends on causal #bar +-- #foo depends on namespace #baz +-- +-- 1. store causal #bar, go to flush dependencies like normal +-- 2. ... oh this case is different than the others - we don't want to delete that row + +---- +-- can't simply treat causal's value hash as a mandatory dependency because we can't be sure +-- that the causal doesn't already exist in the target codebase without the value. +-- it probably does exist together with the value (though we found cases in the past where it didn't +-- due to race conditions, but we fixed that and added transactions and it shouldn't happen again?), +-- but it's not enforced at the schema level. +-- to enforce it at the schema level, we'd have to do something like store namespace_object_id instead +-- of value_hash in causal, which would require a db migration for a thing we don't necessarily even want +-- long term. +-- so, we can't simply "require" the value hash as a dependency of the causals and expect things to work smoothly +-- without relying on prayer. +-- +-- temp_entity +-- branch #foo +-- causal #bar + +-- temp_entity_missing_dependency +-- #foo depends on causal #bar +-- #bar depends on namespace #baz +-- + +data BranchLocalIds' t d p c = LocalIds + { branchTextLookup :: Vector t, + branchDefnLookup :: Vector d, + branchPatchLookup :: Vector p, + branchChildLookup :: Vector c } deriving (Show) -data SyncBranchFormat - = SyncFull BranchLocalIds ByteString - | SyncDiff BranchObjectId BranchLocalIds ByteString +data SyncBranchFormat' parent text defn patch child + = SyncFull (BranchLocalIds' text defn patch child) ByteString + | SyncDiff parent (BranchLocalIds' text defn patch child) ByteString + +type SyncBranchFormat = SyncBranchFormat' BranchObjectId TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId) localToDbBranch :: BranchLocalIds -> LocalBranch -> DbBranch localToDbBranch li = diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs index 208f005e76..c792d00de9 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs @@ -36,10 +36,10 @@ data PatchLocalIds' t h d = LocalIds type SyncPatchFormat = SyncPatchFormat' PatchObjectId TextId HashId ObjectId -data SyncPatchFormat' p t h d - = SyncFull (PatchLocalIds' t h d) ByteString +data SyncPatchFormat' parent text hash defn + = SyncFull (PatchLocalIds' text hash defn) ByteString | -- | p is the identity of the thing that the diff is relative to - SyncDiff p (PatchLocalIds' t h d) ByteString + SyncDiff parent (PatchLocalIds' text hash defn) ByteString -- | Apply a list of patch diffs to a patch, left to right. applyPatchDiffs :: Patch -> [PatchDiff] -> Patch diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index 3cc5b8fe81..afc2a2dee4 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -1,5 +1,6 @@ module U.Codebase.Sqlite.TempEntity where +import qualified U.Codebase.Sqlite.Branch.Format as Namespace import qualified U.Codebase.Sqlite.Decl.Format as Decl import qualified U.Codebase.Sqlite.Patch.Format as Patch import qualified U.Codebase.Sqlite.Term.Format as Term @@ -13,6 +14,6 @@ data TempEntity = TC (Term.SyncTermFormat' Text HashJWT) | DC (Decl.SyncDeclFormat' Text HashJWT) | P (Patch.SyncPatchFormat' HashJWT Text Base32Hex HashJWT) + | N (Namespace.SyncBranchFormat' HashJWT Text HashJWT HashJWT (HashJWT, HashJWT)) --- | N (Namespace text hash) -- | C (Causal hash) From b224bb09c7e875bb14a594a4b814aad6579ad9ca Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 11 Apr 2022 09:57:58 -0600 Subject: [PATCH 089/529] Move the Share server into its own package. --- .../unison-parser-typechecker.cabal | 16 ------- unison-share-api/package.yaml | 27 +++++++++++ .../src/Unison/Server/Backend.hs | 1 + .../src/Unison/Server/CodebaseServer.hs | 0 .../src/Unison/Server/Doc.hs | 0 .../src/Unison/Server/Doc/AsHtml.hs | 0 .../src/Unison/Server/Endpoints/FuzzyFind.hs | 0 .../Unison/Server/Endpoints/GetDefinitions.hs | 0 .../Server/Endpoints/NamespaceDetails.hs | 0 .../Server/Endpoints/NamespaceListing.hs | 0 .../src/Unison/Server/Endpoints/Projects.hs | 0 .../src/Unison/Server/Errors.hs | 0 .../src/Unison/Server/QueryResult.hs | 0 .../src/Unison/Server/SearchResult'.hs | 0 .../src/Unison/Server/SearchResult.hs | 0 .../src/Unison/Server/Syntax.hs | 0 .../src/Unison/Server/Types.hs | 0 .../src/Unison/Util/Find.hs | 0 unison-share-api/unison-share-api.cabal | 45 ++++++++++++++++++- 19 files changed, 72 insertions(+), 17 deletions(-) rename {parser-typechecker => unison-share-api}/src/Unison/Server/Backend.hs (99%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/CodebaseServer.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/Doc.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/Doc/AsHtml.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/Endpoints/FuzzyFind.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/Endpoints/GetDefinitions.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/Endpoints/NamespaceDetails.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/Endpoints/NamespaceListing.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/Endpoints/Projects.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/Errors.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/QueryResult.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/SearchResult'.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/SearchResult.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/Syntax.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Server/Types.hs (100%) rename {parser-typechecker => unison-share-api}/src/Unison/Util/Find.hs (100%) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 1e8c460f3c..e4c764c60b 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -131,21 +131,6 @@ library Unison.Runtime.SparseVector Unison.Runtime.Stack Unison.Runtime.Vector - Unison.Server.Backend - Unison.Server.CodebaseServer - Unison.Server.Doc - Unison.Server.Doc.AsHtml - Unison.Server.Endpoints.FuzzyFind - Unison.Server.Endpoints.GetDefinitions - Unison.Server.Endpoints.NamespaceDetails - Unison.Server.Endpoints.NamespaceListing - Unison.Server.Endpoints.Projects - Unison.Server.Errors - Unison.Server.QueryResult - Unison.Server.SearchResult - Unison.Server.SearchResult' - Unison.Server.Syntax - Unison.Server.Types Unison.TermParser Unison.TermPrinter Unison.Typechecker @@ -169,7 +154,6 @@ library Unison.Util.CyclicOrd Unison.Util.EnumContainers Unison.Util.Exception - Unison.Util.Find Unison.Util.Free Unison.Util.Logger Unison.Util.PinBoard diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index cfa0c24516..f17ce35258 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -17,6 +17,33 @@ dependencies: - bytestring - aeson - memory + - unison-util-relation + - unison-core1 + - unison-prelude + - unison-parser-typechecker + - unison-pretty-printer + - lucid + - openapi3 + - extra + - lens + - fuzzyfind + - filepath + - directory + - yaml + - errors + - servant-server + - servant-docs + - servant-openapi3 + - mwc-random + - warp + - wai + - uri-encode + - http-types + - http-media + - NanoID + - utf8-string + - async + - regex-tdfa ghc-options: -Wall diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs similarity index 99% rename from parser-typechecker/src/Unison/Server/Backend.hs rename to unison-share-api/src/Unison/Server/Backend.hs index e19b4be9ea..f129a3f7da 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -5,6 +5,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE ApplicativeDo #-} module Unison.Server.Backend where diff --git a/parser-typechecker/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/CodebaseServer.hs rename to unison-share-api/src/Unison/Server/CodebaseServer.hs diff --git a/parser-typechecker/src/Unison/Server/Doc.hs b/unison-share-api/src/Unison/Server/Doc.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/Doc.hs rename to unison-share-api/src/Unison/Server/Doc.hs diff --git a/parser-typechecker/src/Unison/Server/Doc/AsHtml.hs b/unison-share-api/src/Unison/Server/Doc/AsHtml.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/Doc/AsHtml.hs rename to unison-share-api/src/Unison/Server/Doc/AsHtml.hs diff --git a/parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/Endpoints/FuzzyFind.hs rename to unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs diff --git a/parser-typechecker/src/Unison/Server/Endpoints/GetDefinitions.hs b/unison-share-api/src/Unison/Server/Endpoints/GetDefinitions.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/Endpoints/GetDefinitions.hs rename to unison-share-api/src/Unison/Server/Endpoints/GetDefinitions.hs diff --git a/parser-typechecker/src/Unison/Server/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/Endpoints/NamespaceDetails.hs rename to unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs diff --git a/parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/Endpoints/NamespaceListing.hs rename to unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs diff --git a/parser-typechecker/src/Unison/Server/Endpoints/Projects.hs b/unison-share-api/src/Unison/Server/Endpoints/Projects.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/Endpoints/Projects.hs rename to unison-share-api/src/Unison/Server/Endpoints/Projects.hs diff --git a/parser-typechecker/src/Unison/Server/Errors.hs b/unison-share-api/src/Unison/Server/Errors.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/Errors.hs rename to unison-share-api/src/Unison/Server/Errors.hs diff --git a/parser-typechecker/src/Unison/Server/QueryResult.hs b/unison-share-api/src/Unison/Server/QueryResult.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/QueryResult.hs rename to unison-share-api/src/Unison/Server/QueryResult.hs diff --git a/parser-typechecker/src/Unison/Server/SearchResult'.hs b/unison-share-api/src/Unison/Server/SearchResult'.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/SearchResult'.hs rename to unison-share-api/src/Unison/Server/SearchResult'.hs diff --git a/parser-typechecker/src/Unison/Server/SearchResult.hs b/unison-share-api/src/Unison/Server/SearchResult.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/SearchResult.hs rename to unison-share-api/src/Unison/Server/SearchResult.hs diff --git a/parser-typechecker/src/Unison/Server/Syntax.hs b/unison-share-api/src/Unison/Server/Syntax.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/Syntax.hs rename to unison-share-api/src/Unison/Server/Syntax.hs diff --git a/parser-typechecker/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs similarity index 100% rename from parser-typechecker/src/Unison/Server/Types.hs rename to unison-share-api/src/Unison/Server/Types.hs diff --git a/parser-typechecker/src/Unison/Util/Find.hs b/unison-share-api/src/Unison/Util/Find.hs similarity index 100% rename from parser-typechecker/src/Unison/Util/Find.hs rename to unison-share-api/src/Unison/Util/Find.hs diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index 0cb38677fb..ba2d81fc7d 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -17,8 +17,24 @@ source-repository head library exposed-modules: + Unison.Server.Backend + Unison.Server.CodebaseServer + Unison.Server.Doc + Unison.Server.Doc.AsHtml + Unison.Server.Endpoints.FuzzyFind + Unison.Server.Endpoints.GetDefinitions + Unison.Server.Endpoints.NamespaceDetails + Unison.Server.Endpoints.NamespaceListing + Unison.Server.Endpoints.Projects + Unison.Server.Errors + Unison.Server.QueryResult + Unison.Server.SearchResult + Unison.Server.SearchResult' + Unison.Server.Syntax + Unison.Server.Types Unison.Sync.API Unison.Sync.Types + Unison.Util.Find other-modules: Paths_unison_share_api hs-source-dirs: @@ -50,15 +66,42 @@ library ViewPatterns ghc-options: -Wall build-depends: - aeson + NanoID + , aeson + , async , base , bytestring , containers + , directory + , errors + , extra + , filepath + , fuzzyfind + , http-media + , http-types + , lens + , lucid , memory , mtl + , mwc-random , nonempty-containers + , openapi3 + , regex-tdfa , servant + , servant-docs + , servant-openapi3 + , servant-server , text , transformers + , unison-core1 + , unison-parser-typechecker + , unison-prelude + , unison-pretty-printer + , unison-util-relation , unliftio + , uri-encode + , utf8-string + , wai + , warp + , yaml default-language: Haskell2010 From 1aef8505f6073088b8054754c59b003dc2267d87 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 11 Apr 2022 12:43:41 -0400 Subject: [PATCH 090/529] get migrations type-checking --- .../src/Unison/Codebase/SqliteCodebase.hs | 3 +- .../Codebase/SqliteCodebase/Migrations.hs | 9 ++---- .../Migrations/MigrateSchema1To2.hs | 9 +----- .../Migrations/MigrateSchema2To3.hs | 30 +++++-------------- 4 files changed, 12 insertions(+), 39 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 8517b99a92..fa89215300 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -430,7 +430,6 @@ sqliteCodebase debugName root localOrRemote action = do Sqlite.runTransaction conn (Ops2.sqlLca h1 h2) let codebase = C.Codebase - -- FIXME urgh these caches :| (Cache.applyDefined termCache getTerm) (Cache.applyDefined typeOfTermCache getTypeOfTermImpl) (Cache.applyDefined declCache getTypeDeclaration) @@ -486,7 +485,7 @@ sqliteCodebase debugName root localOrRemote action = do flip finally finalizer $ do -- Migrate if necessary. - ensureCodebaseIsUpToDate localOrRemote root undefined undefined undefined conn >>= \case + ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer conn >>= \case Left err -> pure $ Left err Right () -> Right <$> action (codebase, conn) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index c2fe54e1fe..acefc9707d 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -12,19 +12,16 @@ import qualified U.Codebase.Sqlite.Queries as Q import Unison.Codebase (CodebasePath) import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (OpenCodebaseUnknownSchemaVersion)) import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase -import Unison.Codebase.SqliteCodebase.Migrations.Errors (MigrationError) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3 (migrateSchema2To3) import qualified Unison.Codebase.SqliteCodebase.Operations as Ops2 import Unison.Codebase.SqliteCodebase.Paths -import Unison.Codebase.Type (Codebase, LocalOrRemote (..)) +import Unison.Codebase.Type (LocalOrRemote (..)) import qualified Unison.ConstructorType as CT import Unison.Hash (Hash) import Unison.Prelude import qualified Unison.Sqlite as Sqlite import qualified Unison.Sqlite.Connection as Sqlite.Connection -import Unison.Symbol (Symbol) -import Unison.Var (Var) import qualified UnliftIO -- | Mapping from schema version to the migration required to get there. @@ -39,8 +36,8 @@ migrations :: Map SchemaVersion (Sqlite.Transaction ()) migrations getDeclType termBuffer declBuffer runIO = Map.fromList - [ (2, migrateSchema1To2 getDeclType termBuffer declBuffer runIO) - -- (3, migrateSchema2To3) + [ (2, migrateSchema1To2 getDeclType termBuffer declBuffer runIO), + (3, migrateSchema2To3 runIO) ] -- | Migrates a codebase up to the most recent version known to ucm. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 46418a2e97..2641313278 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -13,7 +13,6 @@ where import Control.Concurrent.STM (TVar) import Control.Lens import Control.Monad.Except (runExceptT) -import Control.Monad.Reader (ReaderT (runReaderT), ask) import Control.Monad.State.Strict import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Writer.CPS (Writer, execWriter, tell) @@ -57,12 +56,9 @@ import U.Codebase.WatchKind (WatchKind) import qualified U.Codebase.WatchKind as WK import U.Util.Monoid (foldMapM) import qualified Unison.ABT as ABT -import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv -import Unison.Codebase.SqliteCodebase.Migrations.Errors (MigrationError) import qualified Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers as Hashing import qualified Unison.Codebase.SqliteCodebase.Operations as Ops2 -import Unison.Codebase.Type (Codebase (Codebase)) import qualified Unison.ConstructorReference as ConstructorReference import qualified Unison.ConstructorType as CT import qualified Unison.DataDeclaration as DD @@ -84,7 +80,6 @@ import qualified Unison.Term as Term import Unison.Type (Type) import qualified Unison.Type as Type import qualified Unison.Util.Set as Set -import Unison.Var (Var) verboseOutput :: Bool verboseOutput = @@ -196,9 +191,7 @@ migrationSync getDeclType termBuffer declBuffer = Sync \case TermComponent hash -> migrateTermComponent getDeclType termBuffer declBuffer hash DeclComponent hash -> migrateDeclComponent termBuffer declBuffer hash BranchE objectId -> migrateBranch objectId - -- CausalE causalHashId -> do - -- Env {db} <- ask - -- lift (migrateCausal db causalHashId) + CausalE causalHashId -> migrateCausal causalHashId PatchE objectId -> migratePatch (PatchObjectId objectId) W watchKind watchId -> migrateWatch getDeclType watchKind watchId diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs index 212455a360..87fe257c8d 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs @@ -1,14 +1,11 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3 (migrateSchema2To3) where +import Control.Exception (throwIO) import Control.Monad.Reader import U.Codebase.Sqlite.DbId (HashVersion (..), SchemaVersion (..)) import qualified U.Codebase.Sqlite.Queries as Q -import Unison.Codebase (Codebase) import Unison.Codebase.SqliteCodebase.Migrations.Errors (MigrationError (IncorrectStartingSchemaVersion)) -import Unison.Prelude import qualified Unison.Sqlite as Sqlite -import Unison.Var (Var) -import qualified UnliftIO -- | The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this -- caused an issue: @@ -25,22 +22,9 @@ import qualified UnliftIO -- -- This migration drops all the v1 hash objects to avoid this issue, since these hash objects -- weren't being used for anything anyways. -migrateSchema2To3 :: forall a m v. (MonadUnliftIO m, Var v) => Sqlite.Connection -> Codebase m v a -> m (Either MigrationError ()) -migrateSchema2To3 conn _ = - UnliftIO.try . flip runReaderT conn $ - undefined - --- Sqlite.withSavepoint "MIGRATE_SCHEMA_2_TO_3" $ \_rollback -> do --- version <- Q.schemaVersion --- when (version /= 2) $ UnliftIO.throwIO (IncorrectStartingSchemaVersion version) --- Q.removeHashObjectsByHashingVersion (HashVersion 1) --- Q.setSchemaVersion (SchemaVersion 3) - -migrateSchema2To3' :: MonadUnliftIO m => Sqlite.Connection -> m (Either MigrationError ()) -migrateSchema2To3' conn = - UnliftIO.try do - Sqlite.runTransactionWithAbort conn \abort -> do - version <- Q.schemaVersion - when (version /= 2) $ abort (IncorrectStartingSchemaVersion version) - Q.removeHashObjectsByHashingVersion (HashVersion 1) - Q.setSchemaVersion (SchemaVersion 3) +migrateSchema2To3 :: (forall a. IO a -> Sqlite.Transaction a) -> Sqlite.Transaction () +migrateSchema2To3 runIO = do + version <- Q.schemaVersion + when (version /= 2) $ runIO $ throwIO (IncorrectStartingSchemaVersion version) + Q.removeHashObjectsByHashingVersion (HashVersion 1) + Q.setSchemaVersion (SchemaVersion 3) From d239ba8bebdb9b63f288a2eb74a467100dcb9b8f Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 11 Apr 2022 17:02:26 -0500 Subject: [PATCH 091/529] Serialization.putTempEntity --- .../U/Codebase/Sqlite/Decl/Format.hs | 2 +- .../U/Codebase/Sqlite/Serialization.hs | 99 ++++++++++++++++++- .../U/Codebase/Sqlite/TempEntity.hs | 20 +++- 3 files changed, 112 insertions(+), 9 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs index b8b4c6bf84..b055f42495 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs @@ -29,7 +29,7 @@ type SyncDeclFormat = SyncDeclFormat' TextId ObjectId data SyncDeclFormat' t d - = SyncTerm (SyncLocallyIndexedComponent' t d) + = SyncDecl (SyncLocallyIndexedComponent' t d) newtype SyncLocallyIndexedComponent' t d = SyncLocallyIndexedComponent (Vector (LocalIds' t d, ByteString)) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index 6358182ce5..75e2297d19 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -17,6 +17,7 @@ import Data.Bytes.VarInt (VarInt (VarInt), unVarInt) import Data.Int (Int64) import Data.List (elemIndex) import qualified Data.Set as Set +import Data.Text (Text) import Data.Word (Word64) import Debug.Trace (trace) import qualified U.Codebase.Decl as Decl @@ -37,10 +38,13 @@ import qualified U.Codebase.Sqlite.Patch.Full as PatchFull import qualified U.Codebase.Sqlite.Patch.TermEdit as TermEdit import qualified U.Codebase.Sqlite.Patch.TypeEdit as TypeEdit import U.Codebase.Sqlite.Symbol (Symbol (..)) +import U.Codebase.Sqlite.TempEntity (TempEntity) +import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat import qualified U.Codebase.Term as Term import qualified U.Codebase.Type as Type import qualified U.Core.ABT as ABT +import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Monoid as Monoid import U.Util.Serialization hiding (debug) import Prelude hiding (getChar, putChar) @@ -108,9 +112,12 @@ getABT getVar getA getF = getList getVar >>= go [] _ -> unknownTag "getABT" tag putLocalIds :: (MonadPut m, Integral t, Bits t, Integral d, Bits d) => LocalIds' t d -> m () -putLocalIds LocalIds {..} = do - putFoldable putVarInt textLookup - putFoldable putVarInt defnLookup +putLocalIds = putLocalIdsWith putVarInt putVarInt + +putLocalIdsWith :: (MonadPut m) => (t -> m ()) -> (d -> m ()) -> LocalIds' t d -> m () +putLocalIdsWith putText putDefn LocalIds {textLookup, defnLookup} = do + putFoldable putText textLookup + putFoldable putDefn defnLookup getLocalIds :: MonadGet m => m LocalIds getLocalIds = LocalIds <$> getVector getVarInt <*> getVector getVarInt @@ -686,6 +693,92 @@ recomposeBranchFormat = \case BranchFormat.SyncDiff id li bs -> putWord8 1 *> putVarInt id *> putBranchLocalIds li *> putByteString bs +putTempEntity :: MonadPut m => TempEntity -> m () +putTempEntity = \case + TempEntity.TC tc -> case tc of + TermFormat.SyncTerm term -> + putWord8 0 *> putSyncTerm term + TempEntity.DC dc -> case dc of + DeclFormat.SyncDecl decl -> + putWord8 0 *> putSyncDecl decl + TempEntity.P p -> case p of + PatchFormat.SyncFull lids bytes -> + putWord8 0 *> putSyncFullPatch lids bytes + PatchFormat.SyncDiff parent lids bytes -> + putWord8 1 *> putSyncDiffPatch parent lids bytes + TempEntity.N n -> case n of + BranchFormat.SyncFull lids bytes -> + putWord8 0 *> putSyncFullNamespace lids bytes + BranchFormat.SyncDiff parent lids bytes -> + putWord8 1 *> putSyncDiffNamespace parent lids bytes + TempEntity.C gdc -> + putSyncCausal gdc + where + putHashJWT = putText + putBase32Hex = putText . Base32Hex.toText + putPatchLocalIds PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} = do + putFoldable putText patchTextLookup + putFoldable putBase32Hex patchHashLookup + putFoldable putHashJWT patchDefnLookup + putNamespaceLocalIds BranchFormat.LocalIds {branchTextLookup, branchDefnLookup, branchPatchLookup, branchChildLookup} = do + putFoldable putText branchTextLookup + putFoldable putHashJWT branchDefnLookup + putFoldable putHashJWT branchPatchLookup + putFoldable (putPair putHashJWT putHashJWT) branchChildLookup + putSyncCausal TempEntity.TempCausalFormat {valueHash, parents} = do + putHashJWT valueHash + putFoldable putHashJWT parents + putSyncFullPatch lids bytes = do + putPatchLocalIds lids + putByteString bytes + putSyncDiffPatch parent lids bytes = do + putHashJWT parent + putPatchLocalIds lids + putByteString bytes + putSyncFullNamespace lids bytes = do + putNamespaceLocalIds lids + putByteString bytes + putSyncDiffNamespace parent lids bytes = do + putHashJWT parent + putNamespaceLocalIds lids + putByteString bytes + + putSyncTerm (TermFormat.SyncLocallyIndexedComponent vec) = + -- we're not leaving ourselves the ability to skip over the localIds + -- when deserializing, because we don't think we need to (and it adds a + -- little overhead.) + flip putFoldable vec \(localIds, bytes) -> do + putLocalIdsWith putHashJWT putHashJWT localIds + putByteString bytes + putSyncDecl (DeclFormat.SyncLocallyIndexedComponent vec) = + flip putFoldable vec \(localIds, bytes) -> do + putLocalIdsWith putHashJWT putHashJWT localIds + putByteString bytes + +getTempTermFormat :: MonadGet m => m TempEntity.TempTermFormat +getTempTermFormat = + getWord8 >>= \case + 0 -> undefined + tag -> unknownTag "getTempTermFormat" tag + +getTempDeclFormat :: MonadGet m => m TempEntity.TempDeclFormat +getTempDeclFormat = + getWord8 >>= \case + tag -> unknownTag "getTempDeclFormat" tag + +getTempPatchFormat :: MonadGet m => m TempEntity.TempPatchFormat +getTempPatchFormat = + getWord8 >>= \case + tag -> unknownTag "getTempPatchFormat" tag + +getTempNamespaceFormat :: MonadGet m => m TempEntity.TempNamespaceFormat +getTempNamespaceFormat = + getWord8 >>= \case + tag -> unknownTag "getTempNamespaceFormat" tag + +getTempCausalFormat :: MonadGet m => m TempEntity.TempCausalFormat +getTempCausalFormat = undefined + getSymbol :: MonadGet m => m Symbol getSymbol = Symbol <$> getVarInt <*> getText diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index afc2a2dee4..60d95db77f 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -1,5 +1,6 @@ module U.Codebase.Sqlite.TempEntity where +import Data.Vector (Vector) import qualified U.Codebase.Sqlite.Branch.Format as Namespace import qualified U.Codebase.Sqlite.Decl.Format as Decl import qualified U.Codebase.Sqlite.Patch.Format as Patch @@ -11,9 +12,18 @@ import Unison.Prelude type HashJWT = Text data TempEntity - = TC (Term.SyncTermFormat' Text HashJWT) - | DC (Decl.SyncDeclFormat' Text HashJWT) - | P (Patch.SyncPatchFormat' HashJWT Text Base32Hex HashJWT) - | N (Namespace.SyncBranchFormat' HashJWT Text HashJWT HashJWT (HashJWT, HashJWT)) + = TC TempTermFormat + | DC TempDeclFormat + | P TempPatchFormat + | N TempNamespaceFormat + | C TempCausalFormat --- | C (Causal hash) +type TempTermFormat = Term.SyncTermFormat' Text HashJWT + +type TempDeclFormat = Decl.SyncDeclFormat' Text HashJWT + +type TempPatchFormat = Patch.SyncPatchFormat' HashJWT Text Base32Hex HashJWT + +type TempNamespaceFormat = Namespace.SyncBranchFormat' HashJWT Text HashJWT HashJWT (HashJWT, HashJWT) + +data TempCausalFormat = TempCausalFormat {valueHash :: HashJWT, parents :: Vector HashJWT} From dea52a34e23d0e71f564f7cf52368b38ae1b76ff Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 11 Apr 2022 20:58:41 -0500 Subject: [PATCH 092/529] Serialization.getTemp{Term,Decl,Patch}Format --- .../U/Codebase/Sqlite/Serialization.hs | 59 ++++++++++++++++--- 1 file changed, 50 insertions(+), 9 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index 75e2297d19..c868a4276a 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -44,6 +44,7 @@ import qualified U.Codebase.Sqlite.Term.Format as TermFormat import qualified U.Codebase.Term as Term import qualified U.Codebase.Type as Type import qualified U.Core.ABT as ABT +import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Monoid as Monoid import U.Util.Serialization hiding (debug) @@ -120,10 +121,14 @@ putLocalIdsWith putText putDefn LocalIds {textLookup, defnLookup} = do putFoldable putDefn defnLookup getLocalIds :: MonadGet m => m LocalIds -getLocalIds = LocalIds <$> getVector getVarInt <*> getVector getVarInt +getLocalIds = getLocalIdsWith getVarInt getVarInt getWatchLocalIds :: MonadGet m => m WatchLocalIds -getWatchLocalIds = LocalIds <$> getVector getVarInt <*> getVector getVarInt +getWatchLocalIds = getLocalIdsWith getVarInt getVarInt + +getLocalIdsWith :: MonadGet m => m t -> m d -> m (LocalIds' t d) +getLocalIdsWith getText getDefn = + LocalIds <$> getVector getText <*> getVector getDefn putUnit :: Applicative m => () -> m () putUnit _ = pure () @@ -730,46 +735,82 @@ putTempEntity = \case putFoldable putHashJWT parents putSyncFullPatch lids bytes = do putPatchLocalIds lids - putByteString bytes + putFramedByteString bytes putSyncDiffPatch parent lids bytes = do putHashJWT parent putPatchLocalIds lids - putByteString bytes + putFramedByteString bytes putSyncFullNamespace lids bytes = do putNamespaceLocalIds lids putByteString bytes putSyncDiffNamespace parent lids bytes = do putHashJWT parent putNamespaceLocalIds lids - putByteString bytes - + putFramedByteString bytes putSyncTerm (TermFormat.SyncLocallyIndexedComponent vec) = -- we're not leaving ourselves the ability to skip over the localIds -- when deserializing, because we don't think we need to (and it adds a -- little overhead.) flip putFoldable vec \(localIds, bytes) -> do putLocalIdsWith putHashJWT putHashJWT localIds - putByteString bytes + putFramedByteString bytes putSyncDecl (DeclFormat.SyncLocallyIndexedComponent vec) = flip putFoldable vec \(localIds, bytes) -> do putLocalIdsWith putHashJWT putHashJWT localIds - putByteString bytes + putFramedByteString bytes + +getHashJWT :: MonadGet m => m TempEntity.HashJWT +getHashJWT = error "getHashJWT" undefined + +getBase32Hex :: MonadGet m => m Base32Hex +getBase32Hex = Base32Hex.UnsafeFromText <$> getText + +putFramedBytes :: MonadPut m => BS.ByteString -> m () +putFramedBytes bs = do + putVarInt (BS.length bs) + putByteString bs + +getFramedBytes :: MonadGet m => m BS.ByteString +getFramedBytes = do + length <- getVarInt + getByteString length getTempTermFormat :: MonadGet m => m TempEntity.TempTermFormat getTempTermFormat = getWord8 >>= \case - 0 -> undefined + 0 -> + TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent + <$> getVector + ( getPair + (getLocalIdsWith getHashJWT getHashJWT) + getFramedByteString + ) tag -> unknownTag "getTempTermFormat" tag getTempDeclFormat :: MonadGet m => m TempEntity.TempDeclFormat getTempDeclFormat = getWord8 >>= \case + 0 -> + DeclFormat.SyncDecl . DeclFormat.SyncLocallyIndexedComponent + <$> getVector + ( getPair + (getLocalIdsWith getHashJWT getHashJWT) + getFramedByteString + ) tag -> unknownTag "getTempDeclFormat" tag getTempPatchFormat :: MonadGet m => m TempEntity.TempPatchFormat getTempPatchFormat = getWord8 >>= \case + 0 -> PatchFormat.SyncFull <$> getPatchLocalIds <*> getFramedByteString + 1 -> PatchFormat.SyncDiff <$> getHashJWT <*> getPatchLocalIds <*> getFramedByteString tag -> unknownTag "getTempPatchFormat" tag + where + getPatchLocalIds = + PatchFormat.LocalIds + <$> getVector getText + <*> getVector getBase32Hex + <*> getVector getHashJWT getTempNamespaceFormat :: MonadGet m => m TempEntity.TempNamespaceFormat getTempNamespaceFormat = From eab5010cf92049e1a6a8ea5b29746ac42499f816 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 11 Apr 2022 21:44:32 -0500 Subject: [PATCH 093/529] Serialization.getTemp{Namespace,Causal}Format --- .../U/Codebase/Sqlite/Serialization.hs | 17 ++++++++++++++--- unison-cli/src/Unison/Share/Sync.hs | 2 -- 2 files changed, 14 insertions(+), 5 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index c868a4276a..95312460bf 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -17,7 +17,6 @@ import Data.Bytes.VarInt (VarInt (VarInt), unVarInt) import Data.Int (Int64) import Data.List (elemIndex) import qualified Data.Set as Set -import Data.Text (Text) import Data.Word (Word64) import Debug.Trace (trace) import qualified U.Codebase.Decl as Decl @@ -760,7 +759,7 @@ putTempEntity = \case putFramedByteString bytes getHashJWT :: MonadGet m => m TempEntity.HashJWT -getHashJWT = error "getHashJWT" undefined +getHashJWT = getText getBase32Hex :: MonadGet m => m Base32Hex getBase32Hex = Base32Hex.UnsafeFromText <$> getText @@ -815,10 +814,22 @@ getTempPatchFormat = getTempNamespaceFormat :: MonadGet m => m TempEntity.TempNamespaceFormat getTempNamespaceFormat = getWord8 >>= \case + 0 -> BranchFormat.SyncFull <$> getBranchLocalIds <*> getFramedByteString + 1 -> BranchFormat.SyncDiff <$> getHashJWT <*> getBranchLocalIds <*> getFramedByteString tag -> unknownTag "getTempNamespaceFormat" tag + where + getBranchLocalIds = + BranchFormat.LocalIds + <$> getVector getText + <*> getVector getHashJWT + <*> getVector getHashJWT + <*> getVector (getPair getHashJWT getHashJWT) getTempCausalFormat :: MonadGet m => m TempEntity.TempCausalFormat -getTempCausalFormat = undefined +getTempCausalFormat = + TempEntity.TempCausalFormat + <$> getHashJWT + <*> getVector getHashJWT getSymbol :: MonadGet m => m Symbol getSymbol = Symbol <$> getVarInt <*> getText diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 6a978fc79b..71110236e9 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -22,8 +22,6 @@ import U.Codebase.Sqlite.DbId (HashId) import qualified U.Codebase.Sqlite.Queries as Q import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as Hash -import qualified Data.Set.Lens as Lens (setOf) -import Data.Generics.Product.Typed (typed) import Unison.Prelude import qualified Unison.Sync.Types as Share import qualified Unison.Sync.Types as Share.LocalIds (LocalIds (..)) From e698acf0e8ae31df3334984ad07e139c587534da Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 12 Apr 2022 07:40:42 -0500 Subject: [PATCH 094/529] Sync.{makeTempEntity,tempEntityType} --- .../U/Codebase/Sqlite/TempEntityType.hs | 22 ++++++++++++++ .../unison-codebase-sqlite.cabal | 1 + unison-cli/package.yaml | 1 + unison-cli/src/Unison/Share/Sync.hs | 29 ++++++++++++++++--- unison-cli/unison-cli.cabal | 5 ++++ 5 files changed, 54 insertions(+), 4 deletions(-) create mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntityType.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntityType.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntityType.hs new file mode 100644 index 0000000000..8f9837a072 --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntityType.hs @@ -0,0 +1,22 @@ +module U.Codebase.Sqlite.TempEntityType where + +import Database.SQLite.Simple (SQLData (SQLInteger)) +import Database.SQLite.Simple.FromField (FromField (..)) +import Database.SQLite.Simple.ToField (ToField (..)) + +-- | Don't reorder these, they are part of the database, +-- and the ToField and FromField implementation currently +-- depends on the derived Enum implementation. +data TempEntityType + = TermComponentType -- 0 + | DeclComponentType -- 1 + | NamespaceType -- 2 + | PatchType -- 3 + | CausalType -- 4 + deriving (Eq, Ord, Show, Enum) + +instance ToField TempEntityType where + toField = SQLInteger . fromIntegral . fromEnum + +instance FromField TempEntityType where + fromField = fmap toEnum . fromField diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 087ac81ff2..62eec7b77f 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -43,6 +43,7 @@ library U.Codebase.Sqlite.Symbol U.Codebase.Sqlite.Sync22 U.Codebase.Sqlite.TempEntity + U.Codebase.Sqlite.TempEntityType U.Codebase.Sqlite.Term.Format other-modules: Paths_unison_codebase_sqlite diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index aadc12f4f9..4a522a4146 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -15,6 +15,7 @@ dependencies: - ListLike - async - base + - bytes - bytestring - configurator - containers >= 0.6.3 diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 71110236e9..1b402d364b 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -11,6 +11,7 @@ where import Control.Monad.Extra ((||^)) import Control.Monad.Reader (ReaderT, runReaderT) +import Data.Bytes.Put (runPutS) import qualified Data.List.NonEmpty as List.NonEmpty import qualified Data.Map.NonEmpty as NEMap import qualified Data.Set as Set @@ -20,6 +21,10 @@ import U.Codebase.HashTags (CausalHash (unCausalHash)) import U.Codebase.Sqlite.Connection (Connection) import U.Codebase.Sqlite.DbId (HashId) import qualified U.Codebase.Sqlite.Queries as Q +import qualified U.Codebase.Sqlite.Serialization as S +import U.Codebase.Sqlite.TempEntity (TempEntity) +import qualified U.Codebase.Sqlite.TempEntity as TempEntity +import qualified U.Codebase.Sqlite.TempEntityType as TempEntity import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as Hash import Unison.Prelude @@ -214,12 +219,12 @@ download conn repoName = do let putInMainStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> IO () putInMainStorage _hash _entity = undefined let putInTempStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> IO () - putInTempStorage _hash _entity = do - let bytes = case _entity of - _ -> undefined - + putInTempStorage _hash entity = do -- convert the blob to the data type we have a serializer for + let tempEntity = makeTempEntity entity + _entityType = tempEntityType entity -- serialize the blob + let _bytes = runPutS (S.putTempEntity tempEntity) -- insert the blob undefined let insertMissingDependencies = undefined @@ -400,3 +405,19 @@ _downloadEntities = undefined _uploadEntities :: Share.UploadEntitiesRequest -> IO UploadEntitiesResponse _uploadEntities = undefined + +makeTempEntity :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity +makeTempEntity e = case e of + Share.TC _ -> (TempEntity.TC _) + Share.DC _ -> (TempEntity.DC _) + Share.P _ -> (TempEntity.P _) + Share.N _ -> (TempEntity.N _) + Share.C _ -> (TempEntity.C _) + +tempEntityType :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity.TempEntityType +tempEntityType = \case + Share.TC tc -> TempEntity.TermComponentType + Share.DC dc -> TempEntity.DeclComponentType + Share.P pa -> TempEntity.PatchType + Share.N name -> TempEntity.NamespaceType + Share.C ca -> TempEntity.CausalType diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index eef3858b4e..d8038c429e 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -97,6 +97,7 @@ library , aeson , async , base + , bytes , bytestring , configurator , containers >=0.6.3 @@ -189,6 +190,7 @@ executable cli-integration-tests , aeson , async , base + , bytes , bytestring , code-page , configurator @@ -279,6 +281,7 @@ executable transcripts , aeson , async , base + , bytes , bytestring , code-page , configurator @@ -373,6 +376,7 @@ executable unison , aeson , async , base + , bytes , bytestring , code-page , configurator @@ -472,6 +476,7 @@ test-suite cli-tests , aeson , async , base + , bytes , bytestring , code-page , configurator From 50ae4af63c4558c38809f92a9893d428ccc5d649 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 13:15:38 -0400 Subject: [PATCH 095/529] commit in runWriteTransaction --- .../src/Unison/Sqlite/Transaction.hs | 29 ++++++++++--------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 86c8e87c9b..048fdfbf2e 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -85,19 +85,18 @@ runTransaction :: MonadIO m => Connection -> Transaction a -> m a runTransaction conn (Transaction f) = liftIO do uninterruptibleMask \restore -> do Connection.begin conn - result <- - -- Catch all exceptions (sync or async), because we want to ROLLBACK the BEGIN no matter what. - trySyncOrAsync @_ @SomeException (restore (f conn)) >>= \case - Left exception -> do - ignoringExceptions (Connection.rollback conn) - case fromException exception of - Just SqliteBusyException -> do - restore (threadDelay 100_000) - runWriteTransaction_ restore 200_000 conn (f conn) - _ -> throwIO exception - Right result -> pure result - Connection.commit conn - pure result + -- Catch all exceptions (sync or async), because we want to ROLLBACK the BEGIN no matter what. + trySyncOrAsync @_ @SomeException (restore (f conn)) >>= \case + Left exception -> do + ignoringExceptions (Connection.rollback conn) + case fromException exception of + Just SqliteBusyException -> do + restore (threadDelay 100_000) + runWriteTransaction_ restore 200_000 conn (f conn) + _ -> throwIO exception + Right result -> do + Connection.commit conn + pure result {-# SPECIALIZE runTransaction :: Connection -> Transaction a -> IO a #-} -- | Run a transaction with a function that aborts the transaction with an exception. @@ -176,7 +175,9 @@ runWriteTransactionIO conn f = runWriteTransaction_ :: (forall x. IO x -> IO x) -> Int -> Connection -> IO a -> IO a runWriteTransaction_ restore microseconds conn transaction = do keepTryingToBeginImmediate restore conn microseconds - restore transaction `onException` ignoringExceptions (Connection.rollback conn) + result <- restore transaction `onException` ignoringExceptions (Connection.rollback conn) + Connection.commit conn + pure result -- @BEGIN IMMEDIATE@ until success. keepTryingToBeginImmediate :: (forall x. IO x -> IO x) -> Connection -> Int -> IO () From 396ebc485e152bcdbd9dfa3561e1951b910d3d47 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 12 Apr 2022 13:14:46 -0500 Subject: [PATCH 096/529] partially broken stuff --- .../U/Codebase/Sqlite/Queries.hs | 64 ++++++++++++++++--- .../U/Codebase/Sqlite/Serialization.hs | 4 +- .../U/Codebase/Sqlite/TempEntity.hs | 4 +- codebase2/codebase-sqlite/package.yaml | 1 + .../sql/001-temp-entity-tables.sql | 12 ++-- .../unison-codebase-sqlite.cabal | 1 + unison-cli/src/Unison/Share/Sync.hs | 64 +++++++++++++------ 7 files changed, 111 insertions(+), 39 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index c915c08cc8..dad031c23a 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -128,7 +128,8 @@ module U.Codebase.Sqlite.Queries -- * sync temp entities getMissingDependencyJwtsForTempEntity, tempEntityExists, - -- insertTempEntity, + insertTempEntity, + deleteTempDependencies, -- * db misc createSchema, @@ -156,11 +157,14 @@ import Control.Monad.Reader (MonadReader (ask)) import qualified Control.Monad.Reader as Reader import qualified Control.Monad.Writer as Writer import qualified Data.Char as Char +import qualified Data.Foldable as Foldable import qualified Data.List.Extra as List import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel import Data.Maybe (fromJust) import qualified Data.Set as Set +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NESet import Data.String.Here.Uninterpolated (here, hereFile) import Database.SQLite.Simple ( FromRow, @@ -191,6 +195,8 @@ import qualified U.Codebase.Sqlite.JournalMode as JournalMode import U.Codebase.Sqlite.ObjectType (ObjectType) import qualified U.Codebase.Sqlite.Reference as Reference import qualified U.Codebase.Sqlite.Referent as Referent +import U.Codebase.Sqlite.TempEntity (HashJWT) +import U.Codebase.Sqlite.TempEntityType (TempEntityType) import U.Codebase.WatchKind (WatchKind) import qualified U.Codebase.WatchKind as WatchKind import qualified U.Util.Alternative as Alternative @@ -947,14 +953,16 @@ ancestorSql = -- * share sync / temp entities -getMissingDependencyJwtsForTempEntity :: DB m => Base32Hex -> m [Text] +-- +getMissingDependencyJwtsForTempEntity :: DB m => Base32Hex -> m (Maybe (NESet Text)) getMissingDependencyJwtsForTempEntity h = - queryAtoms - [here| - SELECT jwt FROM temp_entity_missing_dependency - WHERE dependent = ? - |] - (Only h) + NESet.nonEmptySet . Set.fromList + <$> queryAtoms + [here| + SELECT dependencyJwt FROM temp_entity_missing_dependency + WHERE dependent = ? + |] + (Only h) tempEntityExists :: DB m => Base32Hex -> m Bool tempEntityExists h = queryOne $ queryAtom sql (Only h) @@ -968,6 +976,42 @@ tempEntityExists h = queryOne $ queryAtom sql (Only h) ) |] +-- | Insert a new `temp_entity` row, and its associated 1+ `temp_entity_missing_dependency` rows. +-- +-- Preconditions: +-- 1. The entity does not already exist in "main" storage (`object` / `causal`) +-- 2. The entity does not already exist in `temp_entity`. +insertTempEntity :: DB m => Base32Hex -> ByteString -> TempEntityType -> NESet (Base32Hex, HashJWT) -> m () +insertTempEntity dependentHash dependentBlob dependentType missingDependencies = do + execute + [here| + INSERT INTO temp_entity (hash, blob, typeId) + VALUES (?, ?, ?) + |] + (dependentHash, dependentBlob, dependentType) + + executeMany + [here| + INSERT INTO temp_entity_missing_dependencies (dependent, dependency, dependencyJwt) + VALUES (?, ?, ?) + |] + ( NESet.map + (\(dependencyHash, dependencyHashJwt) -> (dependentHash, dependencyHash, dependencyHashJwt)) + missingDependencies + ) + +-- | takes a dependent's hash and multiple dependency hashes +deleteTempDependencies :: (DB m, Foldable f) => Base32Hex -> f Base32Hex -> m () +deleteTempDependencies dependent (Foldable.toList -> dependencies) = + executeMany sql (map (dependent,) dependencies) + where + sql = + [here| + DELETE FROM temp_entity_missing_dependencies + WHERE dependent = ? + AND dependency = ? + |] + -- * helper functions -- | composite input, atomic List output @@ -1060,8 +1104,8 @@ execute_ q = do header <- debugHeader liftIO . queryTrace_ (header ++ " " ++ "execute_") q $ SQLite.execute_ c q -executeMany :: (DB m, ToRow q, Show q) => SQLite.Query -> [q] -> m () -executeMany q r = do +executeMany :: (DB m, Foldable f, ToRow q, Show q) => SQLite.Query -> f q -> m () +executeMany q (Foldable.toList -> r) = do c <- Reader.reader Connection.underlying header <- debugHeader liftIO . queryTrace (header ++ " " ++ "executeMany") q r $ SQLite.executeMany c q r diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index 95312460bf..2aa6a3cd5d 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -729,7 +729,7 @@ putTempEntity = \case putFoldable putHashJWT branchDefnLookup putFoldable putHashJWT branchPatchLookup putFoldable (putPair putHashJWT putHashJWT) branchChildLookup - putSyncCausal TempEntity.TempCausalFormat {valueHash, parents} = do + putSyncCausal TempEntity.TempCausalFormat' {valueHash, parents} = do putHashJWT valueHash putFoldable putHashJWT parents putSyncFullPatch lids bytes = do @@ -827,7 +827,7 @@ getTempNamespaceFormat = getTempCausalFormat :: MonadGet m => m TempEntity.TempCausalFormat getTempCausalFormat = - TempEntity.TempCausalFormat + TempEntity.TempCausalFormat' <$> getHashJWT <*> getVector getHashJWT diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index 60d95db77f..32e556073f 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -26,4 +26,6 @@ type TempPatchFormat = Patch.SyncPatchFormat' HashJWT Text Base32Hex HashJWT type TempNamespaceFormat = Namespace.SyncBranchFormat' HashJWT Text HashJWT HashJWT (HashJWT, HashJWT) -data TempCausalFormat = TempCausalFormat {valueHash :: HashJWT, parents :: Vector HashJWT} +type TempCausalFormat = TempCausalFormat' HashJWT HashJWT + +data TempCausalFormat' valueHash parent = TempCausalFormat' {valueHash :: valueHash, parents :: Vector parent} diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index caadc6620b..71b67f463e 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -42,6 +42,7 @@ dependencies: - generic-lens - monad-validate - mtl + - nonempty-containers - safe - sqlite-simple - text diff --git a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql index be9446f1bd..1b390f382b 100644 --- a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql +++ b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql @@ -46,15 +46,15 @@ create table temp_entity ( -- +------------------------+ -- -- temp_entity_missing_dependency --- +-----------------------------------+ --- | dependent | dependency | jwt | --- |===================================| --- | #foo | #bar | aT.Eb.cx | --- +-----------------------------------+ +-- +----------------------------------------+ +-- | dependent | dependency | dependencyJwt | +-- |========================================| +-- | #foo | #bar | aT.Eb.cx | +-- +----------------------------------------+ create table temp_entity_missing_dependency ( dependent text not null references temp_entity(hash), dependency text not null, - jwt text not null, + dependencyJwt text not null, unique (dependent, dependency) ); create index temp_entity_missing_dependency_ix_dependent on temp_entity_missing_dependency (dependent); diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 62eec7b77f..99e9eef73b 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -83,6 +83,7 @@ library , lens , monad-validate , mtl + , nonempty-containers , safe , sqlite-simple , text diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 1b402d364b..b9fe196413 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -18,13 +18,17 @@ import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import U.Codebase.HashTags (CausalHash (unCausalHash)) +import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import U.Codebase.Sqlite.Connection (Connection) -import U.Codebase.Sqlite.DbId (HashId) +import U.Codebase.Sqlite.DbId (CausalHashId, HashId) +import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat +import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat import qualified U.Codebase.Sqlite.Queries as Q import qualified U.Codebase.Sqlite.Serialization as S import U.Codebase.Sqlite.TempEntity (TempEntity) import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.TempEntityType as TempEntity +import qualified U.Codebase.Sqlite.Term.Format as TermFormat import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as Hash import Unison.Prelude @@ -218,28 +222,24 @@ download conn repoName = do NEMap.toList entities & foldMapM \(hash, entity) -> do let putInMainStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> IO () putInMainStorage _hash _entity = undefined - let putInTempStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> IO () - putInTempStorage _hash entity = do + let putInTempStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> NESet Share.DecodedHashJWT -> IO () + putInTempStorage _hash entity _missingDependencies = do -- convert the blob to the data type we have a serializer for let tempEntity = makeTempEntity entity - _entityType = tempEntityType entity + entityType = tempEntityType entity -- serialize the blob - let _bytes = runPutS (S.putTempEntity tempEntity) + let bytes = runPutS (S.putTempEntity tempEntity) -- insert the blob - undefined - let insertMissingDependencies = undefined - -- select dependency - -- from temp_entity_missing_dependency - -- where dependent = - let getTempEntityMissingDependencies :: Share.Entity Text Share.Hash Share.HashJWT -> IO (Set Share.DecodedHashJWT) - getTempEntityMissingDependencies = undefined + runDB do + Q.insertTempEntity _hash _bytes _entityType _missingDependencies + inMainStorage hash >>= \case + True -> pure Set.empty inMainStorage hash >>= \case True -> pure Set.empty False -> - inTempStorage hash >>= \case - True -> getTempEntityMissingDependencies entity - False -> do + missingDependencies <- Set.filterM (inMainStorage . decodedHashJWTHash) (directDepsOfEntity entity) + if Set.null missingDependencies missingDependencies <- Set.filterM (inMainStorage . decodedHashJWTHash) (directDepsOfEntity entity) if Set.null missingDependencies then putInMainStorage hash entity @@ -247,6 +247,7 @@ download conn repoName = do putInTempStorage hash entity insertMissingDependencies hash missingDependencies pure missingDependencies + case NESet.nonEmptySet missingDependencies0 of case NESet.nonEmptySet missingDependencies0 of Nothing -> pure () @@ -408,11 +409,34 @@ _uploadEntities = undefined makeTempEntity :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity makeTempEntity e = case e of - Share.TC _ -> (TempEntity.TC _) - Share.DC _ -> (TempEntity.DC _) - Share.P _ -> (TempEntity.P _) - Share.N _ -> (TempEntity.N _) - Share.C _ -> (TempEntity.C _) + Share.P _ -> undefined -- (TempEntity.P _) + Share.N _ -> undefined -- (TempEntity.N _) + Share.C _ -> undefined -- (TempEntity.C _) + +-- have to convert from Entity format to TempEntity format (`makeTempEntity` on 414) + +-- also have to convert from TempEntity format to Sync format โ€”ย this means exchanging Text for TextId and `Base32Hex`es for `HashId`s and/or `ObjectId`s +convertTempTermComponent :: TempEntity.TempTermFormat -> IO TermFormat.SyncTermFormat +convertTempTermComponent = do + undefined + +convertTempDeclComponent :: TempEntity.TempDeclFormat -> IO DeclFormat.SyncDeclFormat +convertTempDeclComponent = do + undefined + +convertTempPatch :: TempEntity.TempPatchFormat -> IO PatchFormat.SyncPatchFormat +convertTempPatch = do + undefined + +convertTempNamespace :: TempEntity.TempNamespaceFormat -> IO NamespaceFormat.SyncBranchFormat +convertTempNamespace = do + undefined + +convertTempCausal :: TempEntity.TempCausalFormat -> IO (TempEntity.TempCausalFormat' CausalHashId CausalHashId) -- could probably use a better type name here +convertTempCausal = do + undefined + +tempEntityType :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity.TempEntityType tempEntityType :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity.TempEntityType tempEntityType = \case From 28463439f4bd425d9a346c2d763507dbf33c2911 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 12 Apr 2022 13:35:58 -0500 Subject: [PATCH 097/529] maybe done with download? --- unison-cli/src/Unison/Share/Sync.hs | 51 ++++++++++++++--------- unison-share-api/src/Unison/Sync/Types.hs | 2 +- 2 files changed, 33 insertions(+), 20 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index b9fe196413..b91de44a8f 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -184,9 +184,9 @@ download conn repoName = do let directDepsOfHash :: Share.Hash -> IO (Set Share.DecodedHashJWT) directDepsOfHash (Share.Hash b32) = do - jwts <- runDB (Q.getMissingDependencyJwtsForTempEntity (Base32Hex.UnsafeFromText b32)) + maybeJwts <- runDB (Q.getMissingDependencyJwtsForTempEntity (Base32Hex.UnsafeFromText b32)) let decode = decodeHashJWT . Share.HashJWT - pure (Set.fromList (map decode jwts)) + pure (maybe Set.empty (Set.map decode . NESet.toSet) maybeJwts) let loop :: NESet Share.DecodedHashJWT -> IO () loop hashes0 = do let elaborateHashes :: Set Share.DecodedHashJWT -> Set Share.HashJWT -> IO (Maybe (NESet Share.HashJWT)) @@ -223,7 +223,7 @@ download conn repoName = do let putInMainStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> IO () putInMainStorage _hash _entity = undefined let putInTempStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> NESet Share.DecodedHashJWT -> IO () - putInTempStorage _hash entity _missingDependencies = do + putInTempStorage hash entity missingDependencies = do -- convert the blob to the data type we have a serializer for let tempEntity = makeTempEntity entity entityType = tempEntityType entity @@ -231,23 +231,36 @@ download conn repoName = do let bytes = runPutS (S.putTempEntity tempEntity) -- insert the blob runDB do - Q.insertTempEntity _hash _bytes _entityType _missingDependencies - - inMainStorage hash >>= \case - True -> pure Set.empty + Q.insertTempEntity + (Base32Hex.UnsafeFromText $ Share.toBase32Hex hash) + bytes + entityType + ( NESet.map + ( \Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}, hashJWT} -> + ( Base32Hex.UnsafeFromText $ Share.toBase32Hex hash, + Share.unHashJWT hashJWT + ) + ) + missingDependencies + ) + + -- still trying to figure out missing dependencies of hash/entity. inMainStorage hash >>= \case True -> pure Set.empty False -> - missingDependencies <- Set.filterM (inMainStorage . decodedHashJWTHash) (directDepsOfEntity entity) - if Set.null missingDependencies - missingDependencies <- Set.filterM (inMainStorage . decodedHashJWTHash) (directDepsOfEntity entity) - if Set.null missingDependencies - then putInMainStorage hash entity - else do - putInTempStorage hash entity - insertMissingDependencies hash missingDependencies - pure missingDependencies - case NESet.nonEmptySet missingDependencies0 of + runDB (Q.getMissingDependencyJwtsForTempEntity (Base32Hex.UnsafeFromText (Share.toBase32Hex hash))) >>= \case + Just missingDependencies -> + -- already in temp storage, due to missing dependencies + pure (Set.map (decodeHashJWT . Share.HashJWT) (NESet.toSet missingDependencies)) + Nothing -> do + -- not in temp storage. + -- if it has missing dependencies, add it to temp storage; + -- otherwise add it to main storage. + missingDependencies0 <- Set.filterM (inMainStorage . decodedHashJWTHash) (directDepsOfEntity entity) + case NESet.nonEmptySet missingDependencies0 of + Nothing -> putInMainStorage hash entity + Just missingDependencies -> putInTempStorage hash entity missingDependencies + pure missingDependencies0 case NESet.nonEmptySet missingDependencies0 of Nothing -> pure () @@ -409,6 +422,8 @@ _uploadEntities = undefined makeTempEntity :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity makeTempEntity e = case e of + Share.TC _ -> undefined -- (TempEntity.TC _) + Share.DC _ -> undefined -- (TempEntity.DC _) Share.P _ -> undefined -- (TempEntity.P _) Share.N _ -> undefined -- (TempEntity.N _) Share.C _ -> undefined -- (TempEntity.C _) @@ -436,8 +451,6 @@ convertTempCausal :: TempEntity.TempCausalFormat -> IO (TempEntity.TempCausalFor convertTempCausal = do undefined -tempEntityType :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity.TempEntityType - tempEntityType :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity.TempEntityType tempEntityType = \case Share.TC tc -> TempEntity.TermComponentType diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 3aa097fac7..e117a77ae8 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -31,7 +31,7 @@ instance FromJSON Base64Bytes where newtype RepoName = RepoName Text deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) -newtype HashJWT = HashJWT Text +newtype HashJWT = HashJWT {unHashJWT :: Text} deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) data DecodedHashJWT = DecodedHashJWT From 7eadba793a2a645cc9600a31bbbe2e136419a3f8 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 12 Apr 2022 13:56:55 -0500 Subject: [PATCH 098/529] tempToSyncTermComponent --- .../U/Codebase/Sqlite/TempEntity.hs | 4 +- unison-cli/src/Unison/Share/Sync.hs | 42 +++++++++++++------ 2 files changed, 32 insertions(+), 14 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index 32e556073f..c3047f9300 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -26,6 +26,6 @@ type TempPatchFormat = Patch.SyncPatchFormat' HashJWT Text Base32Hex HashJWT type TempNamespaceFormat = Namespace.SyncBranchFormat' HashJWT Text HashJWT HashJWT (HashJWT, HashJWT) -type TempCausalFormat = TempCausalFormat' HashJWT HashJWT +type TempCausalFormat = SyncCausalFormat' HashJWT HashJWT -data TempCausalFormat' valueHash parent = TempCausalFormat' {valueHash :: valueHash, parents :: Vector parent} +data SyncCausalFormat' causalHash namespaceHash = SyncCausalFormat {valueHash :: namespaceHash, parents :: Vector causalHash} diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index b91de44a8f..fe9d62df81 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -9,8 +9,10 @@ module Unison.Share.Sync ) where +import qualified Control.Lens as Lens import Control.Monad.Extra ((||^)) import Control.Monad.Reader (ReaderT, runReaderT) +import Data.Bitraversable (bitraverse) import Data.Bytes.Put (runPutS) import qualified Data.List.NonEmpty as List.NonEmpty import qualified Data.Map.NonEmpty as NEMap @@ -20,7 +22,7 @@ import qualified Data.Set.NonEmpty as NESet import U.Codebase.HashTags (CausalHash (unCausalHash)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import U.Codebase.Sqlite.Connection (Connection) -import U.Codebase.Sqlite.DbId (CausalHashId, HashId) +import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId, HashId) import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat import qualified U.Codebase.Sqlite.Queries as Q @@ -431,25 +433,41 @@ makeTempEntity e = case e of -- have to convert from Entity format to TempEntity format (`makeTempEntity` on 414) -- also have to convert from TempEntity format to Sync format โ€”ย this means exchanging Text for TextId and `Base32Hex`es for `HashId`s and/or `ObjectId`s -convertTempTermComponent :: TempEntity.TempTermFormat -> IO TermFormat.SyncTermFormat -convertTempTermComponent = do +tempToSyncTermComponent :: TempEntity.TempTermFormat -> IO TermFormat.SyncTermFormat +tempToSyncTermComponent = \case + TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent vec) -> + TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent + <$> traverse + ( \(localIds, bytes) -> do + localIds' <- bitraverse _saveText _hashJWT_to_expectHashId_expectObjectId localIds + undefined localIds' bytes {-recompose something-} + ) + vec + +-- Serialization.recomposeComponent :: MonadPut m => [(LocalIds, BS.ByteString)] -> m () +-- Serialization.recomposePatchFormat :: MonadPut m => PatchFormat.SyncPatchFormat -> m () +-- Serialization.recomposeBranchFormat :: MonadPut m => BranchFormat.SyncBranchFormat -> m () +-- Q.saveObject :: DB m => HashId -> ObjectType -> ByteString -> m ObjectId + +tempToSyncDeclComponent :: TempEntity.TempDeclFormat -> IO DeclFormat.SyncDeclFormat +tempToSyncDeclComponent = do undefined -convertTempDeclComponent :: TempEntity.TempDeclFormat -> IO DeclFormat.SyncDeclFormat -convertTempDeclComponent = do +tempToSyncPatch :: TempEntity.TempPatchFormat -> IO PatchFormat.SyncPatchFormat +tempToSyncPatch = do undefined -convertTempPatch :: TempEntity.TempPatchFormat -> IO PatchFormat.SyncPatchFormat -convertTempPatch = do +tempToSyncNamespace :: TempEntity.TempNamespaceFormat -> IO NamespaceFormat.SyncBranchFormat +tempToSyncNamespace = do undefined -convertTempNamespace :: TempEntity.TempNamespaceFormat -> IO NamespaceFormat.SyncBranchFormat -convertTempNamespace = do +tempToSyncCausal :: TempEntity.TempCausalFormat -> IO (Causal.SyncCausalFormat' CausalHashId BranchHashId) -- could probably use a better type name here +tempToSyncCausal = do undefined -convertTempCausal :: TempEntity.TempCausalFormat -> IO (TempEntity.TempCausalFormat' CausalHashId CausalHashId) -- could probably use a better type name here -convertTempCausal = do - undefined +-- Q.saveCausalHash :: DB m => CausalHash -> m CausalHashId -- only affects `hash` table +-- Q.saveCausal :: DB m => CausalHashId -> BranchHashId -> m () +-- Q.saveCausalParents :: DB m => CausalHashId -> [CausalHashId] -> m () tempEntityType :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity.TempEntityType tempEntityType = \case From 5d7df3a7ff52f798642f8d2dd4dd000b1e17a37b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 15:24:52 -0400 Subject: [PATCH 099/529] get code compiling, bit of work on temp->main term --- .../U/Codebase/Sqlite/Causal.hs | 51 +++++-------------- .../U/Codebase/Sqlite/Queries.hs | 1 + .../U/Codebase/Sqlite/Serialization.hs | 5 +- .../U/Codebase/Sqlite/TempEntity.hs | 6 +-- codebase2/codebase-sqlite/package.yaml | 2 + .../unison-codebase-sqlite.cabal | 2 + .../Migrations/MigrateSchema1To2.hs | 6 +-- unison-cli/src/Unison/Share/Sync.hs | 40 +++++++++++---- 8 files changed, 54 insertions(+), 59 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs index c8a6885534..19fd7f7794 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs @@ -1,7 +1,11 @@ -{-# LANGUAGE RecordWildCards #-} - -module U.Codebase.Sqlite.Causal where - +module U.Codebase.Sqlite.Causal + ( DbCausal, + GDbCausal (..), + SyncCausalFormat' (..), + ) +where + +import Data.Vector (Vector) import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId) import Unison.Prelude @@ -11,40 +15,9 @@ data GDbCausal causalHash valueHash = DbCausal parents :: Set causalHash } --- Causal Plan - --- * Load a DbCausal (how do we do this) - --- => new function Queries.localCausalByCausalHashId, can model after loadCausalByCausalHash or factor out of - --- * Add valueHashId as a dependency if unmigrated - --- * Add parent causal hash ids as dependencies if unmigrated - --- => Queries.loadCausalParents - --- * Map over Branch hash IDs - --- * Inside saveDBCausal (new / factored out of original) - --- * Save as a new self-hash --- ==> Queries.saveCausal --- * Map over parent causal hash IDs --- ==> Queries.saveCausalParents - type DbCausal = GDbCausal CausalHashId BranchHashId --- causalHashes_ :: Traversal (GDbCausal ch vh) (GDbCausal ch' vh) ch ch' --- causalHashes_ f DbCausal {..} = --- DbCausal <$> f selfHash <*> pure valueHash <*> (fmap Set.fromList . traverse f . Set.toList $ parents) - --- valueHashes_ :: Lens (GDbCausal ch vh) (GDbCausal ch vh) vh vh' --- valueHashes_ f DbCausal{..} = --- (\p vh -> DbCausal selfHash vh p) parents <$> f valueHash - --- data Causal m hc he e = Causal --- { causalHash :: hc, --- valueHash :: he, --- parents :: Map hc (m (Causal m hc he e)), --- value :: m e --- } +data SyncCausalFormat' causalHash valueHash = SyncCausalFormat + { valueHash :: valueHash, + parents :: Vector causalHash + } diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index dad031c23a..ad2ae6cebe 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -244,6 +244,7 @@ data Integrity | MultipleSchemaVersions [SchemaVersion] | NoTypeIndexForTerm Referent.Id deriving (Show) + deriving anyclass (Exception) orError :: Err m => Integrity -> Maybe b -> m b orError e = maybe (throwError e) pure diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index 2aa6a3cd5d..bf1a9da22a 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -29,6 +29,7 @@ import qualified U.Codebase.Referent as Referent import qualified U.Codebase.Sqlite.Branch.Diff as BranchDiff import qualified U.Codebase.Sqlite.Branch.Format as BranchFormat import qualified U.Codebase.Sqlite.Branch.Full as BranchFull +import qualified U.Codebase.Sqlite.Causal as Causal import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat import U.Codebase.Sqlite.LocalIds (LocalIds, LocalIds' (..), LocalTextId, WatchLocalIds) import qualified U.Codebase.Sqlite.Patch.Diff as PatchDiff @@ -729,7 +730,7 @@ putTempEntity = \case putFoldable putHashJWT branchDefnLookup putFoldable putHashJWT branchPatchLookup putFoldable (putPair putHashJWT putHashJWT) branchChildLookup - putSyncCausal TempEntity.TempCausalFormat' {valueHash, parents} = do + putSyncCausal Causal.SyncCausalFormat {valueHash, parents} = do putHashJWT valueHash putFoldable putHashJWT parents putSyncFullPatch lids bytes = do @@ -827,7 +828,7 @@ getTempNamespaceFormat = getTempCausalFormat :: MonadGet m => m TempEntity.TempCausalFormat getTempCausalFormat = - TempEntity.TempCausalFormat' + Causal.SyncCausalFormat <$> getHashJWT <*> getVector getHashJWT diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index c3047f9300..ebff378827 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -1,7 +1,7 @@ module U.Codebase.Sqlite.TempEntity where -import Data.Vector (Vector) import qualified U.Codebase.Sqlite.Branch.Format as Namespace +import qualified U.Codebase.Sqlite.Causal as Causal import qualified U.Codebase.Sqlite.Decl.Format as Decl import qualified U.Codebase.Sqlite.Patch.Format as Patch import qualified U.Codebase.Sqlite.Term.Format as Term @@ -26,6 +26,4 @@ type TempPatchFormat = Patch.SyncPatchFormat' HashJWT Text Base32Hex HashJWT type TempNamespaceFormat = Namespace.SyncBranchFormat' HashJWT Text HashJWT HashJWT (HashJWT, HashJWT) -type TempCausalFormat = SyncCausalFormat' HashJWT HashJWT - -data SyncCausalFormat' causalHash namespaceHash = SyncCausalFormat {valueHash :: namespaceHash, parents :: Vector causalHash} +type TempCausalFormat = Causal.SyncCausalFormat' HashJWT HashJWT diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index 71b67f463e..ef1a1467c7 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -6,10 +6,12 @@ default-extensions: - BangPatterns - BlockArguments - ConstraintKinds + - DeriveAnyClass - DeriveFunctor - DeriveGeneric - DerivingStrategies - DoAndIfThenElse + - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - FunctionalDependencies diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 99e9eef73b..caa865785f 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -54,10 +54,12 @@ library BangPatterns BlockArguments ConstraintKinds + DeriveAnyClass DeriveFunctor DeriveGeneric DerivingStrategies DoAndIfThenElse + DuplicateRecordFields FlexibleContexts FlexibleInstances FunctionalDependencies diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 0964c07fc6..2fff1a1556 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -32,7 +32,7 @@ import qualified U.Codebase.Referent as UReferent import qualified U.Codebase.Sqlite.Branch.Full as S import qualified U.Codebase.Sqlite.Branch.Full as S.Branch.Full import U.Codebase.Sqlite.Causal (GDbCausal (..)) -import qualified U.Codebase.Sqlite.Causal as SC +import qualified U.Codebase.Sqlite.Causal as SC.DbCausal (GDbCausal (..)) import U.Codebase.Sqlite.Connection (Connection) import U.Codebase.Sqlite.DbId ( BranchHashId (..), @@ -302,8 +302,8 @@ migrateCausal conn oldCausalHashId = fmap (either id id) . runExceptT $ do parents = newParentHashIds } runDB conn do - Q.saveCausal (SC.selfHash newCausal) (SC.valueHash newCausal) - Q.saveCausalParents (SC.selfHash newCausal) (Set.toList $ SC.parents newCausal) + Q.saveCausal (SC.DbCausal.selfHash newCausal) (SC.DbCausal.valueHash newCausal) + Q.saveCausalParents (SC.DbCausal.selfHash newCausal) (Set.toList $ SC.DbCausal.parents newCausal) field @"causalMapping" %= Map.insert oldCausalHashId (newCausalHash, newCausalHashId) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index fe9d62df81..b91e50fbe8 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -21,8 +21,9 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import U.Codebase.HashTags (CausalHash (unCausalHash)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat +import qualified U.Codebase.Sqlite.Causal as Causal import U.Codebase.Sqlite.Connection (Connection) -import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId, HashId) +import U.Codebase.Sqlite.DbId (ObjectId, BranchHashId, CausalHashId, HashId) import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat import qualified U.Codebase.Sqlite.Queries as Q @@ -31,6 +32,7 @@ import U.Codebase.Sqlite.TempEntity (TempEntity) import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.TempEntityType as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat +import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as Hash import Unison.Prelude @@ -39,6 +41,7 @@ import qualified Unison.Sync.Types as Share.LocalIds (LocalIds (..)) import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set +import qualified Unison.Sync.Types as Share ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path @@ -120,6 +123,9 @@ push conn repoPath expectedHash causalHash = do UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> Left (PushErrorServerMissingDependencies dependencies) +-- Upload a set of entities to Unison Share. If the server responds that it cannot yet store any hash(es) due to missing +-- dependencies, send those dependencies too, and on and on, until the server stops responding that it's missing +-- anything. upload :: Connection -> Share.RepoName -> NESet Share.Hash -> IO () upload conn repoName = loop @@ -154,6 +160,11 @@ decodedHashJWTHash = undefined decodeHashJWT :: Share.HashJWT -> Share.DecodedHashJWT decodeHashJWT = undefined +hashJWTHash :: Share.HashJWT -> Base32Hex +hashJWTHash = + Base32Hex.UnsafeFromText . Share.toBase32Hex . decodedHashJWTHash . decodeHashJWT + +-- Download a set of entities from Unison Share. download :: Connection -> Share.RepoName -> NESet Share.HashJWT -> IO () download conn repoName = do let runDB :: ReaderT Connection IO a -> IO a @@ -433,16 +444,23 @@ makeTempEntity e = case e of -- have to convert from Entity format to TempEntity format (`makeTempEntity` on 414) -- also have to convert from TempEntity format to Sync format โ€”ย this means exchanging Text for TextId and `Base32Hex`es for `HashId`s and/or `ObjectId`s -tempToSyncTermComponent :: TempEntity.TempTermFormat -> IO TermFormat.SyncTermFormat -tempToSyncTermComponent = \case - TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent vec) -> - TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent - <$> traverse - ( \(localIds, bytes) -> do - localIds' <- bitraverse _saveText _hashJWT_to_expectHashId_expectObjectId localIds - undefined localIds' bytes {-recompose something-} - ) - vec +tempToSyncTermComponent :: Connection -> TempEntity.TempTermFormat -> IO TermFormat.SyncTermFormat +tempToSyncTermComponent conn = + flip runReaderT conn . \case + TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent vec) -> + TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent + <$> traverse + ( \(localIds, bytes) -> do + localIds' <- bitraverse Q.saveText expectObjectIdForHashJWT localIds + undefined localIds' bytes {-recompose something-} + ) + vec + +expectObjectIdForHashJWT :: Q.DB m => TempEntity.HashJWT -> m ObjectId +expectObjectIdForHashJWT hashJwt = do + hashId <- throwExceptT (Q.expectHashIdByHash (Hash.fromBase32Hex (hashJWTHash (Share.HashJWT hashJwt)))) + -- FIXME mitchell: should this be "for primary hash id" or "for any hash id"? + throwExceptT (Q.expectObjectIdForAnyHashId hashId) -- Serialization.recomposeComponent :: MonadPut m => [(LocalIds, BS.ByteString)] -> m () -- Serialization.recomposePatchFormat :: MonadPut m => PatchFormat.SyncPatchFormat -> m () From cd11a9a0764c34992825d4c5e825748c9062c17e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 15:28:23 -0400 Subject: [PATCH 100/529] finish tempToSyncTermComponent --- unison-cli/src/Unison/Share/Sync.hs | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index b91e50fbe8..7535dbf7c6 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -23,7 +23,7 @@ import U.Codebase.HashTags (CausalHash (unCausalHash)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import qualified U.Codebase.Sqlite.Causal as Causal import U.Codebase.Sqlite.Connection (Connection) -import U.Codebase.Sqlite.DbId (ObjectId, BranchHashId, CausalHashId, HashId) +import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId, HashId, ObjectId) import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat import qualified U.Codebase.Sqlite.Queries as Q @@ -41,7 +41,6 @@ import qualified Unison.Sync.Types as Share.LocalIds (LocalIds (..)) import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set -import qualified Unison.Sync.Types as Share ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path @@ -447,14 +446,9 @@ makeTempEntity e = case e of tempToSyncTermComponent :: Connection -> TempEntity.TempTermFormat -> IO TermFormat.SyncTermFormat tempToSyncTermComponent conn = flip runReaderT conn . \case - TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent vec) -> + TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent terms) -> TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent - <$> traverse - ( \(localIds, bytes) -> do - localIds' <- bitraverse Q.saveText expectObjectIdForHashJWT localIds - undefined localIds' bytes {-recompose something-} - ) - vec + <$> Lens.traverseOf (traverse . Lens._1) (bitraverse Q.saveText expectObjectIdForHashJWT) terms expectObjectIdForHashJWT :: Q.DB m => TempEntity.HashJWT -> m ObjectId expectObjectIdForHashJWT hashJwt = do From 3b62fa777481c325e0b2703bcab1d8c195ef5e0f Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 15:41:42 -0400 Subject: [PATCH 101/529] serialize in insertTempEntity --- .../U/Codebase/Sqlite/Queries.hs | 24 ++++++---- .../U/Codebase/Sqlite/TempEntity.hs | 11 ++++- unison-cli/src/Unison/Share/Sync.hs | 46 ++++++------------- 3 files changed, 39 insertions(+), 42 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index ad2ae6cebe..76c50523d6 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -156,6 +156,7 @@ import qualified Control.Monad.Except as Except import Control.Monad.Reader (MonadReader (ask)) import qualified Control.Monad.Reader as Reader import qualified Control.Monad.Writer as Writer +import Data.Bytes.Put (runPutS) import qualified Data.Char as Char import qualified Data.Foldable as Foldable import qualified Data.List.Extra as List @@ -195,7 +196,9 @@ import qualified U.Codebase.Sqlite.JournalMode as JournalMode import U.Codebase.Sqlite.ObjectType (ObjectType) import qualified U.Codebase.Sqlite.Reference as Reference import qualified U.Codebase.Sqlite.Referent as Referent -import U.Codebase.Sqlite.TempEntity (HashJWT) +import U.Codebase.Sqlite.Serialization as Serialization +import U.Codebase.Sqlite.TempEntity (HashJWT, TempEntity) +import qualified U.Codebase.Sqlite.TempEntity as TempEntity import U.Codebase.Sqlite.TempEntityType (TempEntityType) import U.Codebase.WatchKind (WatchKind) import qualified U.Codebase.WatchKind as WatchKind @@ -982,24 +985,29 @@ tempEntityExists h = queryOne $ queryAtom sql (Only h) -- Preconditions: -- 1. The entity does not already exist in "main" storage (`object` / `causal`) -- 2. The entity does not already exist in `temp_entity`. -insertTempEntity :: DB m => Base32Hex -> ByteString -> TempEntityType -> NESet (Base32Hex, HashJWT) -> m () -insertTempEntity dependentHash dependentBlob dependentType missingDependencies = do +insertTempEntity :: DB m => Base32Hex -> TempEntity -> NESet (Base32Hex, HashJWT) -> m () +insertTempEntity entityHash entity missingDependencies = do execute [here| INSERT INTO temp_entity (hash, blob, typeId) VALUES (?, ?, ?) |] - (dependentHash, dependentBlob, dependentType) + (entityHash, entityBlob, entityType) executeMany [here| INSERT INTO temp_entity_missing_dependencies (dependent, dependency, dependencyJwt) VALUES (?, ?, ?) |] - ( NESet.map - (\(dependencyHash, dependencyHashJwt) -> (dependentHash, dependencyHash, dependencyHashJwt)) - missingDependencies - ) + (map (\(depHash, depHashJwt) -> (entityHash, depHash, depHashJwt)) (Foldable.toList missingDependencies)) + where + entityBlob :: ByteString + entityBlob = + runPutS (Serialization.putTempEntity entity) + + entityType :: TempEntityType + entityType = + TempEntity.tempEntityType entity -- | takes a dependent's hash and multiple dependency hashes deleteTempDependencies :: (DB m, Foldable f) => Base32Hex -> f Base32Hex -> m () diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index ebff378827..dbe09e7e45 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -4,6 +4,7 @@ import qualified U.Codebase.Sqlite.Branch.Format as Namespace import qualified U.Codebase.Sqlite.Causal as Causal import qualified U.Codebase.Sqlite.Decl.Format as Decl import qualified U.Codebase.Sqlite.Patch.Format as Patch +import U.Codebase.Sqlite.TempEntityType (TempEntityType (..)) import qualified U.Codebase.Sqlite.Term.Format as Term import U.Util.Base32Hex (Base32Hex) import Unison.Prelude @@ -14,10 +15,18 @@ type HashJWT = Text data TempEntity = TC TempTermFormat | DC TempDeclFormat - | P TempPatchFormat | N TempNamespaceFormat + | P TempPatchFormat | C TempCausalFormat +tempEntityType :: TempEntity -> TempEntityType +tempEntityType = \case + TC _ -> TermComponentType + DC _ -> DeclComponentType + N _ -> NamespaceType + P _ -> PatchType + C _ -> CausalType + type TempTermFormat = Term.SyncTermFormat' Text HashJWT type TempDeclFormat = Decl.SyncDeclFormat' Text HashJWT diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 7535dbf7c6..7c85d21cf6 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -13,7 +13,6 @@ import qualified Control.Lens as Lens import Control.Monad.Extra ((||^)) import Control.Monad.Reader (ReaderT, runReaderT) import Data.Bitraversable (bitraverse) -import Data.Bytes.Put (runPutS) import qualified Data.List.NonEmpty as List.NonEmpty import qualified Data.Map.NonEmpty as NEMap import qualified Data.Set as Set @@ -27,10 +26,8 @@ import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId, HashId, ObjectId) import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat import qualified U.Codebase.Sqlite.Queries as Q -import qualified U.Codebase.Sqlite.Serialization as S import U.Codebase.Sqlite.TempEntity (TempEntity) import qualified U.Codebase.Sqlite.TempEntity as TempEntity -import qualified U.Codebase.Sqlite.TempEntityType as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Base32Hex as Base32Hex @@ -234,27 +231,6 @@ download conn repoName = do NEMap.toList entities & foldMapM \(hash, entity) -> do let putInMainStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> IO () putInMainStorage _hash _entity = undefined - let putInTempStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> NESet Share.DecodedHashJWT -> IO () - putInTempStorage hash entity missingDependencies = do - -- convert the blob to the data type we have a serializer for - let tempEntity = makeTempEntity entity - entityType = tempEntityType entity - -- serialize the blob - let bytes = runPutS (S.putTempEntity tempEntity) - -- insert the blob - runDB do - Q.insertTempEntity - (Base32Hex.UnsafeFromText $ Share.toBase32Hex hash) - bytes - entityType - ( NESet.map - ( \Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}, hashJWT} -> - ( Base32Hex.UnsafeFromText $ Share.toBase32Hex hash, - Share.unHashJWT hashJWT - ) - ) - missingDependencies - ) -- still trying to figure out missing dependencies of hash/entity. inMainStorage hash >>= \case @@ -271,7 +247,19 @@ download conn repoName = do missingDependencies0 <- Set.filterM (inMainStorage . decodedHashJWTHash) (directDepsOfEntity entity) case NESet.nonEmptySet missingDependencies0 of Nothing -> putInMainStorage hash entity - Just missingDependencies -> putInTempStorage hash entity missingDependencies + Just missingDependencies -> + runDB do + Q.insertTempEntity + (Base32Hex.UnsafeFromText $ Share.toBase32Hex hash) + (makeTempEntity entity) + ( NESet.map + ( \Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}, hashJWT} -> + ( Base32Hex.UnsafeFromText $ Share.toBase32Hex hash, + Share.unHashJWT hashJWT + ) + ) + missingDependencies + ) pure missingDependencies0 case NESet.nonEmptySet missingDependencies0 of @@ -480,11 +468,3 @@ tempToSyncCausal = do -- Q.saveCausalHash :: DB m => CausalHash -> m CausalHashId -- only affects `hash` table -- Q.saveCausal :: DB m => CausalHashId -> BranchHashId -> m () -- Q.saveCausalParents :: DB m => CausalHashId -> [CausalHashId] -> m () - -tempEntityType :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity.TempEntityType -tempEntityType = \case - Share.TC tc -> TempEntity.TermComponentType - Share.DC dc -> TempEntity.DeclComponentType - Share.P pa -> TempEntity.PatchType - Share.N name -> TempEntity.NamespaceType - Share.C ca -> TempEntity.CausalType From a06e6352d0c40f2c77f1bb30cfde7bc0d710381d Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 15:51:03 -0400 Subject: [PATCH 102/529] extract unison-util-base32hex package --- codebase2/codebase-sqlite/package.yaml | 1 + .../unison-codebase-sqlite.cabal | 1 + codebase2/codebase/package.yaml | 1 + codebase2/codebase/unison-codebase.cabal | 3 +- codebase2/util/unison-util.cabal | 2 - hie.yaml | 3 + lib/unison-util-base32hex/package.yaml | 41 +++++++++++++ .../src/U/Util/Base32Hex.hs | 6 +- .../unison-util-base32hex}/src/U/Util/Hash.hs | 0 .../unison-util-base32hex.cabal | 57 +++++++++++++++++++ parser-typechecker/package.yaml | 1 + .../unison-parser-typechecker.cabal | 1 + stack.yaml | 1 + unison-cli/package.yaml | 1 + unison-cli/unison-cli.cabal | 5 ++ unison-core/package.yaml | 1 + unison-core/unison-core1.cabal | 1 + 17 files changed, 117 insertions(+), 9 deletions(-) create mode 100644 lib/unison-util-base32hex/package.yaml rename {codebase2/util => lib/unison-util-base32hex}/src/U/Util/Base32Hex.hs (91%) rename {codebase2/util => lib/unison-util-base32hex}/src/U/Util/Hash.hs (100%) create mode 100644 lib/unison-util-base32hex/unison-util-base32hex.cabal diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index ef1a1467c7..186de3ace1 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -56,5 +56,6 @@ dependencies: - unison-core - unison-prelude - unison-util + - unison-util-base32hex - unison-util-serialization - unison-util-term diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index caa865785f..25b601bfff 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -95,6 +95,7 @@ library , unison-core , unison-prelude , unison-util + , unison-util-base32hex , unison-util-serialization , unison-util-term , unliftio diff --git a/codebase2/codebase/package.yaml b/codebase2/codebase/package.yaml index 5cd83cb575..e0c9a35cfe 100644 --- a/codebase2/codebase/package.yaml +++ b/codebase2/codebase/package.yaml @@ -30,4 +30,5 @@ dependencies: - text - unison-core - unison-util + - unison-util-base32hex - unison-prelude diff --git a/codebase2/codebase/unison-codebase.cabal b/codebase2/codebase/unison-codebase.cabal index d0f15314e2..652782ee95 100644 --- a/codebase2/codebase/unison-codebase.cabal +++ b/codebase2/codebase/unison-codebase.cabal @@ -3,8 +3,6 @@ cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: b4d3c77715f39c915cacffccf179f1ed62bce29ba013cecc3a25c847f5851233 name: unison-codebase version: 0.0.0 @@ -62,4 +60,5 @@ library , unison-core , unison-prelude , unison-util + , unison-util-base32hex default-language: Haskell2010 diff --git a/codebase2/util/unison-util.cabal b/codebase2/util/unison-util.cabal index 9bfd2cf91d..dc31d530a0 100644 --- a/codebase2/util/unison-util.cabal +++ b/codebase2/util/unison-util.cabal @@ -17,10 +17,8 @@ source-repository head library exposed-modules: U.Util.Alternative - U.Util.Base32Hex U.Util.Cache U.Util.Components - U.Util.Hash U.Util.Lens U.Util.Monoid U.Util.String diff --git a/hie.yaml b/hie.yaml index 01a7d9d04e..06fd56067b 100644 --- a/hie.yaml +++ b/hie.yaml @@ -33,6 +33,9 @@ cradle: - path: "unison-share-api/src" component: "unison-share-api:lib" + - path: "lib/unison-util-base32hex/src" + component: "unison-util-base32hex:lib" + - path: "lib/unison-util-relation/src" component: "unison-util-relation:lib" diff --git a/lib/unison-util-base32hex/package.yaml b/lib/unison-util-base32hex/package.yaml new file mode 100644 index 0000000000..ad8647beaf --- /dev/null +++ b/lib/unison-util-base32hex/package.yaml @@ -0,0 +1,41 @@ +name: unison-util-base32hex +github: unisonweb/unison +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors + +library: + source-dirs: src + +dependencies: + - base + - base32 + - bytestring + - containers + - unison-prelude + - text + +ghc-options: + -Wall + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - TupleSections + - TypeApplications + - ViewPatterns diff --git a/codebase2/util/src/U/Util/Base32Hex.hs b/lib/unison-util-base32hex/src/U/Util/Base32Hex.hs similarity index 91% rename from codebase2/util/src/U/Util/Base32Hex.hs rename to lib/unison-util-base32hex/src/U/Util/Base32Hex.hs index e5ffdc0104..5c62dac60e 100644 --- a/codebase2/util/src/U/Util/Base32Hex.hs +++ b/lib/unison-util-base32hex/src/U/Util/Base32Hex.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} - module U.Util.Base32Hex ( Base32Hex (UnsafeFromText), fromByteString, @@ -10,13 +8,11 @@ module U.Util.Base32Hex ) where -import Data.ByteString (ByteString) import qualified Data.ByteString.Base32.Hex as Base32.Hex -import Data.Set (Set) import qualified Data.Set as Set -import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import Unison.Prelude newtype Base32Hex = UnsafeFromText Text deriving (Eq, Ord, Show) diff --git a/codebase2/util/src/U/Util/Hash.hs b/lib/unison-util-base32hex/src/U/Util/Hash.hs similarity index 100% rename from codebase2/util/src/U/Util/Hash.hs rename to lib/unison-util-base32hex/src/U/Util/Hash.hs diff --git a/lib/unison-util-base32hex/unison-util-base32hex.cabal b/lib/unison-util-base32hex/unison-util-base32hex.cabal new file mode 100644 index 0000000000..4c13522ead --- /dev/null +++ b/lib/unison-util-base32hex/unison-util-base32hex.cabal @@ -0,0 +1,57 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: unison-util-base32hex +version: 0.0.0 +homepage: https://github.com/unisonweb/unison#readme +bug-reports: https://github.com/unisonweb/unison/issues +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors +build-type: Simple + +source-repository head + type: git + location: https://github.com/unisonweb/unison + +library + exposed-modules: + U.Util.Base32Hex + U.Util.Hash + other-modules: + Paths_unison_util_base32hex + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall + build-depends: + base + , base32 + , bytestring + , containers + , text + , unison-prelude + default-language: Haskell2010 diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 9a46c12893..68c3a7f6ff 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -117,6 +117,7 @@ library: - unison-prelude - unison-pretty-printer - unison-util + - unison-util-base32hex - unison-util-relation - open-browser - uri-encode diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 1e8c460f3c..29ba467d04 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -297,6 +297,7 @@ library , unison-prelude , unison-pretty-printer , unison-util + , unison-util-base32hex , unison-util-relation , unliftio , uri-encode diff --git a/stack.yaml b/stack.yaml index 1abc629fee..d3d7933e0e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -24,6 +24,7 @@ packages: - codebase2/util-term - lib/unison-prelude - lib/unison-sqlite +- lib/unison-util-base32hex - lib/unison-util-relation - lib/unison-pretty-printer diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 4a522a4146..d6c786f932 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -42,6 +42,7 @@ dependencies: - unison-parser-typechecker - unison-prelude - unison-util + - unison-util-base32hex - unison-util-relation - unison-pretty-printer - unison-share-api diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index d8038c429e..fb922643c0 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -139,6 +139,7 @@ library , unison-pretty-printer , unison-share-api , unison-util + , unison-util-base32hex , unison-util-relation , unliftio , wai @@ -236,6 +237,7 @@ executable cli-integration-tests , unison-pretty-printer , unison-share-api , unison-util + , unison-util-base32hex , unison-util-relation , unliftio , wai @@ -328,6 +330,7 @@ executable transcripts , unison-pretty-printer , unison-share-api , unison-util + , unison-util-base32hex , unison-util-relation , unliftio , wai @@ -424,6 +427,7 @@ executable unison , unison-pretty-printer , unison-share-api , unison-util + , unison-util-base32hex , unison-util-relation , unliftio , wai @@ -524,6 +528,7 @@ test-suite cli-tests , unison-pretty-printer , unison-share-api , unison-util + , unison-util-base32hex , unison-util-relation , unliftio , wai diff --git a/unison-core/package.yaml b/unison-core/package.yaml index 77738de834..3ae9322bb1 100644 --- a/unison-core/package.yaml +++ b/unison-core/package.yaml @@ -25,6 +25,7 @@ library: - transformers - unison-prelude - unison-util + - unison-util-base32hex - unison-util-relation - util - vector diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index 8739a9938e..8f29e98810 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -103,6 +103,7 @@ library , transformers , unison-prelude , unison-util + , unison-util-base32hex , unison-util-relation , util , vector From a2565618c23f423bc2e1a23bcd330d39032e1d53 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 15:54:48 -0400 Subject: [PATCH 103/529] use Base32Hex in unison-share-api --- unison-cli/src/Unison/Share/Sync.hs | 18 +++++++----------- unison-share-api/package.yaml | 13 +++++++------ unison-share-api/src/Unison/Sync/Types.hs | 5 +++-- unison-share-api/unison-share-api.cabal | 1 + 4 files changed, 18 insertions(+), 19 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 7c85d21cf6..649c922081 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -30,7 +30,6 @@ import U.Codebase.Sqlite.TempEntity (TempEntity) import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Util.Base32Hex (Base32Hex) -import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as Hash import Unison.Prelude import qualified Unison.Sync.Types as Share @@ -92,7 +91,6 @@ push conn repoPath expectedHash causalHash = do causalHash & unCausalHash & Hash.toBase32Hex - & Base32Hex.toText & Share.Hash, entityType = Share.CausalType } @@ -158,7 +156,7 @@ decodeHashJWT = undefined hashJWTHash :: Share.HashJWT -> Base32Hex hashJWTHash = - Base32Hex.UnsafeFromText . Share.toBase32Hex . decodedHashJWTHash . decodeHashJWT + Share.toBase32Hex . decodedHashJWTHash . decodeHashJWT -- Download a set of entities from Unison Share. download :: Connection -> Share.RepoName -> NESet Share.HashJWT -> IO () @@ -168,12 +166,12 @@ download conn repoName = do let inMainStorage :: Share.Hash -> IO Bool inMainStorage (Share.Hash b32) = runDB do -- first get hashId if exists - Q.loadHashId (Base32Hex.UnsafeFromText b32) >>= \case + Q.loadHashId b32 >>= \case Nothing -> pure False -- then check if is causal hash or if object exists for hash id Just hashId -> Q.isCausalHash hashId ||^ Q.isObjectHash hashId let inTempStorage :: Share.Hash -> IO Bool - inTempStorage (Share.Hash b32) = runDB $ Q.tempEntityExists (Base32Hex.UnsafeFromText b32) + inTempStorage (Share.Hash b32) = runDB $ Q.tempEntityExists b32 let directDepsOfEntity :: Share.Entity Text Share.Hash Share.HashJWT -> Set Share.DecodedHashJWT directDepsOfEntity = Set.map decodeHashJWT . \case @@ -193,7 +191,7 @@ download conn repoName = do let directDepsOfHash :: Share.Hash -> IO (Set Share.DecodedHashJWT) directDepsOfHash (Share.Hash b32) = do - maybeJwts <- runDB (Q.getMissingDependencyJwtsForTempEntity (Base32Hex.UnsafeFromText b32)) + maybeJwts <- runDB (Q.getMissingDependencyJwtsForTempEntity b32) let decode = decodeHashJWT . Share.HashJWT pure (maybe Set.empty (Set.map decode . NESet.toSet) maybeJwts) let loop :: NESet Share.DecodedHashJWT -> IO () @@ -236,7 +234,7 @@ download conn repoName = do inMainStorage hash >>= \case True -> pure Set.empty False -> - runDB (Q.getMissingDependencyJwtsForTempEntity (Base32Hex.UnsafeFromText (Share.toBase32Hex hash))) >>= \case + runDB (Q.getMissingDependencyJwtsForTempEntity (Share.toBase32Hex hash)) >>= \case Just missingDependencies -> -- already in temp storage, due to missing dependencies pure (Set.map (decodeHashJWT . Share.HashJWT) (NESet.toSet missingDependencies)) @@ -250,13 +248,11 @@ download conn repoName = do Just missingDependencies -> runDB do Q.insertTempEntity - (Base32Hex.UnsafeFromText $ Share.toBase32Hex hash) + (Share.toBase32Hex hash) (makeTempEntity entity) ( NESet.map ( \Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}, hashJWT} -> - ( Base32Hex.UnsafeFromText $ Share.toBase32Hex hash, - Share.unHashJWT hashJWT - ) + (Share.toBase32Hex hash, Share.unHashJWT hashJWT) ) missingDependencies ) diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index cfa0c24516..2f08e0c8d5 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -6,17 +6,18 @@ library: source-dirs: src dependencies: + - aeson - base + - bytestring + - containers + - memory - mtl + - nonempty-containers + - servant - text - transformers + - unison-util-base32hex - unliftio - - servant - - containers - - nonempty-containers - - bytestring - - aeson - - memory ghc-options: -Wall diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index e117a77ae8..ffb9d6f1b0 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -17,6 +17,7 @@ import Data.Set (Set) import Data.Set.NonEmpty (NESet) import Data.Text (Text) import qualified Data.Text.Encoding as Text +import U.Util.Base32Hex (Base32Hex (..)) -- | A newtype for JSON encoding binary data. newtype Base64Bytes = Base64Bytes ByteString @@ -59,8 +60,8 @@ instance FromJSON HashJWTClaims where entityType <- obj .: "t" pure HashJWTClaims {..} -newtype Hash = Hash {toBase32Hex :: Text} - deriving newtype (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey) +newtype Hash = Hash {toBase32Hex :: Base32Hex} + deriving (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey) via (Text) data TypedHash = TypedHash { hash :: Hash, diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index 0cb38677fb..e80eeff4a2 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -60,5 +60,6 @@ library , servant , text , transformers + , unison-util-base32hex , unliftio default-language: Haskell2010 From 70ff3105bb22a48168933698013473f1b47c0e58 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 16:12:46 -0400 Subject: [PATCH 104/529] cleanup/refactoring --- unison-cli/src/Unison/Share/Sync.hs | 179 ++++++++++++++++------------ 1 file changed, 106 insertions(+), 73 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 649c922081..10417c7139 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -163,15 +163,6 @@ download :: Connection -> Share.RepoName -> NESet Share.HashJWT -> IO () download conn repoName = do let runDB :: ReaderT Connection IO a -> IO a runDB action = runReaderT action conn - let inMainStorage :: Share.Hash -> IO Bool - inMainStorage (Share.Hash b32) = runDB do - -- first get hashId if exists - Q.loadHashId b32 >>= \case - Nothing -> pure False - -- then check if is causal hash or if object exists for hash id - Just hashId -> Q.isCausalHash hashId ||^ Q.isObjectHash hashId - let inTempStorage :: Share.Hash -> IO Bool - inTempStorage (Share.Hash b32) = runDB $ Q.tempEntityExists b32 let directDepsOfEntity :: Share.Entity Text Share.Hash Share.HashJWT -> Set Share.DecodedHashJWT directDepsOfEntity = Set.map decodeHashJWT . \case @@ -189,33 +180,9 @@ download conn repoName = do directDepsOfEntity2 = Lens.setOf (typed @Share.HashJWT) -} - let directDepsOfHash :: Share.Hash -> IO (Set Share.DecodedHashJWT) - directDepsOfHash (Share.Hash b32) = do - maybeJwts <- runDB (Q.getMissingDependencyJwtsForTempEntity b32) - let decode = decodeHashJWT . Share.HashJWT - pure (maybe Set.empty (Set.map decode . NESet.toSet) maybeJwts) let loop :: NESet Share.DecodedHashJWT -> IO () loop hashes0 = do - let elaborateHashes :: Set Share.DecodedHashJWT -> Set Share.HashJWT -> IO (Maybe (NESet Share.HashJWT)) - elaborateHashes hashes outputs = - case Set.minView hashes of - Nothing -> pure (NESet.nonEmptySet outputs) - Just (Share.DecodedHashJWT (Share.HashJWTClaims {hash}) jwt, hashes') -> - inMainStorage hash >>= \case - False -> - inTempStorage hash >>= \case - False -> - -- we need the entity, it's not in main or temp storage - elaborateHashes hashes' (Set.insert jwt outputs) - True -> do - -- entity already in temp storage - deps <- directDepsOfHash hash - elaborateHashes (Set.union deps hashes') outputs - True -> - -- hash already in main storage - elaborateHashes hashes' outputs - - elaborateHashes (NESet.toSet hashes0) Set.empty >>= \case + runDB (elaborateHashes (NESet.toSet hashes0) Set.empty) >>= \case Nothing -> pure () Just hashes1 -> do Share.DownloadEntitiesResponse entities <- @@ -226,37 +193,26 @@ download conn repoName = do } missingDependencies0 <- - NEMap.toList entities & foldMapM \(hash, entity) -> do - let putInMainStorage :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> IO () - putInMainStorage _hash _entity = undefined - - -- still trying to figure out missing dependencies of hash/entity. - inMainStorage hash >>= \case - True -> pure Set.empty - False -> - runDB (Q.getMissingDependencyJwtsForTempEntity (Share.toBase32Hex hash)) >>= \case - Just missingDependencies -> - -- already in temp storage, due to missing dependencies - pure (Set.map (decodeHashJWT . Share.HashJWT) (NESet.toSet missingDependencies)) - Nothing -> do - -- not in temp storage. - -- if it has missing dependencies, add it to temp storage; - -- otherwise add it to main storage. - missingDependencies0 <- Set.filterM (inMainStorage . decodedHashJWTHash) (directDepsOfEntity entity) - case NESet.nonEmptySet missingDependencies0 of - Nothing -> putInMainStorage hash entity - Just missingDependencies -> - runDB do - Q.insertTempEntity - (Share.toBase32Hex hash) - (makeTempEntity entity) - ( NESet.map - ( \Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}, hashJWT} -> - (Share.toBase32Hex hash, Share.unHashJWT hashJWT) - ) - missingDependencies - ) - pure missingDependencies0 + runDB do + NEMap.toList entities & foldMapM \(hash, entity) -> do + -- still trying to figure out missing dependencies of hash/entity. + entityExists hash >>= \case + True -> pure Set.empty + False -> + Q.getMissingDependencyJwtsForTempEntity (Share.toBase32Hex hash) >>= \case + Just missingDependencies -> + -- already in temp storage, due to missing dependencies + pure (Set.map (decodeHashJWT . Share.HashJWT) (NESet.toSet missingDependencies)) + Nothing -> do + -- not in temp storage. + -- if it has missing dependencies, add it to temp storage; + -- otherwise add it to main storage. + missingDependencies0 <- + Set.filterM (entityExists . decodedHashJWTHash) (directDepsOfEntity entity) + case NESet.nonEmptySet missingDependencies0 of + Nothing -> insertEntity hash entity + Just missingDependencies -> insertTempEntity hash entity missingDependencies + pure missingDependencies0 case NESet.nonEmptySet missingDependencies0 of Nothing -> pure () @@ -416,14 +372,6 @@ _downloadEntities = undefined _uploadEntities :: Share.UploadEntitiesRequest -> IO UploadEntitiesResponse _uploadEntities = undefined -makeTempEntity :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity -makeTempEntity e = case e of - Share.TC _ -> undefined -- (TempEntity.TC _) - Share.DC _ -> undefined -- (TempEntity.DC _) - Share.P _ -> undefined -- (TempEntity.P _) - Share.N _ -> undefined -- (TempEntity.N _) - Share.C _ -> undefined -- (TempEntity.C _) - -- have to convert from Entity format to TempEntity format (`makeTempEntity` on 414) -- also have to convert from TempEntity format to Sync format โ€”ย this means exchanging Text for TextId and `Base32Hex`es for `HashId`s and/or `ObjectId`s @@ -464,3 +412,88 @@ tempToSyncCausal = do -- Q.saveCausalHash :: DB m => CausalHash -> m CausalHashId -- only affects `hash` table -- Q.saveCausal :: DB m => CausalHashId -> BranchHashId -> m () -- Q.saveCausalParents :: DB m => CausalHashId -> [CausalHashId] -> m () + +------------------------------------------------------------------------------------------------------------------------ +-- Database operations + +-- | Where is an entity stored? +data EntityLocation + = -- | `object` / `causal` + EntityInMainStorage + | -- | `temp_entity` + EntityInTempStorage + | -- | Nowhere + EntityNotStored + +-- | Does this entity already exist in the database, i.e. in the `object` or `causal` table? +entityExists :: Q.DB m => Share.Hash -> m Bool +entityExists (Share.Hash b32) = do + -- first get hashId if exists + Q.loadHashId b32 >>= \case + Nothing -> pure False + -- then check if is causal hash or if object exists for hash id + Just hashId -> Q.isCausalHash hashId ||^ Q.isObjectHash hashId + +-- | Does this entity already exist in the `temp_entity` table? +tempEntityExists :: Q.DB m => Share.Hash -> m Bool +tempEntityExists (Share.Hash b32) = + Q.tempEntityExists b32 + +-- | Where is an entity stored? +entityLocation :: Q.DB m => Share.Hash -> m EntityLocation +entityLocation hash = + entityExists hash >>= \case + True -> pure EntityInMainStorage + False -> + tempEntityExists hash >>= \case + True -> pure EntityInTempStorage + False -> pure EntityNotStored + +-- FIXME comment +elaborateHashes :: forall m. Q.DB m => Set Share.DecodedHashJWT -> Set Share.HashJWT -> m (Maybe (NESet Share.HashJWT)) +elaborateHashes hashes outputs = + case Set.minView hashes of + Nothing -> pure (NESet.nonEmptySet outputs) + Just (Share.DecodedHashJWT (Share.HashJWTClaims {hash}) jwt, hashes') -> + entityLocation hash >>= \case + EntityNotStored -> elaborateHashes hashes' (Set.insert jwt outputs) + EntityInTempStorage -> do + deps <- directDepsOfHash hash + elaborateHashes (Set.union deps hashes') outputs + EntityInMainStorage -> elaborateHashes hashes' outputs + where + directDepsOfHash :: Share.Hash -> m (Set Share.DecodedHashJWT) + directDepsOfHash (Share.Hash b32) = do + maybeJwts <- Q.getMissingDependencyJwtsForTempEntity b32 + let decode = decodeHashJWT . Share.HashJWT + pure (maybe Set.empty (Set.map decode . NESet.toSet) maybeJwts) + +insertEntity :: Q.DB m => Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> m () +insertEntity _hash = undefined + +-- | Insert an entity and its missing dependencies. +insertTempEntity :: + Q.DB m => + Share.Hash -> + Share.Entity Text Share.Hash Share.HashJWT -> + NESet Share.DecodedHashJWT -> + m () +insertTempEntity hash entity missingDependencies = + Q.insertTempEntity + (Share.toBase32Hex hash) + tempEntity + ( NESet.map + ( \Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}, hashJWT} -> + (Share.toBase32Hex hash, Share.unHashJWT hashJWT) + ) + missingDependencies + ) + where + tempEntity :: TempEntity + tempEntity = + case entity of + Share.TC _ -> undefined -- (TempEntity.TC _) + Share.DC _ -> undefined -- (TempEntity.DC _) + Share.P _ -> undefined -- (TempEntity.P _) + Share.N _ -> undefined -- (TempEntity.N _) + Share.C _ -> undefined -- (TempEntity.C _) From dc26b0bb569e8a654935c3ba110c9a2fdb8543b9 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 16:22:04 -0400 Subject: [PATCH 105/529] begin implementing entityToTempEntity --- unison-cli/package.yaml | 41 +++++++++++++++-------------- unison-cli/src/Unison/Share/Sync.hs | 32 +++++++++++++++------- unison-cli/unison-cli.cabal | 5 ++++ 3 files changed, 49 insertions(+), 29 deletions(-) diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index d6c786f932..b7265c4383 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -10,58 +10,59 @@ flags: ghc-options: -Wall dependencies: - - semialign - - these - ListLike + - aeson - async - base - bytes - bytestring - configurator - containers >= 0.6.3 - - nonempty-containers - cryptonite - directory + - either - errors - extra - filepath - generic-lens - haskeline + - http-client >= 0.7.6 + - http-client-tls + - http-types + - jwt - lens + - lock-file - megaparsec >= 5.0.0 && < 7.0.0 + - memory - mtl - - transformers + - network-uri + - nonempty-containers - open-browser - random >= 1.2.0 - regex-tdfa + - semialign + - servant + - servant-client - stm - text + - these + - time + - transformers - unison-codebase - unison-codebase-sqlite - unison-core1 - unison-parser-typechecker - unison-prelude + - unison-pretty-printer + - unison-share-api + - unison-share-api - unison-util - unison-util-base32hex - unison-util-relation - - unison-pretty-printer - - unison-share-api - unliftio - - network-uri - - aeson - - http-client >= 0.7.6 - - http-client-tls - - http-types - - warp + - vector - wai - - memory - - time - - lock-file - - jwt - - either - - unison-share-api - - servant-client - - servant + - warp library: source-dirs: src diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 10417c7139..e19c787c4c 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -18,12 +18,14 @@ import qualified Data.Map.NonEmpty as NEMap import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet +import qualified Data.Vector as Vector import U.Codebase.HashTags (CausalHash (unCausalHash)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import qualified U.Codebase.Sqlite.Causal as Causal import U.Codebase.Sqlite.Connection (Connection) import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId, HashId, ObjectId) import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat +import U.Codebase.Sqlite.LocalIds (LocalIds' (..)) import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat import qualified U.Codebase.Sqlite.Queries as Q import U.Codebase.Sqlite.TempEntity (TempEntity) @@ -481,19 +483,31 @@ insertTempEntity :: insertTempEntity hash entity missingDependencies = Q.insertTempEntity (Share.toBase32Hex hash) - tempEntity + (entityToTempEntity entity) ( NESet.map ( \Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}, hashJWT} -> (Share.toBase32Hex hash, Share.unHashJWT hashJWT) ) missingDependencies ) + +entityToTempEntity :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity +entityToTempEntity = \case + Share.TC (Share.TermComponent terms) -> + terms + & Vector.fromList + & Vector.map (Lens.over Lens._1 mungeLocalIds) + & TermFormat.SyncLocallyIndexedComponent + & TermFormat.SyncTerm + & TempEntity.TC + Share.DC _ -> undefined -- (TempEntity.DC _) + Share.P _ -> undefined -- (TempEntity.P _) + Share.N _ -> undefined -- (TempEntity.N _) + Share.C _ -> undefined -- (TempEntity.C _) where - tempEntity :: TempEntity - tempEntity = - case entity of - Share.TC _ -> undefined -- (TempEntity.TC _) - Share.DC _ -> undefined -- (TempEntity.DC _) - Share.P _ -> undefined -- (TempEntity.P _) - Share.N _ -> undefined -- (TempEntity.N _) - Share.C _ -> undefined -- (TempEntity.C _) + mungeLocalIds :: Share.LocalIds Text Share.HashJWT -> LocalIds' Text TempEntity.HashJWT + mungeLocalIds Share.LocalIds {texts, hashes} = + LocalIds + { textLookup = Vector.fromList texts, + defnLookup = Vector.map Share.unHashJWT (Vector.fromList hashes) + } diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index fb922643c0..0dae253810 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -142,6 +142,7 @@ library , unison-util-base32hex , unison-util-relation , unliftio + , vector , wai , warp if flag(optimized) @@ -240,6 +241,7 @@ executable cli-integration-tests , unison-util-base32hex , unison-util-relation , unliftio + , vector , wai , warp if flag(optimized) @@ -333,6 +335,7 @@ executable transcripts , unison-util-base32hex , unison-util-relation , unliftio + , vector , wai , warp if flag(optimized) @@ -430,6 +433,7 @@ executable unison , unison-util-base32hex , unison-util-relation , unliftio + , vector , wai , warp if flag(optimized) @@ -531,6 +535,7 @@ test-suite cli-tests , unison-util-base32hex , unison-util-relation , unliftio + , vector , wai , warp if flag(optimized) From 9715b1149f4dabec41c56b08d3c9573a2feb2887 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 16:32:56 -0400 Subject: [PATCH 106/529] fill out most of entityToTempEntity --- unison-cli/src/Unison/Share/Sync.hs | 40 ++++++++++++++++++++++++++--- 1 file changed, 36 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index e19c787c4c..c2c29172e0 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -491,6 +491,7 @@ insertTempEntity hash entity missingDependencies = missingDependencies ) +-- FIXME mitchell says: working on this again made me wonder whether formats (e.g. patch diff) should be in the API entityToTempEntity :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity entityToTempEntity = \case Share.TC (Share.TermComponent terms) -> @@ -500,10 +501,41 @@ entityToTempEntity = \case & TermFormat.SyncLocallyIndexedComponent & TermFormat.SyncTerm & TempEntity.TC - Share.DC _ -> undefined -- (TempEntity.DC _) - Share.P _ -> undefined -- (TempEntity.P _) - Share.N _ -> undefined -- (TempEntity.N _) - Share.C _ -> undefined -- (TempEntity.C _) + Share.DC (Share.DeclComponent decls) -> + decls + & Vector.fromList + & Vector.map (Lens.over Lens._1 mungeLocalIds) + & DeclFormat.SyncLocallyIndexedComponent + & DeclFormat.SyncDecl + & TempEntity.DC + Share.P Share.Patch {textLookup, oldHashLookup, newHashLookup, bytes} -> + TempEntity.P + ( PatchFormat.SyncFull + PatchFormat.LocalIds + { patchTextLookup = Vector.fromList textLookup, + patchHashLookup = Vector.fromList (coerce @[Share.Hash] @[Base32Hex] oldHashLookup), + patchDefnLookup = Vector.fromList (coerce @[Share.HashJWT] @[TempEntity.HashJWT] newHashLookup) + } + bytes + ) + Share.N Share.Namespace {textLookup, defnLookup, patchLookup, childLookup, bytes} -> + TempEntity.N + ( NamespaceFormat.SyncFull + NamespaceFormat.LocalIds + { branchTextLookup = Vector.fromList textLookup, + branchDefnLookup = Vector.fromList (coerce @[Share.HashJWT] @[TempEntity.HashJWT] defnLookup), + branchPatchLookup = Vector.fromList (coerce @[Share.HashJWT] @[TempEntity.HashJWT] patchLookup), + -- FIXME need values hashes in API type + branchChildLookup = undefined childLookup + } + bytes + ) + Share.C Share.Causal {namespaceHash, parents} -> + TempEntity.C + Causal.SyncCausalFormat + { valueHash = coerce @Share.HashJWT @TempEntity.HashJWT namespaceHash, + parents = Vector.fromList (coerce @[Share.HashJWT] @[TempEntity.HashJWT] (Set.toList parents)) + } where mungeLocalIds :: Share.LocalIds Text Share.HashJWT -> LocalIds' Text TempEntity.HashJWT mungeLocalIds Share.LocalIds {texts, hashes} = From c8cd5c4ce5ccfaf050528e3ffe6c0f78c5bba4d8 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 12 Apr 2022 18:16:17 -0500 Subject: [PATCH 107/529] added value hash to api type --- unison-cli/src/Unison/Share/Sync.hs | 7 ++++--- unison-share-api/src/Unison/Sync/Types.hs | 4 ++-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index c2c29172e0..8ffa4d2d9c 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -13,6 +13,7 @@ import qualified Control.Lens as Lens import Control.Monad.Extra ((||^)) import Control.Monad.Reader (ReaderT, runReaderT) import Data.Bitraversable (bitraverse) +import qualified Data.Foldable as Foldable import qualified Data.List.NonEmpty as List.NonEmpty import qualified Data.Map.NonEmpty as NEMap import qualified Data.Set as Set @@ -175,7 +176,8 @@ download conn repoName = do Share.P (Share.Patch {newHashLookup}) -> Set.fromList newHashLookup Share.N (Share.Namespace {defnLookup, patchLookup, childLookup}) -> - Set.fromList defnLookup <> Set.fromList patchLookup <> Set.fromList childLookup + Set.fromList defnLookup <> Set.fromList patchLookup + <> Foldable.foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup Share.C (Share.Causal {parents}) -> parents {- let directDepsOfEntity2 :: Share.Entity Text Share.Hash Share.HashJWT -> Set Share.DecodedHashJWT @@ -525,8 +527,7 @@ entityToTempEntity = \case { branchTextLookup = Vector.fromList textLookup, branchDefnLookup = Vector.fromList (coerce @[Share.HashJWT] @[TempEntity.HashJWT] defnLookup), branchPatchLookup = Vector.fromList (coerce @[Share.HashJWT] @[TempEntity.HashJWT] patchLookup), - -- FIXME need values hashes in API type - branchChildLookup = undefined childLookup + branchChildLookup = Vector.fromList (coerce @[(Share.HashJWT, Share.HashJWT)] @[(TempEntity.HashJWT, TempEntity.HashJWT)] childLookup) } bytes ) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index ffb9d6f1b0..1253ebdb30 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -468,7 +468,7 @@ data Namespace text hash = Namespace { textLookup :: [text], defnLookup :: [hash], patchLookup :: [hash], - childLookup :: [hash], + childLookup :: [(hash, hash)], -- (namespace hash, causal hash) bytes :: ByteString } deriving stock (Eq, Ord, Show) @@ -485,7 +485,7 @@ instance Bitraversable Namespace where <$> traverse f tl <*> traverse g dl <*> traverse g pl - <*> traverse g cl + <*> traverse (bitraverse g g) cl <*> pure b instance (ToJSON text, ToJSON hash) => ToJSON (Namespace text hash) where From 62a1a60a818489459e99ea1ce7d379a53dccf1a3 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 20:43:36 -0400 Subject: [PATCH 108/529] use the real http update path --- unison-cli/src/Unison/Share/Sync.hs | 89 ++++++++++++----------------- 1 file changed, 36 insertions(+), 53 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 8ffa4d2d9c..bee6a22f07 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -20,6 +20,7 @@ import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import qualified Data.Vector as Vector +import Servant.Client (BaseUrl) import U.Codebase.HashTags (CausalHash (unCausalHash)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import qualified U.Codebase.Sqlite.Causal as Causal @@ -34,7 +35,9 @@ import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Hash as Hash +import Unison.Auth.HTTPClient (AuthorizedHttpClient) import Unison.Prelude +import qualified Unison.Sync.HTTP as Share (updatePathHandler) import qualified Unison.Sync.Types as Share import qualified Unison.Sync.Types as Share.LocalIds (LocalIds (..)) import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) @@ -67,6 +70,10 @@ data PushError -- | Push a causal to Unison Share. push :: + -- | The HTTP client to use for Unison Share requests. + AuthorizedHttpClient -> + -- | The Unison Share URL. + BaseUrl -> -- | SQLite connection, for reading entities to push. Connection -> -- | The repo+path to push to. @@ -77,9 +84,33 @@ push :: -- | The hash of our local causal to push. CausalHash -> IO (Either PushError ()) -push conn repoPath expectedHash causalHash = do - let theUpdatePathRequest :: Share.UpdatePathRequest - theUpdatePathRequest = +push httpClient unisonShareUrl conn repoPath expectedHash causalHash = do + -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs + -- this causal (UpdatePathMissingDependencies). + updatePath >>= \case + Share.UpdatePathSuccess -> pure (Right ()) + Share.UpdatePathHashMismatch mismatch -> pure (Left (PushErrorHashMismatch mismatch)) + Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do + -- Upload the causal and all of its dependencies. + upload conn (Share.RepoPath.repoName repoPath) dependencies + + -- After uploading the causal and all of its dependencies, try setting the remote path again. + updatePath <&> \case + Share.UpdatePathSuccess -> Right () + -- Between the initial updatePath attempt and this one, someone else managed to update the path. That's ok; we + -- still managed to upload our causal, but the push has indeed failed overall. + Share.UpdatePathHashMismatch mismatch -> Left (PushErrorHashMismatch mismatch) + -- Unexpected, but possible: we thought we uploaded all we needed to, yet the server still won't accept our + -- causal. Bug in the client because we didn't upload enough? Bug in the server because we weren't told to + -- upload some dependency? Who knows. + Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> + Left (PushErrorServerMissingDependencies dependencies) + where + updatePath :: IO Share.UpdatePathResponse + updatePath = + Share.updatePathHandler + httpClient + unisonShareUrl Share.UpdatePathRequest { path = repoPath, expectedHash = @@ -99,27 +130,6 @@ push conn repoPath expectedHash causalHash = do } } - -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs - -- this causal (UpdatePathMissingDependencies). - _updatePath theUpdatePathRequest >>= \case - UpdatePathSuccess -> pure (Right ()) - UpdatePathHashMismatch mismatch -> pure (Left (PushErrorHashMismatch mismatch)) - UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do - -- Upload the causal and all of its dependencies. - upload conn (Share.RepoPath.repoName repoPath) dependencies - - -- After uploading the causal and all of its dependencies, try setting the remote path again. - _updatePath theUpdatePathRequest <&> \case - UpdatePathSuccess -> Right () - -- Between the initial updatePath attempt and this one, someone else managed to update the path. That's ok; we - -- still managed to upload our causal, but the push has indeed failed overall. - UpdatePathHashMismatch mismatch -> Left (PushErrorHashMismatch mismatch) - -- Unexpected, but possible: we thought we uploaded all we needed to, yet the server still won't accept our - -- causal. Bug in the client because we didn't upload enough? Bug in the server because we weren't told to - -- upload some dependency? Who knows. - UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> - Left (PushErrorServerMissingDependencies dependencies) - -- Upload a set of entities to Unison Share. If the server responds that it cannot yet store any hash(es) due to missing -- dependencies, send those dependencies too, and on and on, until the server stops responding that it's missing -- anything. @@ -322,26 +332,6 @@ data UploadEntitiesResponse data PullError --- Option 1: have push be itself in the Transaction monad, use unsafePerformIdempotentIO --- fuction to do the interleaved IO calls (http, etc) --- --- push :: RepoPath -> ... -> Transaction (Either PushError ()) --- push = do --- unsafePerformIdempotentIO (updatePath ...) --- --- Option 2: have push "go around" the Transaction abstraction by beginning/commiting explicitly, --- and immediately un-Transaction-newtyping the low-level calls like loadHashId --- --- push :: Connection -> RepoPath -> ... -> IO (Either PushError ()) --- push conn = do --- let foo transaction = unsafeUnTransaction transaction conn --- --- ... --- result <- foo (loadHashId hashId) --- ... --- --- newtype Transaction a = Transaction { unsafeUnTransaction :: Connection -> IO a } - type Transaction a = () expectHash :: HashId -> Transaction Hash.Hash @@ -359,17 +349,9 @@ data GetCausalHashByPathResponse | GetCausalHashByPathEmpty | GetCausalHashByPathNoReadPermission -data UpdatePathResponse - = UpdatePathSuccess - | UpdatePathHashMismatch Share.HashMismatch - | UpdatePathMissingDependencies (Share.NeedDependencies Share.Hash) - _getCausalHashByPath :: Share.GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse _getCausalHashByPath = undefined -_updatePath :: Share.UpdatePathRequest -> IO UpdatePathResponse -_updatePath = undefined - _downloadEntities :: Share.DownloadEntitiesRequest -> IO Share.DownloadEntitiesResponse _downloadEntities = undefined @@ -493,7 +475,8 @@ insertTempEntity hash entity missingDependencies = missingDependencies ) --- FIXME mitchell says: working on this again made me wonder whether formats (e.g. patch diff) should be in the API +-- | Convert an entity that came over the wire from Unison Share into an equivalent type that we can store in the +-- `temp_entity` table. entityToTempEntity :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity entityToTempEntity = \case Share.TC (Share.TermComponent terms) -> From ca41818517349f1f3516c23661894898e381231c Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 20:46:38 -0400 Subject: [PATCH 109/529] uploadEntities --- unison-cli/src/Unison/Share/Sync.hs | 42 +++++++++++++++-------------- 1 file changed, 22 insertions(+), 20 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index bee6a22f07..eba87e7bf2 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -37,7 +37,7 @@ import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Hash as Hash import Unison.Auth.HTTPClient (AuthorizedHttpClient) import Unison.Prelude -import qualified Unison.Sync.HTTP as Share (updatePathHandler) +import qualified Unison.Sync.HTTP as Share (updatePathHandler, uploadEntitiesHandler) import qualified Unison.Sync.Types as Share import qualified Unison.Sync.Types as Share.LocalIds (LocalIds (..)) import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) @@ -92,7 +92,7 @@ push httpClient unisonShareUrl conn repoPath expectedHash causalHash = do Share.UpdatePathHashMismatch mismatch -> pure (Left (PushErrorHashMismatch mismatch)) Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do -- Upload the causal and all of its dependencies. - upload conn (Share.RepoPath.repoName repoPath) dependencies + upload httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) dependencies -- After uploading the causal and all of its dependencies, try setting the remote path again. updatePath <&> \case @@ -133,8 +133,14 @@ push httpClient unisonShareUrl conn repoPath expectedHash causalHash = do -- Upload a set of entities to Unison Share. If the server responds that it cannot yet store any hash(es) due to missing -- dependencies, send those dependencies too, and on and on, until the server stops responding that it's missing -- anything. -upload :: Connection -> Share.RepoName -> NESet Share.Hash -> IO () -upload conn repoName = +upload :: + AuthorizedHttpClient -> + BaseUrl -> + Connection -> + Share.RepoName -> + NESet Share.Hash -> + IO () +upload httpClient unisonShareUrl conn repoName = loop where loop :: NESet Share.Hash -> IO () @@ -142,18 +148,21 @@ upload conn repoName = -- Get each entity that the server is missing out of the database. entities <- traverse (resolveHashToEntity conn) hashes - let theUploadEntitiesRequest :: Share.UploadEntitiesRequest - theUploadEntitiesRequest = - Share.UploadEntitiesRequest - { entities = NEMap.fromAscList (List.NonEmpty.zip hashes entities), - repoName - } + let uploadEntities :: IO Share.UploadEntitiesResponse + uploadEntities = + Share.uploadEntitiesHandler + httpClient + unisonShareUrl + Share.UploadEntitiesRequest + { entities = NEMap.fromAscList (List.NonEmpty.zip hashes entities), + repoName + } -- Upload all of the entities we know the server needs, and if the server responds that it needs yet more, loop to -- upload those too. - _uploadEntities theUploadEntitiesRequest >>= \case - UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> loop moreHashes - UploadEntitiesSuccess -> pure () + uploadEntities >>= \case + Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> loop moreHashes + Share.UploadEntitiesSuccess -> pure () ------------------------------------------------------------------------------------------------------------------------ -- Pull @@ -326,10 +335,6 @@ server sqlite db ------------------------------------------------------------------------------------------------------------------------ -- -data UploadEntitiesResponse - = UploadEntitiesSuccess - | UploadEntitiesNeedDependencies (Share.NeedDependencies Share.Hash) - data PullError type Transaction a = () @@ -355,9 +360,6 @@ _getCausalHashByPath = undefined _downloadEntities :: Share.DownloadEntitiesRequest -> IO Share.DownloadEntitiesResponse _downloadEntities = undefined -_uploadEntities :: Share.UploadEntitiesRequest -> IO UploadEntitiesResponse -_uploadEntities = undefined - -- have to convert from Entity format to TempEntity format (`makeTempEntity` on 414) -- also have to convert from TempEntity format to Sync format โ€”ย this means exchanging Text for TextId and `Base32Hex`es for `HashId`s and/or `ObjectId`s From abd67c6c134998f9a7b5c490860b14f39effe6a6 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 21:27:10 -0400 Subject: [PATCH 110/529] move some code around and add docs --- unison-cli/src/Unison/Share/Sync.hs | 61 +++++++++-------------- unison-share-api/src/Unison/Sync/Types.hs | 30 +++++++++++ 2 files changed, 53 insertions(+), 38 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index eba87e7bf2..f5340fc091 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -13,7 +13,6 @@ import qualified Control.Lens as Lens import Control.Monad.Extra ((||^)) import Control.Monad.Reader (ReaderT, runReaderT) import Data.Bitraversable (bitraverse) -import qualified Data.Foldable as Foldable import qualified Data.List.NonEmpty as List.NonEmpty import qualified Data.Map.NonEmpty as NEMap import qualified Data.Set as Set @@ -34,12 +33,12 @@ import U.Codebase.Sqlite.TempEntity (TempEntity) import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Util.Base32Hex (Base32Hex) +import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash import Unison.Auth.HTTPClient (AuthorizedHttpClient) import Unison.Prelude import qualified Unison.Sync.HTTP as Share (updatePathHandler, uploadEntitiesHandler) import qualified Unison.Sync.Types as Share -import qualified Unison.Sync.Types as Share.LocalIds (LocalIds (..)) import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set @@ -167,41 +166,23 @@ upload httpClient unisonShareUrl conn repoName = ------------------------------------------------------------------------------------------------------------------------ -- Pull -pull :: Connection -> Share.RepoPath -> IO (Either PullError CausalHash) -pull _conn _repoPath = undefined - -decodedHashJWTHash :: Share.DecodedHashJWT -> Share.Hash -decodedHashJWTHash = undefined - -decodeHashJWT :: Share.HashJWT -> Share.DecodedHashJWT -decodeHashJWT = undefined - -hashJWTHash :: Share.HashJWT -> Base32Hex -hashJWTHash = - Share.toBase32Hex . decodedHashJWTHash . decodeHashJWT +pull :: + -- | The HTTP client to use for Unison Share requests. + AuthorizedHttpClient -> + -- | The Unison Share URL. + BaseUrl -> + -- | SQLite connection, for storing entities we pull. + Connection -> + -- | The repo+path to pull from. + Share.RepoPath -> + IO (Either PullError CausalHash) +pull httpClient unisonShareUrl _conn _repoPath = undefined -- Download a set of entities from Unison Share. download :: Connection -> Share.RepoName -> NESet Share.HashJWT -> IO () download conn repoName = do let runDB :: ReaderT Connection IO a -> IO a runDB action = runReaderT action conn - let directDepsOfEntity :: Share.Entity Text Share.Hash Share.HashJWT -> Set Share.DecodedHashJWT - directDepsOfEntity = - Set.map decodeHashJWT . \case - Share.TC (Share.TermComponent terms) -> flip foldMap terms \(localIds, _term) -> - Set.fromList (Share.LocalIds.hashes localIds) - Share.DC (Share.DeclComponent terms) -> flip foldMap terms \(localIds, _term) -> - Set.fromList (Share.LocalIds.hashes localIds) - Share.P (Share.Patch {newHashLookup}) -> - Set.fromList newHashLookup - Share.N (Share.Namespace {defnLookup, patchLookup, childLookup}) -> - Set.fromList defnLookup <> Set.fromList patchLookup - <> Foldable.foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup - Share.C (Share.Causal {parents}) -> parents - {- - let directDepsOfEntity2 :: Share.Entity Text Share.Hash Share.HashJWT -> Set Share.DecodedHashJWT - directDepsOfEntity2 = - Lens.setOf (typed @Share.HashJWT) -} let loop :: NESet Share.DecodedHashJWT -> IO () loop hashes0 = do @@ -225,13 +206,15 @@ download conn repoName = do Q.getMissingDependencyJwtsForTempEntity (Share.toBase32Hex hash) >>= \case Just missingDependencies -> -- already in temp storage, due to missing dependencies - pure (Set.map (decodeHashJWT . Share.HashJWT) (NESet.toSet missingDependencies)) + pure (Set.map (Share.decodeHashJWT . Share.HashJWT) (NESet.toSet missingDependencies)) Nothing -> do -- not in temp storage. -- if it has missing dependencies, add it to temp storage; -- otherwise add it to main storage. missingDependencies0 <- - Set.filterM (entityExists . decodedHashJWTHash) (directDepsOfEntity entity) + Set.filterM + (entityExists . Share.decodedHashJWTHash) + (Set.map Share.decodeHashJWT (Share.entityDependencies entity)) case NESet.nonEmptySet missingDependencies0 of Nothing -> insertEntity hash entity Just missingDependencies -> insertTempEntity hash entity missingDependencies @@ -240,7 +223,7 @@ download conn repoName = do case NESet.nonEmptySet missingDependencies0 of Nothing -> pure () Just missingDependencies -> loop missingDependencies - in loop . NESet.map decodeHashJWT + in loop . NESet.map Share.decodeHashJWT --------- @@ -372,9 +355,12 @@ tempToSyncTermComponent conn = expectObjectIdForHashJWT :: Q.DB m => TempEntity.HashJWT -> m ObjectId expectObjectIdForHashJWT hashJwt = do - hashId <- throwExceptT (Q.expectHashIdByHash (Hash.fromBase32Hex (hashJWTHash (Share.HashJWT hashJwt)))) - -- FIXME mitchell: should this be "for primary hash id" or "for any hash id"? + hashId <- throwExceptT (Q.expectHashIdByHash (decode hashJwt)) throwExceptT (Q.expectObjectIdForAnyHashId hashId) + where + decode :: TempEntity.HashJWT -> Hash + decode = + Hash.fromBase32Hex . Share.toBase32Hex . Share.hashJWTHash . Share.HashJWT -- Serialization.recomposeComponent :: MonadPut m => [(LocalIds, BS.ByteString)] -> m () -- Serialization.recomposePatchFormat :: MonadPut m => PatchFormat.SyncPatchFormat -> m () @@ -453,8 +439,7 @@ elaborateHashes hashes outputs = directDepsOfHash :: Share.Hash -> m (Set Share.DecodedHashJWT) directDepsOfHash (Share.Hash b32) = do maybeJwts <- Q.getMissingDependencyJwtsForTempEntity b32 - let decode = decodeHashJWT . Share.HashJWT - pure (maybe Set.empty (Set.map decode . NESet.toSet) maybeJwts) + pure (maybe Set.empty (Set.map (Share.decodeHashJWT . Share.HashJWT) . NESet.toSet) maybeJwts) insertEntity :: Q.DB m => Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> m () insertEntity _hash = undefined diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 1253ebdb30..72db4e32c7 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -14,6 +14,7 @@ import Data.ByteString (ByteString) import Data.Function ((&)) import Data.Map.NonEmpty (NEMap) import Data.Set (Set) +import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import Data.Text (Text) import qualified Data.Text.Encoding as Text @@ -35,12 +36,28 @@ newtype RepoName = RepoName Text newtype HashJWT = HashJWT {unHashJWT :: Text} deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) +-- | Grab the hash out of a hash JWT. +-- +-- This decodes the whole JWT, then throws away the claims; use it if you really only need the hash! +hashJWTHash :: HashJWT -> Hash +hashJWTHash = + decodedHashJWTHash . decodeHashJWT + +-- | A decoded hash JWT that retains the original encoded JWT. data DecodedHashJWT = DecodedHashJWT { claims :: HashJWTClaims, hashJWT :: HashJWT } deriving (Eq, Ord, Show) +-- | Decode a hash JWT. +decodeHashJWT :: HashJWT -> DecodedHashJWT +decodeHashJWT = undefined + +-- | Grab the hash out of a decoded hash JWT. +decodedHashJWTHash :: DecodedHashJWT -> Hash +decodedHashJWTHash = undefined + data HashJWTClaims = HashJWTClaims { hash :: Hash, entityType :: EntityType @@ -336,6 +353,19 @@ instance (FromJSON text, FromJSON noSyncHash, FromJSON hash, Ord hash) => FromJS NamespaceType -> N <$> obj .: "object" CausalType -> C <$> obj .: "object" +-- | Get the direct dependencies of an entity (which are actually sync'd). +-- +-- FIXME use generic-lens here? (typed @hash) +entityDependencies :: Ord hash => Entity text noSyncHash hash -> Set hash +entityDependencies = \case + TC (TermComponent terms) -> flip foldMap terms \(LocalIds {hashes}, _term) -> Set.fromList hashes + DC (DeclComponent decls) -> flip foldMap decls \(LocalIds {hashes}, _decl) -> Set.fromList hashes + P Patch {newHashLookup} -> Set.fromList newHashLookup + N Namespace {defnLookup, patchLookup, childLookup} -> + Set.fromList defnLookup <> Set.fromList patchLookup + <> foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup + C Causal {parents} -> parents + data TermComponent text hash = TermComponent [(LocalIds text hash, ByteString)] deriving stock (Show, Eq, Ord) From f6c6aa784feafb3be456bd3167e0d715483356a0 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 21:31:01 -0400 Subject: [PATCH 111/529] actually call downloadEntities --- unison-cli/src/Unison/Share/Sync.hs | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index f5340fc091..e8f5370265 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -37,7 +37,7 @@ import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash import Unison.Auth.HTTPClient (AuthorizedHttpClient) import Unison.Prelude -import qualified Unison.Sync.HTTP as Share (updatePathHandler, uploadEntitiesHandler) +import qualified Unison.Sync.HTTP as Share (downloadEntitiesHandler, updatePathHandler, uploadEntitiesHandler) import qualified Unison.Sync.Types as Share import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) import Unison.Util.Monoid (foldMapM) @@ -179,8 +179,14 @@ pull :: pull httpClient unisonShareUrl _conn _repoPath = undefined -- Download a set of entities from Unison Share. -download :: Connection -> Share.RepoName -> NESet Share.HashJWT -> IO () -download conn repoName = do +download :: + AuthorizedHttpClient -> + BaseUrl -> + Connection -> + Share.RepoName -> + NESet Share.HashJWT -> + IO () +download httpClient unisonShareUrl conn repoName = do let runDB :: ReaderT Connection IO a -> IO a runDB action = runReaderT action conn @@ -190,7 +196,9 @@ download conn repoName = do Nothing -> pure () Just hashes1 -> do Share.DownloadEntitiesResponse entities <- - _downloadEntities + Share.downloadEntitiesHandler + httpClient + unisonShareUrl Share.DownloadEntitiesRequest { repoName, hashes = hashes1 @@ -340,9 +348,6 @@ data GetCausalHashByPathResponse _getCausalHashByPath :: Share.GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse _getCausalHashByPath = undefined -_downloadEntities :: Share.DownloadEntitiesRequest -> IO Share.DownloadEntitiesResponse -_downloadEntities = undefined - -- have to convert from Entity format to TempEntity format (`makeTempEntity` on 414) -- also have to convert from TempEntity format to Sync format โ€”ย this means exchanging Text for TextId and `Base32Hex`es for `HashId`s and/or `ObjectId`s From 30e8c8b4a41ce4a5f99c4e05fb15fe33a548800b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 21:49:33 -0400 Subject: [PATCH 112/529] fill out pull --- unison-cli/src/Unison/Share/Sync.hs | 96 ++++++++++++++++++++--------- 1 file changed, 66 insertions(+), 30 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index e8f5370265..9642a666d3 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -6,6 +6,10 @@ module Unison.Share.Sync -- * Push push, PushError (..), + + -- * Pull + pull, + PullError (..), ) where @@ -20,11 +24,11 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import qualified Data.Vector as Vector import Servant.Client (BaseUrl) -import U.Codebase.HashTags (CausalHash (unCausalHash)) +import U.Codebase.HashTags (CausalHash (..)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import qualified U.Codebase.Sqlite.Causal as Causal import U.Codebase.Sqlite.Connection (Connection) -import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId, HashId, ObjectId) +import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId, ObjectId) import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat import U.Codebase.Sqlite.LocalIds (LocalIds' (..)) import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat @@ -166,6 +170,11 @@ upload httpClient unisonShareUrl conn repoName = ------------------------------------------------------------------------------------------------------------------------ -- Pull +-- | An error occurred while pulling code from Unison Share. +data PullError + = -- | An error occurred while resolving a repo+path to a causal hash. + PullErrorGetCausalHashByPath GetCausalHashByPathError + pull :: -- | The HTTP client to use for Unison Share requests. AuthorizedHttpClient -> @@ -175,8 +184,26 @@ pull :: Connection -> -- | The repo+path to pull from. Share.RepoPath -> - IO (Either PullError CausalHash) -pull httpClient unisonShareUrl _conn _repoPath = undefined + IO (Either PullError (Maybe CausalHash)) +pull httpClient unisonShareUrl conn repoPath = do + getCausalHashByPath repoPath >>= \case + Left err -> pure (Left (PullErrorGetCausalHashByPath err)) + -- There's nothing at the remote path, so there's no causal to pull. + Right Nothing -> pure (Right Nothing) + Right (Just hashJwt) -> do + let hash = Share.hashJWTHash hashJwt + let success = pure (Right (Just (CausalHash (Hash.fromBase32Hex (Share.toBase32Hex hash))))) + runDB (entityLocation2 hash) >>= \case + EntityInMainStorage2 -> success + EntityInTempStorage2 missingDependencies -> do + download httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) missingDependencies + success + EntityNotStored2 -> do + download httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) (NESet.singleton hashJwt) + success + where + runDB :: ReaderT Connection IO a -> IO a + runDB action = runReaderT action conn -- Download a set of entities from Unison Share. download :: @@ -184,6 +211,7 @@ download :: BaseUrl -> Connection -> Share.RepoName -> + -- FIXME mitchell: less decoding if this is a DecodedHashJWT NESet Share.HashJWT -> IO () download httpClient unisonShareUrl conn repoName = do @@ -208,25 +236,21 @@ download httpClient unisonShareUrl conn repoName = do runDB do NEMap.toList entities & foldMapM \(hash, entity) -> do -- still trying to figure out missing dependencies of hash/entity. - entityExists hash >>= \case - True -> pure Set.empty - False -> - Q.getMissingDependencyJwtsForTempEntity (Share.toBase32Hex hash) >>= \case - Just missingDependencies -> - -- already in temp storage, due to missing dependencies - pure (Set.map (Share.decodeHashJWT . Share.HashJWT) (NESet.toSet missingDependencies)) - Nothing -> do - -- not in temp storage. - -- if it has missing dependencies, add it to temp storage; - -- otherwise add it to main storage. - missingDependencies0 <- - Set.filterM - (entityExists . Share.decodedHashJWTHash) - (Set.map Share.decodeHashJWT (Share.entityDependencies entity)) - case NESet.nonEmptySet missingDependencies0 of - Nothing -> insertEntity hash entity - Just missingDependencies -> insertTempEntity hash entity missingDependencies - pure missingDependencies0 + entityLocation2 hash >>= \case + EntityInMainStorage2 -> pure Set.empty + EntityInTempStorage2 missingDependencies -> + pure (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) + EntityNotStored2 -> do + -- if it has missing dependencies, add it to temp storage; + -- otherwise add it to main storage. + missingDependencies0 <- + Set.filterM + (entityExists . Share.decodedHashJWTHash) + (Set.map Share.decodeHashJWT (Share.entityDependencies entity)) + case NESet.nonEmptySet missingDependencies0 of + Nothing -> insertEntity hash entity + Just missingDependencies -> insertTempEntity hash entity missingDependencies + pure missingDependencies0 case NESet.nonEmptySet missingDependencies0 of Nothing -> pure () @@ -326,13 +350,6 @@ server sqlite db ------------------------------------------------------------------------------------------------------------------------ -- -data PullError - -type Transaction a = () - -expectHash :: HashId -> Transaction Hash.Hash -expectHash = undefined - -- FIXME rename, etc resolveHashToEntity :: Connection -> Share.Hash -> IO (Share.Entity Text Share.Hash Share.Hash) resolveHashToEntity = undefined @@ -404,6 +421,15 @@ data EntityLocation | -- | Nowhere EntityNotStored +-- | Where is an entity stored? +data EntityLocation2 + = -- | `object` / `causal` + EntityInMainStorage2 + | -- | `temp_entity`, evidenced by these missing dependencies. + EntityInTempStorage2 (NESet Share.HashJWT) + | -- | Nowhere + EntityNotStored2 + -- | Does this entity already exist in the database, i.e. in the `object` or `causal` table? entityExists :: Q.DB m => Share.Hash -> m Bool entityExists (Share.Hash b32) = do @@ -428,6 +454,16 @@ entityLocation hash = True -> pure EntityInTempStorage False -> pure EntityNotStored +-- | Where is an entity stored? +entityLocation2 :: Q.DB m => Share.Hash -> m EntityLocation2 +entityLocation2 hash = + entityExists hash >>= \case + True -> pure EntityInMainStorage2 + False -> + Q.getMissingDependencyJwtsForTempEntity (Share.toBase32Hex hash) <&> \case + Nothing -> EntityNotStored2 + Just missingDependencies -> EntityInTempStorage2 (NESet.map Share.HashJWT missingDependencies) + -- FIXME comment elaborateHashes :: forall m. Q.DB m => Set Share.DecodedHashJWT -> Set Share.HashJWT -> m (Maybe (NESet Share.HashJWT)) elaborateHashes hashes outputs = From 92971e2e7a35d1c0fd213b8571f15768a92e4193 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 21:52:50 -0400 Subject: [PATCH 113/529] cleanup --- unison-cli/src/Unison/Share/Sync.hs | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 9642a666d3..f42686e65e 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -192,19 +192,19 @@ pull httpClient unisonShareUrl conn repoPath = do Right Nothing -> pure (Right Nothing) Right (Just hashJwt) -> do let hash = Share.hashJWTHash hashJwt - let success = pure (Right (Just (CausalHash (Hash.fromBase32Hex (Share.toBase32Hex hash))))) runDB (entityLocation2 hash) >>= \case - EntityInMainStorage2 -> success - EntityInTempStorage2 missingDependencies -> do - download httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) missingDependencies - success - EntityNotStored2 -> do - download httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) (NESet.singleton hashJwt) - success + EntityInMainStorage2 -> pure () + EntityInTempStorage2 missingDependencies -> doDownload missingDependencies + EntityNotStored2 -> doDownload (NESet.singleton hashJwt) + pure (Right (Just (CausalHash (Hash.fromBase32Hex (Share.toBase32Hex hash))))) where runDB :: ReaderT Connection IO a -> IO a runDB action = runReaderT action conn + doDownload :: NESet Share.HashJWT -> IO () + doDownload = + download httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) + -- Download a set of entities from Unison Share. download :: AuthorizedHttpClient -> From 875787bc0df2769707371acdd7f709bb9c76d777 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Apr 2022 22:05:13 -0400 Subject: [PATCH 114/529] fix a couple transaction-inside-transaction bugs --- lib/unison-sqlite/package.yaml | 1 + .../src/Unison/Sqlite/Connection.hs | 18 +++++++++++++++--- lib/unison-sqlite/unison-sqlite.cabal | 1 + .../src/Unison/Codebase/SqliteCodebase.hs | 11 ++++++----- 4 files changed, 23 insertions(+), 8 deletions(-) diff --git a/lib/unison-sqlite/package.yaml b/lib/unison-sqlite/package.yaml index 3186443490..470387298a 100644 --- a/lib/unison-sqlite/package.yaml +++ b/lib/unison-sqlite/package.yaml @@ -15,6 +15,7 @@ dependencies: - direct-sqlite - exceptions - mtl + - pretty-simple - random - recover-rtti - sqlite-simple diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index a9eb9ecb40..258a67f0bc 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -78,7 +78,9 @@ where import Data.Bifunctor (bimap) import qualified Database.SQLite.Simple as Sqlite import qualified Database.SQLite.Simple.FromField as Sqlite +import Debug.Pretty.Simple (pTraceShowM) import Debug.RecoverRTTI (anythingToString) +import GHC.Stack (currentCallStack) import qualified Unison.Debug as Debug import Unison.Prelude import Unison.Sqlite.Connection.Internal (Connection (..)) @@ -129,22 +131,32 @@ closeConnection (Connection _ _ conn) = data Query = Query { sql :: Sql, params :: Maybe String, - result :: Maybe String + result :: Maybe String, + callStack :: [String] } instance Show Query where - show Query {sql, params, result} = + show Query {sql, params, result, callStack} = concat [ "Query { sql = ", show sql, maybe "" (\p -> ", params = " ++ show p) params, maybe "" (\r -> ", results = " ++ show r) result, + if null callStack then "" else ", callStack = " ++ show callStack, " }" ] logQuery :: Sql -> Maybe a -> Maybe b -> IO () logQuery sql params result = - Debug.debugM Debug.Sqlite "SQL query" (Query sql (anythingToString <$> params) (anythingToString <$> result)) + Debug.whenDebug Debug.Sqlite do + callStack <- currentCallStack + pTraceShowM + Query + { sql, + params = anythingToString <$> params, + result = anythingToString <$> result, + callStack + } -- Without results, with parameters diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 11025e81b8..67e02d8e98 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -59,6 +59,7 @@ library , direct-sqlite , exceptions , mtl + , pretty-simple , random , recover-rtti , sqlite-simple diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index fa89215300..f86a49fe14 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -209,7 +209,8 @@ sqliteCodebase debugName root localOrRemote action = do getDeclType :: C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType getDeclType = - Sqlite.idempotentIO . Cache.apply declTypeCache (Sqlite.runTransaction conn . Ops2.getDeclType) + Sqlite.idempotentIO + . Cache.apply declTypeCache (\ref -> Sqlite.unsafeUnTransaction (Ops2.getDeclType ref) conn) getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann)) getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined @@ -250,8 +251,8 @@ sqliteCodebase debugName root localOrRemote action = do getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> m (Branch m) getRootBranch rootBranchCache = - Branch.transform (Sqlite.runTransaction conn) - <$> Sqlite.runTransaction conn (Ops2.getRootBranch getDeclType rootBranchCache) + Sqlite.runReadOnlyTransactionIO conn \run -> + Branch.transform run <$> run (Ops2.getRootBranch getDeclType rootBranchCache) getRootBranchExists :: m Bool getRootBranchExists = @@ -306,8 +307,8 @@ sqliteCodebase debugName root localOrRemote action = do -- to one that returns Maybe. getBranchForHash :: Branch.Hash -> m (Maybe (Branch m)) getBranchForHash h = - fmap (Branch.transform (Sqlite.runTransaction conn)) - <$> Sqlite.runTransaction conn (Ops2.getBranchForHash getDeclType h) + Sqlite.runReadOnlyTransactionIO conn \run -> + fmap (Branch.transform run) <$> run (Ops2.getBranchForHash getDeclType h) putBranch :: Branch m -> m () putBranch branch = From d4029a8e1093c52428124552f945699531595d7c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 12 Apr 2022 20:21:33 -0600 Subject: [PATCH 115/529] Prepare local-ui endpoints for use in share-server (#3043) * Move auth checks up to the top-level for sharing with enlil * Change handlers to use Backend monad rather than Handler * Add some helpful Show/Eq instances * Clarify runtime types * Fix up Backend error outputs --- .../src/Unison/Codebase/Init.hs | 1 + .../Unison/Codebase/Init/OpenCodebaseError.hs | 2 +- .../src/Unison/Runtime/Interface.hs | 11 ++- .../tests/Unison/Test/UnisonSources.hs | 2 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 2 + .../src/Unison/Codebase/Editor/Output.hs | 2 + .../src/Unison/Codebase/TranscriptParser.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 2 + unison-cli/unison/Main.hs | 8 +- unison-share-api/src/Unison/Server/Backend.hs | 14 ++- .../src/Unison/Server/CodebaseServer.hs | 96 +++++++++++++------ .../src/Unison/Server/Endpoints/FuzzyFind.hs | 30 +++--- .../Unison/Server/Endpoints/GetDefinitions.hs | 23 ++--- .../Server/Endpoints/NamespaceDetails.hs | 26 ++--- .../Server/Endpoints/NamespaceListing.hs | 30 ++---- .../src/Unison/Server/Endpoints/Projects.hs | 45 ++++----- unison-share-api/src/Unison/Server/Errors.hs | 1 + unison-share-api/src/Unison/Server/Types.hs | 4 +- 18 files changed, 154 insertions(+), 147 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Init.hs b/parser-typechecker/src/Unison/Codebase/Init.hs index ee3fe950a3..7a78aa7a84 100644 --- a/parser-typechecker/src/Unison/Codebase/Init.hs +++ b/parser-typechecker/src/Unison/Codebase/Init.hs @@ -63,6 +63,7 @@ data InitError = FoundV1Codebase | InitErrorOpen OpenCodebaseError | CouldntCreateCodebase Pretty + deriving (Show, Eq) data InitResult = OpenedCodebase diff --git a/parser-typechecker/src/Unison/Codebase/Init/OpenCodebaseError.hs b/parser-typechecker/src/Unison/Codebase/Init/OpenCodebaseError.hs index 5994cd5c68..32af40f082 100644 --- a/parser-typechecker/src/Unison/Codebase/Init/OpenCodebaseError.hs +++ b/parser-typechecker/src/Unison/Codebase/Init/OpenCodebaseError.hs @@ -14,5 +14,5 @@ data OpenCodebaseError OpenCodebaseDoesntExist | -- | The codebase exists, but its schema version is unknown to this application. OpenCodebaseUnknownSchemaVersion Word64 - deriving stock (Show) + deriving stock (Show, Eq) deriving anyclass (Exception) diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index 9dc6730fe7..b26c110a5f 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -490,10 +490,11 @@ decodeStandalone b = bimap thd thd $ runGetOrFail g b <*> getNat <*> getStoredCache --- | Whether the runtime is hosted within a UCM session or as a standalone process. +-- | Whether the runtime is hosted within a persistent session or as a one-off process. +-- This affects the amount of clean-up and book-keeping the runtime does. data RuntimeHost - = Standalone - | UCM + = OneOff + | Persistent startRuntime :: RuntimeHost -> Text -> IO (Runtime Symbol) startRuntime runtimeHost version = do @@ -501,10 +502,10 @@ startRuntime runtimeHost version = do (activeThreads, cleanupThreads) <- case runtimeHost of -- Don't bother tracking open threads when running standalone, they'll all be cleaned up -- when the process itself exits. - Standalone -> pure (Nothing, pure ()) + OneOff -> pure (Nothing, pure ()) -- Track all forked threads so that they can be killed when the main process returns, -- otherwise they'll be orphaned and left running. - UCM -> do + Persistent -> do activeThreads <- newIORef Set.empty let cleanupThreads = do threads <- readIORef activeThreads diff --git a/parser-typechecker/tests/Unison/Test/UnisonSources.hs b/parser-typechecker/tests/Unison/Test/UnisonSources.hs index c5c3a88635..1e4d130e14 100644 --- a/parser-typechecker/tests/Unison/Test/UnisonSources.hs +++ b/parser-typechecker/tests/Unison/Test/UnisonSources.hs @@ -59,7 +59,7 @@ bad r = EasyTest.expectLeft r >> done test :: Test () test = do - rt <- io (RTI.startRuntime RTI.Standalone "") + rt <- io (RTI.startRuntime RTI.OneOff "") scope "unison-src" . tests $ [ go rt shouldPassNow good, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 2b58b0bf40..36c71ade32 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -2448,6 +2448,8 @@ handleBackendError :: Backend.BackendError -> Action m i v () handleBackendError = \case Backend.NoSuchNamespace path -> respond . BranchNotFound $ Path.absoluteToPath' path + Backend.BadNamespace msg namespace -> + respond $ BadNamespace msg namespace Backend.BadRootBranch e -> respond $ BadRootBranch e Backend.NoBranchForHash h -> do sbhLength <- eval BranchHashLength diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index e986e0977b..8e7e91d8ef 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -143,6 +143,7 @@ data Output v | TermAmbiguous (HQ.HashQualified Name) (Set Referent) | HashAmbiguous ShortHash (Set Referent) | BranchHashAmbiguous ShortBranchHash (Set ShortBranchHash) + | BadNamespace String String | BranchNotFound Path' | NameNotFound Path.HQSplit' | PatchNotFound Path.Split' @@ -310,6 +311,7 @@ isFailure o = case o of TermAmbiguous {} -> True BranchHashAmbiguous {} -> True BadName {} -> True + BadNamespace {} -> True BranchNotFound {} -> True NameNotFound {} -> True PatchNotFound {} -> True diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 86f3d79cd0..fae82cf998 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -159,7 +159,7 @@ withTranscriptRunner ucmVersion configFile action = do withRuntime :: ((Runtime.Runtime Symbol -> m a) -> m a) withRuntime action = UnliftIO.bracket - (liftIO $ RTI.startRuntime RTI.UCM ucmVersion) + (liftIO $ RTI.startRuntime RTI.Persistent ucmVersion) (liftIO . Runtime.terminate) action withConfig :: forall a. ((Maybe Config -> m a) -> m a) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 588468780c..6003b49c52 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -798,6 +798,8 @@ notifyUser dir o = case o of "The file " <> P.blue (P.shown name) <> " could not be loaded." + BadNamespace msg path -> + pure . P.warnCallout $ "Invalid namespace " <> P.blue (P.string path) <> ", " <> P.string msg BranchNotFound b -> pure . P.warnCallout $ "The namespace " <> P.blue (P.shown b) <> " doesn't exist." CreatedNewBranch path -> diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index f8f0b5bdda..7734ae5987 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -107,7 +107,7 @@ main = withCP65001 do ) Run (RunFromSymbol mainName) args -> do getCodebaseOrExit mCodePathOption \(_, _, theCodebase) -> do - runtime <- RTI.startRuntime RTI.Standalone Version.gitDescribeWithDate + runtime <- RTI.startRuntime RTI.OneOff Version.gitDescribeWithDate withArgs args $ execute theCodebase runtime mainName Run (RunFromFile file mainName) args | not (isDotU file) -> PT.putPrettyLn $ P.callout "โš ๏ธ" "Files must have a .u extension." @@ -117,7 +117,7 @@ main = withCP65001 do Left _ -> PT.putPrettyLn $ P.callout "โš ๏ธ" "I couldn't find that file or it is for some reason unreadable." Right contents -> do getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do - rt <- RTI.startRuntime RTI.Standalone Version.gitDescribeWithDate + rt <- RTI.startRuntime RTI.OneOff Version.gitDescribeWithDate let fileEvent = Input.UnisonFileChanged (Text.pack file) contents launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes Run (RunFromPipe mainName) args -> do @@ -126,7 +126,7 @@ main = withCP65001 do Left _ -> PT.putPrettyLn $ P.callout "โš ๏ธ" "I had trouble reading this input." Right contents -> do getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do - rt <- RTI.startRuntime RTI.Standalone Version.gitDescribeWithDate + rt <- RTI.startRuntime RTI.OneOff Version.gitDescribeWithDate let fileEvent = Input.UnisonFileChanged (Text.pack "") contents launch currentDir @@ -202,7 +202,7 @@ main = withCP65001 do runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles Launch isHeadless codebaseServerOpts downloadBase -> do getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do - runtime <- RTI.startRuntime RTI.UCM Version.gitDescribeWithDate + runtime <- RTI.startRuntime RTI.Persistent Version.gitDescribeWithDate Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do case isHeadless of Headless -> do diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index f129a3f7da..5bb99126ea 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -1,11 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE ApplicativeDo #-} module Unison.Server.Backend where @@ -127,6 +127,12 @@ listEntryName = \case data BackendError = NoSuchNamespace Path.Absolute + | -- Failed to parse path + BadNamespace + String + -- ^ error message + String + -- ^ namespace | BadRootBranch Codebase.GetRootBranchError | CouldntExpandBranchHash ShortBranchHash | AmbiguousBranchHash ShortBranchHash (Set ShortBranchHash) @@ -289,7 +295,7 @@ findShallowReadmeInBranchAndRender width runtime codebase printNames namespaceBr let ppe hqLen = PPE.fromNamesDecl hqLen printNames renderReadme ppe r = do - (_, _, doc) <- liftIO $ renderDoc ppe width runtime codebase (Referent.toReference r) + (_, _, doc) <- renderDoc ppe width runtime codebase (Referent.toReference r) pure doc -- allow any of these capitalizations @@ -299,8 +305,8 @@ findShallowReadmeInBranchAndRender width runtime codebase printNames namespaceBr where lookup seg = R.lookupRan seg rel rel = Star3.d1 (Branch._terms (Branch.head namespaceBranch)) - in do - hqLen <- liftIO $ Codebase.hashLength codebase + in liftIO $ do + hqLen <- Codebase.hashLength codebase traverse (renderReadme (ppe hqLen)) (Set.lookupMin readmes) isDoc :: Monad m => Codebase m Symbol Ann -> Referent -> m Bool diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index a5a40e14dc..d5a34cd6e6 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -12,6 +12,7 @@ import Control.Concurrent (newEmptyMVar, putMVar, readMVar) import Control.Concurrent.Async (race) import Control.Exception (ErrorCall (..), throwIO) import Control.Lens ((.~)) +import Control.Monad.Trans.Except import Data.Aeson () import qualified Data.ByteString as Strict import Data.ByteString.Char8 (unpack) @@ -26,6 +27,7 @@ import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import GHC.Generics () import Network.HTTP.Media ((//), (/:)) +import Network.HTTP.Types (HeaderName) import Network.HTTP.Types.Status (ok200) import qualified Network.URI.Encode as URI import Network.Wai (responseLBS) @@ -39,7 +41,10 @@ import Network.Wai.Handler.Warp withApplicationSettings, ) import Servant - ( MimeRender (..), + ( Handler, + HasServer, + MimeRender (..), + ServerT, serve, throwError, ) @@ -63,12 +68,13 @@ import Servant.Docs import Servant.OpenApi (HasOpenApi (toOpenApi)) import Servant.Server ( Application, - Handler, + Handler (Handler), Server, ServerError (..), Tagged (Tagged), err401, err404, + hoistServer, ) import Servant.Server.StaticFiles (serveDirectoryWebApp) import System.Directory (canonicalizePath, doesFileExist) @@ -80,6 +86,7 @@ import Unison.Codebase (Codebase) import qualified Unison.Codebase.Runtime as Rt import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.Server.Backend (Backend) import Unison.Server.Endpoints.FuzzyFind (FuzzyFindAPI, serveFuzzyFind) import Unison.Server.Endpoints.GetDefinitions ( DefinitionsAPI, @@ -88,7 +95,8 @@ import Unison.Server.Endpoints.GetDefinitions import qualified Unison.Server.Endpoints.NamespaceDetails as NamespaceDetails import qualified Unison.Server.Endpoints.NamespaceListing as NamespaceListing import qualified Unison.Server.Endpoints.Projects as Projects -import Unison.Server.Types (mungeString) +import Unison.Server.Errors (backendError) +import Unison.Server.Types (mungeString, setCacheControl) import Unison.Symbol (Symbol) -- HTML content type @@ -104,7 +112,7 @@ instance MimeRender HTML RawHtml where type OpenApiJSON = "openapi.json" :> Get '[JSON] OpenApi -type DocAPI = UnisonAPI :<|> OpenApiJSON :<|> Raw +type UnisonAndDocsAPI = UnisonAPI :<|> OpenApiJSON :<|> Raw type UnisonAPI = NamespaceListing.NamespaceListingAPI @@ -115,9 +123,13 @@ type UnisonAPI = type WebUI = CaptureAll "route" Text :> Get '[HTML] RawHtml -type ServerAPI = ("ui" :> WebUI) :<|> ("api" :> DocAPI) +type ServerAPI = ("ui" :> WebUI) :<|> ("api" :> UnisonAndDocsAPI) -type AuthedServerAPI = ("static" :> Raw) :<|> (Capture "token" Text :> ServerAPI) +type StaticAPI = "static" :> Raw + +type Authed api = (Capture "token" Text :> api) + +type AppAPI = StaticAPI :<|> Authed ServerAPI instance ToSample Char where toSamples _ = singleSample 'x' @@ -173,15 +185,18 @@ docsBS = mungeString . markdown $ docsWithIntros [intro] api (Text.unpack $ _infoTitle infoObject) (toList $ Text.unpack <$> _infoDescription infoObject) -docAPI :: Proxy DocAPI -docAPI = Proxy +unisonAndDocsAPI :: Proxy UnisonAndDocsAPI +unisonAndDocsAPI = Proxy api :: Proxy UnisonAPI api = Proxy -serverAPI :: Proxy AuthedServerAPI +serverAPI :: Proxy ServerAPI serverAPI = Proxy +appAPI :: Proxy AppAPI +appAPI = Proxy + app :: Rt.Runtime Symbol -> Codebase IO Symbol Ann -> @@ -189,9 +204,9 @@ app :: Strict.ByteString -> Application app rt codebase uiPath expectedToken = - serve serverAPI $ server rt codebase uiPath expectedToken + serve appAPI $ server rt codebase uiPath expectedToken --- The Token is used to help prevent multiple users on a machine gain access to +-- | The Token is used to help prevent multiple users on a machine gain access to -- each others codebases. genToken :: IO Strict.ByteString genToken = do @@ -285,31 +300,52 @@ serveIndex path = do <> " environment variable to the directory where the UI is installed." } -serveUI :: Handler () -> FilePath -> Server WebUI -serveUI tryAuth path _ = tryAuth *> serveIndex path +serveUI :: FilePath -> Server WebUI +serveUI path _ = serveIndex path server :: Rt.Runtime Symbol -> Codebase IO Symbol Ann -> FilePath -> Strict.ByteString -> - Server AuthedServerAPI -server rt codebase uiPath token = + Server AppAPI +server rt codebase uiPath expectedToken = serveDirectoryWebApp (uiPath "static") - :<|> ( \token -> - serveUI (tryAuth token) uiPath - :<|> unisonApi token - :<|> serveOpenAPI - :<|> Tagged serveDocs - ) + :<|> hoistWithAuth serverAPI expectedToken serveServer + where + serveServer :: Server ServerAPI + serveServer = + ( serveUI uiPath + :<|> serveUnisonAndDocs rt codebase + ) + +serveUnisonAndDocs :: Rt.Runtime Symbol -> Codebase IO Symbol Ann -> Server UnisonAndDocsAPI +serveUnisonAndDocs rt codebase = serveUnison codebase rt :<|> serveOpenAPI :<|> Tagged serveDocs + +serveDocs :: Application +serveDocs _ respond = respond $ responseLBS ok200 [plain] docsBS where - serveDocs _ respond = respond $ responseLBS ok200 [plain] docsBS - serveOpenAPI = pure openAPI + plain :: (HeaderName, ByteString) plain = ("Content-Type", "text/plain") - tryAuth = handleAuth token - unisonApi t = - NamespaceListing.serve (tryAuth t) codebase - :<|> NamespaceDetails.serve (tryAuth t) rt codebase - :<|> Projects.serve (tryAuth t) codebase - :<|> serveDefinitions (tryAuth t) rt codebase - :<|> serveFuzzyFind (tryAuth t) codebase + +serveOpenAPI :: Handler OpenApi +serveOpenAPI = pure openAPI + +hoistWithAuth :: forall api. HasServer api '[] => Proxy api -> ByteString -> ServerT api Handler -> ServerT (Authed api) Handler +hoistWithAuth api expectedToken server token = hoistServer @api @Handler @Handler api (\h -> handleAuth expectedToken token *> h) server + +serveUnison :: + Codebase IO Symbol Ann -> + Rt.Runtime Symbol -> + Server UnisonAPI +serveUnison codebase rt = + hoistServer (Proxy @UnisonAPI) backendHandler $ + (\root rel name -> setCacheControl <$> NamespaceListing.serve codebase root rel name) + :<|> (\namespaceName mayRoot mayWidth -> setCacheControl <$> NamespaceDetails.serve rt codebase namespaceName mayRoot mayWidth) + :<|> (\mayRoot mayOwner -> setCacheControl <$> Projects.serve codebase mayRoot mayOwner) + :<|> (\mayRoot relativePath rawHqns width suff -> setCacheControl <$> serveDefinitions rt codebase mayRoot relativePath rawHqns width suff) + :<|> (\mayRoot relativePath limit typeWidth query -> setCacheControl <$> serveFuzzyFind codebase mayRoot relativePath limit typeWidth query) + +backendHandler :: Backend IO a -> Handler a +backendHandler m = + Handler $ withExceptT backendError m diff --git a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs index 7934b189c1..74d232953a 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs @@ -10,13 +10,12 @@ module Unison.Server.Endpoints.FuzzyFind where -import Control.Error (runExceptT) +import Control.Monad.Except import Data.Aeson (ToJSON (toEncoding), defaultOptions, genericToEncoding) import Data.OpenApi (ToSchema) import qualified Data.Text as Text import Servant ( QueryParam, - throwError, (:>), ) import Servant.Docs @@ -27,7 +26,6 @@ import Servant.Docs noSamples, ) import Servant.OpenApi () -import Servant.Server (Handler) import qualified Text.FuzzyFind as FZF import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase @@ -41,18 +39,12 @@ import Unison.NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.Server.Backend as Backend -import Unison.Server.Errors - ( backendError, - badNamespace, - ) import Unison.Server.Syntax (SyntaxText) import Unison.Server.Types ( APIGet, - APIHeaders, HashQualifiedName, NamedTerm, NamedType, - addHeaders, mayDefaultWidth, ) import Unison.Symbol (Symbol) @@ -134,22 +126,22 @@ instance ToSample FoundResult where toSamples _ = noSamples serveFuzzyFind :: - Handler () -> - Codebase IO Symbol Ann -> + forall m. + MonadIO m => + Codebase m Symbol Ann -> Maybe SBH.ShortBranchHash -> Maybe HashQualifiedName -> Maybe Int -> Maybe Width -> Maybe String -> - Handler (APIHeaders [(FZF.Alignment, FoundResult)]) -serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query = - addHeaders <$> do - h + Backend.Backend m [(FZF.Alignment, FoundResult)] +serveFuzzyFind codebase mayRoot relativePath limit typeWidth query = + do rel <- maybe mempty Path.fromPath' <$> traverse (parsePath . Text.unpack) relativePath - hashLength <- liftIO $ Codebase.hashLength codebase - ea <- liftIO . runExceptT $ do + hashLength <- lift $ Codebase.hashLength codebase + ea <- lift . runExceptT $ do root <- traverse (Backend.expandShortBranchHash codebase) mayRoot branch <- Backend.resolveBranchHash root codebase let b0 = Branch.head branch @@ -158,7 +150,7 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query = -- Use AllNames to render source ppe = Backend.basicSuffixifiedNames hashLength branch (Backend.AllNames rel) join <$> traverse (loadEntry root (Just rel) ppe b0) alignments - errFromEither backendError ea + liftEither ea where loadEntry _root _rel ppe b0 (a, HQ'.NameOnly . NameSegment -> n, refs) = for refs $ @@ -181,5 +173,5 @@ serveFuzzyFind h codebase mayRoot relativePath limit typeWidth query = let ft = FoundType typeName typeHeader namedType pure (a, FoundTypeResult ft) - parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p + parsePath p = errFromEither (`Backend.BadNamespace` p) $ Path.parsePath' p errFromEither f = either (throwError . f) pure diff --git a/unison-share-api/src/Unison/Server/Endpoints/GetDefinitions.hs b/unison-share-api/src/Unison/Server/Endpoints/GetDefinitions.hs index 94ad3b0672..cd04d4d940 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/GetDefinitions.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/GetDefinitions.hs @@ -6,12 +6,11 @@ module Unison.Server.Endpoints.GetDefinitions where -import Control.Error (runExceptT) +import Control.Monad.Except import qualified Data.Text as Text import Servant ( QueryParam, QueryParams, - throwError, (:>), ) import Servant.Docs @@ -21,7 +20,6 @@ import Servant.Docs ToSample (..), noSamples, ) -import Servant.Server (Handler) import Unison.Codebase (Codebase) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Path.Parse as Path @@ -33,18 +31,12 @@ import qualified Unison.HashQualified as HQ import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.Server.Backend as Backend -import Unison.Server.Errors - ( backendError, - badNamespace, - ) import Unison.Server.Types ( APIGet, - APIHeaders, DefinitionDisplayResults, HashQualifiedName, NamespaceFQN, Suffixify (..), - addHeaders, defaultWidth, ) import Unison.Symbol (Symbol) @@ -113,7 +105,7 @@ instance ToSample DefinitionDisplayResults where toSamples _ = noSamples serveDefinitions :: - Handler () -> + MonadIO m => Rt.Runtime Symbol -> Codebase IO Symbol Ann -> Maybe ShortBranchHash -> @@ -121,10 +113,9 @@ serveDefinitions :: [HashQualifiedName] -> Maybe Width -> Maybe Suffixify -> - Handler (APIHeaders DefinitionDisplayResults) -serveDefinitions h rt codebase mayRoot relativePath rawHqns width suff = - addHeaders <$> do - h + Backend.Backend m DefinitionDisplayResults +serveDefinitions rt codebase mayRoot relativePath rawHqns width suff = + do rel <- fmap Path.fromPath' <$> traverse (parsePath . Text.unpack) relativePath ea <- liftIO . runExceptT $ do @@ -143,7 +134,7 @@ serveDefinitions h rt codebase mayRoot relativePath rawHqns width suff = rt codebase hqns - errFromEither backendError ea + liftEither ea where - parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p + parsePath p = errFromEither (`Backend.BadNamespace` p) $ Path.parsePath' p errFromEither f = either (throwError . f) pure diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs index f615e44c00..ff89f52f2b 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs @@ -9,14 +9,13 @@ module Unison.Server.Endpoints.NamespaceDetails where -import Control.Error (runExceptT) +import Control.Monad.Except import Data.Aeson import Data.OpenApi (ToSchema) import qualified Data.Text as Text -import Servant (Capture, QueryParam, throwError, (:>)) +import Servant (Capture, QueryParam, (:>)) import Servant.Docs (DocCapture (..), ToCapture (..), ToSample (..)) import Servant.OpenApi () -import Servant.Server (Handler) import Unison.Codebase (Codebase) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Path as Path @@ -25,16 +24,14 @@ import qualified Unison.Codebase.Runtime as Rt import Unison.Codebase.ShortBranchHash (ShortBranchHash) import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.Server.Backend import qualified Unison.Server.Backend as Backend import Unison.Server.Doc (Doc) -import Unison.Server.Errors (backendError, badNamespace) import Unison.Server.Types ( APIGet, - APIHeaders, NamespaceFQN, UnisonHash, UnisonName, - addHeaders, branchToUnisonHash, mayDefaultWidth, ) @@ -77,30 +74,25 @@ instance ToJSON NamespaceDetails where deriving instance ToSchema NamespaceDetails serve :: - Handler () -> Rt.Runtime Symbol -> Codebase IO Symbol Ann -> NamespaceFQN -> Maybe ShortBranchHash -> Maybe Width -> - Handler (APIHeaders NamespaceDetails) -serve tryAuth runtime codebase namespaceName mayRoot mayWidth = - let doBackend a = do - ea <- liftIO $ runExceptT a - errFromEither backendError ea - - errFromEither f = either (throwError . f) pure + Backend IO NamespaceDetails +serve runtime codebase namespaceName mayRoot mayWidth = + let errFromEither f = either (throwError . f) pure fqnToPath fqn = do let fqnS = Text.unpack fqn - path' <- errFromEither (`badNamespace` fqnS) $ parsePath' fqnS + path' <- errFromEither (`Backend.BadNamespace` fqnS) $ parsePath' fqnS pure (Path.fromPath' path') width = mayDefaultWidth mayWidth in do namespacePath <- fqnToPath namespaceName - namespaceDetails <- doBackend $ do + namespaceDetails <- do root <- Backend.resolveRootBranchHash mayRoot codebase let namespaceBranch = Branch.getAt' namespacePath root @@ -120,4 +112,4 @@ serve tryAuth runtime codebase namespaceName mayRoot mayWidth = pure $ NamespaceDetails namespaceName (branchToUnisonHash namespaceBranch) readme - addHeaders <$> (tryAuth $> namespaceDetails) + pure $ namespaceDetails diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs index c359bcc396..75dce6ca3a 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs @@ -9,14 +9,13 @@ module Unison.Server.Endpoints.NamespaceListing where -import Control.Error (runExceptT) import Control.Error.Util ((??)) +import Control.Monad.Except import Data.Aeson import Data.OpenApi (ToSchema) import qualified Data.Text as Text import Servant ( QueryParam, - throwError, (:>), ) import Servant.Docs @@ -26,7 +25,6 @@ import Servant.Docs ToSample (..), ) import Servant.OpenApi () -import Servant.Server (Handler) import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch @@ -39,14 +37,8 @@ import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.Server.Backend as Backend -import Unison.Server.Errors - ( backendError, - badNamespace, - rootBranchError, - ) import Unison.Server.Types ( APIGet, - APIHeaders, HashQualifiedName, NamedTerm (..), NamedType (..), @@ -54,7 +46,6 @@ import Unison.Server.Types Size, UnisonHash, UnisonName, - addHeaders, branchToUnisonHash, ) import Unison.Symbol (Symbol) @@ -157,23 +148,18 @@ backendListEntryToNamespaceObject ppe typeWidth = \case PatchObject . NamedPatch $ NameSegment.toText name serve :: - Handler () -> Codebase IO Symbol Ann -> Maybe ShortBranchHash -> Maybe NamespaceFQN -> Maybe NamespaceFQN -> - Handler (APIHeaders NamespaceListing) -serve tryAuth codebase mayRoot mayRelativeTo mayNamespaceName = + Backend.Backend IO NamespaceListing +serve codebase mayRoot mayRelativeTo mayNamespaceName = let -- Various helpers errFromEither f = either (throwError . f) pure - parsePath p = errFromEither (`badNamespace` p) $ Path.parsePath' p - - doBackend a = do - ea <- liftIO $ runExceptT a - errFromEither backendError ea + parsePath p = errFromEither (`Backend.BadNamespace` p) $ Path.parsePath' p - findShallow branch = doBackend $ Backend.findShallowInBranch codebase branch + findShallow branch = Backend.findShallowInBranch codebase branch makeNamespaceListing ppe fqn hash entries = pure . NamespaceListing fqn hash $ @@ -186,13 +172,13 @@ serve tryAuth codebase mayRoot mayRelativeTo mayNamespaceName = root <- case mayRoot of Nothing -> do gotRoot <- liftIO $ Codebase.getRootBranch codebase - errFromEither rootBranchError gotRoot + errFromEither Backend.BadRootBranch gotRoot Just sbh -> do ea <- liftIO . runExceptT $ do h <- Backend.expandShortBranchHash codebase sbh mayBranch <- lift $ Codebase.getBranchForHash codebase h mayBranch ?? Backend.CouldntLoadBranch h - errFromEither backendError ea + liftEither ea -- Relative and Listing Path resolution -- @@ -224,4 +210,4 @@ serve tryAuth codebase mayRoot mayRelativeTo mayNamespaceName = listingEntries <- findShallow listingBranch makeNamespaceListing shallowPPE listingFQN listingHash listingEntries - in addHeaders <$> (tryAuth *> namespaceListing) + in namespaceListing diff --git a/unison-share-api/src/Unison/Server/Endpoints/Projects.hs b/unison-share-api/src/Unison/Server/Endpoints/Projects.hs index a176a28776..58ed3b8678 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/Projects.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/Projects.hs @@ -8,8 +8,8 @@ module Unison.Server.Endpoints.Projects where -import Control.Error (ExceptT, runExceptT) import Control.Error.Util ((??)) +import Control.Monad.Except import Data.Aeson import Data.Char import Data.OpenApi @@ -17,7 +17,7 @@ import Data.OpenApi ToSchema (..), ) import qualified Data.Text as Text -import Servant (QueryParam, ServerError, throwError, (:>)) +import Servant (QueryParam, (:>)) import Servant.API (FromHttpApiData (..)) import Servant.Docs ( DocQueryParam (..), @@ -25,7 +25,6 @@ import Servant.Docs ToParam (..), ToSample (..), ) -import Servant.Server (Handler) import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch @@ -36,9 +35,9 @@ import qualified Unison.Codebase.ShortBranchHash as SBH import qualified Unison.NameSegment as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.Server.Backend import qualified Unison.Server.Backend as Backend -import Unison.Server.Errors (backendError, badNamespace, rootBranchError) -import Unison.Server.Types (APIGet, APIHeaders, UnisonHash, addHeaders) +import Unison.Server.Types (APIGet, UnisonHash) import Unison.Symbol (Symbol) import Unison.Util.Monoid (foldMapM) @@ -122,25 +121,26 @@ entryToOwner = \case _ -> Nothing serve :: - Handler () -> - Codebase IO Symbol Ann -> + forall m. + MonadIO m => + Codebase m Symbol Ann -> Maybe ShortBranchHash -> Maybe ProjectOwner -> - Handler (APIHeaders [ProjectListing]) -serve tryAuth codebase mayRoot mayOwner = addHeaders <$> (tryAuth *> projects) + Backend m [ProjectListing] +serve codebase mayRoot mayOwner = projects where - projects :: Handler [ProjectListing] + projects :: Backend m [ProjectListing] projects = do root <- case mayRoot of Nothing -> do - gotRoot <- liftIO $ Codebase.getRootBranch codebase - errFromEither rootBranchError gotRoot + gotRoot <- lift $ Codebase.getRootBranch codebase + errFromEither BadRootBranch gotRoot Just sbh -> do - ea <- liftIO . runExceptT $ do + ea <- lift . runExceptT $ do h <- Backend.expandShortBranchHash codebase sbh mayBranch <- lift $ Codebase.getBranchForHash codebase h mayBranch ?? Backend.CouldntLoadBranch h - errFromEither backendError ea + liftEither ea ownerEntries <- findShallow root -- If an owner is provided, we only want projects belonging to them @@ -150,7 +150,7 @@ serve tryAuth codebase mayRoot mayOwner = addHeaders <$> (tryAuth *> projects) Nothing -> mapMaybe entryToOwner ownerEntries foldMapM (ownerToProjectListings root) owners - ownerToProjectListings :: Branch.Branch IO -> ProjectOwner -> Handler [ProjectListing] + ownerToProjectListings :: Branch.Branch m -> ProjectOwner -> Backend m [ProjectListing] ownerToProjectListings root owner = do let (ProjectOwner ownerName) = owner ownerPath' <- (parsePath . Text.unpack) ownerName @@ -161,19 +161,14 @@ serve tryAuth codebase mayRoot mayOwner = addHeaders <$> (tryAuth *> projects) -- Minor helpers - findShallow :: Branch.Branch IO -> Handler [Backend.ShallowListEntry Symbol Ann] + findShallow :: Branch.Branch m -> Backend m [Backend.ShallowListEntry Symbol Ann] findShallow branch = - doBackend $ Backend.findShallowInBranch codebase branch + Backend.findShallowInBranch codebase branch - parsePath :: String -> Handler Path.Path' + parsePath :: String -> Backend m Path.Path' parsePath p = - errFromEither (`badNamespace` p) $ Path.parsePath' p + errFromEither (`Backend.BadNamespace` p) $ Path.parsePath' p - errFromEither :: (a -> ServerError) -> Either a a1 -> Handler a1 + errFromEither :: (e -> BackendError) -> Either e a -> Backend m a errFromEither f = either (throwError . f) pure - - doBackend :: ExceptT Backend.BackendError IO b -> Handler b - doBackend a = do - ea <- liftIO $ runExceptT a - errFromEither backendError ea diff --git a/unison-share-api/src/Unison/Server/Errors.hs b/unison-share-api/src/Unison/Server/Errors.hs index f2f6bac336..6093140cb5 100644 --- a/unison-share-api/src/Unison/Server/Errors.hs +++ b/unison-share-api/src/Unison/Server/Errors.hs @@ -36,6 +36,7 @@ backendError :: Backend.BackendError -> ServerError backendError = \case Backend.NoSuchNamespace n -> noSuchNamespace . Path.toText $ Path.unabsolute n + Backend.BadNamespace err namespace -> badNamespace err namespace Backend.BadRootBranch e -> rootBranchError e Backend.NoBranchForHash h -> noSuchNamespace . Text.toStrict . Text.pack $ show h diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index f89bac6bcf..6769447cc6 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -259,8 +259,8 @@ discard = const $ pure () mayDefaultWidth :: Maybe Width -> Width mayDefaultWidth = fromMaybe defaultWidth -addHeaders :: v -> APIHeaders v -addHeaders = addHeader "public" +setCacheControl :: v -> APIHeaders v +setCacheControl = addHeader @"Cache-Control" "public" branchToUnisonHash :: Branch.Branch m -> UnisonHash branchToUnisonHash b = From 6d61d657f4107d04b7e0c6fabcc12405d842254d Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 13 Apr 2022 19:33:58 -0500 Subject: [PATCH 116/529] removing contributor blurbs ... which rapidly got out of date. --- CONTRIBUTORS.markdown | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/CONTRIBUTORS.markdown b/CONTRIBUTORS.markdown index 5bb084fd2c..93b97e9d01 100644 --- a/CONTRIBUTORS.markdown +++ b/CONTRIBUTORS.markdown @@ -6,12 +6,12 @@ All contributions to Unison are licensed in the same way: the MIT license. See t ### Contributors -The format for this list: name, GitHub handle, and then optional blurb about what areas of Unison you've worked on. +The format for this list: name, GitHub handle -* Paul Chiusano (@pchiusano) - I've worked on just about all aspects of Unison: overall design, typechecker, runtime, parser... -* Arya Irani (@aryairani) - Ditto -* Rรบnar Bjarnason (@runarorama) - Typechecker, runtime, parser, code serialization -* Chris Gibbs (@atacratic) - Pretty-printer +* Paul Chiusano (@pchiusano) +* Arya Irani (@aryairani) +* Rรบnar Bjarnason (@runarorama) +* Chris Gibbs (@atacratic) * Noah Haasis (@noahhaasis) * Francis De Brabandere (@francisdb) * Matt Dziuban (@mrdziuban) @@ -45,8 +45,8 @@ The format for this list: name, GitHub handle, and then optional blurb about wha * Cody Allen (@ceedubs) * Ludvig Sundstrรถm (@lsund) * Mohamed Elsharnouby (@sharno) -* Jared Forsyth (@jaredly) - Documentation generation -* Hakim Cassimally (@osfameron) - vim support +* Jared Forsyth (@jaredly) +* Hakim Cassimally (@osfameron) * Will Badart (@wbadart) * Sam Roberts (@samgqroberts) * Nigel Farrelly (@nini-faroux) From 564a43ee686d447af36b86d32b983bcebc66f771 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 13 Apr 2022 19:43:32 -0500 Subject: [PATCH 117/529] Update README.md --- README.md | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/README.md b/README.md index b7c57806ba..4588e0e8f1 100644 --- a/README.md +++ b/README.md @@ -3,7 +3,7 @@ The Unison language [![Build Status](https://travis-ci.org/unisonweb/unison.svg?branch=master)](https://travis-ci.org/unisonweb/unison) -[Unison](https://unisonweb.org) is a new programming language, currently under active development. It's a modern, statically-typed purely functional language, similar to Haskell, but with the ability to describe entire distributed systems with a single program. Here's an example of a distributed map-reduce implementation: +[Unison](https://unisonweb.org) is a modern, statically-typed purely functional language with the ability to describe entire distributed systems using a single program. Here's an example of a distributed map-reduce implementation: ```Haskell -- comments start with `--` @@ -11,16 +11,20 @@ mapReduce loc fn ifEmpty reduce data = match split data with Empty -> ifEmpty One a -> fn a Two left right -> - fl = at loc '(mapReduce loc fn ifEmpty reduce !left) - fr = at loc '(mapReduce loc fn ifEmpty reduce !right) - reduce !fl !fr + fl = forkAt loc '(mapReduce loc fn ifEmpty reduce !left) + fr = forkAt loc '(mapReduce loc fn ifEmpty reduce !right) + reduce (await fl) (await fr) ``` -This function can be either simulated locally (possibly with faults injected for testing purposes), or run atop a distributed pool of compute. +This function can be either simulated locally (possibly with faults injected for testing purposes), or run atop a distributed pool of compute. See [this article](https://www.unison-lang.org/articles/distributed-datasets/) for more in-depth coverage of how to build distributed computing libraries like this. -If you'd like to learn more about the project, [this Strange Loop talk is a good introduction](https://www.youtube.com/watch?v=gCWtkvDQ2ZI). You can also follow along with [project website](https://unisonweb.org) or you can also say hello or lurk [in the Slack chat](https://unisonweb.org/slack). +Other resources: -We are currently alpha testing Unison. If you'd like to participate in alpha testing, you can go to [the docs site](https://www.unisonweb.org/docs) to get started. +* [Learn about the big idea behind Unison](https://www.unison-lang.org/learn/the-big-idea/) +* Check out [the project website](https://unison-lang.org) +* Say hello or lurk [in the Slack chat](https://unison-lang.org/slack) +* Explore [the Unison ecosystem](https://share.unison-lang.org/) +* [Learn Unison](https://www.unison-lang.org/learn/) Building using Stack -------------------- From 8479e996c2f82743e59158858594986498f11e5e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 14 Apr 2022 10:13:08 -0400 Subject: [PATCH 118/529] delete a couple accidentally-added files --- after | 18 ------------------ before | 16 ---------------- 2 files changed, 34 deletions(-) delete mode 100644 after delete mode 100644 before diff --git a/after b/after deleted file mode 100644 index 2730ee634b..0000000000 --- a/after +++ /dev/null @@ -1,18 +0,0 @@ - -handleBackendError :: Backend.BackendError -> Action m i v () -handleBackendError = \case - Backend.NoSuchNamespace path -> - respond . BranchNotFound $ Path.absoluteToPath' path - Backend.BadNamespace msg namespace -> - respond $ BadNamespace msg namespace - Backend.BadRootBranch e -> respond $ BadRootBranch e - Backend.NoBranchForHash h -> do - sbhLength <- eval BranchHashLength - respond . NoBranchWithHash $ SBH.fromHash sbhLength h - Backend.CouldntLoadBranch h -> do - respond . CouldntLoadBranch $ h - Backend.CouldntExpandBranchHash sbh -> respond $ NoBranchWithHash sbh - Backend.AmbiguousBranchHash h hashes -> - respond $ BranchHashAmbiguous h hashes - Backend.MissingSignatureForTerm r -> - respond $ TermMissingType r diff --git a/before b/before deleted file mode 100644 index d25ff97576..0000000000 --- a/before +++ /dev/null @@ -1,16 +0,0 @@ - -handleBackendError :: Backend.BackendError -> Action m i v () -handleBackendError = \case - Backend.NoSuchNamespace path -> - respond . BranchNotFound $ Path.absoluteToPath' path - Backend.BadRootBranch e -> respond $ BadRootBranch e - Backend.NoBranchForHash h -> do - sbhLength <- eval BranchHashLength - respond . NoBranchWithHash $ SBH.fromHash sbhLength h - Backend.CouldntLoadBranch h -> do - respond . CouldntLoadBranch $ h - Backend.CouldntExpandBranchHash sbh -> respond $ NoBranchWithHash sbh - Backend.AmbiguousBranchHash h hashes -> - respond $ BranchHashAmbiguous h hashes - Backend.MissingSignatureForTerm r -> - respond $ TermMissingType r From 1e6aa43994dd61f7aaecec0d08a7d517373fca0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Thu, 14 Apr 2022 10:34:38 -0400 Subject: [PATCH 119/529] Add builtins to support nano system clocks --- parser-typechecker/package.yaml | 1 + parser-typechecker/src/Unison/Builtin.hs | 1134 +++++++++-------- .../src/Unison/Runtime/Builtin.hs | 39 + .../src/Unison/Runtime/Foreign.hs | 4 + .../src/Unison/Server/Backend.hs | 1 + .../unison-parser-typechecker.cabal | 1 + unison-core/src/Unison/Type.hs | 6 +- 7 files changed, 642 insertions(+), 544 deletions(-) diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 2f1a86bcc4..bd6c3f00f6 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -50,6 +50,7 @@ library: - bytestring - bytestring-to-vector - cereal + - clock - containers >= 0.6.3 - configurator - cryptonite diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 9e8857c64b..78e1d451be 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -2,75 +2,89 @@ {-# LANGUAGE Rank2Types #-} module Unison.Builtin - (codeLookup - ,constructorType - ,names - ,names0 - ,builtinDataDecls - ,builtinEffectDecls - ,builtinConstructorType - ,builtinTypeDependents - ,builtinTypeDependentsOfComponent - ,builtinTypes - ,builtinTermsByType - ,builtinTermsByTypeMention - ,intrinsicTermReferences - ,intrinsicTypeReferences - ,isBuiltinType - ,typeOf - ,typeLookup - ,termRefTypes - ) where - -import Unison.Prelude - -import Data.Bifunctor ( second, first ) -import qualified Data.Map as Map -import qualified Data.Set as Set -import qualified Data.Text as Text -import qualified Text.Regex.TDFA as RE -import Unison.ConstructorReference (GConstructorReference(..)) -import qualified Unison.ConstructorType as CT -import Unison.Codebase.CodeLookup ( CodeLookup(..) ) -import qualified Unison.Builtin.Decls as DD -import qualified Unison.Builtin.Terms as TD -import qualified Unison.DataDeclaration as DD + ( codeLookup, + constructorType, + names, + names0, + builtinDataDecls, + builtinEffectDecls, + builtinConstructorType, + builtinTypeDependents, + builtinTypeDependentsOfComponent, + builtinTypes, + builtinTermsByType, + builtinTermsByTypeMention, + intrinsicTermReferences, + intrinsicTypeReferences, + isBuiltinType, + typeOf, + typeLookup, + termRefTypes, + ) +where + +import Data.Bifunctor (first, second) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Text.Regex.TDFA as RE +import qualified Unison.Builtin.Decls as DD +import qualified Unison.Builtin.Terms as TD +import Unison.Codebase.CodeLookup (CodeLookup (..)) +import Unison.ConstructorReference (GConstructorReference (..)) +import qualified Unison.ConstructorType as CT +import qualified Unison.DataDeclaration as DD import Unison.Hash (Hash) +import qualified Unison.Hashing.V2.Convert as H +import Unison.Name (Name) +import qualified Unison.Name as Name +import Unison.Names (Names (Names)) +import Unison.NamesWithHistory (NamesWithHistory (..)) import Unison.Parser.Ann (Ann (..)) -import qualified Unison.Reference as R -import qualified Unison.Referent as Referent -import Unison.Symbol ( Symbol ) -import qualified Unison.Type as Type -import qualified Unison.Var as Var -import Unison.Name ( Name ) -import qualified Unison.Name as Name -import Unison.NamesWithHistory (NamesWithHistory(..)) -import Unison.Names (Names (Names)) +import Unison.Prelude +import qualified Unison.Reference as R +import qualified Unison.Referent as Referent +import Unison.Symbol (Symbol) +import qualified Unison.Type as Type import qualified Unison.Typechecker.TypeLookup as TL -import qualified Unison.Util.Relation as Rel -import qualified Unison.Hashing.V2.Convert as H +import qualified Unison.Util.Relation as Rel +import qualified Unison.Var as Var type DataDeclaration = DD.DataDeclaration Symbol Ann + type EffectDeclaration = DD.EffectDeclaration Symbol Ann + type Type = Type.Type Symbol () names :: NamesWithHistory names = NamesWithHistory names0 mempty names0 :: Names -names0 = Names terms types where - terms = Rel.mapRan Referent.Ref (Rel.fromMap termNameRefs) <> - Rel.fromList [ (Name.unsafeFromVar vc, Referent.Con (ConstructorReference (R.DerivedId r) cid) ct) - | (ct, (_,(r,decl))) <- ((CT.Data,) <$> builtinDataDecls) <> - ((CT.Effect,) . (second . second) DD.toDataDecl <$> builtinEffectDecls) - , ((_,vc,_), cid) <- DD.constructors' decl `zip` [0..]] <> - Rel.fromList [ (Name.unsafeFromVar v, Referent.Ref (R.DerivedId i)) - | (v,i) <- Map.toList $ TD.builtinTermsRef] - types = Rel.fromList builtinTypes <> - Rel.fromList [ (Name.unsafeFromVar v, R.DerivedId r) - | (v,(r,_)) <- builtinDataDecls ] <> - Rel.fromList [ (Name.unsafeFromVar v, R.DerivedId r) - | (v,(r,_)) <- builtinEffectDecls ] +names0 = Names terms types + where + terms = + Rel.mapRan Referent.Ref (Rel.fromMap termNameRefs) + <> Rel.fromList + [ (Name.unsafeFromVar vc, Referent.Con (ConstructorReference (R.DerivedId r) cid) ct) + | (ct, (_, (r, decl))) <- + ((CT.Data,) <$> builtinDataDecls) + <> ((CT.Effect,) . (second . second) DD.toDataDecl <$> builtinEffectDecls), + ((_, vc, _), cid) <- DD.constructors' decl `zip` [0 ..] + ] + <> Rel.fromList + [ (Name.unsafeFromVar v, Referent.Ref (R.DerivedId i)) + | (v, i) <- Map.toList $ TD.builtinTermsRef + ] + types = + Rel.fromList builtinTypes + <> Rel.fromList + [ (Name.unsafeFromVar v, R.DerivedId r) + | (v, (r, _)) <- builtinDataDecls + ] + <> Rel.fromList + [ (Name.unsafeFromVar v, R.DerivedId r) + | (v, (r, _)) <- builtinEffectDecls + ] -- note: this function is really for deciding whether `r` is a term or type, -- but it can only answer correctly for Builtins. @@ -85,21 +99,22 @@ typeLookup = (Map.fromList . map (first R.DerivedId) $ map snd builtinEffectDecls) constructorType :: R.Reference -> Maybe CT.ConstructorType -constructorType r = TL.constructorType typeLookup r - <|> Map.lookup r builtinConstructorType +constructorType r = + TL.constructorType typeLookup r + <|> Map.lookup r builtinConstructorType builtinDataDecls :: [(Symbol, (R.Id, DataDeclaration))] builtinDataDecls = - [ (v, (r, Intrinsic <$ d)) | (v, r, d) <- DD.builtinDataDecls ] + [(v, (r, Intrinsic <$ d)) | (v, r, d) <- DD.builtinDataDecls] builtinEffectDecls :: [(Symbol, (R.Id, EffectDeclaration))] -builtinEffectDecls = [ (v, (r, Intrinsic <$ d)) | (v, r, d) <- DD.builtinEffectDecls ] +builtinEffectDecls = [(v, (r, Intrinsic <$ d)) | (v, r, d) <- DD.builtinEffectDecls] codeLookup :: Applicative m => CodeLookup Symbol m Ann codeLookup = CodeLookup (const $ pure Nothing) $ \r -> - pure - $ lookup r [ (r, Right x) | (r, x) <- snd <$> builtinDataDecls ] - <|> lookup r [ (r, Left x) | (r, x) <- snd <$> builtinEffectDecls ] + pure $ + lookup r [(r, Right x) | (r, x) <- snd <$> builtinDataDecls] + <|> lookup r [(r, Left x) | (r, x) <- snd <$> builtinEffectDecls] -- Relation predicate: Domain depends on range. builtinDependencies :: Rel.Relation R.Reference R.Reference @@ -109,15 +124,18 @@ builtinDependencies = -- a relation whose domain is types and whose range is builtin terms with that type builtinTermsByType :: Rel.Relation R.Reference Referent.Referent builtinTermsByType = - Rel.fromList [ (H.typeToReference ty, Referent.Ref r) - | (r, ty) <- Map.toList termRefTypes ] + Rel.fromList + [ (H.typeToReference ty, Referent.Ref r) + | (r, ty) <- Map.toList termRefTypes + ] -- a relation whose domain is types and whose range is builtin terms that mention that type -- example: Nat.+ mentions the type `Nat` builtinTermsByTypeMention :: Rel.Relation R.Reference Referent.Referent builtinTermsByTypeMention = - Rel.fromList [ (m, Referent.Ref r) | (r, ty) <- Map.toList termRefTypes - , m <- toList $ H.typeToReferenceMentions ty ] + Rel.fromList + [ (m, Referent.Ref r) | (r, ty) <- Map.toList termRefTypes, m <- toList $ H.typeToReferenceMentions ty + ] -- The dependents of a builtin type is the set of builtin terms which -- mention that type. @@ -137,96 +155,119 @@ builtinTypeDependentsOfComponent h0 = Rel.searchRan ord builtinDependencies -- As with the terms, we should avoid changing these references, even -- if we decide to change their names. builtinTypes :: [(Name, R.Reference)] -builtinTypes = Map.toList . Map.mapKeys Name.unsafeFromText - $ foldl' go mempty builtinTypesSrc where - go m = \case - B' r _ -> Map.insert r (R.Builtin r) m - D' r -> Map.insert r (R.Builtin r) m - Rename' r name -> case Map.lookup name m of - Just _ -> error . Text.unpack $ - "tried to rename `" <> r <> "` to `" <> name <> "`, " <> - "which already exists." - Nothing -> case Map.lookup r m of - Nothing -> error . Text.unpack $ - "tried to rename `" <> r <> "` before it was declared." - Just t -> Map.insert name t . Map.delete r $ m - Alias' r name -> case Map.lookup name m of - Just _ -> error . Text.unpack $ - "tried to alias `" <> r <> "` to `" <> name <> "`, " <> - "which already exists." - Nothing -> case Map.lookup r m of - Nothing -> error . Text.unpack $ - "tried to alias `" <> r <> "` before it was declared." - Just t -> Map.insert name t m +builtinTypes = + Map.toList . Map.mapKeys Name.unsafeFromText $ + foldl' go mempty builtinTypesSrc + where + go m = \case + B' r _ -> Map.insert r (R.Builtin r) m + D' r -> Map.insert r (R.Builtin r) m + Rename' r name -> case Map.lookup name m of + Just _ -> + error . Text.unpack $ + "tried to rename `" <> r <> "` to `" <> name <> "`, " + <> "which already exists." + Nothing -> case Map.lookup r m of + Nothing -> + error . Text.unpack $ + "tried to rename `" <> r <> "` before it was declared." + Just t -> Map.insert name t . Map.delete r $ m + Alias' r name -> case Map.lookup name m of + Just _ -> + error . Text.unpack $ + "tried to alias `" <> r <> "` to `" <> name <> "`, " + <> "which already exists." + Nothing -> case Map.lookup r m of + Nothing -> + error . Text.unpack $ + "tried to alias `" <> r <> "` before it was declared." + Just t -> Map.insert name t m -- WARNING: Don't delete any of these lines, only add corrections. builtinTypesSrc :: [BuiltinTypeDSL] builtinTypesSrc = - [ B' "Int" CT.Data - , B' "Nat" CT.Data - , B' "Float" CT.Data - , B' "Boolean" CT.Data - , B' "Sequence" CT.Data, Rename' "Sequence" "List" - , B' "Text" CT.Data - , B' "Char" CT.Data - , B' "Effect" CT.Data, Rename' "Effect" "Request" - , B' "Bytes" CT.Data - , B' "Link.Term" CT.Data - , B' "Link.Type" CT.Data - , B' "IO" CT.Effect, Rename' "IO" "io2.IO" - , B' "Handle" CT.Data, Rename' "Handle" "io2.Handle" - , B' "Socket" CT.Data, Rename' "Socket" "io2.Socket" - , B' "ThreadId" CT.Data, Rename' "ThreadId" "io2.ThreadId" - , B' "MVar" CT.Data, Rename' "MVar" "io2.MVar" - , B' "Code" CT.Data - , B' "Value" CT.Data - , B' "Any" CT.Data - , B' "crypto.HashAlgorithm" CT.Data - , B' "Tls" CT.Data, Rename' "Tls" "io2.Tls" - , B' "Tls.ClientConfig" CT.Data, Rename' "Tls.ClientConfig" "io2.Tls.ClientConfig" - , B' "Tls.ServerConfig" CT.Data, Rename' "Tls.ServerConfig" "io2.Tls.ServerConfig" - , B' "Tls.SignedCert" CT.Data, Rename' "Tls.SignedCert" "io2.Tls.SignedCert" - , B' "Tls.PrivateKey" CT.Data, Rename' "Tls.PrivateKey" "io2.Tls.PrivateKey" - , B' "Tls.Version" CT.Data, Rename' "Tls.Version" "io2.Tls.Version" - , B' "Tls.Cipher" CT.Data, Rename' "Tls.Cipher" "io2.Tls.Cipher" - , B' "TVar" CT.Data, Rename' "TVar" "io2.TVar" - , B' "STM" CT.Effect, Rename' "STM" "io2.STM" - , B' "Ref" CT.Data - , B' "Scope" CT.Effect + [ B' "Int" CT.Data, + B' "Nat" CT.Data, + B' "Float" CT.Data, + B' "Boolean" CT.Data, + B' "Sequence" CT.Data, + Rename' "Sequence" "List", + B' "Text" CT.Data, + B' "Char" CT.Data, + B' "Effect" CT.Data, + Rename' "Effect" "Request", + B' "Bytes" CT.Data, + B' "Link.Term" CT.Data, + B' "Link.Type" CT.Data, + B' "IO" CT.Effect, + Rename' "IO" "io2.IO", + B' "Handle" CT.Data, + Rename' "Handle" "io2.Handle", + B' "Socket" CT.Data, + Rename' "Socket" "io2.Socket", + B' "ThreadId" CT.Data, + Rename' "ThreadId" "io2.ThreadId", + B' "MVar" CT.Data, + Rename' "MVar" "io2.MVar", + B' "Code" CT.Data, + B' "Value" CT.Data, + B' "Any" CT.Data, + B' "crypto.HashAlgorithm" CT.Data, + B' "Tls" CT.Data, + Rename' "Tls" "io2.Tls", + B' "Tls.ClientConfig" CT.Data, + Rename' "Tls.ClientConfig" "io2.Tls.ClientConfig", + B' "Tls.ServerConfig" CT.Data, + Rename' "Tls.ServerConfig" "io2.Tls.ServerConfig", + B' "Tls.SignedCert" CT.Data, + Rename' "Tls.SignedCert" "io2.Tls.SignedCert", + B' "Tls.PrivateKey" CT.Data, + Rename' "Tls.PrivateKey" "io2.Tls.PrivateKey", + B' "Tls.Version" CT.Data, + Rename' "Tls.Version" "io2.Tls.Version", + B' "Tls.Cipher" CT.Data, + Rename' "Tls.Cipher" "io2.Tls.Cipher", + B' "TVar" CT.Data, + Rename' "TVar" "io2.TVar", + B' "STM" CT.Effect, + Rename' "STM" "io2.STM", + B' "Ref" CT.Data, + B' "Scope" CT.Effect, + B' "TimeSpec" CT.Data, + Rename' "TimeSpec" "io2.Clock.internals.TimeSpec" ] -- rename these to "builtin" later, when builtin means intrinsic as opposed to -- stuff that intrinsics depend on. intrinsicTypeReferences :: Set R.Reference -intrinsicTypeReferences = foldl' go mempty builtinTypesSrc where - go acc = \case - B' r _ -> Set.insert (R.Builtin r) acc - D' r -> Set.insert (R.Builtin r) acc - _ -> acc +intrinsicTypeReferences = foldl' go mempty builtinTypesSrc + where + go acc = \case + B' r _ -> Set.insert (R.Builtin r) acc + D' r -> Set.insert (R.Builtin r) acc + _ -> acc intrinsicTermReferences :: Set R.Reference intrinsicTermReferences = Map.keysSet termRefTypes builtinConstructorType :: Map R.Reference CT.ConstructorType -builtinConstructorType = Map.fromList [ (R.Builtin r, ct) | B' r ct <- builtinTypesSrc ] +builtinConstructorType = Map.fromList [(R.Builtin r, ct) | B' r ct <- builtinTypesSrc] data BuiltinTypeDSL = B' Text CT.ConstructorType | D' Text | Rename' Text Text | Alias' Text Text - data BuiltinDSL - -- simple builtin: name=ref, type - = B Text Type - -- deprecated builtin: name=ref, type (TBD) - | D Text Type - -- rename builtin: refname, newname - -- must not appear before corresponding B/D - -- will overwrite newname - | Rename Text Text - -- alias builtin: refname, newname - -- must not appear before corresponding B/D - -- will overwrite newname - | Alias Text Text - + = -- simple builtin: name=ref, type + B Text Type + | -- deprecated builtin: name=ref, type (TBD) + D Text Type + | -- rename builtin: refname, newname + -- must not appear before corresponding B/D + -- will overwrite newname + Rename Text Text + | -- alias builtin: refname, newname + -- must not appear before corresponding B/D + -- will overwrite newname + Alias Text Text instance Show BuiltinDSL where show (B t _) = Text.unpack $ "B" <> t @@ -234,292 +275,283 @@ instance Show BuiltinDSL where show _ = "" termNameRefs :: Map Name R.Reference -termNameRefs = Map.mapKeys Name.unsafeFromText $ foldl' go mempty (stripVersion builtinsSrc) where - go m = \case - B r _tp -> Map.insert r (R.Builtin r) m - D r _tp -> Map.insert r (R.Builtin r) m - Rename r name -> case Map.lookup name m of - Just _ -> error . Text.unpack $ - "tried to rename `" <> r <> "` to `" <> name <> "`, " <> - "which already exists." - Nothing -> case Map.lookup r m of - Nothing -> error . Text.unpack $ - "tried to rename `" <> r <> "` before it was declared." - Just t -> Map.insert name t . Map.delete r $ m - Alias r name -> case Map.lookup name m of - Just _ -> error . Text.unpack $ - "tried to alias `" <> r <> "` to `" <> name <> "`, " <> - "which already exists." - Nothing -> case Map.lookup r m of - Nothing -> error . Text.unpack $ - "tried to alias `" <> r <> "` before it was declared." - Just t -> Map.insert name t m +termNameRefs = Map.mapKeys Name.unsafeFromText $ foldl' go mempty (stripVersion builtinsSrc) + where + go m = \case + B r _tp -> Map.insert r (R.Builtin r) m + D r _tp -> Map.insert r (R.Builtin r) m + Rename r name -> case Map.lookup name m of + Just _ -> + error . Text.unpack $ + "tried to rename `" <> r <> "` to `" <> name <> "`, " + <> "which already exists." + Nothing -> case Map.lookup r m of + Nothing -> + error . Text.unpack $ + "tried to rename `" <> r <> "` before it was declared." + Just t -> Map.insert name t . Map.delete r $ m + Alias r name -> case Map.lookup name m of + Just _ -> + error . Text.unpack $ + "tried to alias `" <> r <> "` to `" <> name <> "`, " + <> "which already exists." + Nothing -> case Map.lookup r m of + Nothing -> + error . Text.unpack $ + "tried to alias `" <> r <> "` before it was declared." + Just t -> Map.insert name t m termRefTypes :: Map R.Reference Type -termRefTypes = foldl' go mempty builtinsSrc where - go m = \case - B r t -> Map.insert (R.Builtin r) t m - D r t -> Map.insert (R.Builtin r) t m - _ -> m +termRefTypes = foldl' go mempty builtinsSrc + where + go m = \case + B r t -> Map.insert (R.Builtin r) t m + D r t -> Map.insert (R.Builtin r) t m + _ -> m typeOf :: a -> (Type -> a) -> R.Reference -> a typeOf a f r = maybe a f (Map.lookup r termRefTypes) builtinsSrc :: [BuiltinDSL] builtinsSrc = - [ B "Any.unsafeExtract" $ forall1 "a" (\a -> anyt --> a) - , B "Int.+" $ int --> int --> int - , B "Int.-" $ int --> int --> int - , B "Int.*" $ int --> int --> int - , B "Int./" $ int --> int --> int - , B "Int.<" $ int --> int --> boolean - , B "Int.>" $ int --> int --> boolean - , B "Int.<=" $ int --> int --> boolean - , B "Int.>=" $ int --> int --> boolean - , B "Int.==" $ int --> int --> boolean - , B "Int.and" $ int --> int --> int - , B "Int.or" $ int --> int --> int - , B "Int.xor" $ int --> int --> int - , B "Int.complement" $ int --> int - , B "Int.increment" $ int --> int - , B "Int.isEven" $ int --> boolean - , B "Int.isOdd" $ int --> boolean - , B "Int.signum" $ int --> int - , B "Int.leadingZeros" $ int --> nat - , B "Int.negate" $ int --> int - , B "Int.mod" $ int --> int --> int - , B "Int.pow" $ int --> nat --> int - , B "Int.shiftLeft" $ int --> nat --> int - , B "Int.shiftRight" $ int --> nat --> int - , B "Int.truncate0" $ int --> nat - , B "Int.toText" $ int --> text - , B "Int.fromText" $ text --> optionalt int - , B "Int.toFloat" $ int --> float - , B "Int.trailingZeros" $ int --> nat - , B "Int.popCount" $ int --> nat - , B "Int.fromRepresentation" $ nat --> int - , B "Int.toRepresentation" $ int --> nat - - , B "Nat.*" $ nat --> nat --> nat - , B "Nat.+" $ nat --> nat --> nat - , B "Nat./" $ nat --> nat --> nat - , B "Nat.<" $ nat --> nat --> boolean - , B "Nat.<=" $ nat --> nat --> boolean - , B "Nat.==" $ nat --> nat --> boolean - , B "Nat.>" $ nat --> nat --> boolean - , B "Nat.>=" $ nat --> nat --> boolean - , B "Nat.and" $ nat --> nat --> nat - , B "Nat.or" $ nat --> nat --> nat - , B "Nat.xor" $ nat --> nat --> nat - , B "Nat.complement" $ nat --> nat - , B "Nat.drop" $ nat --> nat --> nat - , B "Nat.fromText" $ text --> optionalt nat - , B "Nat.increment" $ nat --> nat - , B "Nat.isEven" $ nat --> boolean - , B "Nat.isOdd" $ nat --> boolean - , B "Nat.leadingZeros" $ nat --> nat - , B "Nat.mod" $ nat --> nat --> nat - , B "Nat.pow" $ nat --> nat --> nat - , B "Nat.shiftLeft" $ nat --> nat --> nat - , B "Nat.shiftRight" $ nat --> nat --> nat - , B "Nat.sub" $ nat --> nat --> int - , B "Nat.toFloat" $ nat --> float - , B "Nat.toInt" $ nat --> int - , B "Nat.toText" $ nat --> text - , B "Nat.trailingZeros" $ nat --> nat - , B "Nat.popCount" $ nat --> nat - - , B "Bytes.decodeNat64be" $ bytes --> optionalt (tuple [nat, bytes]) - , B "Bytes.decodeNat64le" $ bytes --> optionalt (tuple [nat, bytes]) - , B "Bytes.decodeNat32be" $ bytes --> optionalt (tuple [nat, bytes]) - , B "Bytes.decodeNat32le" $ bytes --> optionalt (tuple [nat, bytes]) - , B "Bytes.decodeNat16be" $ bytes --> optionalt (tuple [nat, bytes]) - , B "Bytes.decodeNat16le" $ bytes --> optionalt (tuple [nat, bytes]) - - , B "Bytes.encodeNat64be" $ nat --> bytes - , B "Bytes.encodeNat64le" $ nat --> bytes - , B "Bytes.encodeNat32be" $ nat --> bytes - , B "Bytes.encodeNat32le" $ nat --> bytes - , B "Bytes.encodeNat16be" $ nat --> bytes - , B "Bytes.encodeNat16le" $ nat --> bytes - - , B "Float.+" $ float --> float --> float - , B "Float.-" $ float --> float --> float - , B "Float.*" $ float --> float --> float - , B "Float./" $ float --> float --> float - , B "Float.<" $ float --> float --> boolean - , B "Float.>" $ float --> float --> boolean - , B "Float.<=" $ float --> float --> boolean - , B "Float.>=" $ float --> float --> boolean - , B "Float.==" $ float --> float --> boolean - , B "Float.fromRepresentation" $ nat --> float - , B "Float.toRepresentation" $ float --> nat - - -- Trigonmetric Functions - , B "Float.acos" $ float --> float - , B "Float.asin" $ float --> float - , B "Float.atan" $ float --> float - , B "Float.atan2" $ float --> float --> float - , B "Float.cos" $ float --> float - , B "Float.sin" $ float --> float - , B "Float.tan" $ float --> float - - -- Hyperbolic Functions - , B "Float.acosh" $ float --> float - , B "Float.asinh" $ float --> float - , B "Float.atanh" $ float --> float - , B "Float.cosh" $ float --> float - , B "Float.sinh" $ float --> float - , B "Float.tanh" $ float --> float - - -- Exponential Functions - , B "Float.exp" $ float --> float - , B "Float.log" $ float --> float - , B "Float.logBase" $ float --> float --> float - - -- Power Functions - , B "Float.pow" $ float --> float --> float - , B "Float.sqrt" $ float --> float - - -- Rounding and Remainder Functions - , B "Float.ceiling" $ float --> int - , B "Float.floor" $ float --> int - , B "Float.round" $ float --> int - , B "Float.truncate" $ float --> int - - -- Float Utils - , B "Float.abs" $ float --> float - , B "Float.max" $ float --> float --> float - , B "Float.min" $ float --> float --> float - , B "Float.toText" $ float --> text - , B "Float.fromText" $ text --> optionalt float - - , B "Universal.==" $ forall1 "a" (\a -> a --> a --> boolean) - -- Don't we want a Universal.!= ? - - -- Universal.compare intended as a low level function that just returns - -- `Int` rather than some Ordering data type. If we want, later, - -- could provide a pure Unison wrapper for Universal.compare that - -- returns a proper data type. - -- - -- 0 is equal, < 0 is less than, > 0 is greater than - , B "Universal.compare" $ forall1 "a" (\a -> a --> a --> int) - , B "Universal.>" $ forall1 "a" (\a -> a --> a --> boolean) - , B "Universal.<" $ forall1 "a" (\a -> a --> a --> boolean) - , B "Universal.>=" $ forall1 "a" (\a -> a --> a --> boolean) - , B "Universal.<=" $ forall1 "a" (\a -> a --> a --> boolean) - - , B "bug" $ forall1 "a" (\a -> forall1 "b" (\b -> a --> b)) - , B "todo" $ forall1 "a" (\a -> forall1 "b" (\b -> a --> b)) - , B "Any.Any" $ forall1 "a" (\a -> a --> anyt) - - , B "Boolean.not" $ boolean --> boolean - - , B "Text.empty" text - , B "Text.++" $ text --> text --> text - , B "Text.take" $ nat --> text --> text - , B "Text.drop" $ nat --> text --> text - , B "Text.size" $ text --> nat - , B "Text.repeat" $ nat --> text --> text - , B "Text.==" $ text --> text --> boolean - , D "Text.!=" $ text --> text --> boolean - , B "Text.<=" $ text --> text --> boolean - , B "Text.>=" $ text --> text --> boolean - , B "Text.<" $ text --> text --> boolean - , B "Text.>" $ text --> text --> boolean - , B "Text.uncons" $ text --> optionalt (tuple [char, text]) - , B "Text.unsnoc" $ text --> optionalt (tuple [text, char]) - , B "Text.toCharList" $ text --> list char - , B "Text.fromCharList" $ list char --> text - , B "Text.toUtf8" $ text --> bytes - , B "Text.fromUtf8.impl.v3" $ bytes --> eithert failure text - , B "Char.toNat" $ char --> nat - , B "Char.toText" $ char --> text - , B "Char.fromNat" $ nat --> char - - , B "Bytes.empty" bytes - , B "Bytes.fromList" $ list nat --> bytes - , B "Bytes.++" $ bytes --> bytes --> bytes - , B "Bytes.take" $ nat --> bytes --> bytes - , B "Bytes.drop" $ nat --> bytes --> bytes - , B "Bytes.at" $ nat --> bytes --> optionalt nat - , B "Bytes.toList" $ bytes --> list nat - , B "Bytes.size" $ bytes --> nat - , B "Bytes.flatten" $ bytes --> bytes - - , B "Bytes.zlib.compress" $ bytes --> bytes - , B "Bytes.zlib.decompress" $ bytes --> eithert text bytes - , B "Bytes.gzip.compress" $ bytes --> bytes - , B "Bytes.gzip.decompress" $ bytes --> eithert text bytes - - {- These are all `Bytes -> Bytes`, rather than `Bytes -> Text`. - This is intentional: it avoids a round trip to `Text` if all - you are doing with the bytes is dumping them to a file or a - network socket. - - You can always `Text.fromUtf8` the results of these functions - to get some `Text`. - -} - , B "Bytes.toBase16" $ bytes --> bytes - , B "Bytes.toBase32" $ bytes --> bytes - , B "Bytes.toBase64" $ bytes --> bytes - , B "Bytes.toBase64UrlUnpadded" $ bytes --> bytes - - , B "Bytes.fromBase16" $ bytes --> eithert text bytes - , B "Bytes.fromBase32" $ bytes --> eithert text bytes - , B "Bytes.fromBase64" $ bytes --> eithert text bytes - , B "Bytes.fromBase64UrlUnpadded" $ bytes --> eithert text bytes - - , D "List.empty" $ forall1 "a" list - , B "List.cons" $ forall1 "a" (\a -> a --> list a --> list a) - , Alias "List.cons" "List.+:" - , B "List.snoc" $ forall1 "a" (\a -> list a --> a --> list a) - , Alias "List.snoc" "List.:+" - , B "List.take" $ forall1 "a" (\a -> nat --> list a --> list a) - , B "List.drop" $ forall1 "a" (\a -> nat --> list a --> list a) - , B "List.++" $ forall1 "a" (\a -> list a --> list a --> list a) - , B "List.size" $ forall1 "a" (\a -> list a --> nat) - , B "List.at" $ forall1 "a" (\a -> nat --> list a --> optionalt a) - , B "Socket.toText" $ socket --> text - , B "Handle.toText" $ handle --> text - , B "ThreadId.toText" $ threadId --> text - - , B "Debug.watch" $ forall1 "a" (\a -> text --> a --> a) - , B "Debug.trace" $ forall1 "a" (\a -> text --> a --> unit) - , B "unsafe.coerceAbilities" $ + [ B "Any.unsafeExtract" $ forall1 "a" (\a -> anyt --> a), + B "Int.+" $ int --> int --> int, + B "Int.-" $ int --> int --> int, + B "Int.*" $ int --> int --> int, + B "Int./" $ int --> int --> int, + B "Int.<" $ int --> int --> boolean, + B "Int.>" $ int --> int --> boolean, + B "Int.<=" $ int --> int --> boolean, + B "Int.>=" $ int --> int --> boolean, + B "Int.==" $ int --> int --> boolean, + B "Int.and" $ int --> int --> int, + B "Int.or" $ int --> int --> int, + B "Int.xor" $ int --> int --> int, + B "Int.complement" $ int --> int, + B "Int.increment" $ int --> int, + B "Int.isEven" $ int --> boolean, + B "Int.isOdd" $ int --> boolean, + B "Int.signum" $ int --> int, + B "Int.leadingZeros" $ int --> nat, + B "Int.negate" $ int --> int, + B "Int.mod" $ int --> int --> int, + B "Int.pow" $ int --> nat --> int, + B "Int.shiftLeft" $ int --> nat --> int, + B "Int.shiftRight" $ int --> nat --> int, + B "Int.truncate0" $ int --> nat, + B "Int.toText" $ int --> text, + B "Int.fromText" $ text --> optionalt int, + B "Int.toFloat" $ int --> float, + B "Int.trailingZeros" $ int --> nat, + B "Int.popCount" $ int --> nat, + B "Int.fromRepresentation" $ nat --> int, + B "Int.toRepresentation" $ int --> nat, + B "Nat.*" $ nat --> nat --> nat, + B "Nat.+" $ nat --> nat --> nat, + B "Nat./" $ nat --> nat --> nat, + B "Nat.<" $ nat --> nat --> boolean, + B "Nat.<=" $ nat --> nat --> boolean, + B "Nat.==" $ nat --> nat --> boolean, + B "Nat.>" $ nat --> nat --> boolean, + B "Nat.>=" $ nat --> nat --> boolean, + B "Nat.and" $ nat --> nat --> nat, + B "Nat.or" $ nat --> nat --> nat, + B "Nat.xor" $ nat --> nat --> nat, + B "Nat.complement" $ nat --> nat, + B "Nat.drop" $ nat --> nat --> nat, + B "Nat.fromText" $ text --> optionalt nat, + B "Nat.increment" $ nat --> nat, + B "Nat.isEven" $ nat --> boolean, + B "Nat.isOdd" $ nat --> boolean, + B "Nat.leadingZeros" $ nat --> nat, + B "Nat.mod" $ nat --> nat --> nat, + B "Nat.pow" $ nat --> nat --> nat, + B "Nat.shiftLeft" $ nat --> nat --> nat, + B "Nat.shiftRight" $ nat --> nat --> nat, + B "Nat.sub" $ nat --> nat --> int, + B "Nat.toFloat" $ nat --> float, + B "Nat.toInt" $ nat --> int, + B "Nat.toText" $ nat --> text, + B "Nat.trailingZeros" $ nat --> nat, + B "Nat.popCount" $ nat --> nat, + B "Bytes.decodeNat64be" $ bytes --> optionalt (tuple [nat, bytes]), + B "Bytes.decodeNat64le" $ bytes --> optionalt (tuple [nat, bytes]), + B "Bytes.decodeNat32be" $ bytes --> optionalt (tuple [nat, bytes]), + B "Bytes.decodeNat32le" $ bytes --> optionalt (tuple [nat, bytes]), + B "Bytes.decodeNat16be" $ bytes --> optionalt (tuple [nat, bytes]), + B "Bytes.decodeNat16le" $ bytes --> optionalt (tuple [nat, bytes]), + B "Bytes.encodeNat64be" $ nat --> bytes, + B "Bytes.encodeNat64le" $ nat --> bytes, + B "Bytes.encodeNat32be" $ nat --> bytes, + B "Bytes.encodeNat32le" $ nat --> bytes, + B "Bytes.encodeNat16be" $ nat --> bytes, + B "Bytes.encodeNat16le" $ nat --> bytes, + B "Float.+" $ float --> float --> float, + B "Float.-" $ float --> float --> float, + B "Float.*" $ float --> float --> float, + B "Float./" $ float --> float --> float, + B "Float.<" $ float --> float --> boolean, + B "Float.>" $ float --> float --> boolean, + B "Float.<=" $ float --> float --> boolean, + B "Float.>=" $ float --> float --> boolean, + B "Float.==" $ float --> float --> boolean, + B "Float.fromRepresentation" $ nat --> float, + B "Float.toRepresentation" $ float --> nat, + -- Trigonmetric Functions + B "Float.acos" $ float --> float, + B "Float.asin" $ float --> float, + B "Float.atan" $ float --> float, + B "Float.atan2" $ float --> float --> float, + B "Float.cos" $ float --> float, + B "Float.sin" $ float --> float, + B "Float.tan" $ float --> float, + -- Hyperbolic Functions + B "Float.acosh" $ float --> float, + B "Float.asinh" $ float --> float, + B "Float.atanh" $ float --> float, + B "Float.cosh" $ float --> float, + B "Float.sinh" $ float --> float, + B "Float.tanh" $ float --> float, + -- Exponential Functions + B "Float.exp" $ float --> float, + B "Float.log" $ float --> float, + B "Float.logBase" $ float --> float --> float, + -- Power Functions + B "Float.pow" $ float --> float --> float, + B "Float.sqrt" $ float --> float, + -- Rounding and Remainder Functions + B "Float.ceiling" $ float --> int, + B "Float.floor" $ float --> int, + B "Float.round" $ float --> int, + B "Float.truncate" $ float --> int, + -- Float Utils + B "Float.abs" $ float --> float, + B "Float.max" $ float --> float --> float, + B "Float.min" $ float --> float --> float, + B "Float.toText" $ float --> text, + B "Float.fromText" $ text --> optionalt float, + B "Universal.==" $ forall1 "a" (\a -> a --> a --> boolean), + -- Don't we want a Universal.!= ? + + -- Universal.compare intended as a low level function that just returns + -- `Int` rather than some Ordering data type. If we want, later, + -- could provide a pure Unison wrapper for Universal.compare that + -- returns a proper data type. + -- + -- 0 is equal, < 0 is less than, > 0 is greater than + B "Universal.compare" $ forall1 "a" (\a -> a --> a --> int), + B "Universal.>" $ forall1 "a" (\a -> a --> a --> boolean), + B "Universal.<" $ forall1 "a" (\a -> a --> a --> boolean), + B "Universal.>=" $ forall1 "a" (\a -> a --> a --> boolean), + B "Universal.<=" $ forall1 "a" (\a -> a --> a --> boolean), + B "bug" $ forall1 "a" (\a -> forall1 "b" (\b -> a --> b)), + B "todo" $ forall1 "a" (\a -> forall1 "b" (\b -> a --> b)), + B "Any.Any" $ forall1 "a" (\a -> a --> anyt), + B "Boolean.not" $ boolean --> boolean, + B "Text.empty" text, + B "Text.++" $ text --> text --> text, + B "Text.take" $ nat --> text --> text, + B "Text.drop" $ nat --> text --> text, + B "Text.size" $ text --> nat, + B "Text.repeat" $ nat --> text --> text, + B "Text.==" $ text --> text --> boolean, + D "Text.!=" $ text --> text --> boolean, + B "Text.<=" $ text --> text --> boolean, + B "Text.>=" $ text --> text --> boolean, + B "Text.<" $ text --> text --> boolean, + B "Text.>" $ text --> text --> boolean, + B "Text.uncons" $ text --> optionalt (tuple [char, text]), + B "Text.unsnoc" $ text --> optionalt (tuple [text, char]), + B "Text.toCharList" $ text --> list char, + B "Text.fromCharList" $ list char --> text, + B "Text.toUtf8" $ text --> bytes, + B "Text.fromUtf8.impl.v3" $ bytes --> eithert failure text, + B "Char.toNat" $ char --> nat, + B "Char.toText" $ char --> text, + B "Char.fromNat" $ nat --> char, + B "Bytes.empty" bytes, + B "Bytes.fromList" $ list nat --> bytes, + B "Bytes.++" $ bytes --> bytes --> bytes, + B "Bytes.take" $ nat --> bytes --> bytes, + B "Bytes.drop" $ nat --> bytes --> bytes, + B "Bytes.at" $ nat --> bytes --> optionalt nat, + B "Bytes.toList" $ bytes --> list nat, + B "Bytes.size" $ bytes --> nat, + B "Bytes.flatten" $ bytes --> bytes, + B "Bytes.zlib.compress" $ bytes --> bytes, + B "Bytes.zlib.decompress" $ bytes --> eithert text bytes, + B "Bytes.gzip.compress" $ bytes --> bytes, + B "Bytes.gzip.decompress" $ bytes --> eithert text bytes, + {- These are all `Bytes -> Bytes`, rather than `Bytes -> Text`. + This is intentional: it avoids a round trip to `Text` if all + you are doing with the bytes is dumping them to a file or a + network socket. + + You can always `Text.fromUtf8` the results of these functions + to get some `Text`. + -} + B "Bytes.toBase16" $ bytes --> bytes, + B "Bytes.toBase32" $ bytes --> bytes, + B "Bytes.toBase64" $ bytes --> bytes, + B "Bytes.toBase64UrlUnpadded" $ bytes --> bytes, + B "Bytes.fromBase16" $ bytes --> eithert text bytes, + B "Bytes.fromBase32" $ bytes --> eithert text bytes, + B "Bytes.fromBase64" $ bytes --> eithert text bytes, + B "Bytes.fromBase64UrlUnpadded" $ bytes --> eithert text bytes, + D "List.empty" $ forall1 "a" list, + B "List.cons" $ forall1 "a" (\a -> a --> list a --> list a), + Alias "List.cons" "List.+:", + B "List.snoc" $ forall1 "a" (\a -> list a --> a --> list a), + Alias "List.snoc" "List.:+", + B "List.take" $ forall1 "a" (\a -> nat --> list a --> list a), + B "List.drop" $ forall1 "a" (\a -> nat --> list a --> list a), + B "List.++" $ forall1 "a" (\a -> list a --> list a --> list a), + B "List.size" $ forall1 "a" (\a -> list a --> nat), + B "List.at" $ forall1 "a" (\a -> nat --> list a --> optionalt a), + B "Socket.toText" $ socket --> text, + B "Handle.toText" $ handle --> text, + B "ThreadId.toText" $ threadId --> text, + B "Debug.watch" $ forall1 "a" (\a -> text --> a --> a), + B "Debug.trace" $ forall1 "a" (\a -> text --> a --> unit), + B "unsafe.coerceAbilities" $ forall4 "a" "b" "e1" "e2" $ \a b e1 e2 -> - (a --> Type.effect1 () e1 b) --> (a --> Type.effect1 () e2 b) - , B "Scope.run" . forall2 "r" "g" $ \r g -> - (forall1 "s" $ \s -> unit --> Type.effect () [scopet s, g] r) --> Type.effect1 () g r - , B "Scope.ref" . forall2 "a" "s" $ \a s -> - a --> Type.effect1 () (scopet s) (reft (Type.effects () [scopet s]) a) - , B "Ref.read" . forall2 "a" "g" $ \a g -> - reft g a --> Type.effect1 () g a - , B "Ref.write" . forall2 "a" "g" $ \a g -> + (a --> Type.effect1 () e1 b) --> (a --> Type.effect1 () e2 b), + B "Scope.run" . forall2 "r" "g" $ \r g -> + (forall1 "s" $ \s -> unit --> Type.effect () [scopet s, g] r) --> Type.effect1 () g r, + B "Scope.ref" . forall2 "a" "s" $ \a s -> + a --> Type.effect1 () (scopet s) (reft (Type.effects () [scopet s]) a), + B "Ref.read" . forall2 "a" "g" $ \a g -> + reft g a --> Type.effect1 () g a, + B "Ref.write" . forall2 "a" "g" $ \a g -> reft g a --> a --> Type.effect1 () g unit - ] ++ - -- avoid name conflicts with Universal == < > <= >= - [ Rename (t <> "." <> old) (t <> "." <> new) - | t <- ["Int", "Nat", "Float", "Text"] - , (old, new) <- [("==", "eq") - ,("<" , "lt") - ,("<=", "lteq") - ,(">" , "gt") - ,(">=", "gteq")] - ] ++ moveUnder "io2" ioBuiltins + ] + ++ + -- avoid name conflicts with Universal == < > <= >= + [ Rename (t <> "." <> old) (t <> "." <> new) + | t <- ["Int", "Nat", "Float", "Text"], + (old, new) <- + [ ("==", "eq"), + ("<", "lt"), + ("<=", "lteq"), + (">", "gt"), + (">=", "gteq") + ] + ] + ++ moveUnder "io2" ioBuiltins ++ moveUnder "io2" mvarBuiltins ++ moveUnder "io2" stmBuiltins ++ hashBuiltins ++ fmap (uncurry B) codeBuiltins moveUnder :: Text -> [(Text, Type)] -> [BuiltinDSL] -moveUnder prefix bs = bs >>= \(n,ty) -> [B n ty, Rename n (prefix <> "." <> n)] +moveUnder prefix bs = bs >>= \(n, ty) -> [B n ty, Rename n (prefix <> "." <> n)] -- builtins which have a version appended to their name (like the .v2 in IO.putBytes.v2) -- Should be renamed to not have the version suffix stripVersion :: [BuiltinDSL] -> [BuiltinDSL] stripVersion bs = - bs >>= rename where + bs >>= rename + where rename :: BuiltinDSL -> [BuiltinDSL] rename o@(B n _) = renameB o $ RE.matchOnceText regex n rename o@(Rename _ _) = [renameRename o] @@ -539,9 +571,10 @@ stripVersion bs = -- and would be become: -- [ B IO.putBytes.v2 _, Rename IO.putBytes.v2 IO.putBytes, Rename IO.putBytes io2.IO.putBytes ] renameRename :: BuiltinDSL -> BuiltinDSL - renameRename (Rename before1 before2) = let after1 = renamed before1 (RE.matchOnceText regex before1) - after2 = renamed before2 (RE.matchOnceText regex before2) in - Rename after1 after2 + renameRename (Rename before1 before2) = + let after1 = renamed before1 (RE.matchOnceText regex before1) + after2 = renamed before2 (RE.matchOnceText regex before2) + in Rename after1 after2 renameRename x = x renamed :: Text -> Maybe (Text, RE.MatchText Text, Text) -> Text @@ -551,166 +584,177 @@ stripVersion bs = r :: String r = "\\.v[0-9]+" regex :: RE.Regex - regex = RE.makeRegexOpts (RE.defaultCompOpt { RE.caseSensitive = False }) RE.defaultExecOpt r + regex = RE.makeRegexOpts (RE.defaultCompOpt {RE.caseSensitive = False}) RE.defaultExecOpt r hashBuiltins :: [BuiltinDSL] hashBuiltins = - [ B "crypto.hash" $ forall1 "a" (\a -> hashAlgo --> a --> bytes) - , B "crypto.hashBytes" $ hashAlgo --> bytes --> bytes - , B "crypto.hmac" $ forall1 "a" (\a -> hashAlgo --> bytes --> a --> bytes) - , B "crypto.hmacBytes" $ hashAlgo --> bytes --> bytes --> bytes - ] ++ - map h [ "Sha3_512", "Sha3_256", "Sha2_512", "Sha2_256", "Blake2b_512", "Blake2b_256", "Blake2s_256" ] + [ B "crypto.hash" $ forall1 "a" (\a -> hashAlgo --> a --> bytes), + B "crypto.hashBytes" $ hashAlgo --> bytes --> bytes, + B "crypto.hmac" $ forall1 "a" (\a -> hashAlgo --> bytes --> a --> bytes), + B "crypto.hmacBytes" $ hashAlgo --> bytes --> bytes --> bytes + ] + ++ map h ["Sha3_512", "Sha3_256", "Sha2_512", "Sha2_256", "Blake2b_512", "Blake2b_256", "Blake2s_256"] where - hashAlgo = Type.ref() Type.hashAlgorithmRef - h name = B ("crypto.HashAlgorithm."<>name) hashAlgo + hashAlgo = Type.ref () Type.hashAlgorithmRef + h name = B ("crypto.HashAlgorithm." <> name) hashAlgo ioBuiltins :: [(Text, Type)] ioBuiltins = - [ ("IO.openFile.impl.v3", text --> fmode --> iof handle) - , ("IO.closeFile.impl.v3", handle --> iof unit) - , ("IO.isFileEOF.impl.v3", handle --> iof boolean) - , ("IO.isFileOpen.impl.v3", handle --> iof boolean) - , ("IO.isSeekable.impl.v3", handle --> iof boolean) - , ("IO.seekHandle.impl.v3", handle --> smode --> int --> iof unit) - , ("IO.handlePosition.impl.v3", handle --> iof nat) - , ("IO.getEnv.impl.v1", text --> iof text) - , ("IO.getArgs.impl.v1", unit --> iof (list text)) - , ("IO.getBuffering.impl.v3", handle --> iof bmode) - , ("IO.setBuffering.impl.v3", handle --> bmode --> iof unit) - , ("IO.getBytes.impl.v3", handle --> nat --> iof bytes) - , ("IO.putBytes.impl.v3", handle --> bytes --> iof unit) - , ("IO.getLine.impl.v1", handle --> iof text) - , ("IO.systemTime.impl.v3", unit --> iof nat) - , ("IO.systemTimeMicroseconds.v1", unit --> io int) - , ("IO.getTempDirectory.impl.v3", unit --> iof text) - , ("IO.createTempDirectory.impl.v3", text --> iof text) - , ("IO.getCurrentDirectory.impl.v3", unit --> iof text) - , ("IO.setCurrentDirectory.impl.v3", text --> iof unit) - , ("IO.fileExists.impl.v3", text --> iof boolean) - , ("IO.isDirectory.impl.v3", text --> iof boolean) - , ("IO.createDirectory.impl.v3", text --> iof unit) - , ("IO.removeDirectory.impl.v3", text --> iof unit) - , ("IO.renameDirectory.impl.v3", text --> text --> iof unit) - , ("IO.directoryContents.impl.v3", text --> iof (list text)) - , ("IO.removeFile.impl.v3", text --> iof unit) - , ("IO.renameFile.impl.v3", text --> text --> iof unit) - , ("IO.getFileTimestamp.impl.v3", text --> iof nat) - , ("IO.getFileSize.impl.v3", text --> iof nat) - , ("IO.serverSocket.impl.v3", optionalt text --> text --> iof socket) - , ("IO.listen.impl.v3", socket --> iof unit) - , ("IO.clientSocket.impl.v3", text --> text --> iof socket) - , ("IO.closeSocket.impl.v3", socket --> iof unit) - , ("IO.socketPort.impl.v3", socket --> iof nat) - , ("IO.socketAccept.impl.v3", socket --> iof socket) - , ("IO.socketSend.impl.v3", socket --> bytes --> iof unit) - , ("IO.socketReceive.impl.v3", socket --> nat --> iof bytes) - , ("IO.forkComp.v2", forall1 "a" $ \a -> (unit --> io a) --> io threadId) - , ("IO.stdHandle", stdhandle --> handle) - - , ("IO.delay.impl.v3", nat --> iof unit) - , ("IO.kill.impl.v3", threadId --> iof unit) - , ("IO.ref", forall1 "a" $ \a -> - a --> io (reft (Type.effects () [Type.builtinIO ()]) a)) - , ("validateSandboxed", - forall1 "a" $ \a -> list termLink --> a --> boolean) - , ("Tls.newClient.impl.v3", tlsClientConfig --> socket --> iof tls) - , ("Tls.newServer.impl.v3", tlsServerConfig --> socket --> iof tls) - , ("Tls.handshake.impl.v3", tls --> iof unit) - , ("Tls.send.impl.v3", tls --> bytes --> iof unit) - , ("Tls.decodeCert.impl.v3", bytes --> eithert failure tlsSignedCert) - , ("Tls.encodeCert", tlsSignedCert --> bytes) - , ("Tls.decodePrivateKey", bytes --> list tlsPrivateKey) - , ("Tls.encodePrivateKey", tlsPrivateKey --> bytes) - , ("Tls.receive.impl.v3", tls --> iof bytes) - , ("Tls.terminate.impl.v3", tls --> iof unit) - , ("Tls.ClientConfig.default", text --> bytes --> tlsClientConfig) - , ("Tls.ServerConfig.default", list tlsSignedCert --> tlsPrivateKey --> tlsServerConfig) - , ("TLS.ClientConfig.ciphers.set", list tlsCipher --> tlsClientConfig --> tlsClientConfig) - , ("Tls.ServerConfig.ciphers.set", list tlsCipher --> tlsServerConfig --> tlsServerConfig) - , ("Tls.ClientConfig.certificates.set", list tlsSignedCert --> tlsClientConfig --> tlsClientConfig) - , ("Tls.ServerConfig.certificates.set", list tlsSignedCert --> tlsServerConfig --> tlsServerConfig) - , ("Tls.ClientConfig.versions.set", list tlsVersion --> tlsClientConfig --> tlsClientConfig) - , ("Tls.ServerConfig.versions.set", list tlsVersion --> tlsServerConfig --> tlsServerConfig) + [ ("IO.openFile.impl.v3", text --> fmode --> iof handle), + ("IO.closeFile.impl.v3", handle --> iof unit), + ("IO.isFileEOF.impl.v3", handle --> iof boolean), + ("IO.isFileOpen.impl.v3", handle --> iof boolean), + ("IO.isSeekable.impl.v3", handle --> iof boolean), + ("IO.seekHandle.impl.v3", handle --> smode --> int --> iof unit), + ("IO.handlePosition.impl.v3", handle --> iof nat), + ("IO.getEnv.impl.v1", text --> iof text), + ("IO.getArgs.impl.v1", unit --> iof (list text)), + ("IO.getBuffering.impl.v3", handle --> iof bmode), + ("IO.setBuffering.impl.v3", handle --> bmode --> iof unit), + ("IO.getBytes.impl.v3", handle --> nat --> iof bytes), + ("IO.putBytes.impl.v3", handle --> bytes --> iof unit), + ("IO.getLine.impl.v1", handle --> iof text), + ("IO.systemTime.impl.v3", unit --> iof nat), + ("IO.systemTimeMicroseconds.v1", unit --> io int), + ("IO.getTempDirectory.impl.v3", unit --> iof text), + ("IO.createTempDirectory.impl.v3", text --> iof text), + ("IO.getCurrentDirectory.impl.v3", unit --> iof text), + ("IO.setCurrentDirectory.impl.v3", text --> iof unit), + ("IO.fileExists.impl.v3", text --> iof boolean), + ("IO.isDirectory.impl.v3", text --> iof boolean), + ("IO.createDirectory.impl.v3", text --> iof unit), + ("IO.removeDirectory.impl.v3", text --> iof unit), + ("IO.renameDirectory.impl.v3", text --> text --> iof unit), + ("IO.directoryContents.impl.v3", text --> iof (list text)), + ("IO.removeFile.impl.v3", text --> iof unit), + ("IO.renameFile.impl.v3", text --> text --> iof unit), + ("IO.getFileTimestamp.impl.v3", text --> iof nat), + ("IO.getFileSize.impl.v3", text --> iof nat), + ("IO.serverSocket.impl.v3", optionalt text --> text --> iof socket), + ("IO.listen.impl.v3", socket --> iof unit), + ("IO.clientSocket.impl.v3", text --> text --> iof socket), + ("IO.closeSocket.impl.v3", socket --> iof unit), + ("IO.socketPort.impl.v3", socket --> iof nat), + ("IO.socketAccept.impl.v3", socket --> iof socket), + ("IO.socketSend.impl.v3", socket --> bytes --> iof unit), + ("IO.socketReceive.impl.v3", socket --> nat --> iof bytes), + ("IO.forkComp.v2", forall1 "a" $ \a -> (unit --> io a) --> io threadId), + ("IO.stdHandle", stdhandle --> handle), + ("IO.delay.impl.v3", nat --> iof unit), + ("IO.kill.impl.v3", threadId --> iof unit), + ( "IO.ref", + forall1 "a" $ \a -> + a --> io (reft (Type.effects () [Type.builtinIO ()]) a) + ), + ( "validateSandboxed", + forall1 "a" $ \a -> list termLink --> a --> boolean + ), + ("Tls.newClient.impl.v3", tlsClientConfig --> socket --> iof tls), + ("Tls.newServer.impl.v3", tlsServerConfig --> socket --> iof tls), + ("Tls.handshake.impl.v3", tls --> iof unit), + ("Tls.send.impl.v3", tls --> bytes --> iof unit), + ("Tls.decodeCert.impl.v3", bytes --> eithert failure tlsSignedCert), + ("Tls.encodeCert", tlsSignedCert --> bytes), + ("Tls.decodePrivateKey", bytes --> list tlsPrivateKey), + ("Tls.encodePrivateKey", tlsPrivateKey --> bytes), + ("Tls.receive.impl.v3", tls --> iof bytes), + ("Tls.terminate.impl.v3", tls --> iof unit), + ("Tls.ClientConfig.default", text --> bytes --> tlsClientConfig), + ("Tls.ServerConfig.default", list tlsSignedCert --> tlsPrivateKey --> tlsServerConfig), + ("TLS.ClientConfig.ciphers.set", list tlsCipher --> tlsClientConfig --> tlsClientConfig), + ("Tls.ServerConfig.ciphers.set", list tlsCipher --> tlsServerConfig --> tlsServerConfig), + ("Tls.ClientConfig.certificates.set", list tlsSignedCert --> tlsClientConfig --> tlsClientConfig), + ("Tls.ServerConfig.certificates.set", list tlsSignedCert --> tlsServerConfig --> tlsServerConfig), + ("Tls.ClientConfig.versions.set", list tlsVersion --> tlsClientConfig --> tlsClientConfig), + ("Tls.ServerConfig.versions.set", list tlsVersion --> tlsServerConfig --> tlsServerConfig), + ("Clock.internals.monotonic.v1", unit --> iof timeSpec), + ("Clock.internals.processCPUTime.v1", unit --> iof timeSpec), + ("Clock.internals.threadCPUTime.v1", unit --> iof timeSpec), + ("Clock.internals.realtime.v1", unit --> iof timeSpec), + ("Clock.internals.sec.v1", timeSpec --> int), + ("Clock.internals.nsec.v1", timeSpec --> nat) ] mvarBuiltins :: [(Text, Type)] mvarBuiltins = - [ ("MVar.new", forall1 "a" $ \a -> a --> io (mvar a)) - , ("MVar.newEmpty.v2", forall1 "a" $ \a -> unit --> io (mvar a)) - , ("MVar.take.impl.v3", forall1 "a" $ \a -> mvar a --> iof a) - , ("MVar.tryTake", forall1 "a" $ \a -> mvar a --> io (optionalt a)) - , ("MVar.put.impl.v3", forall1 "a" $ \a -> mvar a --> a --> iof unit) - , ("MVar.tryPut.impl.v3", forall1 "a" $ \a -> mvar a --> a --> iof boolean) - , ("MVar.swap.impl.v3", forall1 "a" $ \a -> mvar a --> a --> iof a) - , ("MVar.isEmpty", forall1 "a" $ \a -> mvar a --> io boolean) - , ("MVar.read.impl.v3", forall1 "a" $ \a -> mvar a --> iof a) - , ("MVar.tryRead.impl.v3", forall1 "a" $ \a -> mvar a --> iof (optionalt a)) + [ ("MVar.new", forall1 "a" $ \a -> a --> io (mvar a)), + ("MVar.newEmpty.v2", forall1 "a" $ \a -> unit --> io (mvar a)), + ("MVar.take.impl.v3", forall1 "a" $ \a -> mvar a --> iof a), + ("MVar.tryTake", forall1 "a" $ \a -> mvar a --> io (optionalt a)), + ("MVar.put.impl.v3", forall1 "a" $ \a -> mvar a --> a --> iof unit), + ("MVar.tryPut.impl.v3", forall1 "a" $ \a -> mvar a --> a --> iof boolean), + ("MVar.swap.impl.v3", forall1 "a" $ \a -> mvar a --> a --> iof a), + ("MVar.isEmpty", forall1 "a" $ \a -> mvar a --> io boolean), + ("MVar.read.impl.v3", forall1 "a" $ \a -> mvar a --> iof a), + ("MVar.tryRead.impl.v3", forall1 "a" $ \a -> mvar a --> iof (optionalt a)) ] where - mvar :: Type -> Type - mvar a = Type.ref () Type.mvarRef `app` a + mvar :: Type -> Type + mvar a = Type.ref () Type.mvarRef `app` a codeBuiltins :: [(Text, Type)] codeBuiltins = - [ ("Code.dependencies", code --> list termLink) - , ("Code.isMissing", termLink --> io boolean) - , ("Code.serialize", code --> bytes) - , ("Code.deserialize", bytes --> eithert text code) - , ("Code.cache_", list (tuple [termLink,code]) --> io (list termLink)) - , ("Code.validate", list (tuple [termLink,code]) --> io (optionalt failure)) - , ("Code.lookup", termLink --> io (optionalt code)) - , ("Code.display", text --> code --> text) - , ("Value.dependencies", value --> list termLink) - , ("Value.serialize", value --> bytes) - , ("Value.deserialize", bytes --> eithert text value) - , ("Value.value", forall1 "a" $ \a -> a --> value) - , ("Value.load" - , forall1 "a" $ \a -> value --> io (eithert (list termLink) a)) - , ("Link.Term.toText", termLink --> text) + [ ("Code.dependencies", code --> list termLink), + ("Code.isMissing", termLink --> io boolean), + ("Code.serialize", code --> bytes), + ("Code.deserialize", bytes --> eithert text code), + ("Code.cache_", list (tuple [termLink, code]) --> io (list termLink)), + ("Code.validate", list (tuple [termLink, code]) --> io (optionalt failure)), + ("Code.lookup", termLink --> io (optionalt code)), + ("Code.display", text --> code --> text), + ("Value.dependencies", value --> list termLink), + ("Value.serialize", value --> bytes), + ("Value.deserialize", bytes --> eithert text value), + ("Value.value", forall1 "a" $ \a -> a --> value), + ( "Value.load", + forall1 "a" $ \a -> value --> io (eithert (list termLink) a) + ), + ("Link.Term.toText", termLink --> text) ] stmBuiltins :: [(Text, Type)] stmBuiltins = - [ ("TVar.new", forall1 "a" $ \a -> a --> stm (tvar a)) - , ("TVar.newIO", forall1 "a" $ \a -> a --> io (tvar a)) - , ("TVar.read", forall1 "a" $ \a -> tvar a --> stm a) - , ("TVar.readIO", forall1 "a" $ \a -> tvar a --> io a) - , ("TVar.write", forall1 "a" $ \a -> tvar a --> a --> stm unit) - , ("TVar.swap", forall1 "a" $ \a -> tvar a --> a --> stm a) - , ("STM.retry", forall1 "a" $ \a -> unit --> stm a) - , ("STM.atomically", forall1 "a" $ \a -> (unit --> stm a) --> io a) + [ ("TVar.new", forall1 "a" $ \a -> a --> stm (tvar a)), + ("TVar.newIO", forall1 "a" $ \a -> a --> io (tvar a)), + ("TVar.read", forall1 "a" $ \a -> tvar a --> stm a), + ("TVar.readIO", forall1 "a" $ \a -> tvar a --> io a), + ("TVar.write", forall1 "a" $ \a -> tvar a --> a --> stm unit), + ("TVar.swap", forall1 "a" $ \a -> tvar a --> a --> stm a), + ("STM.retry", forall1 "a" $ \a -> unit --> stm a), + ("STM.atomically", forall1 "a" $ \a -> (unit --> stm a) --> io a) ] forall1 :: Text -> (Type -> Type) -> Type forall1 name body = - let - a = Var.named name - in Type.forall () a (body $ Type.var () a) + let a = Var.named name + in Type.forall () a (body $ Type.var () a) -forall2 - :: Text -> Text -> (Type -> Type -> Type) -> Type -forall2 na nb body = Type.foralls () [a,b] (body ta tb) +forall2 :: + Text -> Text -> (Type -> Type -> Type) -> Type +forall2 na nb body = Type.foralls () [a, b] (body ta tb) where - a = Var.named na - b = Var.named nb - ta = Type.var () a - tb = Type.var () b - -forall4 - :: Text -> Text -> Text -> Text - -> (Type -> Type -> Type -> Type -> Type) - -> Type -forall4 na nb nc nd body = Type.foralls () [a,b,c,d] (body ta tb tc td) + a = Var.named na + b = Var.named nb + ta = Type.var () a + tb = Type.var () b + +forall4 :: + Text -> + Text -> + Text -> + Text -> + (Type -> Type -> Type -> Type -> Type) -> + Type +forall4 na nb nc nd body = Type.foralls () [a, b, c, d] (body ta tb tc td) where - a = Var.named na - b = Var.named nb - c = Var.named nc - d = Var.named nd - ta = Type.var () a - tb = Type.var () b - tc = Type.var () c - td = Type.var () d + a = Var.named na + b = Var.named nb + c = Var.named nc + d = Var.named nd + ta = Type.var () a + tb = Type.var () b + tc = Type.var () c + td = Type.var () d app :: Type -> Type -> Type app = Type.app () @@ -730,7 +774,8 @@ pair l r = DD.pairType () `app` l `app` r (-->) :: Type -> Type -> Type a --> b = Type.arrow () a b -infixr --> + +infixr 9 --> io, iof :: Type -> Type io = Type.effect1 () (Type.builtinIO ()) @@ -779,7 +824,7 @@ float = Type.float () char = Type.char () anyt, code, value, termLink :: Type -anyt = Type.ref() Type.anyRef +anyt = Type.ref () Type.anyRef code = Type.code () value = Type.value () termLink = Type.termLink () @@ -787,3 +832,6 @@ termLink = Type.termLink () stm, tvar :: Type -> Type stm = Type.effect1 () (Type.ref () Type.stmRef) tvar a = Type.ref () Type.tvarRef `app` a + +timeSpec :: Type +timeSpec = Type.ref () Type.timeSpecRef diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 56993f3802..7f70fa60b1 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -74,6 +74,7 @@ import Network.Socket as SYS ) import Network.TLS as TLS import Network.TLS.Extra.Cipher as Cipher +import System.Clock (Clock (..), getTime, nsec, sec) import System.Directory as SYS ( createDirectoryIfMissing, doesDirectoryExist, @@ -1287,6 +1288,18 @@ unitToEFBox = where (unit, stack1, stack2, stack3, fail, result) = fresh6 +-- a -> Int +boxToInt :: ForeignOp +boxToInt = inBx arg result (TCon Ty.intRef 0 [result]) + where + (arg, result) = fresh2 + +-- a -> Nat +boxToNat :: ForeignOp +boxToNat = inBx arg result (TCon Ty.natRef 0 [result]) + where + (arg, result) = fresh2 + boxIomrToEFBox :: ForeignOp boxIomrToEFBox = inBxIomr arg1 arg2 enum result $ @@ -1470,6 +1483,12 @@ boxNatToEFBox = where (arg1, arg2, nat, stack1, stack2, fail, result) = fresh7 +-- Nat -> Either Failure b +-- natToEFBox :: ForeignOp +-- natToEFBox = inNat arg nat result $ outIoFail stack1 stack2 fail result +-- where +-- (arg, nat, stack1, stack2, fail, result) = fresh6 + -- Nat -> Either Failure () natToEFUnit :: ForeignOp natToEFUnit = @@ -1798,6 +1817,26 @@ declareForeigns = do declareForeign Tracked "IO.systemTimeMicroseconds.v1" unitToInt $ mkForeign $ \() -> fmap (1e6 *) getPOSIXTime + declareForeign Tracked "Clock.internals.monotonic.v1" unitToEFBox $ + mkForeignIOF $ \() -> getTime MonotonicRaw <|> getTime Monotonic + + declareForeign Tracked "Clock.internals.realtime.v1" unitToEFBox $ + mkForeignIOF $ \() -> getTime Realtime + + declareForeign Tracked "Clock.internals.processCPUTime.v1" unitToEFBox $ + mkForeignIOF $ \() -> getTime ProcessCPUTime + + declareForeign Tracked "Clock.internals.threadCPUTime.v1" unitToEFBox $ + mkForeignIOF $ \() -> getTime ThreadCPUTime + + declareForeign Untracked "Clock.internals.sec.v1" boxToInt $ + mkForeign (\n -> pure (fromIntegral $ sec n :: Word64)) + + -- A TimeSpec that comes from getTime never has negative nanos, + -- so we can safely cast to Nat + declareForeign Untracked "Clock.internals.nsec.v1" boxToNat $ + mkForeign (\n -> pure (fromIntegral $ nsec n :: Word64)) + declareForeign Tracked "IO.getTempDirectory.impl.v3" unitToEFBox $ mkForeignIOF $ \() -> getTemporaryDirectory diff --git a/parser-typechecker/src/Unison/Runtime/Foreign.hs b/parser-typechecker/src/Unison/Runtime/Foreign.hs index 017fbe30e4..73f29100f2 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign.hs @@ -2,6 +2,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Unison.Runtime.Foreign ( Foreign (..), @@ -24,6 +25,7 @@ import Data.Tagged (Tagged (..)) import qualified Data.X509 as X509 import Network.Socket (Socket) import qualified Network.TLS as TLS (ClientParams, Context, ServerParams) +import System.Clock (TimeSpec) import System.IO (Handle) import Unison.Reference (Reference) import Unison.Referent (Referent) @@ -139,6 +141,8 @@ instance BuiltinForeign (SuperGroup Symbol) where instance BuiltinForeign Value where foreignRef = Tagged Ty.valueRef +instance BuiltinForeign TimeSpec where foreignRef = Tagged Ty.timeSpecRef + data HashAlgorithm where -- Reference is a reference to the hash algorithm HashAlgorithm :: Hash.HashAlgorithm a => Reference -> a -> HashAlgorithm diff --git a/parser-typechecker/src/Unison/Server/Backend.hs b/parser-typechecker/src/Unison/Server/Backend.hs index e19b4be9ea..8e5962c5b7 100644 --- a/parser-typechecker/src/Unison/Server/Backend.hs +++ b/parser-typechecker/src/Unison/Server/Backend.hs @@ -779,6 +779,7 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod (formatSuffixedType ppe width typeSig) docs mkTypeDefinition r tp = do + traceM $ "Making type definition for " <> show r let bn = bestNameForType @Symbol (PPE.suffixifiedPPE ppe) width r tag <- Just . typeEntryTag diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index cef80c191a..392cd37d64 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -219,6 +219,7 @@ library , bytestring , bytestring-to-vector , cereal + , clock , configurator , containers >=0.6.3 , cryptonite diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index 508908076f..8874dc9bd0 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE Rank2Types #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ViewPatterns #-} module Unison.Type where @@ -291,6 +292,9 @@ valueRef = Reference.Builtin "Value" anyRef :: Reference anyRef = Reference.Builtin "Any" +timeSpecRef :: Reference +timeSpecRef = Reference.Builtin "TimeSpec" + any :: Ord v => a -> Type v a any a = ref a anyRef @@ -596,7 +600,7 @@ removePureEffects :: ABT.Var v => Type v a -> Type v a removePureEffects t | not Settings.removePureEffects = t | otherwise = - generalize vs $ removeEffectVars fvs tu + generalize vs $ removeEffectVars fvs tu where (vs, tu) = unforall' t vss = Set.fromList vs From 7f4419a82ce5745afe8749b1ee25a2111fa7f776 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 14 Apr 2022 10:36:01 -0400 Subject: [PATCH 120/529] fix a couple bugs --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 3 ++- parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 0c7bdd459e..d022d4f71e 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -127,6 +127,7 @@ module U.Codebase.Sqlite.Queries ) where +import qualified Data.List.Extra as List (splitOn) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel import qualified Data.Set as Set @@ -162,7 +163,7 @@ import Unison.Sqlite createSchema :: Transaction () createSchema = - execute_ [hereFile|sql/create.sql|] + traverse_ (execute_ . fromString) $ List.splitOn ";" [hereFile|sql/create.sql|] schemaVersion :: Transaction SchemaVersion schemaVersion = queryOneCol_ sql diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index f86a49fe14..00eafda674 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -130,7 +130,7 @@ createCodebaseOrError debugName path action = do (pure $ Left Codebase1.CreateCodebaseAlreadyExists) do createDirectoryIfMissing True (makeCodebaseDirPath path) - Sqlite.withConnection (debugName ++ ".createSchema") path \conn -> + withConnection (debugName ++ ".createSchema") path \conn -> Sqlite.runTransaction conn do Q.createSchema void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty From 758d2f20b76e3323d633fa0fcf9973e9caa2f56c Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 14 Apr 2022 12:27:36 -0500 Subject: [PATCH 121/529] switch EntityLocation/2 around --- unison-cli/src/Unison/Share/Sync.hs | 53 ++++++++--------------------- 1 file changed, 14 insertions(+), 39 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index f42686e65e..7fda9ebf1c 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -192,10 +192,10 @@ pull httpClient unisonShareUrl conn repoPath = do Right Nothing -> pure (Right Nothing) Right (Just hashJwt) -> do let hash = Share.hashJWTHash hashJwt - runDB (entityLocation2 hash) >>= \case - EntityInMainStorage2 -> pure () - EntityInTempStorage2 missingDependencies -> doDownload missingDependencies - EntityNotStored2 -> doDownload (NESet.singleton hashJwt) + runDB (entityLocation hash) >>= \case + EntityInMainStorage -> pure () + EntityInTempStorage missingDependencies -> doDownload missingDependencies + EntityNotStored -> doDownload (NESet.singleton hashJwt) pure (Right (Just (CausalHash (Hash.fromBase32Hex (Share.toBase32Hex hash))))) where runDB :: ReaderT Connection IO a -> IO a @@ -236,11 +236,11 @@ download httpClient unisonShareUrl conn repoName = do runDB do NEMap.toList entities & foldMapM \(hash, entity) -> do -- still trying to figure out missing dependencies of hash/entity. - entityLocation2 hash >>= \case - EntityInMainStorage2 -> pure Set.empty - EntityInTempStorage2 missingDependencies -> + entityLocation hash >>= \case + EntityInMainStorage -> pure Set.empty + EntityInTempStorage missingDependencies -> pure (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) - EntityNotStored2 -> do + EntityNotStored -> do -- if it has missing dependencies, add it to temp storage; -- otherwise add it to main storage. missingDependencies0 <- @@ -416,19 +416,10 @@ tempToSyncCausal = do data EntityLocation = -- | `object` / `causal` EntityInMainStorage - | -- | `temp_entity` - EntityInTempStorage - | -- | Nowhere - EntityNotStored - --- | Where is an entity stored? -data EntityLocation2 - = -- | `object` / `causal` - EntityInMainStorage2 | -- | `temp_entity`, evidenced by these missing dependencies. - EntityInTempStorage2 (NESet Share.HashJWT) + EntityInTempStorage (NESet Share.HashJWT) | -- | Nowhere - EntityNotStored2 + EntityNotStored -- | Does this entity already exist in the database, i.e. in the `object` or `causal` table? entityExists :: Q.DB m => Share.Hash -> m Bool @@ -449,20 +440,10 @@ entityLocation :: Q.DB m => Share.Hash -> m EntityLocation entityLocation hash = entityExists hash >>= \case True -> pure EntityInMainStorage - False -> - tempEntityExists hash >>= \case - True -> pure EntityInTempStorage - False -> pure EntityNotStored - --- | Where is an entity stored? -entityLocation2 :: Q.DB m => Share.Hash -> m EntityLocation2 -entityLocation2 hash = - entityExists hash >>= \case - True -> pure EntityInMainStorage2 False -> Q.getMissingDependencyJwtsForTempEntity (Share.toBase32Hex hash) <&> \case - Nothing -> EntityNotStored2 - Just missingDependencies -> EntityInTempStorage2 (NESet.map Share.HashJWT missingDependencies) + Nothing -> EntityNotStored + Just missingDependencies -> EntityInTempStorage (NESet.map Share.HashJWT missingDependencies) -- FIXME comment elaborateHashes :: forall m. Q.DB m => Set Share.DecodedHashJWT -> Set Share.HashJWT -> m (Maybe (NESet Share.HashJWT)) @@ -472,15 +453,9 @@ elaborateHashes hashes outputs = Just (Share.DecodedHashJWT (Share.HashJWTClaims {hash}) jwt, hashes') -> entityLocation hash >>= \case EntityNotStored -> elaborateHashes hashes' (Set.insert jwt outputs) - EntityInTempStorage -> do - deps <- directDepsOfHash hash - elaborateHashes (Set.union deps hashes') outputs + EntityInTempStorage missingDependencies -> + elaborateHashes (Set.union (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) hashes') outputs EntityInMainStorage -> elaborateHashes hashes' outputs - where - directDepsOfHash :: Share.Hash -> m (Set Share.DecodedHashJWT) - directDepsOfHash (Share.Hash b32) = do - maybeJwts <- Q.getMissingDependencyJwtsForTempEntity b32 - pure (maybe Set.empty (Set.map (Share.decodeHashJWT . Share.HashJWT) . NESet.toSet) maybeJwts) insertEntity :: Q.DB m => Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> m () insertEntity _hash = undefined From 63a209d0801ad52ee21b70079671c793d85ba9e6 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 14 Apr 2022 14:18:58 -0500 Subject: [PATCH 122/529] reorganize createSchema / migrateSchema3To4 --- .../U/Codebase/Sqlite/Queries.hs | 14 +++++++++++-- .../sql/001-temp-entity-tables.sql | 2 +- codebase2/codebase-sqlite/sql/create.sql | 4 ++-- parser-typechecker/package.yaml | 1 + .../Codebase/SqliteCodebase/Migrations.hs | 4 +++- .../Migrations/MigrateSchema3To4.hs | 20 +++++++++++++++++++ .../unison-parser-typechecker.cabal | 2 ++ 7 files changed, 41 insertions(+), 6 deletions(-) create mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 76c50523d6..fd0c4a314a 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -133,6 +133,7 @@ module U.Codebase.Sqlite.Queries -- * db misc createSchema, + addTempEntityTables, schemaVersion, setSchemaVersion, setFlags, @@ -256,8 +257,17 @@ orError e = maybe (throwError e) pure createSchema :: (DB m, MonadUnliftIO m) => m () createSchema = do - withImmediateTransaction . traverse_ (execute_ . fromString) $ - List.splitOn ";" [hereFile|sql/create.sql|] + withImmediateTransaction do + executeFile [hereFile|sql/create.sql|] + addTempEntityTables + +addTempEntityTables :: DB m => m () +addTempEntityTables = + executeFile [hereFile|sql/001-temp-entity-tables.sql|] + +executeFile :: DB m => String -> m () +executeFile = + traverse_ (execute_ . fromString) . filter (not . null) . List.splitOn ";" setJournalMode :: DB m => JournalMode -> m () setJournalMode m = diff --git a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql index 1b390f382b..a5bc1baf53 100644 --- a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql +++ b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql @@ -58,4 +58,4 @@ create table temp_entity_missing_dependency ( unique (dependent, dependency) ); create index temp_entity_missing_dependency_ix_dependent on temp_entity_missing_dependency (dependent); -create index temp_entity_missing_dependency_ix_dependency on temp_entity_missing_dependency (dependency); +create index temp_entity_missing_dependency_ix_dependency on temp_entity_missing_dependency (dependency) diff --git a/codebase2/codebase-sqlite/sql/create.sql b/codebase2/codebase-sqlite/sql/create.sql index 7681df382b..702e8776b3 100644 --- a/codebase2/codebase-sqlite/sql/create.sql +++ b/codebase2/codebase-sqlite/sql/create.sql @@ -3,7 +3,7 @@ CREATE TABLE schema_version ( version INTEGER NOT NULL ); -INSERT INTO schema_version (version) VALUES (3); +INSERT INTO schema_version (version) VALUES (4); -- actually stores the 512-byte hashes CREATE TABLE hash ( @@ -140,7 +140,7 @@ CREATE TABLE watch ( CREATE INDEX watch_kind ON watch(watch_kind_id); -- Note [Watch expression identifier] --- The hash_id + component_index is an unevaluated term reference. We use hash_id instead of object_id because the +-- The hash_id + component_index is an unevaluated term reference. We use hash_id instead of object_id because the -- unevaluated term may not exist in the codebase: it is not added merely by watching it without a name, e.g `> 2 + 3`. diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 68c3a7f6ff..d599833cfd 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -48,6 +48,7 @@ library: - hashable - hashtables - haskeline + - here - http-types - http-media - http-client diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index e993517d71..f87f44a035 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -14,6 +14,7 @@ import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase import Unison.Codebase.SqliteCodebase.Migrations.Errors (MigrationError) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3 (migrateSchema2To3) +import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4) import Unison.Codebase.SqliteCodebase.Paths import Unison.Codebase.Type (Codebase, LocalOrRemote (..)) import Unison.Prelude @@ -34,7 +35,8 @@ migrations :: forall m v a. (MonadUnliftIO m, Var v) => Map SchemaVersion (Migra migrations = Map.fromList [ (2, migrateSchema1To2), - (3, migrateSchema2To3) + (3, migrateSchema2To3), + (4, migrateSchema3To4) ] -- | Migrates a codebase up to the most recent version known to ucm. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs new file mode 100644 index 0000000000..4d56145b97 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs @@ -0,0 +1,20 @@ +module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4) where + +import Control.Monad.Reader +import U.Codebase.Sqlite.Connection (Connection) +import U.Codebase.Sqlite.DbId (SchemaVersion (..)) +import qualified U.Codebase.Sqlite.Queries as Q +import Unison.Codebase (Codebase) +import Unison.Codebase.SqliteCodebase.Migrations.Errors (MigrationError (IncorrectStartingSchemaVersion)) +import Unison.Prelude +import Unison.Var (Var) +import qualified UnliftIO + +-- | The 3 to 4 migration adds initial support for out-of-order sync i.e. Unison Share +migrateSchema3To4 :: forall a m v. (MonadUnliftIO m, Var v) => Connection -> Codebase m v a -> m (Either MigrationError ()) +migrateSchema3To4 conn _ = UnliftIO.try . flip runReaderT conn $ + Q.withSavepoint "MIGRATE_SCHEMA_3_TO_4" $ \_rollback -> do + version <- Q.schemaVersion + when (version /= 2) $ UnliftIO.throwIO (IncorrectStartingSchemaVersion version) + Q.addTempEntityTables + Q.setSchemaVersion (SchemaVersion 4) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 29ba467d04..84aa8a2dad 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -70,6 +70,7 @@ library Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3 + Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 Unison.Codebase.SqliteCodebase.Paths Unison.Codebase.SqliteCodebase.SyncEphemeral Unison.Codebase.SyncMode @@ -241,6 +242,7 @@ library , hashable , hashtables , haskeline + , here , http-client , http-media , http-types From e6692b3eb3d6dc249d72456e88b08326b13b6e4b Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 14 Apr 2022 14:19:18 -0500 Subject: [PATCH 123/529] delete temp comments --- unison-cli/src/Unison/Share/Sync.hs | 59 +++-------------------------- 1 file changed, 6 insertions(+), 53 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 7fda9ebf1c..b5555240e9 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -259,29 +259,12 @@ download httpClient unisonShareUrl conn repoName = do --------- --- * we need hashjwts to make subsequent requests to the server - --- * when look up missing dependencies, it's because we anticipate making a subsequent request to the server for them, - --- so they should also be hashjwts - --- * before making a subsequent request to the server, we elaborate the request set, - --- which requires knowing hashjwts for the dependencies of the request set; --- so we need some way of looking up missing dependency hashjwts from a hash or hashjwt - --- * one way of looking these up would be to include dependency hashjwts in the temp-entity-missing-dependency table --- (dependent -> (dependency, dependencyjwt)) - --- * we need `hash` to find entity in temp or main storage - --- * different entities may arrive with different variations on the same dependency jwts - --- * we need dependency hash (not only hashjwt) in temp-entity-missing-dependency so that we can also look up dependents - --- of a hash without knowing which hashjwt was stored for it - --- Mitchell is on team: add a column to temp-entity-missing-dependency that includes the jwt +-- Some remaining work: +-- +-- [ ] Beef up insert_entity to flush temp entities +-- [ ] Write resolveHashToEntity +-- [ ] Add "no read permission" to GetCausalHashByPathResponse in Share.Types +-- [ ] The tempToSync* stuff {- server sqlite db @@ -307,36 +290,6 @@ server sqlite db -} --------- --- Do this at the top of the procedure. --- --- deps0 = hashes we kinda-maybe think we should request --- deps1 = hashes we will request --- --- frobnicate : Set Hash -> Set Hash ->{IO} Set Hash --- frobnicate deps0 deps1 = --- case deps0 of --- Nothing -> deps1 --- Just (dep0, deps0) -> --- cases --- inMainStorage dep0 -> frobnicate deps0 deps1 --- inTempStorage dep0 -> frobnicate (deps0 + directDepsOf dep0) deps1 --- otherwise -> frobnicate deps0 (deps1 + {dep0}) --- --- If we just got #thing from the server, --- If we already have the entity in the main database, we're done. --- - This should't happen, why would the server have sent us this? --- --- Otherwise, if we already have the entity in temp_entity, --- 1. Add to our work queue requesting all of its deps that we don't have in main storage --- --- Otherwise (if we don't have it at all), --- 1. Deserialize blob and extract dependencies #dep1, #dep2, #dep3 from #thing blob. --- 2. If the {set of dependencies we don't have in the object/causal table} is empty, then store in object/causal. --- 3. Otherwise, --- - Insert into temp_entity --- - For each #dependency in the {set of dependencies we don't have in the object/causal table} --- insert each (#thing, #dependency) into temp_entity_missing_dependency --- - Add to our work queue requesting {set of dependencies we don't have in object/causal} -- -- Note: beef up insert_entity procedure to flush temp_entity table -- 1. When inserting object #foo, From edfb7addbf692be5642399270a9d8b3e0960cb18 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 14 Apr 2022 15:41:56 -0400 Subject: [PATCH 124/529] fix sync bugs --- .../src/Unison/Codebase/SqliteCodebase.hs | 171 +++++++++--------- 1 file changed, 85 insertions(+), 86 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 00eafda674..c1752c76ba 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -71,7 +71,6 @@ import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent import Unison.ShortHash (ShortHash) import qualified Unison.Sqlite as Sqlite -import qualified Unison.Sqlite.Connection as Sqlite.Connection import Unison.Symbol (Symbol) import Unison.Term (Term) import Unison.Type (Type) @@ -343,14 +342,18 @@ sqliteCodebase debugName root localOrRemote action = do syncFromDirectory srcRoot _syncMode b = do withConnection (debugName ++ ".sync.src") srcRoot $ \srcConn -> do progressStateRef <- liftIO (newIORef emptySyncProgressState) - syncInternal (syncProgress progressStateRef) srcConn conn b + Sqlite.runReadOnlyTransactionIO srcConn \runSrc -> + Sqlite.runWriteTransactionIO conn \runDest -> do + syncInternal (syncProgress progressStateRef) runSrc runDest b syncToDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m () syncToDirectory destRoot _syncMode b = withConnection (debugName ++ ".sync.dest") destRoot $ \destConn -> do progressStateRef <- liftIO (newIORef emptySyncProgressState) initSchemaIfNotExist destRoot - syncInternal (syncProgress progressStateRef) conn destConn b + Sqlite.runReadOnlyTransactionIO conn \runSrc -> + Sqlite.runWriteTransactionIO destConn \runDest -> do + syncInternal (syncProgress progressStateRef) runSrc runDest b watches :: UF.WatchKind -> m [Reference.Id] watches w = @@ -494,77 +497,75 @@ syncInternal :: forall m. MonadUnliftIO m => Sync.Progress m Sync22.Entity -> - Sqlite.Connection -> - Sqlite.Connection -> + (forall a. Sqlite.Transaction a -> m a) -> + (forall a. Sqlite.Transaction a -> m a) -> Branch m -> m () -syncInternal progress srcConn destConn b = time "syncInternal" do +syncInternal progress runSrc runDest b = time "syncInternal" do UnliftIO runInIO <- askUnliftIO - Sqlite.runReadOnlyTransactionIO srcConn \runSrc -> do - Sqlite.runWriteTransactionIO destConn \runDest -> do - let syncEnv = Sync22.Env runSrc runDest (16 * 1024 * 1024) - -- we want to use sync22 wherever possible - -- so for each source branch, we'll check if it exists in the destination codebase - -- or if it exists in the source codebase, then we can sync22 it - -- if it doesn't exist in the dest or source branch, - -- then just use putBranch to the dest - sync <- liftIO (Sync22.sync22 (Sync22.mapEnv lift syncEnv)) - let doSync :: [Sync22.Entity] -> m () - doSync = - throwExceptT - . Except.withExceptT SyncEphemeral.Sync22Error - . Sync.sync' sync (Sync.transformProgress lift progress) - let processBranches :: [Entity m] -> m () - processBranches = \case - [] -> pure () - b0@(B h mb) : rest -> do - when debugProcessBranches do - traceM $ "processBranches " ++ show b0 - traceM $ " queue: " ++ show rest - ifM - (runDest (Ops2.isCausalHash h)) - do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " already exists in dest db" - processBranches rest - do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in dest db" - let h2 = CausalHash . Cv.hash1to2 $ Causal.unRawHash h - runSrc (Q.loadCausalHashIdByCausalHash h2) >>= \case - Just chId -> do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " exists in source db, so delegating to direct sync" - doSync [Sync22.C chId] - processBranches rest - Nothing -> - mb >>= \b -> do - when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in either db, so delegating to Codebase.putBranch" - let (branchDeps, BD.to' -> BD.Dependencies' es ts ds) = BD.fromBranch b - when debugProcessBranches do - traceM $ " branchDeps: " ++ show (fst <$> branchDeps) - traceM $ " terms: " ++ show ts - traceM $ " decls: " ++ show ds - traceM $ " edits: " ++ show es - (cs, es, ts, ds) <- runDest do - cs <- filterM (fmap not . Ops2.isCausalHash . fst) branchDeps - es <- filterM (fmap not . Ops2.patchExists) es - ts <- filterM (fmap not . Ops2.termExists) ts - ds <- filterM (fmap not . Ops2.declExists) ds - pure (cs, es, ts, ds) - if null cs && null es && null ts && null ds - then do - runDest (Ops2.putBranch (Branch.transform (Sqlite.idempotentIO . runInIO) b)) - processBranches rest - else do - let bs = map (uncurry B) cs - os = map O (es <> ts <> ds) - processBranches (os ++ bs ++ b0 : rest) - O h : rest -> do - when debugProcessBranches $ traceM $ "processBranches O " ++ take 10 (show h) - oId <- runSrc (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId) - doSync [Sync22.O oId] + let syncEnv = Sync22.Env runSrc runDest (16 * 1024 * 1024) + -- we want to use sync22 wherever possible + -- so for each source branch, we'll check if it exists in the destination codebase + -- or if it exists in the source codebase, then we can sync22 it + -- if it doesn't exist in the dest or source branch, + -- then just use putBranch to the dest + sync <- liftIO (Sync22.sync22 (Sync22.mapEnv lift syncEnv)) + let doSync :: [Sync22.Entity] -> m () + doSync = + throwExceptT + . Except.withExceptT SyncEphemeral.Sync22Error + . Sync.sync' sync (Sync.transformProgress lift progress) + let processBranches :: [Entity m] -> m () + processBranches = \case + [] -> pure () + b0@(B h mb) : rest -> do + when debugProcessBranches do + traceM $ "processBranches " ++ show b0 + traceM $ " queue: " ++ show rest + ifM + (runDest (Ops2.isCausalHash h)) + do + when debugProcessBranches $ traceM $ " " ++ show b0 ++ " already exists in dest db" processBranches rest - let bHash = Branch.headHash b - time "SyncInternal.processBranches" $ processBranches [B bHash (pure b)] + do + when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in dest db" + let h2 = CausalHash . Cv.hash1to2 $ Causal.unRawHash h + runSrc (Q.loadCausalHashIdByCausalHash h2) >>= \case + Just chId -> do + when debugProcessBranches $ traceM $ " " ++ show b0 ++ " exists in source db, so delegating to direct sync" + doSync [Sync22.C chId] + processBranches rest + Nothing -> + mb >>= \b -> do + when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in either db, so delegating to Codebase.putBranch" + let (branchDeps, BD.to' -> BD.Dependencies' es ts ds) = BD.fromBranch b + when debugProcessBranches do + traceM $ " branchDeps: " ++ show (fst <$> branchDeps) + traceM $ " terms: " ++ show ts + traceM $ " decls: " ++ show ds + traceM $ " edits: " ++ show es + (cs, es, ts, ds) <- runDest do + cs <- filterM (fmap not . Ops2.isCausalHash . fst) branchDeps + es <- filterM (fmap not . Ops2.patchExists) es + ts <- filterM (fmap not . Ops2.termExists) ts + ds <- filterM (fmap not . Ops2.declExists) ds + pure (cs, es, ts, ds) + if null cs && null es && null ts && null ds + then do + runDest (Ops2.putBranch (Branch.transform (Sqlite.idempotentIO . runInIO) b)) + processBranches rest + else do + let bs = map (uncurry B) cs + os = map O (es <> ts <> ds) + processBranches (os ++ bs ++ b0 : rest) + O h : rest -> do + when debugProcessBranches $ traceM $ "processBranches O " ++ take 10 (show h) + oId <- runSrc (Q.expectHashIdByHash (Cv.hash1to2 h) >>= Q.expectObjectIdForAnyHashId) + doSync [Sync22.O oId] + processBranches rest + let bHash = Branch.headHash b + time "SyncInternal.processBranches" $ processBranches [B bHash (pure b)] data Entity m = B Branch.Hash (m (Branch m)) @@ -738,38 +739,36 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift action currentRootBranch >>= \case Left e -> pure $ Left e Right newBranch -> do - Sqlite.Connection.withSavepoint destConn "push" \_rollback -> - doSync codebaseStatus (Git.gitDirToPath pushStaging) srcConn destConn newBranch + doSync codebaseStatus (Git.gitDirToPath pushStaging) destConn newBranch pure (Right newBranch) for newBranchOrErr $ push pushStaging repo pure newBranchOrErr where readRepo :: ReadRepo readRepo = writeToRead repo - doSync :: CodebaseStatus -> FilePath -> Sqlite.Connection -> Sqlite.Connection -> Branch m -> m () - doSync codebaseStatus remotePath srcConn destConn newBranch = do + doSync :: CodebaseStatus -> FilePath -> Sqlite.Connection -> Branch m -> m () + doSync codebaseStatus remotePath destConn newBranch = do progressStateRef <- liftIO (newIORef emptySyncProgressState) - _ <- syncInternal (syncProgress progressStateRef) srcConn destConn newBranch - when setRoot . liftIO $ - Sqlite.runTransactionWithAbort - destConn - (\abort -> overwriteRoot abort codebaseStatus remotePath newBranch) + Sqlite.runReadOnlyTransactionIO srcConn \runSrc -> do + Sqlite.runWriteTransactionIO destConn \runDest -> do + _ <- syncInternal (syncProgress progressStateRef) runSrc runDest newBranch + when setRoot (overwriteRoot runDest codebaseStatus remotePath newBranch) overwriteRoot :: - (forall e x. Exception e => e -> Sqlite.Transaction x) -> + (forall a. Sqlite.Transaction a -> m a) -> CodebaseStatus -> FilePath -> Branch m -> - Sqlite.Transaction () - overwriteRoot abort codebaseStatus remotePath newBranch = do + m () + overwriteRoot run codebaseStatus remotePath newBranch = do let newBranchHash = Branch.headHash newBranch case codebaseStatus of ExistingCodebase -> do -- the call to runDB "handles" the possible DB error by bombing - maybeOldRootHash <- fmap Cv.branchHash2to1 <$> Ops.loadRootCausalHash + maybeOldRootHash <- fmap Cv.branchHash2to1 <$> run Ops.loadRootCausalHash case maybeOldRootHash of - Nothing -> setRepoRoot newBranchHash + Nothing -> run (setRepoRoot newBranchHash) Just oldRootHash -> do - Ops2.before oldRootHash newBranchHash >>= \case + run (Ops2.before oldRootHash newBranchHash) >>= \case Nothing -> error $ "I couldn't find the hash " ++ show newBranchHash @@ -779,10 +778,10 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift ++ show remotePath ++ "." Just False -> - abort . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo + throwIO . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo Just True -> pure () CreatedCodebase -> pure () - setRepoRoot newBranchHash + run (setRepoRoot newBranchHash) repoString = Text.unpack $ printWriteRepo repo setRepoRoot :: Branch.Hash -> Sqlite.Transaction () setRepoRoot h = do From b4fa3282aad18f2303af030da7f3bacc04818b9a Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 15 Apr 2022 10:46:17 -0400 Subject: [PATCH 125/529] delete a few unused transaction runners and clean up migrations --- .../U/Codebase/Sqlite/Queries.hs | 18 ++++++ lib/unison-sqlite/src/Unison/Sqlite.hs | 3 - .../src/Unison/Sqlite/Transaction.hs | 57 ++++--------------- .../src/Unison/Codebase/SqliteCodebase.hs | 16 +++--- .../Codebase/SqliteCodebase/Migrations.hs | 21 ++++--- .../SqliteCodebase/Migrations/Errors.hs | 11 ---- .../Migrations/MigrateSchema1To2.hs | 35 ++++++------ .../Migrations/MigrateSchema2To3.hs | 10 ++-- .../unison-parser-typechecker.cabal | 1 - 9 files changed, 68 insertions(+), 104 deletions(-) delete mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/Errors.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index d022d4f71e..190832c741 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -123,6 +123,7 @@ module U.Codebase.Sqlite.Queries -- * db misc createSchema, schemaVersion, + expectSchemaVersion, setSchemaVersion, ) where @@ -170,6 +171,23 @@ schemaVersion = queryOneCol_ sql where sql = "SELECT version from schema_version;" +data UnexpectedSchemaVersion = UnexpectedSchemaVersion + { actual :: SchemaVersion, + expected :: SchemaVersion + } + deriving stock (Show) + deriving anyclass (SqliteExceptionReason) + +-- | Expect the given schema version. +expectSchemaVersion :: SchemaVersion -> Transaction () +expectSchemaVersion expected = + queryOneColCheck_ + [here| + SELECT version + FROM schema_version + |] + (\actual -> if actual /= expected then Left UnexpectedSchemaVersion {actual, expected} else Right ()) + setSchemaVersion :: SchemaVersion -> Transaction () setSchemaVersion schemaVersion = execute sql (Only schemaVersion) where diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index 5ef23cc49d..27247aeb94 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -18,11 +18,8 @@ module Unison.Sqlite -- * Transaction interface Transaction, runTransaction, - runTransactionWithAbort, runReadOnlyTransaction, - runReadOnlyTransactionIO, runWriteTransaction, - runWriteTransactionIO, unsafeUnTransaction, savepoint, idempotentIO, diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 048fdfbf2e..2cf4f3d17f 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -2,11 +2,8 @@ module Unison.Sqlite.Transaction ( -- * Transaction management Transaction, runTransaction, - runTransactionWithAbort, runReadOnlyTransaction, - runReadOnlyTransactionIO, runWriteTransaction, - runWriteTransactionIO, unsafeUnTransaction, savepoint, idempotentIO, @@ -99,41 +96,18 @@ runTransaction conn (Transaction f) = liftIO do pure result {-# SPECIALIZE runTransaction :: Connection -> Transaction a -> IO a #-} --- | Run a transaction with a function that aborts the transaction with an exception. -runTransactionWithAbort :: - MonadIO m => - Connection -> - ((forall e x. Exception e => e -> Transaction x) -> Transaction a) -> - m a -runTransactionWithAbort conn action = - runTransaction conn (action \exception -> idempotentIO (throwIO exception)) -{-# SPECIALIZE runTransactionWithAbort :: - Connection -> - ((forall e x. Exception e => e -> Transaction x) -> Transaction a) -> - IO a - #-} - -- | Run a transaction that is known to only perform reads. -- --- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. --- --- If the transaction does attempt a write and gets SQLITE_BUSY, it's your fault! -runReadOnlyTransaction :: MonadUnliftIO m => Connection -> ((forall x. m x -> Transaction x) -> Transaction a) -> m a -runReadOnlyTransaction conn f = - withRunInIO \runInIO -> - runReadOnlyTransaction_ conn (unsafeUnTransaction (f (idempotentIO . runInIO)) conn) -{-# SPECIALIZE runReadOnlyTransaction :: Connection -> ((forall x. IO x -> Transaction x) -> Transaction a) -> IO a #-} - --- | A variant of 'runReadOnlyTransaction' that may be more convenient for actions that perform more interleaved IO --- calls than database calls, because the transaction action itself is in IO. --- -- The action is provided a function that peels off the 'Transaction' newtype without sending the corresponding -- BEGIN/COMMIT statements. -runReadOnlyTransactionIO :: MonadUnliftIO m => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a -runReadOnlyTransactionIO conn f = +-- +-- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. If the transaction does +-- attempt a write and gets SQLITE_BUSY, it's your fault! +runReadOnlyTransaction :: MonadUnliftIO m => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a +runReadOnlyTransaction conn f = withRunInIO \runInIO -> runReadOnlyTransaction_ conn (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn)))) -{-# SPECIALIZE runReadOnlyTransactionIO :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-} +{-# SPECIALIZE runReadOnlyTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-} runReadOnlyTransaction_ :: Connection -> IO a -> IO a runReadOnlyTransaction_ conn action = do @@ -148,21 +122,12 @@ runReadOnlyTransaction_ conn action = do -- | Run a transaction that is known to perform at least one write. -- --- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. -runWriteTransaction :: MonadUnliftIO m => Connection -> ((forall x. m x -> Transaction x) -> Transaction a) -> m a -runWriteTransaction conn f = - withRunInIO \runInIO -> - uninterruptibleMask \restore -> - runWriteTransaction_ restore 100_000 conn (unsafeUnTransaction (f (idempotentIO . runInIO)) conn) -{-# SPECIALIZE runWriteTransaction :: Connection -> ((forall x. IO x -> Transaction x) -> Transaction a) -> IO a #-} - --- | A variant of 'runWriteTransaction' that may be more convenient for actions that perform more interleaved IO calls --- than database calls, because the transaction action itself is in IO. --- -- The action is provided a function that peels off the 'Transaction' newtype without sending the corresponding -- BEGIN/COMMIT statements. -runWriteTransactionIO :: MonadUnliftIO m => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a -runWriteTransactionIO conn f = +-- +-- The transaction is never retried, so it is (more) safe to interleave arbitrary IO actions. +runWriteTransaction :: MonadUnliftIO m => Connection -> ((forall x. Transaction x -> m x) -> m a) -> m a +runWriteTransaction conn f = withRunInIO \runInIO -> uninterruptibleMask \restore -> runWriteTransaction_ @@ -170,7 +135,7 @@ runWriteTransactionIO conn f = 100_000 conn (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn)))) -{-# SPECIALIZE runWriteTransactionIO :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-} +{-# SPECIALIZE runWriteTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-} runWriteTransaction_ :: (forall x. IO x -> IO x) -> Int -> Connection -> IO a -> IO a runWriteTransaction_ restore microseconds conn transaction = do diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index c1752c76ba..5b7ee2c0ab 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -250,7 +250,7 @@ sqliteCodebase debugName root localOrRemote action = do getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> m (Branch m) getRootBranch rootBranchCache = - Sqlite.runReadOnlyTransactionIO conn \run -> + Sqlite.runReadOnlyTransaction conn \run -> Branch.transform run <$> run (Ops2.getRootBranch getDeclType rootBranchCache) getRootBranchExists :: m Bool @@ -306,7 +306,7 @@ sqliteCodebase debugName root localOrRemote action = do -- to one that returns Maybe. getBranchForHash :: Branch.Hash -> m (Maybe (Branch m)) getBranchForHash h = - Sqlite.runReadOnlyTransactionIO conn \run -> + Sqlite.runReadOnlyTransaction conn \run -> fmap (Branch.transform run) <$> run (Ops2.getBranchForHash getDeclType h) putBranch :: Branch m -> m () @@ -342,8 +342,8 @@ sqliteCodebase debugName root localOrRemote action = do syncFromDirectory srcRoot _syncMode b = do withConnection (debugName ++ ".sync.src") srcRoot $ \srcConn -> do progressStateRef <- liftIO (newIORef emptySyncProgressState) - Sqlite.runReadOnlyTransactionIO srcConn \runSrc -> - Sqlite.runWriteTransactionIO conn \runDest -> do + Sqlite.runReadOnlyTransaction srcConn \runSrc -> + Sqlite.runWriteTransaction conn \runDest -> do syncInternal (syncProgress progressStateRef) runSrc runDest b syncToDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m () @@ -351,8 +351,8 @@ sqliteCodebase debugName root localOrRemote action = do withConnection (debugName ++ ".sync.dest") destRoot $ \destConn -> do progressStateRef <- liftIO (newIORef emptySyncProgressState) initSchemaIfNotExist destRoot - Sqlite.runReadOnlyTransactionIO conn \runSrc -> - Sqlite.runWriteTransactionIO destConn \runDest -> do + Sqlite.runReadOnlyTransaction conn \runSrc -> + Sqlite.runWriteTransaction destConn \runDest -> do syncInternal (syncProgress progressStateRef) runSrc runDest b watches :: UF.WatchKind -> m [Reference.Id] @@ -749,8 +749,8 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift doSync :: CodebaseStatus -> FilePath -> Sqlite.Connection -> Branch m -> m () doSync codebaseStatus remotePath destConn newBranch = do progressStateRef <- liftIO (newIORef emptySyncProgressState) - Sqlite.runReadOnlyTransactionIO srcConn \runSrc -> do - Sqlite.runWriteTransactionIO destConn \runDest -> do + Sqlite.runReadOnlyTransaction srcConn \runSrc -> do + Sqlite.runWriteTransaction destConn \runDest -> do _ <- syncInternal (syncProgress progressStateRef) runSrc runDest newBranch when setRoot (overwriteRoot runDest codebaseStatus remotePath newBranch) overwriteRoot :: diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index acefc9707d..2e8e9e3611 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -32,12 +32,11 @@ migrations :: (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> TVar (Map Hash Ops2.TermBufferEntry) -> TVar (Map Hash Ops2.DeclBufferEntry) -> - (forall x. IO x -> Sqlite.Transaction x) -> Map SchemaVersion (Sqlite.Transaction ()) -migrations getDeclType termBuffer declBuffer runIO = +migrations getDeclType termBuffer declBuffer = Map.fromList - [ (2, migrateSchema1To2 getDeclType termBuffer declBuffer runIO), - (3, migrateSchema2To3 runIO) + [ (2, migrateSchema1To2 getDeclType termBuffer declBuffer), + (3, migrateSchema2To3) ] -- | Migrates a codebase up to the most recent version known to ucm. @@ -57,18 +56,18 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer co UnliftIO.try do liftIO do ranMigrations <- - Sqlite.runWriteTransaction conn \runIO -> do - schemaVersion <- Q.schemaVersion - let migs = migrations getDeclType termBuffer declBuffer runIO + Sqlite.runWriteTransaction conn \run -> do + schemaVersion <- run Q.schemaVersion + let migs = migrations getDeclType termBuffer declBuffer -- The highest schema that this ucm knows how to migrate to. let currentSchemaVersion = fst . head $ Map.toDescList migs - when (schemaVersion > currentSchemaVersion) $ runIO $ UnliftIO.throwIO $ OpenCodebaseUnknownSchemaVersion (fromIntegral schemaVersion) + when (schemaVersion > currentSchemaVersion) $ UnliftIO.throwIO $ OpenCodebaseUnknownSchemaVersion (fromIntegral schemaVersion) let migrationsToRun = Map.filterWithKey (\v _ -> v > schemaVersion) migs - when (localOrRemote == Local && (not . null) migrationsToRun) $ runIO $ backupCodebase root + when (localOrRemote == Local && (not . null) migrationsToRun) $ backupCodebase root for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do - runIO . putStrLn $ "๐Ÿ”จ Migrating codebase to version " <> show v <> "..." - migration + putStrLn $ "๐Ÿ”จ Migrating codebase to version " <> show v <> "..." + run migration pure (not (null migrationsToRun)) when ranMigrations do -- Vacuum once now that any migrations have taken place. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/Errors.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/Errors.hs deleted file mode 100644 index 16973b16d9..0000000000 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/Errors.hs +++ /dev/null @@ -1,11 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} - -module Unison.Codebase.SqliteCodebase.Migrations.Errors where - -import U.Codebase.Sqlite.DbId (SchemaVersion) -import Unison.Prelude - -data MigrationError - = IncorrectStartingSchemaVersion SchemaVersion - deriving (Show, Eq, Ord) - deriving anyclass (Exception) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 2641313278..ef3b3d428c 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -91,19 +91,18 @@ migrateSchema1To2 :: (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> TVar (Map Hash Ops2.TermBufferEntry) -> TVar (Map Hash Ops2.DeclBufferEntry) -> - (forall x. IO x -> Sqlite.Transaction x) -> Sqlite.Transaction () -migrateSchema1To2 getDeclType termBuffer declBuffer runIO = do - runIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" +migrateSchema1To2 getDeclType termBuffer declBuffer = do + Sqlite.idempotentIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" corruptedCausals <- Q.getCausalsWithoutBranchObjects when (not . null $ corruptedCausals) $ - runIO $ do + Sqlite.idempotentIO $ do putStrLn $ "โš ๏ธ I detected " <> show (length corruptedCausals) <> " corrupted namespace(s) in the history of the codebase." putStrLn $ "This is due to a bug in a previous version of ucm." putStrLn $ "This only affects the history of your codebase, the most up-to-date iteration will remain intact." putStrLn $ "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." - runIO $ putStrLn $ "Updating Namespace Root..." + Sqlite.idempotentIO $ putStrLn $ "Updating Namespace Root..." rootCausalHashId <- Q.expectNamespaceRoot numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] v2EmptyBranchHashInfo <- saveV2EmptyBranch @@ -112,42 +111,42 @@ migrateSchema1To2 getDeclType termBuffer declBuffer runIO = do (\watchKind -> map (W watchKind) <$> Ops2.watches (Cv.watchKind2to1 watchKind)) [WK.RegularWatch, WK.TestWatch] migrationState <- - Sync.sync @_ @Entity (migrationSync getDeclType termBuffer declBuffer) (progress runIO numEntitiesToMigrate) (CausalE rootCausalHashId : watches) + Sync.sync @_ @Entity (migrationSync getDeclType termBuffer declBuffer) (progress numEntitiesToMigrate) (CausalE rootCausalHashId : watches) `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId - runIO $ putStrLn $ "Updating Namespace Root..." + Sqlite.idempotentIO $ putStrLn $ "Updating Namespace Root..." Q.setNamespaceRoot newRootCausalHashId - runIO $ putStrLn $ "Rewriting old object IDs..." + Sqlite.idempotentIO $ putStrLn $ "Rewriting old object IDs..." ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do Q.recordObjectRehash oldObjId newObjId - runIO $ putStrLn $ "Garbage collecting orphaned objects..." + Sqlite.idempotentIO $ putStrLn $ "Garbage collecting orphaned objects..." Q.garbageCollectObjectsWithoutHashes - runIO $ putStrLn $ "Garbage collecting orphaned watches..." + Sqlite.idempotentIO $ putStrLn $ "Garbage collecting orphaned watches..." Q.garbageCollectWatchesWithoutObjects - runIO $ putStrLn $ "Updating Schema Version..." + Sqlite.idempotentIO $ putStrLn $ "Updating Schema Version..." Q.setSchemaVersion 2 where - progress :: (forall a. IO a -> Sqlite.Transaction a) -> Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) Entity - progress runIO numToMigrate = + progress :: Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) Entity + progress numToMigrate = let incrementProgress :: StateT MigrationState Sqlite.Transaction () incrementProgress = do numDone <- field @"numMigrated" <+= 1 - lift $ runIO $ putStr $ "\r ๐Ÿ— " <> show numDone <> " / ~" <> show numToMigrate <> " entities migrated. ๐Ÿšง" + lift $ Sqlite.idempotentIO $ putStr $ "\r ๐Ÿ— " <> show numDone <> " / ~" <> show numToMigrate <> " entities migrated. ๐Ÿšง" need :: Entity -> StateT MigrationState Sqlite.Transaction () - need e = when verboseOutput $ lift $ runIO $ putStrLn $ "Need: " ++ show e + need e = when verboseOutput $ lift $ Sqlite.idempotentIO $ putStrLn $ "Need: " ++ show e done :: Entity -> StateT MigrationState Sqlite.Transaction () done e = do - when verboseOutput $ lift $ runIO $ putStrLn $ "Done: " ++ show e + when verboseOutput $ lift $ Sqlite.idempotentIO $ putStrLn $ "Done: " ++ show e incrementProgress errorHandler :: Entity -> StateT MigrationState Sqlite.Transaction () errorHandler e = do case e of -- We expect non-fatal errors when migrating watches. W {} -> pure () - e -> lift $ runIO $ putStrLn $ "Error: " ++ show e + e -> lift $ Sqlite.idempotentIO $ putStrLn $ "Error: " ++ show e incrementProgress allDone :: StateT MigrationState Sqlite.Transaction () - allDone = lift $ runIO $ putStrLn $ "\nFinished migrating, initiating cleanup." + allDone = lift $ Sqlite.idempotentIO $ putStrLn $ "\nFinished migrating, initiating cleanup." in Sync.Progress {need, done, error = errorHandler, allDone} type Old a = a diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs index 87fe257c8d..1f4d5982bb 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs @@ -4,7 +4,6 @@ import Control.Exception (throwIO) import Control.Monad.Reader import U.Codebase.Sqlite.DbId (HashVersion (..), SchemaVersion (..)) import qualified U.Codebase.Sqlite.Queries as Q -import Unison.Codebase.SqliteCodebase.Migrations.Errors (MigrationError (IncorrectStartingSchemaVersion)) import qualified Unison.Sqlite as Sqlite -- | The 1 to 2 migration kept around hash objects of hash version 1, unfortunately this @@ -22,9 +21,8 @@ import qualified Unison.Sqlite as Sqlite -- -- This migration drops all the v1 hash objects to avoid this issue, since these hash objects -- weren't being used for anything anyways. -migrateSchema2To3 :: (forall a. IO a -> Sqlite.Transaction a) -> Sqlite.Transaction () -migrateSchema2To3 runIO = do - version <- Q.schemaVersion - when (version /= 2) $ runIO $ throwIO (IncorrectStartingSchemaVersion version) +migrateSchema2To3 :: Sqlite.Transaction () +migrateSchema2To3 = do + Q.expectSchemaVersion 2 Q.removeHashObjectsByHashingVersion (HashVersion 1) - Q.setSchemaVersion (SchemaVersion 3) + Q.setSchemaVersion 3 diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 9ecf6dc557..d5847318c6 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -66,7 +66,6 @@ library Unison.Codebase.SqliteCodebase.Conversions Unison.Codebase.SqliteCodebase.GitError Unison.Codebase.SqliteCodebase.Migrations - Unison.Codebase.SqliteCodebase.Migrations.Errors Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3 From 62a8b0ca7e9c8095bb9aab5dc196f8adf94e59e3 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 15 Apr 2022 10:17:12 -0500 Subject: [PATCH 126/529] add fail responses to Sync.Types --- unison-share-api/src/Unison/Sync/Types.hs | 39 +++++++++++++++-------- 1 file changed, 25 insertions(+), 14 deletions(-) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 72db4e32c7..f2d7194ca7 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -17,6 +17,7 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import Data.Text (Text) +import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import U.Util.Base32Hex (Base32Hex (..)) @@ -134,21 +135,22 @@ instance FromJSON GetCausalHashByPathRequest where repoPath <- obj .: "repo_path" pure GetCausalHashByPathRequest {..} -newtype GetCausalHashByPathResponse = GetCausalHashByPathResponse - { causalHash :: Maybe HashJWT - } +data GetCausalHashByPathResponse + = GetCausalHashByPathSuccess (Maybe HashJWT) + | GetCausalHashByPathNoReadPermission RepoPath deriving stock (Show, Eq, Ord) instance ToJSON GetCausalHashByPathResponse where - toJSON (GetCausalHashByPathResponse hashJWT) = - object - [ "causal_hash" .= hashJWT - ] + toJSON = \case + GetCausalHashByPathSuccess hashJWT -> jsonUnion "success" hashJWT + GetCausalHashByPathNoReadPermission repoPath -> jsonUnion "no_read_permission" repoPath instance FromJSON GetCausalHashByPathResponse where - parseJSON = Aeson.withObject "GetCausalHashByPathResponse" $ \obj -> do - causalHash <- obj .: "causal_hash" - pure GetCausalHashByPathResponse {..} + parseJSON = Aeson.withObject "GetCausalHashByPathResponse" \obj -> do + obj .: "type" >>= Aeson.withText "type" \case + "success" -> GetCausalHashByPathSuccess <$> obj .: "payload" + "no_read_permission" -> GetCausalHashByPathNoReadPermission <$> obj .: "payload" + t -> failText $ "Unexpected GetCausalHashByPathResponse type: " <> t data DownloadEntitiesRequest = DownloadEntitiesRequest { repoName :: RepoName, @@ -210,6 +212,7 @@ data UpdatePathResponse = UpdatePathSuccess | UpdatePathHashMismatch HashMismatch | UpdatePathMissingDependencies (NeedDependencies Hash) + | UpdatePathNoWritePermission RepoPath deriving stock (Show, Eq, Ord) jsonUnion :: ToJSON a => Text -> a -> Value @@ -224,6 +227,7 @@ instance ToJSON UpdatePathResponse where UpdatePathSuccess -> jsonUnion "success" (Object mempty) UpdatePathHashMismatch hm -> jsonUnion "hash_mismatch" hm UpdatePathMissingDependencies md -> jsonUnion "missing_dependencies" md + UpdatePathNoWritePermission repoPath -> jsonUnion "no_write_permission" repoPath instance FromJSON UpdatePathResponse where parseJSON v = @@ -232,7 +236,8 @@ instance FromJSON UpdatePathResponse where "success" -> pure UpdatePathSuccess "hash_mismatch" -> UpdatePathHashMismatch <$> obj .: "payload" "missing_dependencies" -> UpdatePathMissingDependencies <$> obj .: "payload" - _ -> fail "Unknown UpdatePathResponse type" + "no_write_permission" -> UpdatePathNoWritePermission <$> obj .: "payload" + t -> failText $ "Unexpected UpdatePathResponse type: " <> t data NeedDependencies hash = NeedDependencies { missingDependencies :: NESet hash @@ -292,20 +297,23 @@ instance FromJSON UploadEntitiesRequest where data UploadEntitiesResponse = UploadEntitiesSuccess | UploadEntitiesNeedDependencies (NeedDependencies Hash) + | UploadEntitiesNoWritePermission RepoName deriving stock (Show, Eq, Ord) instance ToJSON UploadEntitiesResponse where toJSON = \case UploadEntitiesSuccess -> jsonUnion "success" (Object mempty) UploadEntitiesNeedDependencies nd -> jsonUnion "need_dependencies" nd + UploadEntitiesNoWritePermission repoName -> jsonUnion "no_write_permission" repoName instance FromJSON UploadEntitiesResponse where parseJSON v = v & Aeson.withObject "UploadEntitiesResponse" \obj -> obj .: "type" >>= Aeson.withText "type" \case - "need_dependencies" -> UploadEntitiesNeedDependencies <$> obj .: "payload" "success" -> pure UploadEntitiesSuccess - _ -> fail "Unknown UploadEntitiesResponse type" + "need_dependencies" -> UploadEntitiesNeedDependencies <$> obj .: "payload" + "no_write_permission" -> UploadEntitiesNoWritePermission <$> obj .: "payload" + t -> failText $ "Unexpected UploadEntitiesResponse type: " <> t data Entity text noSyncHash hash = TC (TermComponent text hash) @@ -409,6 +417,9 @@ decodeComponentPiece = Aeson.withObject "Component Piece" $ \obj -> do Base64Bytes bytes <- obj .: "local_ids" pure (localIDs, bytes) +failText :: MonadFail m => Text -> m a +failText = fail . Text.unpack + instance (FromJSON text, FromJSON hash) => FromJSON (TermComponent text hash) where parseJSON = Aeson.withObject "TermComponent" $ \obj -> do pieces <- obj .: "terms" @@ -581,4 +592,4 @@ instance FromJSON EntityType where "patch" -> pure PatchType "namespace" -> pure NamespaceType "causal" -> pure CausalType - _ -> fail "Unexpected entity type" + t -> failText $ "Unexpected entity type: " <> t From 3fc9435d5f01f5bf6a74aa7a7d4e9819c3fcdd03 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 15 Apr 2022 12:56:51 -0400 Subject: [PATCH 127/529] idempotentIO -> unsafeIO --- lib/unison-sqlite/src/Unison/Sqlite.hs | 2 +- .../src/Unison/Sqlite/Transaction.hs | 8 +++--- .../src/Unison/Codebase/SqliteCodebase.hs | 9 +++---- .../Migrations/MigrateSchema1To2.hs | 26 +++++++++---------- .../Migrations/MigrateSchema2To3.hs | 4 +-- .../Codebase/SqliteCodebase/Operations.hs | 20 +++++++------- 6 files changed, 33 insertions(+), 36 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index 27247aeb94..f929cd6da2 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -22,7 +22,7 @@ module Unison.Sqlite runWriteTransaction, unsafeUnTransaction, savepoint, - idempotentIO, + unsafeIO, -- * Executing queries Sql (..), diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 2cf4f3d17f..9b3e026c40 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -6,7 +6,7 @@ module Unison.Sqlite.Transaction runWriteTransaction, unsafeUnTransaction, savepoint, - idempotentIO, + unsafeIO, -- * Executing queries @@ -182,8 +182,8 @@ savepoint (Transaction action) = do -- | Perform IO inside a transaction, which should be idempotent, because it may be run more than once. -- FIXME rename to unsafeIO or something -idempotentIO :: IO a -> Transaction a -idempotentIO action = +unsafeIO :: IO a -> Transaction a +unsafeIO action = Transaction \_ -> action -- Without results, with parameters @@ -213,7 +213,7 @@ queryStreamRow :: queryStreamRow s params callback = Transaction \conn -> Connection.queryStreamRow conn s params \next -> - unsafeUnTransaction (callback (idempotentIO next)) conn + unsafeUnTransaction (callback (unsafeIO next)) conn queryStreamCol :: forall a b r. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 5b7ee2c0ab..a729166706 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -208,8 +208,7 @@ sqliteCodebase debugName root localOrRemote action = do getDeclType :: C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType getDeclType = - Sqlite.idempotentIO - . Cache.apply declTypeCache (\ref -> Sqlite.unsafeUnTransaction (Ops2.getDeclType ref) conn) + Sqlite.unsafeIO . Cache.apply declTypeCache (\ref -> Sqlite.unsafeUnTransaction (Ops2.getDeclType ref) conn) getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann)) getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined @@ -261,7 +260,7 @@ sqliteCodebase debugName root localOrRemote action = do putRootBranch rootBranchCache branch1 = withRunInIO \runInIO -> Sqlite.runTransaction conn do - Ops2.putRootBranch rootBranchCache (Branch.transform (Sqlite.idempotentIO . runInIO) branch1) + Ops2.putRootBranch rootBranchCache (Branch.transform (Sqlite.unsafeIO . runInIO) branch1) rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.Hash)) rootBranchUpdates _rootBranchCache = do @@ -312,7 +311,7 @@ sqliteCodebase debugName root localOrRemote action = do putBranch :: Branch m -> m () putBranch branch = withRunInIO \runInIO -> - Sqlite.runTransaction conn (Ops2.putBranch (Branch.transform (Sqlite.idempotentIO . runInIO) branch)) + Sqlite.runTransaction conn (Ops2.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch)) isCausalHash :: Branch.Hash -> m Bool isCausalHash h = @@ -553,7 +552,7 @@ syncInternal progress runSrc runDest b = time "syncInternal" do pure (cs, es, ts, ds) if null cs && null es && null ts && null ds then do - runDest (Ops2.putBranch (Branch.transform (Sqlite.idempotentIO . runInIO) b)) + runDest (Ops2.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) b)) processBranches rest else do let bs = map (uncurry B) cs diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index ef3b3d428c..09280fc5d9 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -93,16 +93,16 @@ migrateSchema1To2 :: TVar (Map Hash Ops2.DeclBufferEntry) -> Sqlite.Transaction () migrateSchema1To2 getDeclType termBuffer declBuffer = do - Sqlite.idempotentIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" + Sqlite.unsafeIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" corruptedCausals <- Q.getCausalsWithoutBranchObjects when (not . null $ corruptedCausals) $ - Sqlite.idempotentIO $ do + Sqlite.unsafeIO $ do putStrLn $ "โš ๏ธ I detected " <> show (length corruptedCausals) <> " corrupted namespace(s) in the history of the codebase." putStrLn $ "This is due to a bug in a previous version of ucm." putStrLn $ "This only affects the history of your codebase, the most up-to-date iteration will remain intact." putStrLn $ "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." - Sqlite.idempotentIO $ putStrLn $ "Updating Namespace Root..." + Sqlite.unsafeIO $ putStrLn $ "Updating Namespace Root..." rootCausalHashId <- Q.expectNamespaceRoot numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] v2EmptyBranchHashInfo <- saveV2EmptyBranch @@ -114,16 +114,16 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do Sync.sync @_ @Entity (migrationSync getDeclType termBuffer declBuffer) (progress numEntitiesToMigrate) (CausalE rootCausalHashId : watches) `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId - Sqlite.idempotentIO $ putStrLn $ "Updating Namespace Root..." + Sqlite.unsafeIO $ putStrLn $ "Updating Namespace Root..." Q.setNamespaceRoot newRootCausalHashId - Sqlite.idempotentIO $ putStrLn $ "Rewriting old object IDs..." + Sqlite.unsafeIO $ putStrLn $ "Rewriting old object IDs..." ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do Q.recordObjectRehash oldObjId newObjId - Sqlite.idempotentIO $ putStrLn $ "Garbage collecting orphaned objects..." + Sqlite.unsafeIO $ putStrLn $ "Garbage collecting orphaned objects..." Q.garbageCollectObjectsWithoutHashes - Sqlite.idempotentIO $ putStrLn $ "Garbage collecting orphaned watches..." + Sqlite.unsafeIO $ putStrLn $ "Garbage collecting orphaned watches..." Q.garbageCollectWatchesWithoutObjects - Sqlite.idempotentIO $ putStrLn $ "Updating Schema Version..." + Sqlite.unsafeIO $ putStrLn $ "Updating Schema Version..." Q.setSchemaVersion 2 where progress :: Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) Entity @@ -131,22 +131,22 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do let incrementProgress :: StateT MigrationState Sqlite.Transaction () incrementProgress = do numDone <- field @"numMigrated" <+= 1 - lift $ Sqlite.idempotentIO $ putStr $ "\r ๐Ÿ— " <> show numDone <> " / ~" <> show numToMigrate <> " entities migrated. ๐Ÿšง" + lift $ Sqlite.unsafeIO $ putStr $ "\r ๐Ÿ— " <> show numDone <> " / ~" <> show numToMigrate <> " entities migrated. ๐Ÿšง" need :: Entity -> StateT MigrationState Sqlite.Transaction () - need e = when verboseOutput $ lift $ Sqlite.idempotentIO $ putStrLn $ "Need: " ++ show e + need e = when verboseOutput $ lift $ Sqlite.unsafeIO $ putStrLn $ "Need: " ++ show e done :: Entity -> StateT MigrationState Sqlite.Transaction () done e = do - when verboseOutput $ lift $ Sqlite.idempotentIO $ putStrLn $ "Done: " ++ show e + when verboseOutput $ lift $ Sqlite.unsafeIO $ putStrLn $ "Done: " ++ show e incrementProgress errorHandler :: Entity -> StateT MigrationState Sqlite.Transaction () errorHandler e = do case e of -- We expect non-fatal errors when migrating watches. W {} -> pure () - e -> lift $ Sqlite.idempotentIO $ putStrLn $ "Error: " ++ show e + e -> lift $ Sqlite.unsafeIO $ putStrLn $ "Error: " ++ show e incrementProgress allDone :: StateT MigrationState Sqlite.Transaction () - allDone = lift $ Sqlite.idempotentIO $ putStrLn $ "\nFinished migrating, initiating cleanup." + allDone = lift $ Sqlite.unsafeIO $ putStrLn $ "\nFinished migrating, initiating cleanup." in Sync.Progress {need, done, error = errorHandler, allDone} type Old a = a diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs index 1f4d5982bb..cf0eb8f12d 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema2To3.hs @@ -1,8 +1,6 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3 (migrateSchema2To3) where -import Control.Exception (throwIO) -import Control.Monad.Reader -import U.Codebase.Sqlite.DbId (HashVersion (..), SchemaVersion (..)) +import U.Codebase.Sqlite.DbId (HashVersion (..)) import qualified U.Codebase.Sqlite.Queries as Q import qualified Unison.Sqlite as Sqlite diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 2e070eb54e..8e68081b4c 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -138,16 +138,16 @@ tryFlushBuffer :: tryFlushBuffer buf saveComponent tryWaiting h@(Cv.hash1to2 -> h2) = -- skip if it has already been flushed unlessM (Ops.objectExistsForHash h2) do - BufferEntry size comp (Set.delete h -> missing) waiting <- Sqlite.idempotentIO (getBuffer buf h) + BufferEntry size comp (Set.delete h -> missing) waiting <- Sqlite.unsafeIO (getBuffer buf h) case size of Just size -> do missing' <- filterM (fmap not . Ops.objectExistsForHash . Cv.hash1to2) (toList missing) if null missing' && size == fromIntegral (length comp) then do saveComponent h2 (toList comp) - Sqlite.idempotentIO (removeBuffer buf h) + Sqlite.unsafeIO (removeBuffer buf h) traverse_ tryWaiting waiting - else Sqlite.idempotentIO do + else Sqlite.unsafeIO do putBuffer buf h $ BufferEntry (Just size) comp (Set.fromList missing') waiting Nothing -> @@ -223,7 +223,7 @@ putTerm :: Transaction () putTerm termBuffer declBuffer (Reference.Id h@(Cv.hash1to2 -> h2) i) tm tp = unlessM (Ops.objectExistsForHash h2) do - BufferEntry size comp missing waiting <- Sqlite.idempotentIO (getBuffer termBuffer h) + BufferEntry size comp missing waiting <- Sqlite.unsafeIO (getBuffer termBuffer h) let termDependencies = Set.toList $ Term.termDependencies tm -- update the component target size if we encounter any higher self-references let size' = max size (Just $ biggestSelfReference + 1) @@ -242,7 +242,7 @@ putTerm termBuffer declBuffer (Reference.Id h@(Cv.hash1to2 -> h2) i) tm tp = [h | Reference.Derived h _i <- Set.toList $ Term.typeDependencies tm] ++ [h | Reference.Derived h _i <- Set.toList $ Type.dependencies tp] let missing' = missing <> Set.fromList (missingTerms' <> missingTypes') - Sqlite.idempotentIO do + Sqlite.unsafeIO do -- notify each of the dependencies that h depends on them. traverse_ (addBufferDependent h termBuffer) missingTerms' traverse_ (addBufferDependent h declBuffer) missingTypes' @@ -290,7 +290,7 @@ putTypeDeclaration :: Transaction () putTypeDeclaration termBuffer declBuffer (Reference.Id h@(Cv.hash1to2 -> h2) i) decl = unlessM (Ops.objectExistsForHash h2) do - BufferEntry size comp missing waiting <- Sqlite.idempotentIO (getBuffer declBuffer h) + BufferEntry size comp missing waiting <- Sqlite.unsafeIO (getBuffer declBuffer h) let declDependencies = Set.toList $ Decl.declDependencies decl let size' = max size (Just $ biggestSelfReference + 1) where @@ -302,7 +302,7 @@ putTypeDeclaration termBuffer declBuffer (Reference.Id h@(Cv.hash1to2 -> h2) i) filterM (fmap not . Ops.objectExistsForHash . Cv.hash1to2) $ [h | Reference.Derived h _i <- declDependencies] let missing' = missing <> Set.fromList moreMissing - Sqlite.idempotentIO do + Sqlite.unsafeIO do traverse_ (addBufferDependent h declBuffer) moreMissing putBuffer declBuffer h (BufferEntry size' comp' missing' waiting) tryFlushDeclBuffer termBuffer declBuffer h @@ -331,7 +331,7 @@ getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Transaction)) -> Transaction (Branch Transaction) getRootBranch doGetDeclType rootBranchCache = - Sqlite.idempotentIO (readTVarIO rootBranchCache) >>= \case + Sqlite.unsafeIO (readTVarIO rootBranchCache) >>= \case Nothing -> forceReload Just (v, b) -> do -- check to see if root namespace hash has been externally modified @@ -352,7 +352,7 @@ getRootBranch doGetDeclType rootBranchCache = causal2 <- Ops.expectRootCausal branch1 <- Cv.causalbranch2to1 doGetDeclType causal2 ver <- Sqlite.getDataVersion - Sqlite.idempotentIO (atomically (writeTVar rootBranchCache (Just (ver, branch1)))) + Sqlite.unsafeIO (atomically (writeTVar rootBranchCache (Just (ver, branch1)))) pure branch1 getRootBranchExists :: Transaction Bool @@ -364,7 +364,7 @@ putRootBranch rootBranchCache branch1 = do -- todo: check to see if root namespace hash has been externally modified -- and do something (merge?) it if necessary. But for now, we just overwrite it. void (Ops.saveRootBranch (Cv.causalbranch1to2 branch1)) - Sqlite.idempotentIO (atomically $ modifyTVar' rootBranchCache (fmap . second $ const branch1)) + Sqlite.unsafeIO (atomically $ modifyTVar' rootBranchCache (fmap . second $ const branch1)) -- rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.Hash)) -- rootBranchUpdates _rootBranchCache = do From 56e50557574d0fbb8bdf610bd94f5b67cf7765e8 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 15 Apr 2022 16:15:08 -0400 Subject: [PATCH 128/529] rename some imports and delete some commented out code --- .../src/Unison/Codebase/SqliteCodebase.hs | 90 +++++++++---------- .../Migrations/MigrateSchema1To2.hs | 32 +++---- .../Codebase/SqliteCodebase/Operations.hs | 52 ----------- 3 files changed, 61 insertions(+), 113 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index a729166706..83fb55ae16 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -55,7 +55,7 @@ import qualified Unison.Codebase.SqliteCodebase.Branch.Dependencies as BD import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import qualified Unison.Codebase.SqliteCodebase.GitError as GitError import Unison.Codebase.SqliteCodebase.Migrations (ensureCodebaseIsUpToDate) -import qualified Unison.Codebase.SqliteCodebase.Operations as Ops2 +import qualified Unison.Codebase.SqliteCodebase.Operations as CodebaseOps import Unison.Codebase.SqliteCodebase.Paths import qualified Unison.Codebase.SqliteCodebase.SyncEphemeral as SyncEphemeral import Unison.Codebase.SyncMode (SyncMode) @@ -190,7 +190,7 @@ sqliteCodebase :: ((Codebase m Symbol Ann, Sqlite.Connection) -> m r) -> m (Either Codebase1.OpenCodebaseError r) sqliteCodebase debugName root localOrRemote action = do - -- Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root + Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root withConnection debugName root $ \conn -> do termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable typeOfTermCache <- Cache.semispaceCache 8192 @@ -199,37 +199,37 @@ sqliteCodebase debugName root localOrRemote action = do -- The v1 codebase interface has operations to read and write individual definitions -- whereas the v2 codebase writes them as complete components. These two fields buffer -- the individual definitions until a complete component has been written. - termBuffer :: TVar (Map Hash Ops2.TermBufferEntry) <- newTVarIO Map.empty - declBuffer :: TVar (Map Hash Ops2.DeclBufferEntry) <- newTVarIO Map.empty + termBuffer :: TVar (Map Hash CodebaseOps.TermBufferEntry) <- newTVarIO Map.empty + declBuffer :: TVar (Map Hash CodebaseOps.DeclBufferEntry) <- newTVarIO Map.empty declTypeCache <- Cache.semispaceCache 2048 let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann)) getTerm id = - Sqlite.runTransaction conn (Ops2.getTerm getDeclType id) + Sqlite.runTransaction conn (CodebaseOps.getTerm getDeclType id) getDeclType :: C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType getDeclType = - Sqlite.unsafeIO . Cache.apply declTypeCache (\ref -> Sqlite.unsafeUnTransaction (Ops2.getDeclType ref) conn) + Sqlite.unsafeIO . Cache.apply declTypeCache (\ref -> Sqlite.unsafeUnTransaction (CodebaseOps.getDeclType ref) conn) getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann)) getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined getTypeOfTermImpl id = - Sqlite.runTransaction conn (Ops2.getTypeOfTermImpl id) + Sqlite.runTransaction conn (CodebaseOps.getTypeOfTermImpl id) getTermComponentWithTypes :: Hash -> m (Maybe [(Term Symbol Ann, Type Symbol Ann)]) getTermComponentWithTypes h = - Sqlite.runTransaction conn (Ops2.getTermComponentWithTypes getDeclType h) + Sqlite.runTransaction conn (CodebaseOps.getTermComponentWithTypes getDeclType h) getTypeDeclaration :: Reference.Id -> m (Maybe (Decl Symbol Ann)) getTypeDeclaration id = - Sqlite.runTransaction conn (Ops2.getTypeDeclaration id) + Sqlite.runTransaction conn (CodebaseOps.getTypeDeclaration id) getDeclComponent :: Hash -> m (Maybe [Decl Symbol Ann]) getDeclComponent h = - Sqlite.runTransaction conn (Ops2.getDeclComponent h) + Sqlite.runTransaction conn (CodebaseOps.getDeclComponent h) getCycleLength :: Hash -> m (Maybe Reference.CycleSize) getCycleLength h = - Sqlite.runTransaction conn (Ops2.getCycleLength h) + Sqlite.runTransaction conn (CodebaseOps.getCycleLength h) -- putTermComponent :: MonadIO m => Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> m () -- putTerms :: MonadIO m => Map Reference.Id (Term Symbol Ann, Type Symbol Ann) -> m () -- dies horribly if missing dependencies? @@ -241,26 +241,26 @@ sqliteCodebase debugName root localOrRemote action = do putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m () putTerm id tm tp | debug && trace (show "SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined putTerm id tm tp = - Sqlite.runTransaction conn (Ops2.putTerm termBuffer declBuffer id tm tp) + Sqlite.runTransaction conn (CodebaseOps.putTerm termBuffer declBuffer id tm tp) putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> m () putTypeDeclaration id decl = - Sqlite.runTransaction conn (Ops2.putTypeDeclaration termBuffer declBuffer id decl) + Sqlite.runTransaction conn (CodebaseOps.putTypeDeclaration termBuffer declBuffer id decl) getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> m (Branch m) getRootBranch rootBranchCache = Sqlite.runReadOnlyTransaction conn \run -> - Branch.transform run <$> run (Ops2.getRootBranch getDeclType rootBranchCache) + Branch.transform run <$> run (CodebaseOps.getRootBranch getDeclType rootBranchCache) getRootBranchExists :: m Bool getRootBranchExists = - Sqlite.runTransaction conn Ops2.getRootBranchExists + Sqlite.runTransaction conn CodebaseOps.getRootBranchExists putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> Branch m -> m () putRootBranch rootBranchCache branch1 = withRunInIO \runInIO -> Sqlite.runTransaction conn do - Ops2.putRootBranch rootBranchCache (Branch.transform (Sqlite.unsafeIO . runInIO) branch1) + CodebaseOps.putRootBranch rootBranchCache (Branch.transform (Sqlite.unsafeIO . runInIO) branch1) rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.Hash)) rootBranchUpdates _rootBranchCache = do @@ -306,36 +306,36 @@ sqliteCodebase debugName root localOrRemote action = do getBranchForHash :: Branch.Hash -> m (Maybe (Branch m)) getBranchForHash h = Sqlite.runReadOnlyTransaction conn \run -> - fmap (Branch.transform run) <$> run (Ops2.getBranchForHash getDeclType h) + fmap (Branch.transform run) <$> run (CodebaseOps.getBranchForHash getDeclType h) putBranch :: Branch m -> m () putBranch branch = withRunInIO \runInIO -> - Sqlite.runTransaction conn (Ops2.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch)) + Sqlite.runTransaction conn (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch)) isCausalHash :: Branch.Hash -> m Bool isCausalHash h = - Sqlite.runTransaction conn (Ops2.isCausalHash h) + Sqlite.runTransaction conn (CodebaseOps.isCausalHash h) getPatch :: Branch.EditHash -> m (Maybe Patch) getPatch h = - Sqlite.runTransaction conn (Ops2.getPatch h) + Sqlite.runTransaction conn (CodebaseOps.getPatch h) putPatch :: Branch.EditHash -> Patch -> m () putPatch h p = - Sqlite.runTransaction conn (Ops2.putPatch h p) + Sqlite.runTransaction conn (CodebaseOps.putPatch h p) patchExists :: Branch.EditHash -> m Bool patchExists h = - Sqlite.runTransaction conn (Ops2.patchExists h) + Sqlite.runTransaction conn (CodebaseOps.patchExists h) dependentsImpl :: Reference -> m (Set Reference.Id) dependentsImpl r = - Sqlite.runTransaction conn (Ops2.dependentsImpl r) + Sqlite.runTransaction conn (CodebaseOps.dependentsImpl r) dependentsOfComponentImpl :: Hash -> m (Set Reference.Id) dependentsOfComponentImpl h = - Sqlite.runTransaction conn (Ops2.dependentsOfComponentImpl h) + Sqlite.runTransaction conn (CodebaseOps.dependentsOfComponentImpl h) syncFromDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m () syncFromDirectory srcRoot _syncMode b = do @@ -356,19 +356,19 @@ sqliteCodebase debugName root localOrRemote action = do watches :: UF.WatchKind -> m [Reference.Id] watches w = - Sqlite.runTransaction conn (Ops2.watches w) + Sqlite.runTransaction conn (CodebaseOps.watches w) getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann)) getWatch k r = - Sqlite.runTransaction conn (Ops2.getWatch getDeclType k r) + Sqlite.runTransaction conn (CodebaseOps.getWatch getDeclType k r) putWatch :: UF.WatchKind -> Reference.Id -> Term Symbol Ann -> m () putWatch k r tm = - Sqlite.runTransaction conn (Ops2.putWatch k r tm) + Sqlite.runTransaction conn (CodebaseOps.putWatch k r tm) clearWatches :: m () clearWatches = - Sqlite.runTransaction conn Ops2.clearWatches + Sqlite.runTransaction conn CodebaseOps.clearWatches getReflog :: m [Reflog.Entry Branch.Hash] getReflog = @@ -398,39 +398,39 @@ sqliteCodebase debugName root localOrRemote action = do termsOfTypeImpl :: Reference -> m (Set Referent.Id) termsOfTypeImpl r = - Sqlite.runTransaction conn (Ops2.termsOfTypeImpl getDeclType r) + Sqlite.runTransaction conn (CodebaseOps.termsOfTypeImpl getDeclType r) termsMentioningTypeImpl :: Reference -> m (Set Referent.Id) termsMentioningTypeImpl r = - Sqlite.runTransaction conn (Ops2.termsMentioningTypeImpl getDeclType r) + Sqlite.runTransaction conn (CodebaseOps.termsMentioningTypeImpl getDeclType r) hashLength :: m Int hashLength = - Sqlite.runTransaction conn Ops2.hashLength + Sqlite.runTransaction conn CodebaseOps.hashLength branchHashLength :: m Int branchHashLength = - Sqlite.runTransaction conn Ops2.branchHashLength + Sqlite.runTransaction conn CodebaseOps.branchHashLength termReferencesByPrefix :: ShortHash -> m (Set Reference.Id) termReferencesByPrefix sh = - Sqlite.runTransaction conn (Ops2.termReferencesByPrefix sh) + Sqlite.runTransaction conn (CodebaseOps.termReferencesByPrefix sh) declReferencesByPrefix :: ShortHash -> m (Set Reference.Id) declReferencesByPrefix sh = - Sqlite.runTransaction conn (Ops2.declReferencesByPrefix sh) + Sqlite.runTransaction conn (CodebaseOps.declReferencesByPrefix sh) referentsByPrefix :: ShortHash -> m (Set Referent.Id) referentsByPrefix sh = - Sqlite.runTransaction conn (Ops2.referentsByPrefix getDeclType sh) + Sqlite.runTransaction conn (CodebaseOps.referentsByPrefix getDeclType sh) branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.Hash) branchHashesByPrefix sh = - Sqlite.runTransaction conn (Ops2.branchHashesByPrefix sh) + Sqlite.runTransaction conn (CodebaseOps.branchHashesByPrefix sh) sqlLca :: Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash) sqlLca h1 h2 = - Sqlite.runTransaction conn (Ops2.sqlLca h1 h2) + Sqlite.runTransaction conn (CodebaseOps.sqlLca h1 h2) let codebase = C.Codebase (Cache.applyDefined termCache getTerm) @@ -473,7 +473,7 @@ sqliteCodebase debugName root localOrRemote action = do branchHashLength branchHashesByPrefix (Just sqlLca) - (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> Ops2.before l r) + (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r) let finalizer :: MonadIO m => m () finalizer = do decls <- readTVarIO declBuffer @@ -523,7 +523,7 @@ syncInternal progress runSrc runDest b = time "syncInternal" do traceM $ "processBranches " ++ show b0 traceM $ " queue: " ++ show rest ifM - (runDest (Ops2.isCausalHash h)) + (runDest (CodebaseOps.isCausalHash h)) do when debugProcessBranches $ traceM $ " " ++ show b0 ++ " already exists in dest db" processBranches rest @@ -545,14 +545,14 @@ syncInternal progress runSrc runDest b = time "syncInternal" do traceM $ " decls: " ++ show ds traceM $ " edits: " ++ show es (cs, es, ts, ds) <- runDest do - cs <- filterM (fmap not . Ops2.isCausalHash . fst) branchDeps - es <- filterM (fmap not . Ops2.patchExists) es - ts <- filterM (fmap not . Ops2.termExists) ts - ds <- filterM (fmap not . Ops2.declExists) ds + cs <- filterM (fmap not . CodebaseOps.isCausalHash . fst) branchDeps + es <- filterM (fmap not . CodebaseOps.patchExists) es + ts <- filterM (fmap not . CodebaseOps.termExists) ts + ds <- filterM (fmap not . CodebaseOps.declExists) ds pure (cs, es, ts, ds) if null cs && null es && null ts && null ds then do - runDest (Ops2.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) b)) + runDest (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) b)) processBranches rest else do let bs = map (uncurry B) cs @@ -767,7 +767,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift case maybeOldRootHash of Nothing -> run (setRepoRoot newBranchHash) Just oldRootHash -> do - run (Ops2.before oldRootHash newBranchHash) >>= \case + run (CodebaseOps.before oldRootHash newBranchHash) >>= \case Nothing -> error $ "I couldn't find the hash " ++ show newBranchHash diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 09280fc5d9..510c91dd16 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -58,7 +58,7 @@ import U.Util.Monoid (foldMapM) import qualified Unison.ABT as ABT import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import qualified Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers as Hashing -import qualified Unison.Codebase.SqliteCodebase.Operations as Ops2 +import qualified Unison.Codebase.SqliteCodebase.Operations as CodebaseOps import qualified Unison.ConstructorReference as ConstructorReference import qualified Unison.ConstructorType as CT import qualified Unison.DataDeclaration as DD @@ -89,8 +89,8 @@ verboseOutput = migrateSchema1To2 :: -- | A 'getDeclType'-like lookup, possibly backed by a cache. (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - TVar (Map Hash Ops2.TermBufferEntry) -> - TVar (Map Hash Ops2.DeclBufferEntry) -> + TVar (Map Hash CodebaseOps.TermBufferEntry) -> + TVar (Map Hash CodebaseOps.DeclBufferEntry) -> Sqlite.Transaction () migrateSchema1To2 getDeclType termBuffer declBuffer = do Sqlite.unsafeIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" @@ -108,7 +108,7 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do v2EmptyBranchHashInfo <- saveV2EmptyBranch watches <- foldMapM - (\watchKind -> map (W watchKind) <$> Ops2.watches (Cv.watchKind2to1 watchKind)) + (\watchKind -> map (W watchKind) <$> CodebaseOps.watches (Cv.watchKind2to1 watchKind)) [WK.RegularWatch, WK.TestWatch] migrationState <- Sync.sync @_ @Entity (migrationSync getDeclType termBuffer declBuffer) (progress numEntitiesToMigrate) (CausalE rootCausalHashId : watches) @@ -183,8 +183,8 @@ data Entity migrationSync :: -- | A 'getDeclType'-like lookup, possibly backed by a cache. (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - TVar (Map Hash Ops2.TermBufferEntry) -> - TVar (Map Hash Ops2.DeclBufferEntry) -> + TVar (Map Hash CodebaseOps.TermBufferEntry) -> + TVar (Map Hash CodebaseOps.DeclBufferEntry) -> Sync (StateT MigrationState Sqlite.Transaction) Entity migrationSync getDeclType termBuffer declBuffer = Sync \case TermComponent hash -> migrateTermComponent getDeclType termBuffer declBuffer hash @@ -402,7 +402,7 @@ migrateWatch :: migrateWatch getDeclType watchKind oldWatchId = fmap (either id id) . runExceptT $ do let watchKindV1 = Cv.watchKind2to1 watchKind watchResultTerm <- - (lift . lift) (Ops2.getWatch getDeclType watchKindV1 oldWatchId) >>= \case + (lift . lift) (CodebaseOps.getWatch getDeclType watchKindV1 oldWatchId) >>= \case -- The hash which we're watching doesn't exist in the codebase, throw out this watch. Nothing -> throwE Sync.Done Just term -> pure term @@ -418,7 +418,7 @@ migrateWatch getDeclType watchKind oldWatchId = fmap (either id id) . runExceptT -- One or more references in the result didn't exist in our codebase. Nothing -> pure Sync.NonFatalError Just remappedTerm -> do - lift . lift $ Ops2.putWatch watchKindV1 newWatchId remappedTerm + lift . lift $ CodebaseOps.putWatch watchKindV1 newWatchId remappedTerm pure Sync.Done uRefIdAsRefId_ :: Iso' (SomeReference (UReference.Id' Hash)) SomeReferenceId @@ -502,15 +502,15 @@ typeEditRefs_ _f (TypeEdit.Deprecate) = pure TypeEdit.Deprecate migrateTermComponent :: -- | A 'getDeclType'-like lookup, possibly backed by a cache. (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - TVar (Map Hash Ops2.TermBufferEntry) -> - TVar (Map Hash Ops2.DeclBufferEntry) -> + TVar (Map Hash CodebaseOps.TermBufferEntry) -> + TVar (Map Hash CodebaseOps.DeclBufferEntry) -> Unison.Hash -> StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) migrateTermComponent getDeclType termBuffer declBuffer oldHash = fmap (either id id) . runExceptT $ do whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone) oldComponent <- - (lift . lift $ Ops2.getTermComponentWithTypes getDeclType oldHash) >>= \case + (lift . lift $ CodebaseOps.getTermComponentWithTypes getDeclType oldHash) >>= \case Nothing -> error $ "Hash was missing from codebase: " <> show oldHash Just c -> pure c @@ -565,7 +565,7 @@ migrateTermComponent getDeclType termBuffer declBuffer oldHash = fmap (either id ifor newTermComponents $ \v (newReferenceId, trm, typ) -> do let oldReferenceId = vToOldReferenceMapping ^?! ix v field @"referenceMapping" %= Map.insert (TermReference oldReferenceId) (TermReference newReferenceId) - lift . lift $ Ops2.putTerm termBuffer declBuffer newReferenceId trm typ + lift . lift $ CodebaseOps.putTerm termBuffer declBuffer newReferenceId trm typ -- Need to get one of the new references to grab its hash, doesn't matter which one since -- all hashes in the component are the same. @@ -577,15 +577,15 @@ migrateTermComponent getDeclType termBuffer declBuffer oldHash = fmap (either id pure Sync.Done migrateDeclComponent :: - TVar (Map Hash Ops2.TermBufferEntry) -> - TVar (Map Hash Ops2.DeclBufferEntry) -> + TVar (Map Hash CodebaseOps.TermBufferEntry) -> + TVar (Map Hash CodebaseOps.DeclBufferEntry) -> Unison.Hash -> StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) migrateDeclComponent termBuffer declBuffer oldHash = fmap (either id id) . runExceptT $ do whenM (Set.member oldHash <$> use (field @"migratedDefnHashes")) (throwE Sync.PreviouslyDone) declComponent :: [DD.Decl v a] <- - (lift . lift $ Ops2.getDeclComponent oldHash) >>= \case + (lift . lift $ CodebaseOps.getDeclComponent oldHash) >>= \case Nothing -> error $ "Expected decl component for hash:" <> show oldHash Just dc -> pure dc @@ -662,7 +662,7 @@ migrateDeclComponent termBuffer declBuffer oldHash = fmap (either id id) . runEx (ConstructorReference oldReferenceId (oldConstructorIds ^?! ix constructorName)) (ConstructorReference newReferenceId newConstructorId) - lift . lift $ Ops2.putTypeDeclaration termBuffer declBuffer newReferenceId dd + lift . lift $ CodebaseOps.putTypeDeclaration termBuffer declBuffer newReferenceId dd -- Need to get one of the new references to grab its hash, doesn't matter which one since -- all hashes in the component are the same. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 8e68081b4c..f80889c3f8 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -366,45 +366,6 @@ putRootBranch rootBranchCache branch1 = do void (Ops.saveRootBranch (Cv.causalbranch1to2 branch1)) Sqlite.unsafeIO (atomically $ modifyTVar' rootBranchCache (fmap . second $ const branch1)) --- rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.Hash)) --- rootBranchUpdates _rootBranchCache = do --- -- branchHeadChanges <- TQueue.newIO --- -- (cancelWatch, watcher) <- Watch.watchDirectory' (v2dir root) --- -- watcher1 <- --- -- liftIO . forkIO --- -- $ forever --- -- $ do --- -- -- void ignores the name and time of the changed file, --- -- -- and assume 'unison.sqlite3' has changed --- -- (filename, time) <- watcher --- -- traceM $ "SqliteCodebase.watcher " ++ show (filename, time) --- -- readTVarIO rootBranchCache >>= \case --- -- Nothing -> pure () --- -- Just (v, _) -> do --- -- -- this use of `conn` in a separate thread may be problematic. --- -- -- hopefully sqlite will produce an obvious error message if it is. --- -- v' <- runDB conn Ops.dataVersion --- -- if v /= v' then --- -- atomically --- -- . TQueue.enqueue branchHeadChanges =<< runDB conn Ops.loadRootCausalHash --- -- else pure () - --- -- -- case hashFromFilePath filePath of --- -- -- Nothing -> failWith $ CantParseBranchHead filePath --- -- -- Just h -> --- -- -- atomically . TQueue.enqueue branchHeadChanges $ Branch.Hash h --- -- -- smooth out intermediate queue --- -- pure --- -- ( cancelWatch >> killThread watcher1 --- -- , Set.fromList <$> Watch.collectUntilPause branchHeadChanges 400000 --- -- ) --- pure (cleanup, liftIO newRootsDiscovered) --- where --- newRootsDiscovered = do --- Control.Concurrent.threadDelay maxBound -- hold off on returning --- pure mempty -- returning nothing --- cleanup = pure () - -- if this blows up on cromulent hashes, then switch from `hashToHashId` -- to one that returns Maybe. getBranchForHash :: @@ -453,19 +414,6 @@ dependentsOfComponentImpl h = Set.map Cv.referenceid2to1 <$> Ops.dependentsOfComponent (Cv.hash1to2 h) --- syncFromDirectory :: MonadUnliftIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m () --- syncFromDirectory srcRoot _syncMode b = do --- withConnection (debugName ++ ".sync.src") srcRoot $ \srcConn -> do --- flip State.evalStateT emptySyncProgressState $ do --- syncInternal syncProgress srcConn conn $ Branch.transform lift b - --- syncToDirectory :: MonadUnliftIO m => Codebase1.CodebasePath -> SyncMode -> Branch m -> m () --- syncToDirectory destRoot _syncMode b = --- withConnection (debugName ++ ".sync.dest") destRoot $ \destConn -> --- flip State.evalStateT emptySyncProgressState $ do --- initSchemaIfNotExist destRoot --- syncInternal syncProgress conn destConn $ Branch.transform lift b - watches :: UF.WatchKind -> Transaction [Reference.Id] watches w = Ops.listWatches (Cv.watchKind1to2 w) From 84dc47579900de2cb64170b64f51b7a332a63fb8 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 16 Apr 2022 10:34:44 -0500 Subject: [PATCH 129/529] please review - refactored saveCausal to handle parents as well - moved Q.saveCausal in Ops.saveBranch to after looking up parent ids - fleshing out Q.tryMoveTempEntityDependents (needs another name) - implemented decompose/recomposeTerm/DeclFormat for Q.saveReadyEntity - replaced sketchy usages of decompose/recomposeComponent with decompose/recomposeTerm/DeclFormat in Sync22.hs - needs audit - would hide decompose/recomposeComponent from export list, but we don't have one yet. --- .../U/Codebase/Sqlite/Operations.hs | 19 +- .../U/Codebase/Sqlite/Queries.hs | 177 ++++++++++++++++-- .../U/Codebase/Sqlite/ReadyEntity.hs | 15 ++ .../U/Codebase/Sqlite/Serialization.hs | 33 +++- .../U/Codebase/Sqlite/Sync22.hs | 132 ++++++------- .../unison-codebase-sqlite.cabal | 1 + unison-cli/src/Unison/Share/Sync.hs | 3 +- 7 files changed, 297 insertions(+), 83 deletions(-) create mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/ReadyEntity.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 105a952536..9b66958d9a 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -997,8 +997,18 @@ saveBranch (C.Causal hc he parents me) = do -- if not exist, create these chId <- liftQ (Q.saveCausalHash hc) bhId <- liftQ (Q.saveBranchHash he) - liftQ (Q.saveCausal chId bhId) - -- save the link between child and parents + + -- Mitchell's Idea + -- =============== + -- 1. Compute [CausalHashId] of parents' hashes, by doing the same short-circuity thing below + -- (just returning the hash id if it exists, or else calling this function recusrively to store the whole parent causal(s)) + -- 2. With that [CausalHashId], proceed to store this causal with a `saveCausal chId bhId parentIds` + -- 3. Beef up that `saveCausal` to do flushing things + + -- Iterate over the parent branches/causal in the in-memory Causal, + -- either looking up their CausalHashIds if they have been saved previously, + -- or storing them to the db now and collecting the resulting CausalHashIds. + -- In the end, all the parent branches/causals are saved and we have the CausalHashIds for them. parentCausalHashIds <- -- so try to save each parent (recursively) before continuing to save hc for (Map.toList parents) $ \(parentHash, mcausal) -> @@ -1007,8 +1017,9 @@ saveBranch (C.Causal hc he parents me) = do (flip Monad.fromMaybeM) (liftQ $ Q.loadCausalHashIdByCausalHash parentHash) (mcausal >>= fmap snd . saveBranch) - unless (null parentCausalHashIds) $ - liftQ (Q.saveCausalParents chId parentCausalHashIds) + + -- Save these CausalHashIds to the causal_parents table, + liftQ (Q.saveCausal chId bhId parentCausalHashIds) pure (chId, bhId) boId <- flip Monad.fromMaybeM (liftQ $ Q.loadBranchObjectIdByCausalHashId chId) do branch <- c2sBranch =<< me diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index fd0c4a314a..26707b6934 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -126,6 +126,7 @@ module U.Codebase.Sqlite.Queries garbageCollectWatchesWithoutObjects, -- * sync temp entities + getMissingDependentsForTempEntity, getMissingDependencyJwtsForTempEntity, tempEntityExists, insertTempEntity, @@ -157,6 +158,7 @@ import qualified Control.Monad.Except as Except import Control.Monad.Reader (MonadReader (ask)) import qualified Control.Monad.Reader as Reader import qualified Control.Monad.Writer as Writer +import Data.Bytes.Get (runGetS) import Data.Bytes.Put (runPutS) import qualified Data.Char as Char import qualified Data.Foldable as Foldable @@ -180,6 +182,7 @@ import Database.SQLite.Simple.ToField (ToField (..)) import U.Codebase.HashTags (BranchHash (..), CausalHash (..)) import U.Codebase.Reference (Reference' (..)) import qualified U.Codebase.Reference as C.Reference +import qualified U.Codebase.Sqlite.Causal as Sqlite.Causal import U.Codebase.Sqlite.Connection (Connection) import qualified U.Codebase.Sqlite.Connection as Connection import U.Codebase.Sqlite.DbId @@ -195,12 +198,16 @@ import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.JournalMode (JournalMode) import qualified U.Codebase.Sqlite.JournalMode as JournalMode import U.Codebase.Sqlite.ObjectType (ObjectType) +import qualified U.Codebase.Sqlite.ObjectType as ObjectType +import U.Codebase.Sqlite.ReadyEntity (ReadyEntity) +import qualified U.Codebase.Sqlite.ReadyEntity as ReadyEntity import qualified U.Codebase.Sqlite.Reference as Reference import qualified U.Codebase.Sqlite.Referent as Referent import U.Codebase.Sqlite.Serialization as Serialization import U.Codebase.Sqlite.TempEntity (HashJWT, TempEntity) import qualified U.Codebase.Sqlite.TempEntity as TempEntity import U.Codebase.Sqlite.TempEntityType (TempEntityType) +import qualified U.Codebase.Sqlite.TempEntityType as TempEntityType import U.Codebase.WatchKind (WatchKind) import qualified U.Codebase.WatchKind as WatchKind import qualified U.Util.Alternative as Alternative @@ -208,6 +215,23 @@ import U.Util.Base32Hex (Base32Hex (..)) import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash import Unison.Prelude + ( ByteString, + Exception, + HasCallStack, + Int8, + IsString (fromString), + MaybeT (MaybeT, runMaybeT), + MonadIO (..), + MonadUnliftIO (..), + Text, + headMay, + trace, + traceM, + traverse_, + try, + when, + (<&>), + ) import UnliftIO (throwIO, tryAny) import qualified UnliftIO import UnliftIO.Concurrent (myThreadId) @@ -486,17 +510,127 @@ updateObjectBlob oId bs = execute sql (oId, bs) where sql = [here| -- |Maybe we would generalize this to something other than NamespaceHash if we -- end up wanting to store other kinds of Causals here too. -saveCausal :: DB m => CausalHashId -> BranchHashId -> m () -saveCausal self value = execute sql (self, value) where sql = [here| - INSERT INTO causal (self_hash_id, value_hash_id) - VALUES (?, ?) - ON CONFLICT DO NOTHING -|] --- saveCausal self value = execute sql (self, value, Committed True, Generation 0) where sql = [here| --- INSERT INTO causal (self_hash_id, value_hash_id, commit_flag, gc_generation) --- VALUES (?, ?, ?, ?) --- ON CONFLICT DO NOTHING --- |] +saveCausal :: EDB m => CausalHashId -> BranchHashId -> [CausalHashId] -> m () +saveCausal self value parents = do + execute insertCausalSql (self, value) + changes >>= \case + 0 -> pure () + _ -> do + executeMany insertCausalParentsSql (fmap (self,) parents) + flushCausalDependents self + where + insertCausalSql = [here| + INSERT INTO causal (self_hash_id, value_hash_id) + VALUES (?, ?) + ON CONFLICT DO NOTHING + |] + insertCausalParentsSql = [here| + INSERT INTO causal_parent (causal_id, parent_id) VALUES (?, ?) + |] + +flushCausalDependents :: EDB m => CausalHashId -> m () +flushCausalDependents chId = loadHashById (unCausalHashId chId) >>= tryMoveTempEntityDependents + +-- Note: beef up insert_entity procedure to flush temp_entity table + +-- | flushTempEntity does this: +-- 1. When inserting object #foo, +-- look up all dependents of #foo in +-- temp_entity_missing_dependency table (say #bar, #baz). +-- 2. Delete (#bar, #foo) and (#baz, #foo) from temp_entity_missing_dependency. +-- 3. Delete #foo from temp_entity (if it's there) +-- 4. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, +-- insert_entity them. +-- +-- Precondition: Must have inserted the entity with hash b32 already. +tryMoveTempEntityDependents :: EDB m => Base32Hex -> m () +tryMoveTempEntityDependents dependencyBase32 = do + dependents <- getMissingDependentsForTempEntity dependencyBase32 + executeMany deleteTempDependents (dependents <&> (,dependencyBase32)) + deleteTempEntity dependencyBase32 + traverse_ moveTempEntityToMain =<< tempEntitiesWithNoMissingDependencies + where + deleteTempDependents :: SQLite.Query + deleteTempDependents = [here| + DELETE FROM temp_entity_missing_dependency + WHERE dependent = ? + AND dependency = ? + |] + + tempEntitiesWithNoMissingDependencies :: DB m => m [Base32Hex] + tempEntitiesWithNoMissingDependencies = fmap (map fromOnly) $ query_ [here| + SELECT hash FROM temp_entity + WHERE NOT EXISTS( + SELECT COUNT (1) + FROM temp_entity_missing_dependency + WHERE dependent = hash + ) + |] + +moveTempEntityToMain :: EDB m => Base32Hex -> m () +moveTempEntityToMain b32 = do + loadTempEntity b32 >>= \case + Left _ -> undefined + Right t -> do + r <- readyTempEntity t + _ <- saveReadyEntity b32 r + pure () + +loadTempEntity :: DB m => Base32Hex -> m (Either String TempEntity) +loadTempEntity b32 = do + (blob, typeId) <- queryOne $ queryMaybe sql (Only b32) + pure $ case typeId of + TempEntityType.TermComponentType -> + TempEntity.TC <$> runGetS Serialization.getTempTermFormat blob + TempEntityType.DeclComponentType -> + TempEntity.DC <$> runGetS Serialization.getTempDeclFormat blob + TempEntityType.NamespaceType -> + TempEntity.N <$> runGetS Serialization.getTempNamespaceFormat blob + TempEntityType.PatchType -> + TempEntity.P <$> runGetS Serialization.getTempPatchFormat blob + TempEntityType.CausalType -> + TempEntity.C <$> runGetS Serialization.getTempCausalFormat blob + + where sql = [here| + SELECT (blob, type_id) + FROM temp_entity + WHERE hash = ? + |] + +readyTempEntity :: DB m => TempEntity -> m ReadyEntity +readyTempEntity = \case + TempEntity.TC stf -> undefined + TempEntity.DC sdf -> undefined + TempEntity.N sbf -> undefined + TempEntity.P spf -> undefined + TempEntity.C scf -> undefined + +saveReadyEntity :: EDB m => Base32Hex -> ReadyEntity -> m (Either CausalHashId ObjectId) +saveReadyEntity b32Hex entity = do + hashId <- saveHash b32Hex + case entity of + ReadyEntity.TC stf -> do + let bytes = runPutS (Serialization.recomposeTermFormat stf) + Right <$> saveObject hashId ObjectType.TermComponent bytes + ReadyEntity.DC sdf -> do + let bytes = runPutS (Serialization.recomposeDeclFormat sdf) + Right <$> saveObject hashId ObjectType.DeclComponent bytes + ReadyEntity.N sbf -> do + let bytes = runPutS (Serialization.recomposeBranchFormat sbf) + Right <$> saveObject hashId ObjectType.Namespace bytes + ReadyEntity.P spf -> do + let bytes = runPutS (Serialization.recomposePatchFormat spf) + Right <$> saveObject hashId ObjectType.Patch bytes + ReadyEntity.C scf -> case scf of + Sqlite.Causal.SyncCausalFormat{valueHash, parents} -> do + let causalHashId = CausalHashId hashId + saveCausal causalHashId valueHash (Foldable.toList parents) + pure $ Left causalHashId + +changes :: DB m => m Int +changes = do + conn <- Reader.reader Connection.underlying + liftIO (SQLite.changes conn) -- -- maybe: look at whether parent causal is "committed"; if so, then increment; -- -- otherwise, don't. @@ -978,6 +1112,16 @@ getMissingDependencyJwtsForTempEntity h = |] (Only h) +getMissingDependentsForTempEntity :: DB m => Base32Hex -> m [Base32Hex] +getMissingDependentsForTempEntity h = + queryAtoms + [here| + SELECT dependent + FROM temp_entity_missing_dependency + WHERE dependency = ? + |] + (Only h) + tempEntityExists :: DB m => Base32Hex -> m Bool tempEntityExists h = queryOne $ queryAtom sql (Only h) where @@ -1019,6 +1163,17 @@ insertTempEntity entityHash entity missingDependencies = do entityType = TempEntity.tempEntityType entity +-- | Delete a row from the `temp_entity` table, if it exists. +deleteTempEntity :: DB m => Base32Hex -> m () +deleteTempEntity hash = + execute + [here| + DELETE + FROM temp_entity + WHERE hash = ? + |] + (Only hash) + -- | takes a dependent's hash and multiple dependency hashes deleteTempDependencies :: (DB m, Foldable f) => Base32Hex -> f Base32Hex -> m () deleteTempDependencies dependent (Foldable.toList -> dependencies) = diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ReadyEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ReadyEntity.hs new file mode 100644 index 0000000000..0c86561e1e --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ReadyEntity.hs @@ -0,0 +1,15 @@ +module U.Codebase.Sqlite.ReadyEntity where + +import qualified U.Codebase.Sqlite.Branch.Format as Namespace +import qualified U.Codebase.Sqlite.Causal as Causal +import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId) +import qualified U.Codebase.Sqlite.Decl.Format as Decl +import qualified U.Codebase.Sqlite.Patch.Format as Patch +import qualified U.Codebase.Sqlite.Term.Format as Term + +data ReadyEntity + = TC Term.SyncTermFormat + | DC Decl.SyncDeclFormat + | N Namespace.SyncBranchFormat + | P Patch.SyncPatchFormat + | C (Causal.SyncCausalFormat' CausalHashId BranchHashId) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index bf1a9da22a..9aba3cba37 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -17,6 +17,7 @@ import Data.Bytes.VarInt (VarInt (VarInt), unVarInt) import Data.Int (Int64) import Data.List (elemIndex) import qualified Data.Set as Set +import Data.Vector (Vector) import Data.Word (Word64) import Debug.Trace (trace) import qualified U.Codebase.Decl as Decl @@ -645,7 +646,25 @@ getBranchLocalIds = <*> getVector getVarInt <*> getVector (getPair getVarInt getVarInt) -decomposeComponent :: MonadGet m => m [(LocalIds, BS.ByteString)] +decomposeTermFormat :: MonadGet m => m TermFormat.SyncTermFormat +decomposeTermFormat = + getWord8 >>= \case + 0 -> + TermFormat.SyncTerm + . TermFormat.SyncLocallyIndexedComponent + <$> decomposeComponent + tag -> error $ "todo: unknown term format tag " ++ show tag + +decomposeDeclFormat :: MonadGet m => m DeclFormat.SyncDeclFormat +decomposeDeclFormat = + getWord8 >>= \case + 0 -> + DeclFormat.SyncDecl + . DeclFormat.SyncLocallyIndexedComponent + <$> decomposeComponent + tag -> error $ "todo: unknown term format tag " ++ show tag + +decomposeComponent :: MonadGet m => m (Vector (LocalIds, BS.ByteString)) decomposeComponent = do offsets <- getList (getVarInt @_ @Int) componentBytes <- getByteString (last offsets) @@ -655,7 +674,17 @@ decomposeComponent = do split = (,) <$> getLocalIds <*> getRemainingByteString Monoid.foldMapM get1 (zip offsets (tail offsets)) -recomposeComponent :: MonadPut m => [(LocalIds, BS.ByteString)] -> m () +recomposeTermFormat :: MonadPut m => TermFormat.SyncTermFormat -> m () +recomposeTermFormat = \case + TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent x) -> + putWord8 0 >> recomposeComponent x + +recomposeDeclFormat :: MonadPut m => DeclFormat.SyncDeclFormat -> m () +recomposeDeclFormat = \case + DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent x) -> + putWord8 0 >> recomposeComponent x + +recomposeComponent :: MonadPut m => Vector (LocalIds, BS.ByteString) -> m () recomposeComponent = putFramedArray \(localIds, bytes) -> do putLocalIds localIds putByteString bytes diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs index d1cfb526ad..7bc0c76a3b 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs @@ -18,14 +18,16 @@ import Control.Monad.Validate (ValidateT, runValidateT) import qualified Control.Monad.Validate as Validate import Data.Bifunctor (bimap) import Data.Bitraversable (bitraverse) -import Data.Bytes.Get (getWord8, runGetS) -import Data.Bytes.Put (putWord8, runPutS) +import Data.Bytes.Get (runGetS) +import Data.Bytes.Put (runPutS) import Data.List.Extra (nubOrd) import qualified Data.Set as Set +import qualified Data.Vector as Vector import qualified U.Codebase.Reference as Reference import qualified U.Codebase.Sqlite.Branch.Format as BL import U.Codebase.Sqlite.Connection (Connection) import U.Codebase.Sqlite.DbId +import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat import qualified U.Codebase.Sqlite.LocalIds as L import qualified U.Codebase.Sqlite.ObjectType as OT import qualified U.Codebase.Sqlite.Patch.Format as PL @@ -35,6 +37,7 @@ import qualified U.Codebase.Sqlite.Reference as Sqlite.Reference import qualified U.Codebase.Sqlite.Referent as Sqlite.Referent import qualified U.Codebase.Sqlite.Serialization as S import qualified U.Codebase.Sqlite.Term.Format as TL +import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Codebase.Sync (Sync (Sync), TrySyncResult) import qualified U.Codebase.Sync as Sync import qualified U.Codebase.WatchKind as WK @@ -121,8 +124,7 @@ trySync tCache hCache oCache cCache = \case bhId' <- lift $ syncBranchHashId bhId chId' <- lift $ syncCausalHashId chId runDest do - Q.saveCausal chId' bhId' - Q.saveCausalParents chId' parents' + Q.saveCausal chId' bhId' parents' case result of Left deps -> pure . Sync.Missing $ toList deps @@ -139,69 +141,69 @@ trySync tCache hCache oCache cCache = \case result <- runValidateT @(Set Entity) @m @ObjectId case objType of OT.TermComponent -> do -- split up the localIds (parsed), term, and type blobs - -- note: this whole business with `fmt` is pretty weird, and will need to be - -- revisited when there are more formats. - -- (or maybe i'll learn something by implementing sync for patches and namespaces, - -- which have two formats already) - -- - -- todo: replace all this with something that de/serializes to SyncTermFormat - (fmt, unzip -> (localIds, bytes)) <- - lift case flip runGetS bytes do - tag <- getWord8 - component <- S.decomposeComponent - pure (tag, component) of - Right x -> pure x - Left s -> throwError $ DecodeError ErrTermComponent bytes s - -- iterate through the local ids looking for missing deps; - -- then either enqueue the missing deps, or proceed to move the object - when debug $ traceM $ "LocalIds for Source " ++ show oId ++ ": " ++ show localIds - localIds' <- traverse syncLocalIds localIds - when debug $ traceM $ "LocalIds for Dest: " ++ show localIds' - -- reassemble and save the reindexed term - let bytes' = - runPutS $ - putWord8 fmt >> S.recomposeComponent (zip localIds' bytes) - oId' <- runDest $ Q.saveObject hId' objType bytes' - lift do - -- copy reference-specific stuff - for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do - let ref = Reference.Id oId idx - refH = Reference.Id hId idx - ref' = Reference.Id oId' idx - -- sync watch results - for_ [WK.TestWatch] \wk -> - syncWatch wk refH - syncDependenciesIndex ref ref' - syncTypeIndex oId oId' - syncTypeMentionsIndex oId oId' - pure oId' + case flip runGetS bytes S.decomposeTermFormat of + Left s -> throwError $ DecodeError ErrTermComponent bytes s + Right + ( TermFormat.SyncTerm + ( TermFormat.SyncLocallyIndexedComponent + (Vector.unzip -> (localIds, bytes)) + ) + ) -> do + -- iterate through the local ids looking for missing deps; + -- then either enqueue the missing deps, or proceed to move the object + when debug $ traceM $ "LocalIds for Source " ++ show oId ++ ": " ++ show localIds + localIds' <- traverse syncLocalIds localIds + when debug $ traceM $ "LocalIds for Dest: " ++ show localIds' + -- reassemble and save the reindexed term + let bytes' = + runPutS + . S.recomposeTermFormat + . TermFormat.SyncTerm + . TermFormat.SyncLocallyIndexedComponent + $ Vector.zip localIds' bytes + oId' <- runDest $ Q.saveObject hId' objType bytes' + lift do + -- copy reference-specific stuff + for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do + let ref = Reference.Id oId idx + refH = Reference.Id hId idx + ref' = Reference.Id oId' idx + -- sync watch results + for_ [WK.TestWatch] \wk -> + syncWatch wk refH + syncDependenciesIndex ref ref' + syncTypeIndex oId oId' + syncTypeMentionsIndex oId oId' + pure oId' OT.DeclComponent -> do -- split up the localIds (parsed), decl blobs - (fmt, unzip -> (localIds, declBytes)) <- - case flip runGetS bytes do - tag <- getWord8 - component <- S.decomposeComponent - pure (tag, component) of - Right x -> pure x - Left s -> throwError $ DecodeError ErrDeclComponent bytes s - -- iterate through the local ids looking for missing deps; - -- then either enqueue the missing deps, or proceed to move the object - localIds' <- traverse syncLocalIds localIds - -- reassemble and save the reindexed term - let bytes' = - runPutS $ - putWord8 fmt - >> S.recomposeComponent (zip localIds' declBytes) - oId' <- runDest $ Q.saveObject hId' objType bytes' - lift do - -- copy per-element-of-the-component stuff - for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do - let ref = Reference.Id oId idx - ref' = Reference.Id oId' idx - syncDependenciesIndex ref ref' - syncTypeIndex oId oId' - syncTypeMentionsIndex oId oId' - pure oId' + case flip runGetS bytes S.decomposeDeclFormat of + Left s -> throwError $ DecodeError ErrDeclComponent bytes s + Right + ( DeclFormat.SyncDecl + ( DeclFormat.SyncLocallyIndexedComponent + (Vector.unzip -> (localIds, declBytes)) + ) + ) -> do + -- iterate through the local ids looking for missing deps; + -- then either enqueue the missing deps, or proceed to move the object + localIds' <- traverse syncLocalIds localIds + -- reassemble and save the reindexed term + let bytes' = + runPutS . S.recomposeDeclFormat + . DeclFormat.SyncDecl + . DeclFormat.SyncLocallyIndexedComponent + $ Vector.zip localIds' declBytes + oId' <- runDest $ Q.saveObject hId' objType bytes' + lift do + -- copy per-element-of-the-component stuff + for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do + let ref = Reference.Id oId idx + ref' = Reference.Id oId' idx + syncDependenciesIndex ref ref' + syncTypeIndex oId oId' + syncTypeMentionsIndex oId oId' + pure oId' OT.Namespace -> case flip runGetS bytes S.decomposeBranchFormat of Right (BL.SyncFull ids body) -> do ids' <- syncBranchLocalIds ids diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 25b601bfff..535581e09e 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -37,6 +37,7 @@ library U.Codebase.Sqlite.Patch.TermEdit U.Codebase.Sqlite.Patch.TypeEdit U.Codebase.Sqlite.Queries + U.Codebase.Sqlite.ReadyEntity U.Codebase.Sqlite.Reference U.Codebase.Sqlite.Referent U.Codebase.Sqlite.Serialization diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index b5555240e9..730a3960dc 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -263,7 +263,8 @@ download httpClient unisonShareUrl conn repoName = do -- -- [ ] Beef up insert_entity to flush temp entities -- [ ] Write resolveHashToEntity --- [ ] Add "no read permission" to GetCausalHashByPathResponse in Share.Types +-- [x] Add "no read permission" to GetCausalHashByPathResponse in Share.Types +-- [x] Add "no write permission" to UpdatePathResponse in Share.Types -- [ ] The tempToSync* stuff {- From 50a6eaf0a15bc7f6274de852e8347cd6befde657 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Sat, 16 Apr 2022 16:49:30 -0500 Subject: [PATCH 130/529] Improve performance of various relation operations - Use logarithmic lookups rather than O(n^2) algorithm for restrictDom/Ran - Remove some duplication by defining some functions in terms of each other, using swap - subtractDom/Ran avoids traversing the whole relation, O(k log k) - Use Map.intersectWith for intersection, rather than scanning either relation --- .../src/Unison/Util/Relation.hs | 58 ++++++++++--------- 1 file changed, 32 insertions(+), 26 deletions(-) diff --git a/lib/unison-util-relation/src/Unison/Util/Relation.hs b/lib/unison-util-relation/src/Unison/Util/Relation.hs index eb0ec20c59..1b1724674a 100644 --- a/lib/unison-util-relation/src/Unison/Util/Relation.hs +++ b/lib/unison-util-relation/src/Unison/Util/Relation.hs @@ -230,9 +230,11 @@ union r s = } intersection :: (Ord a, Ord b) => Relation a b -> Relation a b -> Relation a b -intersection r s - | size r > size s = intersection s r - | otherwise = filter (\(a, b) -> member a b s) r +intersection r s = + Relation + { domain = M.intersectionWith Set.intersection (domain r) (domain s), + range = M.intersectionWith Set.intersection (range r) (range s) + } outerJoinDomMultimaps :: (Ord a, Ord b, Ord c) => @@ -500,32 +502,40 @@ compactSet = S.fold (S.union . fromMaybe S.empty) S.empty -- | Domain restriction for a relation. Modeled on z. (<|), restrictDom :: (Ord a, Ord b) => Set a -> Relation a b -> Relation a b restrictDom = (<|) -s <| r = - fromList $ - concatMap (\(x, y) -> zip (repeat x) (S.toList y)) (M.toList domain') +s <| r = go s (domain r) where - domain' = M.unions . List.map filtrar . S.toList $ s - filtrar x = M.filterWithKey (\k _ -> k == x) dr - dr = domain r -- just to memoize the value + go _ Map.Tip = mempty + go s _ | Set.null s = mempty + go s (Map.Bin _ amid bs l r) = here <> go sl l <> go sr r + where + (sl, sr) = Set.split amid s + mids = Set.singleton amid + here = + if Set.member amid s + then Relation (Map.singleton amid bs) (Map.fromList $ (,mids) <$> (Set.toList bs)) + else mempty -- | Range restriction for a relation. Modeled on z. (|>), restrictRan :: (Ord a, Ord b) => Relation a b -> Set b -> Relation a b restrictRan = (|>) -r |> t = - fromList $ - concatMap (\(x, y) -> zip (S.toList y) (repeat x)) (M.toList range') - where - range' = M.unions . List.map filtrar . S.toList $ t - filtrar x = M.filterWithKey (\k _ -> k == x) rr - rr = range r -- just to memoize the value +r |> t = swap (t <| swap r) -- | Restrict the range to not include these `b`s. (||>) :: (Ord a, Ord b) => Relation a b -> Set b -> Relation a b -Relation {domain, range} ||> t = - Relation - { domain = Map.mapMaybe (`Set.difference1` t) domain, - range = range `Map.withoutKeys` t - } +r@(Relation {domain, range}) ||> t = + Relation domain' range' + where + go m a = Map.alter g a m + where + g Nothing = Nothing + g (Just s) = + if Set.null s' + then Nothing + else Just s' + where + s' = Set.difference s t + domain' = foldl' go domain (foldMap (`lookupRan` r) t) + range' = range `Map.withoutKeys` t -- | Named version of ('||>'). subtractRan :: (Ord a, Ord b) => Set b -> Relation a b -> Relation a b @@ -533,11 +543,7 @@ subtractRan = flip (||>) -- | Restrict the domain to not include these `a`s. (<||) :: (Ord a, Ord b) => Set a -> Relation a b -> Relation a b -s <|| Relation {domain, range} = - Relation - { domain = domain `Map.withoutKeys` s, - range = Map.mapMaybe (`Set.difference1` s) range - } +s <|| r = swap (swap r ||> s) -- | Named version of ('<||'). subtractDom :: (Ord a, Ord b) => Set a -> Relation a b -> Relation a b From 143a8232df697c4ff1a1add676068224277a6dad Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Sat, 16 Apr 2022 17:07:00 -0500 Subject: [PATCH 131/529] unit tests for subtract/restrict dom --- .../tests/Unison/Test/Util/Relation.hs | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/parser-typechecker/tests/Unison/Test/Util/Relation.hs b/parser-typechecker/tests/Unison/Test/Util/Relation.hs index ef1338b895..015b2776b7 100644 --- a/parser-typechecker/tests/Unison/Test/Util/Relation.hs +++ b/parser-typechecker/tests/Unison/Test/Util/Relation.hs @@ -1,6 +1,7 @@ module Unison.Test.Util.Relation where import Control.Monad +import qualified Data.Map as Map import qualified Data.Set as Set import EasyTest import qualified Unison.Util.Relation as R @@ -20,5 +21,16 @@ test = expect' $ R.searchDom (\(x, _) -> compare x q) r == Set.fromList [z | ((x, _), z) <- pairs, x == q] + ok, + scope "(restrict/subtract)Dom" $ do + replicateM_ 100 $ do + n <- int' 0 100 + pairs <- listOf n (liftM2 (,) (int' 0 10) (int' 0 1000)) + let r = R.fromList pairs + forM_ (R.dom r) $ \i -> do + expect' $ + R.restrictDom (Set.singleton i) r + == R.fromMultimap (Map.singleton i (R.lookupDom i r)) + expect' $ R.subtractDom (Set.singleton i) r == R.deleteDom i r ok ] From 25155233a38ec94a0204bd360a01dd9d0f5a5414 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Sat, 16 Apr 2022 17:25:46 -0500 Subject: [PATCH 132/529] add a bunch of timing logging (enabled/disabled by Timing.hs) to HandleInput --- .../src/Unison/Codebase/Editor/HandleInput.hs | 24 +++++++++---------- 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 36c71ade32..600356f1ad 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -237,7 +237,7 @@ loop = do let parseNames = Backend.getCurrentParseNames (Backend.Within currentPath'') root' LoopState.latestFile .= Just (Text.unpack sourceName, False) LoopState.latestTypecheckedFile .= Nothing - Result notes r <- eval $ Typecheck ambient parseNames sourceName lexed + Result notes r <- unsafeTime "typechecking" $ eval $ Typecheck ambient parseNames sourceName lexed case r of -- Parsing failed Nothing -> @@ -258,19 +258,19 @@ loop = do loadUnisonFile sourceName text = do let lexed = L.lexer (Text.unpack sourceName) (Text.unpack text) withFile [] sourceName (text, lexed) $ \unisonFile -> do - currentNames <- currentPathNames + currentNames <- unsafeTime "currentPathNames" currentPathNames let sr = Slurp.slurpFile unisonFile mempty Slurp.CheckOp currentNames - names <- displayNames unisonFile + names <- unsafeTime "displayNames" $ displayNames unisonFile pped <- prettyPrintEnvDecl names let ppe = PPE.suffixifiedPPE pped - respond $ Typechecked sourceName ppe sr unisonFile + unsafeTime "typechecked.respond" $ respond $ Typechecked sourceName ppe sr unisonFile unlessError' EvaluationFailure do - (bindings, e) <- ExceptT . eval . Evaluate ppe $ unisonFile + (bindings, e) <- unsafeTime "evaluate" $ ExceptT . eval . Evaluate ppe $ unisonFile lift do let e' = Map.map go e go (ann, kind, _hash, _uneval, eval, isHit) = (ann, kind, eval, isHit) unless (null e') $ - respond $ Evaluated text ppe bindings e' + unsafeTime "evaluate.respond" $ respond $ Evaluated text ppe bindings e' LoopState.latestTypecheckedFile .= Just unisonFile case e of @@ -627,7 +627,7 @@ loop = do else diffHelper (Branch.head destb) (Branch.head merged) >>= respondNumbered . uncurry (ShowDiffAfterMergePreview dest0 dest) - DiffNamespaceI before after -> unlessError do + DiffNamespaceI before after -> unsafeTime "diff.namespace" $ unlessError do let (absBefore, absAfter) = (resolveToAbsolute <$> before, resolveToAbsolute <$> after) beforeBranch0 <- Branch.head <$> branchForBranchId absBefore afterBranch0 <- Branch.head <$> branchForBranchId absAfter @@ -1965,7 +1965,7 @@ handleUpdate input optionalPatch requestedNames = do -- propagatePatch prints TodoOutput for_ patchOps $ \case (updatedPatch, _, _) -> void $ propagatePatchNoSync updatedPatch currentPath' - addDefaultMetadata addsAndUpdates + unsafeTime "addDefaultMetadata" $ addDefaultMetadata addsAndUpdates syncRoot $ case patchPath of Nothing -> "update.nopatch" Just p -> @@ -2253,7 +2253,7 @@ propagatePatchNoSync :: Patch -> Path.Absolute -> Action' m v Bool -propagatePatchNoSync patch scopePath = do +propagatePatchNoSync patch scopePath = unsafeTime "propagate" $ do r <- use LoopState.root let nroot = Branch.toNames (Branch.head r) stepAtMNoSync' @@ -2696,12 +2696,12 @@ stepManyAtMNoSync' strat actions = do -- | Sync the in-memory root branch. syncRoot :: LoopState.InputDescription -> Action m i v () -syncRoot description = do +syncRoot description = unsafeTime "syncRoot" $ do root' <- use LoopState.root Unison.Codebase.Editor.HandleInput.updateRoot root' description updateRoot :: Branch m -> LoopState.InputDescription -> Action m i v () -updateRoot new reason = do +updateRoot new reason = unsafeTime "updateRoot" $ do old <- use LoopState.lastSavedRoot when (old /= new) $ do LoopState.root .= new @@ -3259,7 +3259,7 @@ diffHelper :: Branch0 m -> Branch0 m -> Action' m v (PPE.PrettyPrintEnv, OBranchDiff.BranchDiffOutput v Ann) -diffHelper before after = do +diffHelper before after = unsafeTime "HandleInput.diffHelper" $ do currentRoot <- use LoopState.root currentPath <- use LoopState.currentPath diffHelperCmd currentRoot currentPath before after From ab1ff3ec5f4d95f2d17613eb770d23298efdaac5 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Sat, 16 Apr 2022 17:38:58 -0500 Subject: [PATCH 133/529] Add moar timing! --- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 600356f1ad..6723e6bb6f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -573,10 +573,10 @@ loop = do (Just new) (Output.ReflogEntry (SBH.fromHash sbhLength new) reason : acc) rest - ResetRootI src0 -> + ResetRootI src0 -> unsafeTime "reset-root" $ case src0 of Left hash -> unlessError do - newRoot <- resolveShortBranchHash hash + newRoot <- unsafeTime "resolveShortBranchHash" $ resolveShortBranchHash hash lift do updateRoot newRoot success From 6955743dd8056bbdddf0c0bb81e05aa400b4cf19 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 11:03:37 -0400 Subject: [PATCH 134/529] fix compiler error in migration --- .../SqliteCodebase/Migrations/MigrateSchema1To2.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 2fff1a1556..5102c00ffb 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -302,8 +302,11 @@ migrateCausal conn oldCausalHashId = fmap (either id id) . runExceptT $ do parents = newParentHashIds } runDB conn do - Q.saveCausal (SC.DbCausal.selfHash newCausal) (SC.DbCausal.valueHash newCausal) - Q.saveCausalParents (SC.DbCausal.selfHash newCausal) (Set.toList $ SC.DbCausal.parents newCausal) + liftQ do + Q.saveCausal + (SC.DbCausal.selfHash newCausal) + (SC.DbCausal.valueHash newCausal) + (Set.toList $ SC.DbCausal.parents newCausal) field @"causalMapping" %= Map.insert oldCausalHashId (newCausalHash, newCausalHashId) From 6a617cc54fcfb182069c5562d7c232f63d3912e0 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 11:40:44 -0400 Subject: [PATCH 135/529] fix query --- .../codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 15 ++++++++------- 1 file changed, 8 insertions(+), 7 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 26707b6934..a9434f58d8 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -559,13 +559,14 @@ tryMoveTempEntityDependents dependencyBase32 = do tempEntitiesWithNoMissingDependencies :: DB m => m [Base32Hex] tempEntitiesWithNoMissingDependencies = fmap (map fromOnly) $ query_ [here| - SELECT hash FROM temp_entity - WHERE NOT EXISTS( - SELECT COUNT (1) - FROM temp_entity_missing_dependency - WHERE dependent = hash - ) - |] + SELECT hash + FROM temp_entity + WHERE NOT EXISTS( + SELECT 1 + FROM temp_entity_missing_dependency dep + WHERE dep.dependent = temp_entity.hash + ) + |] moveTempEntityToMain :: EDB m => Base32Hex -> m () moveTempEntityToMain b32 = do From 6d67941c5338fe7143c1538a9cc71f98635be877 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 11:41:15 -0400 Subject: [PATCH 136/529] delete explicit imports of Unison.Prelude --- .../U/Codebase/Sqlite/Queries.hs | 17 ----------------- 1 file changed, 17 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index a9434f58d8..be440288a7 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -215,23 +215,6 @@ import U.Util.Base32Hex (Base32Hex (..)) import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash import Unison.Prelude - ( ByteString, - Exception, - HasCallStack, - Int8, - IsString (fromString), - MaybeT (MaybeT, runMaybeT), - MonadIO (..), - MonadUnliftIO (..), - Text, - headMay, - trace, - traceM, - traverse_, - try, - when, - (<&>), - ) import UnliftIO (throwIO, tryAny) import qualified UnliftIO import UnliftIO.Concurrent (myThreadId) From f08f7c18222b7af5639d952e1e352c753ac2e39e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 15:13:46 -0400 Subject: [PATCH 137/529] fill out the tempToSync* things --- unison-cli/src/Unison/Share/Sync.hs | 94 ++++++++++++++++++++++++----- 1 file changed, 79 insertions(+), 15 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 730a3960dc..7e8ffe4541 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -28,7 +28,15 @@ import U.Codebase.HashTags (CausalHash (..)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import qualified U.Codebase.Sqlite.Causal as Causal import U.Codebase.Sqlite.Connection (Connection) -import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId, ObjectId) +import U.Codebase.Sqlite.DbId + ( BranchHashId, + BranchObjectId (..), + CausalHashId, + HashId, + ObjectId, + PatchObjectId (..), + TextId, + ) import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat import U.Codebase.Sqlite.LocalIds (LocalIds' (..)) import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat @@ -338,26 +346,82 @@ expectObjectIdForHashJWT hashJwt = do decode = Hash.fromBase32Hex . Share.toBase32Hex . Share.hashJWTHash . Share.HashJWT +expectBranchObjectIdForHashJWT :: Q.DB m => TempEntity.HashJWT -> m BranchObjectId +expectBranchObjectIdForHashJWT = + fmap BranchObjectId . expectObjectIdForHashJWT + +expectPatchObjectIdForHashJWT :: Q.DB m => TempEntity.HashJWT -> m PatchObjectId +expectPatchObjectIdForHashJWT = + fmap PatchObjectId . expectObjectIdForHashJWT + +expectBranchHashIdForHashJWT :: Q.DB m => TempEntity.HashJWT -> m BranchHashId +expectBranchHashIdForHashJWT = undefined + +expectCausalHashIdForHashJWT :: Q.DB m => TempEntity.HashJWT -> m CausalHashId +expectCausalHashIdForHashJWT = undefined + -- Serialization.recomposeComponent :: MonadPut m => [(LocalIds, BS.ByteString)] -> m () -- Serialization.recomposePatchFormat :: MonadPut m => PatchFormat.SyncPatchFormat -> m () -- Serialization.recomposeBranchFormat :: MonadPut m => BranchFormat.SyncBranchFormat -> m () -- Q.saveObject :: DB m => HashId -> ObjectType -> ByteString -> m ObjectId -tempToSyncDeclComponent :: TempEntity.TempDeclFormat -> IO DeclFormat.SyncDeclFormat -tempToSyncDeclComponent = do - undefined - -tempToSyncPatch :: TempEntity.TempPatchFormat -> IO PatchFormat.SyncPatchFormat -tempToSyncPatch = do - undefined - -tempToSyncNamespace :: TempEntity.TempNamespaceFormat -> IO NamespaceFormat.SyncBranchFormat -tempToSyncNamespace = do - undefined +tempToSyncDeclComponent :: Q.DB m => TempEntity.TempDeclFormat -> m DeclFormat.SyncDeclFormat +tempToSyncDeclComponent = \case + DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent decls) -> + DeclFormat.SyncDecl . DeclFormat.SyncLocallyIndexedComponent + <$> Lens.traverseOf (traverse . Lens._1) (bitraverse Q.saveText expectObjectIdForHashJWT) decls + +tempToSyncPatch :: Q.DB m => TempEntity.TempPatchFormat -> m PatchFormat.SyncPatchFormat +tempToSyncPatch = \case + PatchFormat.SyncFull localIds bytes -> PatchFormat.SyncFull <$> localizePatchLocalIds localIds <*> pure bytes + PatchFormat.SyncDiff parent localIds bytes -> + PatchFormat.SyncDiff + <$> expectPatchObjectIdForHashJWT parent + <*> localizePatchLocalIds localIds + <*> pure bytes + +localizePatchLocalIds :: + Q.DB m => + PatchFormat.PatchLocalIds' Text Base32Hex TempEntity.HashJWT -> + m (PatchFormat.PatchLocalIds' TextId HashId ObjectId) +localizePatchLocalIds (PatchFormat.LocalIds texts hashes defns) = + PatchFormat.LocalIds + <$> traverse Q.saveText texts + <*> traverse Q.saveHash hashes + <*> traverse expectObjectIdForHashJWT defns + +tempToSyncNamespace :: Q.DB m => TempEntity.TempNamespaceFormat -> m NamespaceFormat.SyncBranchFormat +tempToSyncNamespace = \case + NamespaceFormat.SyncFull localIds bytes -> + NamespaceFormat.SyncFull <$> localizeNamespaceLocalIds localIds <*> pure bytes + NamespaceFormat.SyncDiff parent localIds bytes -> + NamespaceFormat.SyncDiff + <$> expectBranchObjectIdForHashJWT parent + <*> localizeNamespaceLocalIds localIds + <*> pure bytes + +localizeNamespaceLocalIds :: + Q.DB m => + NamespaceFormat.BranchLocalIds' Text TempEntity.HashJWT TempEntity.HashJWT (TempEntity.HashJWT, TempEntity.HashJWT) -> + m (NamespaceFormat.BranchLocalIds' TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)) +localizeNamespaceLocalIds (NamespaceFormat.LocalIds texts defns patches children) = + NamespaceFormat.LocalIds + <$> traverse Q.saveText texts + <*> traverse expectObjectIdForHashJWT defns + <*> traverse expectPatchObjectIdForHashJWT patches + <*> traverse + ( \(branch, causal) -> + (,) + <$> expectBranchObjectIdForHashJWT branch + <*> expectCausalHashIdForHashJWT causal + ) + children -tempToSyncCausal :: TempEntity.TempCausalFormat -> IO (Causal.SyncCausalFormat' CausalHashId BranchHashId) -- could probably use a better type name here -tempToSyncCausal = do - undefined +tempToSyncCausal :: Q.DB m => TempEntity.TempCausalFormat -> m (Causal.SyncCausalFormat' CausalHashId BranchHashId) -- could probably use a better type name here +tempToSyncCausal Causal.SyncCausalFormat {valueHash, parents} = + Causal.SyncCausalFormat + <$> expectBranchHashIdForHashJWT valueHash + <*> traverse expectCausalHashIdForHashJWT parents -- Q.saveCausalHash :: DB m => CausalHash -> m CausalHashId -- only affects `hash` table -- Q.saveCausal :: DB m => CausalHashId -> BranchHashId -> m () From fa879aac36d1621daf9f537c02eb7829b8e397c4 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 15:28:05 -0400 Subject: [PATCH 138/529] flush temp entities in saveObject --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs | 2 +- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 7 +++++++ 2 files changed, 8 insertions(+), 1 deletion(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 9b66958d9a..d73806668a 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -108,7 +108,7 @@ where import Control.Lens (Lens') import qualified Control.Lens as Lens -import Control.Monad (MonadPlus (mzero), join, unless, when, (<=<)) +import Control.Monad (MonadPlus (mzero), join, when, (<=<)) import Control.Monad.Except (ExceptT, MonadError, MonadIO (liftIO), runExceptT) import qualified Control.Monad.Except as Except import qualified Control.Monad.Extra as Monad diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index be440288a7..98b29409ae 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -395,6 +395,13 @@ saveObject :: DB m => HashId -> ObjectType -> ByteString -> m ObjectId saveObject h t blob = do oId <- execute sql (h, t, blob) >> queryOne (maybeObjectIdForPrimaryHashId h) saveHashObject h oId 2 -- todo: remove this from here, and add it to other relevant places once there are v1 and v2 hashes + changes >>= \case + 0 -> pure () + _ -> do + _ <- Except.runExceptT do + hash <- loadHashById h + tryMoveTempEntityDependents hash + pure () pure oId where sql = [here| From 2a67ea4f9e6b293cc8018a03daac73c9dcd320ee Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 15:46:20 -0400 Subject: [PATCH 139/529] change some names --- .../U/Codebase/Sqlite/Causal.hs | 3 +++ .../U/Codebase/Sqlite/TempEntity.hs | 4 ++++ unison-cli/src/Unison/Share/Sync.hs | 24 +++++++------------ 3 files changed, 16 insertions(+), 15 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs index 19fd7f7794..582bfc65a3 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs @@ -1,6 +1,7 @@ module U.Codebase.Sqlite.Causal ( DbCausal, GDbCausal (..), + SyncCausalFormat, SyncCausalFormat' (..), ) where @@ -21,3 +22,5 @@ data SyncCausalFormat' causalHash valueHash = SyncCausalFormat { valueHash :: valueHash, parents :: Vector causalHash } + +type SyncCausalFormat = SyncCausalFormat' CausalHashId BranchHashId diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index dbe09e7e45..ded0648305 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -33,6 +33,10 @@ type TempDeclFormat = Decl.SyncDeclFormat' Text HashJWT type TempPatchFormat = Patch.SyncPatchFormat' HashJWT Text Base32Hex HashJWT +type TempPatchLocalIds = Patch.PatchLocalIds' Text Base32Hex HashJWT + type TempNamespaceFormat = Namespace.SyncBranchFormat' HashJWT Text HashJWT HashJWT (HashJWT, HashJWT) +type TempNamespaceLocalIds = Namespace.BranchLocalIds' Text HashJWT HashJWT (HashJWT, HashJWT) + type TempCausalFormat = Causal.SyncCausalFormat' HashJWT HashJWT diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 7e8ffe4541..7b13d3f932 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -373,18 +373,15 @@ tempToSyncDeclComponent = \case tempToSyncPatch :: Q.DB m => TempEntity.TempPatchFormat -> m PatchFormat.SyncPatchFormat tempToSyncPatch = \case - PatchFormat.SyncFull localIds bytes -> PatchFormat.SyncFull <$> localizePatchLocalIds localIds <*> pure bytes + PatchFormat.SyncFull localIds bytes -> PatchFormat.SyncFull <$> tempToSyncPatchLocalIds localIds <*> pure bytes PatchFormat.SyncDiff parent localIds bytes -> PatchFormat.SyncDiff <$> expectPatchObjectIdForHashJWT parent - <*> localizePatchLocalIds localIds + <*> tempToSyncPatchLocalIds localIds <*> pure bytes -localizePatchLocalIds :: - Q.DB m => - PatchFormat.PatchLocalIds' Text Base32Hex TempEntity.HashJWT -> - m (PatchFormat.PatchLocalIds' TextId HashId ObjectId) -localizePatchLocalIds (PatchFormat.LocalIds texts hashes defns) = +tempToSyncPatchLocalIds :: Q.DB m => TempEntity.TempPatchLocalIds -> m PatchFormat.PatchLocalIds +tempToSyncPatchLocalIds (PatchFormat.LocalIds texts hashes defns) = PatchFormat.LocalIds <$> traverse Q.saveText texts <*> traverse Q.saveHash hashes @@ -393,18 +390,15 @@ localizePatchLocalIds (PatchFormat.LocalIds texts hashes defns) = tempToSyncNamespace :: Q.DB m => TempEntity.TempNamespaceFormat -> m NamespaceFormat.SyncBranchFormat tempToSyncNamespace = \case NamespaceFormat.SyncFull localIds bytes -> - NamespaceFormat.SyncFull <$> localizeNamespaceLocalIds localIds <*> pure bytes + NamespaceFormat.SyncFull <$> tempToSyncNamespaceLocalIds localIds <*> pure bytes NamespaceFormat.SyncDiff parent localIds bytes -> NamespaceFormat.SyncDiff <$> expectBranchObjectIdForHashJWT parent - <*> localizeNamespaceLocalIds localIds + <*> tempToSyncNamespaceLocalIds localIds <*> pure bytes -localizeNamespaceLocalIds :: - Q.DB m => - NamespaceFormat.BranchLocalIds' Text TempEntity.HashJWT TempEntity.HashJWT (TempEntity.HashJWT, TempEntity.HashJWT) -> - m (NamespaceFormat.BranchLocalIds' TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId)) -localizeNamespaceLocalIds (NamespaceFormat.LocalIds texts defns patches children) = +tempToSyncNamespaceLocalIds :: Q.DB m => TempEntity.TempNamespaceLocalIds -> m NamespaceFormat.BranchLocalIds +tempToSyncNamespaceLocalIds (NamespaceFormat.LocalIds texts defns patches children) = NamespaceFormat.LocalIds <$> traverse Q.saveText texts <*> traverse expectObjectIdForHashJWT defns @@ -417,7 +411,7 @@ localizeNamespaceLocalIds (NamespaceFormat.LocalIds texts defns patches children ) children -tempToSyncCausal :: Q.DB m => TempEntity.TempCausalFormat -> m (Causal.SyncCausalFormat' CausalHashId BranchHashId) -- could probably use a better type name here +tempToSyncCausal :: Q.DB m => TempEntity.TempCausalFormat -> m Causal.SyncCausalFormat -- could probably use a better type name here tempToSyncCausal Causal.SyncCausalFormat {valueHash, parents} = Causal.SyncCausalFormat <$> expectBranchHashIdForHashJWT valueHash From 1357e3946562b4960ec13efbf4e4c087333e15b3 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 15:57:19 -0400 Subject: [PATCH 140/529] fill out tempToSyncEntity --- .../U/Codebase/Sqlite/Queries.hs | 107 ++++++++++++++++-- unison-cli/src/Unison/Share/Sync.hs | 94 --------------- 2 files changed, 99 insertions(+), 102 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 98b29409ae..e86eaeb217 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -153,11 +153,13 @@ module U.Codebase.Sqlite.Queries where import qualified Control.Exception as Exception +import qualified Control.Lens as Lens import Control.Monad.Except (MonadError) import qualified Control.Monad.Except as Except import Control.Monad.Reader (MonadReader (ask)) import qualified Control.Monad.Reader as Reader import qualified Control.Monad.Writer as Writer +import Data.Bitraversable (bitraverse) import Data.Bytes.Get (runGetS) import Data.Bytes.Put (runPutS) import qualified Data.Char as Char @@ -182,6 +184,8 @@ import Database.SQLite.Simple.ToField (ToField (..)) import U.Codebase.HashTags (BranchHash (..), CausalHash (..)) import U.Codebase.Reference (Reference' (..)) import qualified U.Codebase.Reference as C.Reference +import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat +import qualified U.Codebase.Sqlite.Causal as Causal import qualified U.Codebase.Sqlite.Causal as Sqlite.Causal import U.Codebase.Sqlite.Connection (Connection) import qualified U.Codebase.Sqlite.Connection as Connection @@ -192,13 +196,16 @@ import U.Codebase.Sqlite.DbId HashId (..), HashVersion, ObjectId (..), + PatchObjectId (..), SchemaVersion, TextId, ) +import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat import U.Codebase.Sqlite.JournalMode (JournalMode) import qualified U.Codebase.Sqlite.JournalMode as JournalMode import U.Codebase.Sqlite.ObjectType (ObjectType) import qualified U.Codebase.Sqlite.ObjectType as ObjectType +import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat import U.Codebase.Sqlite.ReadyEntity (ReadyEntity) import qualified U.Codebase.Sqlite.ReadyEntity as ReadyEntity import qualified U.Codebase.Sqlite.Reference as Reference @@ -208,6 +215,7 @@ import U.Codebase.Sqlite.TempEntity (HashJWT, TempEntity) import qualified U.Codebase.Sqlite.TempEntity as TempEntity import U.Codebase.Sqlite.TempEntityType (TempEntityType) import qualified U.Codebase.Sqlite.TempEntityType as TempEntityType +import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Codebase.WatchKind (WatchKind) import qualified U.Codebase.WatchKind as WatchKind import qualified U.Util.Alternative as Alternative @@ -521,6 +529,31 @@ saveCausal self value parents = do flushCausalDependents :: EDB m => CausalHashId -> m () flushCausalDependents chId = loadHashById (unCausalHashId chId) >>= tryMoveTempEntityDependents +expectObjectIdForHashJWT :: DB m => TempEntity.HashJWT -> m ObjectId +expectObjectIdForHashJWT hashJwt = do + hashId <- throwExceptT (expectHashIdByHash (decode hashJwt)) + throwExceptT (expectObjectIdForAnyHashId hashId) + where + decode :: TempEntity.HashJWT -> Hash + decode = + undefined + -- FIXME need to know how to go HashJWT -> Hash at the DB layer too, not just Share API layer + -- Hash.fromBase32Hex . Share.toBase32Hex . Share.hashJWTHash . Share.HashJWT + +expectBranchObjectIdForHashJWT :: DB m => TempEntity.HashJWT -> m BranchObjectId +expectBranchObjectIdForHashJWT = + fmap BranchObjectId . expectObjectIdForHashJWT + +expectPatchObjectIdForHashJWT :: DB m => TempEntity.HashJWT -> m PatchObjectId +expectPatchObjectIdForHashJWT = + fmap PatchObjectId . expectObjectIdForHashJWT + +expectBranchHashIdForHashJWT :: DB m => TempEntity.HashJWT -> m BranchHashId +expectBranchHashIdForHashJWT = undefined + +expectCausalHashIdForHashJWT :: DB m => TempEntity.HashJWT -> m CausalHashId +expectCausalHashIdForHashJWT = undefined + -- Note: beef up insert_entity procedure to flush temp_entity table -- | flushTempEntity does this: @@ -563,7 +596,7 @@ moveTempEntityToMain b32 = do loadTempEntity b32 >>= \case Left _ -> undefined Right t -> do - r <- readyTempEntity t + r <- tempToSyncEntity t _ <- saveReadyEntity b32 r pure () @@ -588,13 +621,71 @@ loadTempEntity b32 = do WHERE hash = ? |] -readyTempEntity :: DB m => TempEntity -> m ReadyEntity -readyTempEntity = \case - TempEntity.TC stf -> undefined - TempEntity.DC sdf -> undefined - TempEntity.N sbf -> undefined - TempEntity.P spf -> undefined - TempEntity.C scf -> undefined +tempToSyncEntity :: DB m => TempEntity -> m ReadyEntity +tempToSyncEntity = \case + TempEntity.TC term -> ReadyEntity.TC <$> tempToSyncTermComponent term + TempEntity.DC decl -> ReadyEntity.DC <$> tempToSyncDeclComponent decl + TempEntity.N namespace -> ReadyEntity.N <$> tempToSyncNamespace namespace + TempEntity.P patch -> ReadyEntity.P <$> tempToSyncPatch patch + TempEntity.C causal -> ReadyEntity.C <$> tempToSyncCausal causal + where + tempToSyncCausal :: DB m => TempEntity.TempCausalFormat -> m Causal.SyncCausalFormat + tempToSyncCausal Causal.SyncCausalFormat {valueHash, parents} = + Causal.SyncCausalFormat + <$> expectBranchHashIdForHashJWT valueHash + <*> traverse expectCausalHashIdForHashJWT parents + + tempToSyncDeclComponent :: DB m => TempEntity.TempDeclFormat -> m DeclFormat.SyncDeclFormat + tempToSyncDeclComponent = \case + DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent decls) -> + DeclFormat.SyncDecl . DeclFormat.SyncLocallyIndexedComponent + <$> Lens.traverseOf (traverse . Lens._1) (bitraverse saveText expectObjectIdForHashJWT) decls + + tempToSyncNamespace :: DB m => TempEntity.TempNamespaceFormat -> m NamespaceFormat.SyncBranchFormat + tempToSyncNamespace = \case + NamespaceFormat.SyncFull localIds bytes -> + NamespaceFormat.SyncFull <$> tempToSyncNamespaceLocalIds localIds <*> pure bytes + NamespaceFormat.SyncDiff parent localIds bytes -> + NamespaceFormat.SyncDiff + <$> expectBranchObjectIdForHashJWT parent + <*> tempToSyncNamespaceLocalIds localIds + <*> pure bytes + + tempToSyncNamespaceLocalIds :: DB m => TempEntity.TempNamespaceLocalIds -> m NamespaceFormat.BranchLocalIds + tempToSyncNamespaceLocalIds (NamespaceFormat.LocalIds texts defns patches children) = + NamespaceFormat.LocalIds + <$> traverse saveText texts + <*> traverse expectObjectIdForHashJWT defns + <*> traverse expectPatchObjectIdForHashJWT patches + <*> traverse + ( \(branch, causal) -> + (,) + <$> expectBranchObjectIdForHashJWT branch + <*> expectCausalHashIdForHashJWT causal + ) + children + + tempToSyncPatch :: DB m => TempEntity.TempPatchFormat -> m PatchFormat.SyncPatchFormat + tempToSyncPatch = \case + PatchFormat.SyncFull localIds bytes -> PatchFormat.SyncFull <$> tempToSyncPatchLocalIds localIds <*> pure bytes + PatchFormat.SyncDiff parent localIds bytes -> + PatchFormat.SyncDiff + <$> expectPatchObjectIdForHashJWT parent + <*> tempToSyncPatchLocalIds localIds + <*> pure bytes + + tempToSyncPatchLocalIds :: DB m => TempEntity.TempPatchLocalIds -> m PatchFormat.PatchLocalIds + tempToSyncPatchLocalIds (PatchFormat.LocalIds texts hashes defns) = + PatchFormat.LocalIds + <$> traverse saveText texts + <*> traverse saveHash hashes + <*> traverse expectObjectIdForHashJWT defns + + tempToSyncTermComponent :: DB m => TempEntity.TempTermFormat -> m TermFormat.SyncTermFormat + tempToSyncTermComponent = \case + TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent terms) -> + TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent + <$> Lens.traverseOf (traverse . Lens._1) (bitraverse saveText expectObjectIdForHashJWT) terms saveReadyEntity :: EDB m => Base32Hex -> ReadyEntity -> m (Either CausalHashId ObjectId) saveReadyEntity b32Hex entity = do diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 7b13d3f932..f861414ee5 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -327,100 +327,6 @@ data GetCausalHashByPathResponse _getCausalHashByPath :: Share.GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse _getCausalHashByPath = undefined --- have to convert from Entity format to TempEntity format (`makeTempEntity` on 414) - --- also have to convert from TempEntity format to Sync format โ€”ย this means exchanging Text for TextId and `Base32Hex`es for `HashId`s and/or `ObjectId`s -tempToSyncTermComponent :: Connection -> TempEntity.TempTermFormat -> IO TermFormat.SyncTermFormat -tempToSyncTermComponent conn = - flip runReaderT conn . \case - TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent terms) -> - TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent - <$> Lens.traverseOf (traverse . Lens._1) (bitraverse Q.saveText expectObjectIdForHashJWT) terms - -expectObjectIdForHashJWT :: Q.DB m => TempEntity.HashJWT -> m ObjectId -expectObjectIdForHashJWT hashJwt = do - hashId <- throwExceptT (Q.expectHashIdByHash (decode hashJwt)) - throwExceptT (Q.expectObjectIdForAnyHashId hashId) - where - decode :: TempEntity.HashJWT -> Hash - decode = - Hash.fromBase32Hex . Share.toBase32Hex . Share.hashJWTHash . Share.HashJWT - -expectBranchObjectIdForHashJWT :: Q.DB m => TempEntity.HashJWT -> m BranchObjectId -expectBranchObjectIdForHashJWT = - fmap BranchObjectId . expectObjectIdForHashJWT - -expectPatchObjectIdForHashJWT :: Q.DB m => TempEntity.HashJWT -> m PatchObjectId -expectPatchObjectIdForHashJWT = - fmap PatchObjectId . expectObjectIdForHashJWT - -expectBranchHashIdForHashJWT :: Q.DB m => TempEntity.HashJWT -> m BranchHashId -expectBranchHashIdForHashJWT = undefined - -expectCausalHashIdForHashJWT :: Q.DB m => TempEntity.HashJWT -> m CausalHashId -expectCausalHashIdForHashJWT = undefined - --- Serialization.recomposeComponent :: MonadPut m => [(LocalIds, BS.ByteString)] -> m () --- Serialization.recomposePatchFormat :: MonadPut m => PatchFormat.SyncPatchFormat -> m () --- Serialization.recomposeBranchFormat :: MonadPut m => BranchFormat.SyncBranchFormat -> m () --- Q.saveObject :: DB m => HashId -> ObjectType -> ByteString -> m ObjectId - -tempToSyncDeclComponent :: Q.DB m => TempEntity.TempDeclFormat -> m DeclFormat.SyncDeclFormat -tempToSyncDeclComponent = \case - DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent decls) -> - DeclFormat.SyncDecl . DeclFormat.SyncLocallyIndexedComponent - <$> Lens.traverseOf (traverse . Lens._1) (bitraverse Q.saveText expectObjectIdForHashJWT) decls - -tempToSyncPatch :: Q.DB m => TempEntity.TempPatchFormat -> m PatchFormat.SyncPatchFormat -tempToSyncPatch = \case - PatchFormat.SyncFull localIds bytes -> PatchFormat.SyncFull <$> tempToSyncPatchLocalIds localIds <*> pure bytes - PatchFormat.SyncDiff parent localIds bytes -> - PatchFormat.SyncDiff - <$> expectPatchObjectIdForHashJWT parent - <*> tempToSyncPatchLocalIds localIds - <*> pure bytes - -tempToSyncPatchLocalIds :: Q.DB m => TempEntity.TempPatchLocalIds -> m PatchFormat.PatchLocalIds -tempToSyncPatchLocalIds (PatchFormat.LocalIds texts hashes defns) = - PatchFormat.LocalIds - <$> traverse Q.saveText texts - <*> traverse Q.saveHash hashes - <*> traverse expectObjectIdForHashJWT defns - -tempToSyncNamespace :: Q.DB m => TempEntity.TempNamespaceFormat -> m NamespaceFormat.SyncBranchFormat -tempToSyncNamespace = \case - NamespaceFormat.SyncFull localIds bytes -> - NamespaceFormat.SyncFull <$> tempToSyncNamespaceLocalIds localIds <*> pure bytes - NamespaceFormat.SyncDiff parent localIds bytes -> - NamespaceFormat.SyncDiff - <$> expectBranchObjectIdForHashJWT parent - <*> tempToSyncNamespaceLocalIds localIds - <*> pure bytes - -tempToSyncNamespaceLocalIds :: Q.DB m => TempEntity.TempNamespaceLocalIds -> m NamespaceFormat.BranchLocalIds -tempToSyncNamespaceLocalIds (NamespaceFormat.LocalIds texts defns patches children) = - NamespaceFormat.LocalIds - <$> traverse Q.saveText texts - <*> traverse expectObjectIdForHashJWT defns - <*> traverse expectPatchObjectIdForHashJWT patches - <*> traverse - ( \(branch, causal) -> - (,) - <$> expectBranchObjectIdForHashJWT branch - <*> expectCausalHashIdForHashJWT causal - ) - children - -tempToSyncCausal :: Q.DB m => TempEntity.TempCausalFormat -> m Causal.SyncCausalFormat -- could probably use a better type name here -tempToSyncCausal Causal.SyncCausalFormat {valueHash, parents} = - Causal.SyncCausalFormat - <$> expectBranchHashIdForHashJWT valueHash - <*> traverse expectCausalHashIdForHashJWT parents - --- Q.saveCausalHash :: DB m => CausalHash -> m CausalHashId -- only affects `hash` table --- Q.saveCausal :: DB m => CausalHashId -> BranchHashId -> m () --- Q.saveCausalParents :: DB m => CausalHashId -> [CausalHashId] -> m () - ------------------------------------------------------------------------------------------------------------------------ -- Database operations From 500c6886b53a13943241ed4bd8a2d2df26d736f1 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 16:07:48 -0400 Subject: [PATCH 141/529] fill out insertEntity --- .../U/Codebase/Sqlite/Queries.hs | 23 +++++++++++------- unison-cli/src/Unison/Share/Sync.hs | 24 ++++--------------- 2 files changed, 19 insertions(+), 28 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index e86eaeb217..234d213e48 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -129,7 +129,9 @@ module U.Codebase.Sqlite.Queries getMissingDependentsForTempEntity, getMissingDependencyJwtsForTempEntity, tempEntityExists, + tempToSyncEntity, insertTempEntity, + saveReadyEntity, deleteTempDependencies, -- * db misc @@ -406,9 +408,9 @@ saveObject h t blob = do changes >>= \case 0 -> pure () _ -> do - _ <- Except.runExceptT do - hash <- loadHashById h - tryMoveTempEntityDependents hash + Except.runExceptT (loadHashById h) >>= \case + Left _ -> undefined -- will be better after unison-sqlite PR merges + Right hash -> tryMoveTempEntityDependents hash pure () pure oId where @@ -508,7 +510,7 @@ updateObjectBlob oId bs = execute sql (oId, bs) where sql = [here| -- |Maybe we would generalize this to something other than NamespaceHash if we -- end up wanting to store other kinds of Causals here too. -saveCausal :: EDB m => CausalHashId -> BranchHashId -> [CausalHashId] -> m () +saveCausal :: DB m => CausalHashId -> BranchHashId -> [CausalHashId] -> m () saveCausal self value parents = do execute insertCausalSql (self, value) changes >>= \case @@ -526,8 +528,11 @@ saveCausal self value parents = do INSERT INTO causal_parent (causal_id, parent_id) VALUES (?, ?) |] -flushCausalDependents :: EDB m => CausalHashId -> m () -flushCausalDependents chId = loadHashById (unCausalHashId chId) >>= tryMoveTempEntityDependents +flushCausalDependents :: DB m => CausalHashId -> m () +flushCausalDependents chId = + Except.runExceptT (loadHashById (unCausalHashId chId)) >>= \case + Left _ -> undefined -- will be better after unison-sqlite PR merges + Right hash -> tryMoveTempEntityDependents hash expectObjectIdForHashJWT :: DB m => TempEntity.HashJWT -> m ObjectId expectObjectIdForHashJWT hashJwt = do @@ -566,7 +571,7 @@ expectCausalHashIdForHashJWT = undefined -- insert_entity them. -- -- Precondition: Must have inserted the entity with hash b32 already. -tryMoveTempEntityDependents :: EDB m => Base32Hex -> m () +tryMoveTempEntityDependents :: DB m => Base32Hex -> m () tryMoveTempEntityDependents dependencyBase32 = do dependents <- getMissingDependentsForTempEntity dependencyBase32 executeMany deleteTempDependents (dependents <&> (,dependencyBase32)) @@ -591,7 +596,7 @@ tryMoveTempEntityDependents dependencyBase32 = do ) |] -moveTempEntityToMain :: EDB m => Base32Hex -> m () +moveTempEntityToMain :: DB m => Base32Hex -> m () moveTempEntityToMain b32 = do loadTempEntity b32 >>= \case Left _ -> undefined @@ -687,7 +692,7 @@ tempToSyncEntity = \case TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent <$> Lens.traverseOf (traverse . Lens._1) (bitraverse saveText expectObjectIdForHashJWT) terms -saveReadyEntity :: EDB m => Base32Hex -> ReadyEntity -> m (Either CausalHashId ObjectId) +saveReadyEntity :: DB m => Base32Hex -> ReadyEntity -> m (Either CausalHashId ObjectId) saveReadyEntity b32Hex entity = do hashId <- saveHash b32Hex case entity of diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index f861414ee5..9a1a54f558 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -269,11 +269,7 @@ download httpClient unisonShareUrl conn repoName = do -- Some remaining work: -- --- [ ] Beef up insert_entity to flush temp entities -- [ ] Write resolveHashToEntity --- [x] Add "no read permission" to GetCausalHashByPathResponse in Share.Types --- [x] Add "no write permission" to UpdatePathResponse in Share.Types --- [ ] The tempToSync* stuff {- server sqlite db @@ -298,20 +294,6 @@ server sqlite db -} ---------- --- --- Note: beef up insert_entity procedure to flush temp_entity table --- 1. When inserting object #foo, --- look up all dependents of #foo in --- temp_entity_missing_dependency table (say #bar, #baz). --- 2. Delete (#bar, #foo) and (#baz, #foo) from temp_entity_missing_dependency. --- 3. Delete #foo from temp_entity (if it's there) --- 4. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, --- insert_entity them. - ------------------------------------------------------------------------------------------------------------------------- --- - -- FIXME rename, etc resolveHashToEntity :: Connection -> Share.Hash -> IO (Share.Entity Text Share.Hash Share.Hash) resolveHashToEntity = undefined @@ -375,8 +357,12 @@ elaborateHashes hashes outputs = elaborateHashes (Set.union (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) hashes') outputs EntityInMainStorage -> elaborateHashes hashes' outputs +-- | Insert an entity that doesn't have any missing dependencies. insertEntity :: Q.DB m => Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> m () -insertEntity _hash = undefined +insertEntity hash entity = do + readyEntity <- Q.tempToSyncEntity (entityToTempEntity entity) + _id <- Q.saveReadyEntity (Share.toBase32Hex hash) readyEntity + pure () -- | Insert an entity and its missing dependencies. insertTempEntity :: From e7773ff06e497f9346e850b5dca8ee0244486d8b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 17:26:29 -0400 Subject: [PATCH 142/529] make executeMany do less work on empty list --- .../src/Unison/Sqlite/Connection.hs | 22 ++++++++++--------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index 258a67f0bc..a1bf1c9a59 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -173,16 +173,18 @@ execute conn@(Connection _ _ conn0) s params = do } executeMany :: Sqlite.ToRow a => Connection -> Sql -> [a] -> IO () -executeMany conn@(Connection _ _ conn0) s params = do - logQuery s (Just params) Nothing - Sqlite.executeMany conn0 (coerce s) params `catch` \(exception :: Sqlite.SQLError) -> - throwSqliteQueryException - SqliteQueryExceptionInfo - { connection = conn, - exception = SomeSqliteExceptionReason exception, - params = Just params, - sql = s - } +executeMany conn@(Connection _ _ conn0) s = \case + [] -> pure () + params -> do + logQuery s (Just params) Nothing + Sqlite.executeMany conn0 (coerce s) params `catch` \(exception :: Sqlite.SQLError) -> + throwSqliteQueryException + SqliteQueryExceptionInfo + { connection = conn, + exception = SomeSqliteExceptionReason exception, + params = Just params, + sql = s + } -- Without results, without parameters From 478943f8b6de519c6e36a627bce96b9d7b3dd5f2 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 17:27:19 -0400 Subject: [PATCH 143/529] mapEnv -> hoistEnv --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs | 4 ++-- parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs index f99a3139eb..c129c949de 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs @@ -70,8 +70,8 @@ data Env m = Env idCacheSize :: Word } -mapEnv :: (forall x. m x -> n x) -> Env m -> Env n -mapEnv f Env {runSrc, runDest, idCacheSize} = +hoistEnv :: (forall x. m x -> n x) -> Env m -> Env n +hoistEnv f Env {runSrc, runDest, idCacheSize} = Env { runSrc = f . runSrc, runDest = f . runDest, diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 83fb55ae16..828d95a7e0 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -509,7 +509,7 @@ syncInternal progress runSrc runDest b = time "syncInternal" do -- or if it exists in the source codebase, then we can sync22 it -- if it doesn't exist in the dest or source branch, -- then just use putBranch to the dest - sync <- liftIO (Sync22.sync22 (Sync22.mapEnv lift syncEnv)) + sync <- liftIO (Sync22.sync22 (Sync22.hoistEnv lift syncEnv)) let doSync :: [Sync22.Entity] -> m () doSync = throwExceptT From 83c8e59c38d027c185ba422689ca9f93872d5a4f Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 17:38:41 -0400 Subject: [PATCH 144/529] thing -> run --- lib/unison-sqlite/src/Unison/Sqlite/Connection.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index a1bf1c9a59..04ebf35cae 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -204,7 +204,7 @@ execute_ conn@(Connection _ _ conn0) s = do queryStreamRow :: (Sqlite.FromRow b, Sqlite.ToRow a) => Connection -> Sql -> a -> (IO (Maybe b) -> IO r) -> IO r queryStreamRow conn@(Connection _ _ conn0) s params callback = - thing `catch` \(exception :: Sqlite.SQLError) -> + run `catch` \(exception :: Sqlite.SQLError) -> throwSqliteQueryException SqliteQueryExceptionInfo { connection = conn, @@ -213,7 +213,7 @@ queryStreamRow conn@(Connection _ _ conn0) s params callback = sql = s } where - thing = + run = bracket (Sqlite.openStatement conn0 (coerce s)) Sqlite.closeStatement \statement -> do Sqlite.bind statement params callback (Sqlite.nextRow statement) From 530916f84788bab262204f50cb8a68aca5d3786e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 17:38:57 -0400 Subject: [PATCH 145/529] Sqlite.unsafeIO . putStrLn -> log --- .../Migrations/MigrateSchema1To2.hs | 40 ++++++++++--------- 1 file changed, 22 insertions(+), 18 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 510c91dd16..2c2089dbe6 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -80,6 +80,7 @@ import qualified Unison.Term as Term import Unison.Type (Type) import qualified Unison.Type as Type import qualified Unison.Util.Set as Set +import Prelude hiding (log) verboseOutput :: Bool verboseOutput = @@ -93,16 +94,15 @@ migrateSchema1To2 :: TVar (Map Hash CodebaseOps.DeclBufferEntry) -> Sqlite.Transaction () migrateSchema1To2 getDeclType termBuffer declBuffer = do - Sqlite.unsafeIO $ putStrLn $ "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" + log "Starting codebase migration. This may take a while, it's a good time to make some tea โ˜•๏ธ" corruptedCausals <- Q.getCausalsWithoutBranchObjects - when (not . null $ corruptedCausals) $ - Sqlite.unsafeIO $ do - putStrLn $ "โš ๏ธ I detected " <> show (length corruptedCausals) <> " corrupted namespace(s) in the history of the codebase." - putStrLn $ "This is due to a bug in a previous version of ucm." - putStrLn $ "This only affects the history of your codebase, the most up-to-date iteration will remain intact." - putStrLn $ "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." - - Sqlite.unsafeIO $ putStrLn $ "Updating Namespace Root..." + when (not . null $ corruptedCausals) do + log $ "โš ๏ธ I detected " <> show (length corruptedCausals) <> " corrupted namespace(s) in the history of the codebase." + log "This is due to a bug in a previous version of ucm." + log "This only affects the history of your codebase, the most up-to-date iteration will remain intact." + log "I'll go ahead with the migration, but will replace any corrupted namespaces with empty ones." + + log "Updating Namespace Root..." rootCausalHashId <- Q.expectNamespaceRoot numEntitiesToMigrate <- sum <$> sequenceA [Q.countObjects, Q.countCausals, Q.countWatches] v2EmptyBranchHashInfo <- saveV2EmptyBranch @@ -114,16 +114,16 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do Sync.sync @_ @Entity (migrationSync getDeclType termBuffer declBuffer) (progress numEntitiesToMigrate) (CausalE rootCausalHashId : watches) `execStateT` MigrationState Map.empty Map.empty Map.empty Set.empty 0 v2EmptyBranchHashInfo let (_, newRootCausalHashId) = causalMapping migrationState ^?! ix rootCausalHashId - Sqlite.unsafeIO $ putStrLn $ "Updating Namespace Root..." + log "Updating Namespace Root..." Q.setNamespaceRoot newRootCausalHashId - Sqlite.unsafeIO $ putStrLn $ "Rewriting old object IDs..." + log "Rewriting old object IDs..." ifor_ (objLookup migrationState) \oldObjId (newObjId, _, _, _) -> do Q.recordObjectRehash oldObjId newObjId - Sqlite.unsafeIO $ putStrLn $ "Garbage collecting orphaned objects..." + log "Garbage collecting orphaned objects..." Q.garbageCollectObjectsWithoutHashes - Sqlite.unsafeIO $ putStrLn $ "Garbage collecting orphaned watches..." + log "Garbage collecting orphaned watches..." Q.garbageCollectWatchesWithoutObjects - Sqlite.unsafeIO $ putStrLn $ "Updating Schema Version..." + log "Updating Schema Version..." Q.setSchemaVersion 2 where progress :: Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) Entity @@ -133,22 +133,26 @@ migrateSchema1To2 getDeclType termBuffer declBuffer = do numDone <- field @"numMigrated" <+= 1 lift $ Sqlite.unsafeIO $ putStr $ "\r ๐Ÿ— " <> show numDone <> " / ~" <> show numToMigrate <> " entities migrated. ๐Ÿšง" need :: Entity -> StateT MigrationState Sqlite.Transaction () - need e = when verboseOutput $ lift $ Sqlite.unsafeIO $ putStrLn $ "Need: " ++ show e + need e = when verboseOutput $ lift $ log $ "Need: " ++ show e done :: Entity -> StateT MigrationState Sqlite.Transaction () done e = do - when verboseOutput $ lift $ Sqlite.unsafeIO $ putStrLn $ "Done: " ++ show e + when verboseOutput $ lift $ log $ "Done: " ++ show e incrementProgress errorHandler :: Entity -> StateT MigrationState Sqlite.Transaction () errorHandler e = do case e of -- We expect non-fatal errors when migrating watches. W {} -> pure () - e -> lift $ Sqlite.unsafeIO $ putStrLn $ "Error: " ++ show e + e -> lift $ log $ "Error: " ++ show e incrementProgress allDone :: StateT MigrationState Sqlite.Transaction () - allDone = lift $ Sqlite.unsafeIO $ putStrLn $ "\nFinished migrating, initiating cleanup." + allDone = lift $ log $ "\nFinished migrating, initiating cleanup." in Sync.Progress {need, done, error = errorHandler, allDone} +log :: String -> Sqlite.Transaction () +log = + Sqlite.unsafeIO . putStrLn + type Old a = a type New a = a From 2128a6e60cccbe485fb71bb2c8f50a7dc6f421d7 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 17:47:29 -0400 Subject: [PATCH 146/529] fix comment --- lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 9b3e026c40..d02243b3c8 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -180,8 +180,10 @@ savepoint (Transaction action) = do pure result Right result -> pure result --- | Perform IO inside a transaction, which should be idempotent, because it may be run more than once. --- FIXME rename to unsafeIO or something +-- | Perform IO inside a transaction, which should be idempotent, because it may be run more than once if the +-- transaction needs to retry. +-- +-- /Warning/: attempting to run a transaction inside a transaction will cause an exception! unsafeIO :: IO a -> Transaction a unsafeIO action = Transaction \_ -> action From 4aa595f37caef9fd4c0856e263e8b533813f2d31 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 22:38:45 -0400 Subject: [PATCH 147/529] handle a couple missing cases --- unison-cli/src/Unison/Share/Sync.hs | 41 ++++++++++++++++------------- 1 file changed, 23 insertions(+), 18 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index beb9aa171c..4e38430f01 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -64,8 +64,9 @@ getCausalHashByPath repoPath = -- | An error occurred while pushing code to Unison Share. data PushError - = PushErrorServerMissingDependencies (NESet Share.Hash) - | PushErrorHashMismatch Share.HashMismatch + = PushErrorHashMismatch Share.HashMismatch + | PushErrorNoWritePermission Share.RepoPath + | PushErrorServerMissingDependencies (NESet Share.Hash) -- | Push a causal to Unison Share. push :: @@ -91,19 +92,22 @@ push httpClient unisonShareUrl runDB repoPath expectedHash causalHash = do Share.UpdatePathHashMismatch mismatch -> pure (Left (PushErrorHashMismatch mismatch)) Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do -- Upload the causal and all of its dependencies. - upload httpClient unisonShareUrl runDB (Share.RepoPath.repoName repoPath) dependencies - - -- After uploading the causal and all of its dependencies, try setting the remote path again. - updatePath <&> \case - Share.UpdatePathSuccess -> Right () - -- Between the initial updatePath attempt and this one, someone else managed to update the path. That's ok; we - -- still managed to upload our causal, but the push has indeed failed overall. - Share.UpdatePathHashMismatch mismatch -> Left (PushErrorHashMismatch mismatch) - -- Unexpected, but possible: we thought we uploaded all we needed to, yet the server still won't accept our - -- causal. Bug in the client because we didn't upload enough? Bug in the server because we weren't told to - -- upload some dependency? Who knows. - Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> - Left (PushErrorServerMissingDependencies dependencies) + upload httpClient unisonShareUrl runDB (Share.RepoPath.repoName repoPath) dependencies >>= \case + False -> pure (Left (PushErrorNoWritePermission repoPath)) + True -> + -- After uploading the causal and all of its dependencies, try setting the remote path again. + updatePath <&> \case + Share.UpdatePathSuccess -> Right () + -- Between the initial updatePath attempt and this one, someone else managed to update the path. That's ok; + -- we still managed to upload our causal, but the push has indeed failed overall. + Share.UpdatePathHashMismatch mismatch -> Left (PushErrorHashMismatch mismatch) + -- Unexpected, but possible: we thought we uploaded all we needed to, yet the server still won't accept our + -- causal. Bug in the client because we didn't upload enough? Bug in the server because we weren't told to + -- upload some dependency? Who knows. + Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> + Left (PushErrorServerMissingDependencies dependencies) + Share.UpdatePathNoWritePermission _ -> Left (PushErrorNoWritePermission repoPath) + Share.UpdatePathNoWritePermission _ -> pure (Left (PushErrorNoWritePermission repoPath)) where updatePath :: IO Share.UpdatePathResponse updatePath = @@ -138,11 +142,11 @@ upload :: (forall a. Sqlite.Transaction a -> IO a) -> Share.RepoName -> NESet Share.Hash -> - IO () + IO Bool upload httpClient unisonShareUrl runDB repoName = loop where - loop :: NESet Share.Hash -> IO () + loop :: NESet Share.Hash -> IO Bool loop (NESet.toAscList -> hashes) = do -- Get each entity that the server is missing out of the database. entities <- traverse (runDB . resolveHashToEntity) hashes @@ -161,7 +165,8 @@ upload httpClient unisonShareUrl runDB repoName = -- upload those too. uploadEntities >>= \case Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> loop moreHashes - Share.UploadEntitiesSuccess -> pure () + Share.UploadEntitiesNoWritePermission _ -> pure False + Share.UploadEntitiesSuccess -> pure True ------------------------------------------------------------------------------------------------------------------------ -- Pull From 0320ca0711fe4546f4f794788213bd786b27f52b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 22:39:07 -0400 Subject: [PATCH 148/529] delete unused function --- unison-cli/src/Unison/Share/Sync.hs | 5 ----- 1 file changed, 5 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 4e38430f01..2e1f0772e4 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -317,11 +317,6 @@ entityExists (Share.Hash b32) = do -- then check if is causal hash or if object exists for hash id Just hashId -> Q.isCausalHash hashId ||^ Q.isObjectHash hashId --- | Does this entity already exist in the `temp_entity` table? -tempEntityExists :: Share.Hash -> Sqlite.Transaction Bool -tempEntityExists (Share.Hash b32) = - Q.tempEntityExists b32 - -- | Where is an entity stored? entityLocation :: Share.Hash -> Sqlite.Transaction EntityLocation entityLocation hash = From 831f97b60f18777e6f6ed33bb417c5f093faab74 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 22:39:28 -0400 Subject: [PATCH 149/529] delete unused query --- .../codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 14 -------------- 1 file changed, 14 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 85a24ae028..9e57e943eb 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -124,7 +124,6 @@ module U.Codebase.Sqlite.Queries -- * sync temp entities getMissingDependentsForTempEntity, getMissingDependencyJwtsForTempEntity, - tempEntityExists, tempToSyncEntity, insertTempEntity, saveReadyEntity, @@ -1220,19 +1219,6 @@ getMissingDependentsForTempEntity h = |] (Only h) -tempEntityExists :: Base32Hex -> Transaction Bool -tempEntityExists h = - queryOneCol sql (Only h) - where - sql = - [here| - SELECT EXISTS ( - SELECT 1 - FROM temp_entity - WHERE hash = ? - ) - |] - -- | Insert a new `temp_entity` row, and its associated 1+ `temp_entity_missing_dependency` rows. -- -- Preconditions: From 639706afb8fbe194d56bef474d9077153bee1b32 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 19 Apr 2022 22:43:52 -0400 Subject: [PATCH 150/529] hit actual getCausalHashByPath endpoint --- unison-cli/src/Unison/Share/Sync.hs | 39 ++++++++++++++--------------- 1 file changed, 19 insertions(+), 20 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 2e1f0772e4..1e57ff9fb0 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -37,7 +37,12 @@ import qualified U.Util.Hash as Hash import Unison.Auth.HTTPClient (AuthorizedHttpClient) import Unison.Prelude import qualified Unison.Sqlite as Sqlite -import qualified Unison.Sync.HTTP as Share (downloadEntitiesHandler, updatePathHandler, uploadEntitiesHandler) +import qualified Unison.Sync.HTTP as Share + ( downloadEntitiesHandler, + getPathHandler, + updatePathHandler, + uploadEntitiesHandler, + ) import qualified Unison.Sync.Types as Share import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) import Unison.Util.Monoid (foldMapM) @@ -49,15 +54,20 @@ import qualified Unison.Util.Set as Set -- | An error occurred when getting causal hash by path. data GetCausalHashByPathError = -- | The user does not have permission to read this path. - GetCausalHashByPathErrorNoReadPermission + GetCausalHashByPathErrorNoReadPermission Share.RepoPath -- | Get the causal hash of a path hosted on Unison Share. -getCausalHashByPath :: Share.RepoPath -> IO (Either GetCausalHashByPathError (Maybe Share.HashJWT)) -getCausalHashByPath repoPath = - _getCausalHashByPath (Share.GetCausalHashByPathRequest repoPath) <&> \case - GetCausalHashByPathSuccess hashJwt -> Right (Just hashJwt) - GetCausalHashByPathEmpty -> Right Nothing - GetCausalHashByPathNoReadPermission -> Left GetCausalHashByPathErrorNoReadPermission +getCausalHashByPath :: + -- | The HTTP client to use for Unison Share requests. + AuthorizedHttpClient -> + -- | The Unison Share URL. + BaseUrl -> + Share.RepoPath -> + IO (Either GetCausalHashByPathError (Maybe Share.HashJWT)) +getCausalHashByPath httpClient unisonShareUrl repoPath = + Share.getPathHandler httpClient unisonShareUrl (Share.GetCausalHashByPathRequest repoPath) <&> \case + Share.GetCausalHashByPathSuccess maybeHashJwt -> Right maybeHashJwt + Share.GetCausalHashByPathNoReadPermission _ -> Left (GetCausalHashByPathErrorNoReadPermission repoPath) ------------------------------------------------------------------------------------------------------------------------ -- Push @@ -187,7 +197,7 @@ pull :: Share.RepoPath -> IO (Either PullError (Maybe CausalHash)) pull httpClient unisonShareUrl runDB repoPath = do - getCausalHashByPath repoPath >>= \case + getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case Left err -> pure (Left (PullErrorGetCausalHashByPath err)) -- There's nothing at the remote path, so there's no causal to pull. Right Nothing -> pure (Right Nothing) @@ -285,17 +295,6 @@ server sqlite db resolveHashToEntity :: Share.Hash -> Sqlite.Transaction (Share.Entity Text Share.Hash Share.Hash) resolveHashToEntity = undefined ------------------------------------------------------------------------------------------------------------------------- --- TODO these things come from servant-client / api types module(s) - -data GetCausalHashByPathResponse - = GetCausalHashByPathSuccess Share.HashJWT - | GetCausalHashByPathEmpty - | GetCausalHashByPathNoReadPermission - -_getCausalHashByPath :: Share.GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse -_getCausalHashByPath = undefined - ------------------------------------------------------------------------------------------------------------------------ -- Database operations From bb6a6613285167cc87fd858d806b76dccce2e0a4 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 20 Apr 2022 16:59:40 -0500 Subject: [PATCH 151/529] use `splitMember` --- lib/unison-util-relation/src/Unison/Util/Relation.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/unison-util-relation/src/Unison/Util/Relation.hs b/lib/unison-util-relation/src/Unison/Util/Relation.hs index 1b1724674a..d1f8254c5e 100644 --- a/lib/unison-util-relation/src/Unison/Util/Relation.hs +++ b/lib/unison-util-relation/src/Unison/Util/Relation.hs @@ -508,10 +508,10 @@ s <| r = go s (domain r) go s _ | Set.null s = mempty go s (Map.Bin _ amid bs l r) = here <> go sl l <> go sr r where - (sl, sr) = Set.split amid s + (sl, hasMid, sr) = Set.splitMember amid s mids = Set.singleton amid here = - if Set.member amid s + if hasMid then Relation (Map.singleton amid bs) (Map.fromList $ (,mids) <$> (Set.toList bs)) else mempty From 4765d1366d6cb3562a57ec8e0fa2c449406fbed7 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 25 Apr 2022 15:07:15 -0400 Subject: [PATCH 152/529] implement rowsModified --- .../codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 11 ++--------- lib/unison-sqlite/src/Unison/Sqlite.hs | 3 +++ lib/unison-sqlite/src/Unison/Sqlite/Connection.hs | 9 +++++++++ lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs | 9 +++++++++ 4 files changed, 23 insertions(+), 9 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 9e57e943eb..31a960eb40 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -335,7 +335,7 @@ saveObject :: HashId -> ObjectType -> ByteString -> Transaction ObjectId saveObject h t blob = do oId <- execute sql (h, t, blob) >> expectObjectIdForPrimaryHashId h saveHashObject h oId 2 -- todo: remove this from here, and add it to other relevant places once there are v1 and v2 hashes - changes >>= \case + rowsModified >>= \case 0 -> pure () _ -> do hash <- expectHash32 h @@ -528,7 +528,7 @@ recordObjectRehash old new = saveCausal :: CausalHashId -> BranchHashId -> [CausalHashId] -> Transaction () saveCausal self value parents = do execute insertCausalSql (self, value) - changes >>= \case + rowsModified >>= \case 0 -> pure () _ -> do executeMany insertCausalParentsSql (fmap (self,) parents) @@ -725,13 +725,6 @@ saveReadyEntity b32Hex entity = do saveCausal causalHashId valueHash (Foldable.toList parents) pure $ Left causalHashId --- FIXME -changes :: Transaction Int -changes = do - undefined - -- conn <- Reader.reader Connection.underlying - -- liftIO (SQLite.changes conn) - -- -- maybe: look at whether parent causal is "committed"; if so, then increment; -- -- otherwise, don't. -- getNurseryGeneration :: DB m => m Generation diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index f929cd6da2..e01d9c85c0 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -73,6 +73,9 @@ module Unison.Sqlite queryOneRowCheck_, queryOneColCheck_, + -- * Rows modified + rowsModified, + -- * Data version DataVersion (..), getDataVersion, diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index 04ebf35cae..499e83d1a3 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -50,6 +50,9 @@ module Unison.Sqlite.Connection queryOneRowCheck_, queryOneColCheck_, + -- * Rows modified + rowsModified, + -- * Vacuum (into) vacuum, vacuumInto, @@ -472,6 +475,12 @@ queryOneColCheck_ :: queryOneColCheck_ conn s check = queryOneRowCheck_ conn s (coerce @(a -> Either e r) @(Sqlite.Only a -> Either e r) check) +-- Rows modified + +rowsModified :: Connection -> IO Int +rowsModified (Connection _ _ conn) = + Sqlite.changes conn + -- Vacuum -- | @VACUUM@ diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index d02243b3c8..6c316385f9 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -54,6 +54,9 @@ module Unison.Sqlite.Transaction queryMaybeColCheck_, queryOneRowCheck_, queryOneColCheck_, + + -- * Rows modified + rowsModified, ) where @@ -361,3 +364,9 @@ queryOneRowCheck_ s check = queryOneColCheck_ :: (Sqlite.FromField a, SqliteExceptionReason e) => Sql -> (a -> Either e r) -> Transaction r queryOneColCheck_ s check = Transaction \conn -> Connection.queryOneColCheck_ conn s check + +-- Rows modified + +rowsModified :: Transaction Int +rowsModified = + Transaction Connection.rowsModified From 56d70105f10c4c20b924f518049b3a8f8ce4bc14 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 25 Apr 2022 15:37:26 -0400 Subject: [PATCH 153/529] don't store hash jwts in temp_entity --- .../U/Codebase/Sqlite/Queries.hs | 69 +++++++++---------- .../U/Codebase/Sqlite/Serialization.hs | 44 ++++++------ .../U/Codebase/Sqlite/TempEntity.hs | 14 ++-- unison-cli/src/Unison/Share/Sync.hs | 20 +++--- 4 files changed, 70 insertions(+), 77 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 31a960eb40..f4f290def0 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -448,10 +448,28 @@ loadObjectIdForPrimaryHash h = Just hashId -> loadObjectIdForPrimaryHashId hashId expectObjectIdForPrimaryHash :: Hash -> Transaction ObjectId -expectObjectIdForPrimaryHash h = do - hashId <- expectHashIdByHash h +expectObjectIdForPrimaryHash = + expectObjectIdForHash32 . Hash.toBase32Hex + +expectObjectIdForHash32 :: Base32Hex -> Transaction ObjectId +expectObjectIdForHash32 hash = do + hashId <- expectHashId hash expectObjectIdForPrimaryHashId hashId +expectBranchObjectIdForHash32 :: Base32Hex -> Transaction BranchObjectId +expectBranchObjectIdForHash32 = + fmap BranchObjectId . expectObjectIdForHash32 + +expectPatchObjectIdForHash32 :: Base32Hex -> Transaction PatchObjectId +expectPatchObjectIdForHash32 = + fmap PatchObjectId . expectObjectIdForHash32 + +expectBranchHashIdForHash32 :: Base32Hex -> Transaction BranchHashId +expectBranchHashIdForHash32 = undefined + +expectCausalHashIdForHash32 :: Base32Hex -> Transaction CausalHashId +expectCausalHashIdForHash32 = undefined + loadPatchObjectIdForPrimaryHash :: PatchHash -> Transaction (Maybe PatchObjectId) loadPatchObjectIdForPrimaryHash = (fmap . fmap) PatchObjectId . loadObjectIdForPrimaryHash . unPatchHash @@ -548,31 +566,6 @@ flushCausalDependents chId = do hash <- expectHash32 (unCausalHashId chId) tryMoveTempEntityDependents hash -expectObjectIdForHashJWT :: TempEntity.HashJWT -> Transaction ObjectId -expectObjectIdForHashJWT hashJwt = do - hashId <- expectHashIdByHash (decode hashJwt) - expectObjectIdForAnyHashId hashId - where - decode :: TempEntity.HashJWT -> Hash - decode = - undefined - -- FIXME need to know how to go HashJWT -> Hash at the DB layer too, not just Share API layer - -- Hash.fromBase32Hex . Share.toBase32Hex . Share.hashJWTHash . Share.HashJWT - -expectBranchObjectIdForHashJWT :: TempEntity.HashJWT -> Transaction BranchObjectId -expectBranchObjectIdForHashJWT = - fmap BranchObjectId . expectObjectIdForHashJWT - -expectPatchObjectIdForHashJWT :: TempEntity.HashJWT -> Transaction PatchObjectId -expectPatchObjectIdForHashJWT = - fmap PatchObjectId . expectObjectIdForHashJWT - -expectBranchHashIdForHashJWT :: TempEntity.HashJWT -> Transaction BranchHashId -expectBranchHashIdForHashJWT = undefined - -expectCausalHashIdForHashJWT :: TempEntity.HashJWT -> Transaction CausalHashId -expectCausalHashIdForHashJWT = undefined - -- Note: beef up insert_entity procedure to flush temp_entity table -- | flushTempEntity does this: @@ -648,14 +641,14 @@ tempToSyncEntity = \case tempToSyncCausal :: TempEntity.TempCausalFormat -> Transaction Causal.SyncCausalFormat tempToSyncCausal Causal.SyncCausalFormat {valueHash, parents} = Causal.SyncCausalFormat - <$> expectBranchHashIdForHashJWT valueHash - <*> traverse expectCausalHashIdForHashJWT parents + <$> expectBranchHashIdForHash32 valueHash + <*> traverse expectCausalHashIdForHash32 parents tempToSyncDeclComponent :: TempEntity.TempDeclFormat -> Transaction DeclFormat.SyncDeclFormat tempToSyncDeclComponent = \case DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent decls) -> DeclFormat.SyncDecl . DeclFormat.SyncLocallyIndexedComponent - <$> Lens.traverseOf (traverse . Lens._1) (bitraverse saveText expectObjectIdForHashJWT) decls + <$> Lens.traverseOf (traverse . Lens._1) (bitraverse saveText expectObjectIdForHash32) decls tempToSyncNamespace :: TempEntity.TempNamespaceFormat -> Transaction NamespaceFormat.SyncBranchFormat tempToSyncNamespace = \case @@ -663,7 +656,7 @@ tempToSyncEntity = \case NamespaceFormat.SyncFull <$> tempToSyncNamespaceLocalIds localIds <*> pure bytes NamespaceFormat.SyncDiff parent localIds bytes -> NamespaceFormat.SyncDiff - <$> expectBranchObjectIdForHashJWT parent + <$> expectBranchObjectIdForHash32 parent <*> tempToSyncNamespaceLocalIds localIds <*> pure bytes @@ -671,13 +664,13 @@ tempToSyncEntity = \case tempToSyncNamespaceLocalIds (NamespaceFormat.LocalIds texts defns patches children) = NamespaceFormat.LocalIds <$> traverse saveText texts - <*> traverse expectObjectIdForHashJWT defns - <*> traverse expectPatchObjectIdForHashJWT patches + <*> traverse expectObjectIdForHash32 defns + <*> traverse expectPatchObjectIdForHash32 patches <*> traverse ( \(branch, causal) -> (,) - <$> expectBranchObjectIdForHashJWT branch - <*> expectCausalHashIdForHashJWT causal + <$> expectBranchObjectIdForHash32 branch + <*> expectCausalHashIdForHash32 causal ) children @@ -686,7 +679,7 @@ tempToSyncEntity = \case PatchFormat.SyncFull localIds bytes -> PatchFormat.SyncFull <$> tempToSyncPatchLocalIds localIds <*> pure bytes PatchFormat.SyncDiff parent localIds bytes -> PatchFormat.SyncDiff - <$> expectPatchObjectIdForHashJWT parent + <$> expectPatchObjectIdForHash32 parent <*> tempToSyncPatchLocalIds localIds <*> pure bytes @@ -695,13 +688,13 @@ tempToSyncEntity = \case PatchFormat.LocalIds <$> traverse saveText texts <*> traverse saveHash hashes - <*> traverse expectObjectIdForHashJWT defns + <*> traverse expectObjectIdForHash32 defns tempToSyncTermComponent :: TempEntity.TempTermFormat -> Transaction TermFormat.SyncTermFormat tempToSyncTermComponent = \case TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent terms) -> TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent - <$> Lens.traverseOf (traverse . Lens._1) (bitraverse saveText expectObjectIdForHashJWT) terms + <$> Lens.traverseOf (traverse . Lens._1) (bitraverse saveText expectObjectIdForHash32) terms saveReadyEntity :: Base32Hex -> ReadyEntity -> Transaction (Either CausalHashId ObjectId) saveReadyEntity b32Hex entity = do diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index 9aba3cba37..2d05fe0c22 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -748,32 +748,31 @@ putTempEntity = \case TempEntity.C gdc -> putSyncCausal gdc where - putHashJWT = putText putBase32Hex = putText . Base32Hex.toText putPatchLocalIds PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} = do putFoldable putText patchTextLookup putFoldable putBase32Hex patchHashLookup - putFoldable putHashJWT patchDefnLookup + putFoldable putBase32Hex patchDefnLookup putNamespaceLocalIds BranchFormat.LocalIds {branchTextLookup, branchDefnLookup, branchPatchLookup, branchChildLookup} = do putFoldable putText branchTextLookup - putFoldable putHashJWT branchDefnLookup - putFoldable putHashJWT branchPatchLookup - putFoldable (putPair putHashJWT putHashJWT) branchChildLookup + putFoldable putBase32Hex branchDefnLookup + putFoldable putBase32Hex branchPatchLookup + putFoldable (putPair putBase32Hex putBase32Hex) branchChildLookup putSyncCausal Causal.SyncCausalFormat {valueHash, parents} = do - putHashJWT valueHash - putFoldable putHashJWT parents + putBase32Hex valueHash + putFoldable putBase32Hex parents putSyncFullPatch lids bytes = do putPatchLocalIds lids putFramedByteString bytes putSyncDiffPatch parent lids bytes = do - putHashJWT parent + putBase32Hex parent putPatchLocalIds lids putFramedByteString bytes putSyncFullNamespace lids bytes = do putNamespaceLocalIds lids putByteString bytes putSyncDiffNamespace parent lids bytes = do - putHashJWT parent + putBase32Hex parent putNamespaceLocalIds lids putFramedByteString bytes putSyncTerm (TermFormat.SyncLocallyIndexedComponent vec) = @@ -781,16 +780,13 @@ putTempEntity = \case -- when deserializing, because we don't think we need to (and it adds a -- little overhead.) flip putFoldable vec \(localIds, bytes) -> do - putLocalIdsWith putHashJWT putHashJWT localIds + putLocalIdsWith putText putBase32Hex localIds putFramedByteString bytes putSyncDecl (DeclFormat.SyncLocallyIndexedComponent vec) = flip putFoldable vec \(localIds, bytes) -> do - putLocalIdsWith putHashJWT putHashJWT localIds + putLocalIdsWith putText putBase32Hex localIds putFramedByteString bytes -getHashJWT :: MonadGet m => m TempEntity.HashJWT -getHashJWT = getText - getBase32Hex :: MonadGet m => m Base32Hex getBase32Hex = Base32Hex.UnsafeFromText <$> getText @@ -811,7 +807,7 @@ getTempTermFormat = TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent <$> getVector ( getPair - (getLocalIdsWith getHashJWT getHashJWT) + (getLocalIdsWith getText getBase32Hex) getFramedByteString ) tag -> unknownTag "getTempTermFormat" tag @@ -823,7 +819,7 @@ getTempDeclFormat = DeclFormat.SyncDecl . DeclFormat.SyncLocallyIndexedComponent <$> getVector ( getPair - (getLocalIdsWith getHashJWT getHashJWT) + (getLocalIdsWith getText getBase32Hex) getFramedByteString ) tag -> unknownTag "getTempDeclFormat" tag @@ -832,34 +828,34 @@ getTempPatchFormat :: MonadGet m => m TempEntity.TempPatchFormat getTempPatchFormat = getWord8 >>= \case 0 -> PatchFormat.SyncFull <$> getPatchLocalIds <*> getFramedByteString - 1 -> PatchFormat.SyncDiff <$> getHashJWT <*> getPatchLocalIds <*> getFramedByteString + 1 -> PatchFormat.SyncDiff <$> getBase32Hex <*> getPatchLocalIds <*> getFramedByteString tag -> unknownTag "getTempPatchFormat" tag where getPatchLocalIds = PatchFormat.LocalIds <$> getVector getText <*> getVector getBase32Hex - <*> getVector getHashJWT + <*> getVector getBase32Hex getTempNamespaceFormat :: MonadGet m => m TempEntity.TempNamespaceFormat getTempNamespaceFormat = getWord8 >>= \case 0 -> BranchFormat.SyncFull <$> getBranchLocalIds <*> getFramedByteString - 1 -> BranchFormat.SyncDiff <$> getHashJWT <*> getBranchLocalIds <*> getFramedByteString + 1 -> BranchFormat.SyncDiff <$> getBase32Hex <*> getBranchLocalIds <*> getFramedByteString tag -> unknownTag "getTempNamespaceFormat" tag where getBranchLocalIds = BranchFormat.LocalIds <$> getVector getText - <*> getVector getHashJWT - <*> getVector getHashJWT - <*> getVector (getPair getHashJWT getHashJWT) + <*> getVector getBase32Hex + <*> getVector getBase32Hex + <*> getVector (getPair getBase32Hex getBase32Hex) getTempCausalFormat :: MonadGet m => m TempEntity.TempCausalFormat getTempCausalFormat = Causal.SyncCausalFormat - <$> getHashJWT - <*> getVector getHashJWT + <$> getBase32Hex + <*> getVector getBase32Hex getSymbol :: MonadGet m => m Symbol getSymbol = Symbol <$> getVarInt <*> getText diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index ded0648305..7a48d761a7 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -27,16 +27,16 @@ tempEntityType = \case P _ -> PatchType C _ -> CausalType -type TempTermFormat = Term.SyncTermFormat' Text HashJWT +type TempTermFormat = Term.SyncTermFormat' Text Base32Hex -type TempDeclFormat = Decl.SyncDeclFormat' Text HashJWT +type TempDeclFormat = Decl.SyncDeclFormat' Text Base32Hex -type TempPatchFormat = Patch.SyncPatchFormat' HashJWT Text Base32Hex HashJWT +type TempPatchFormat = Patch.SyncPatchFormat' Base32Hex Text Base32Hex Base32Hex -type TempPatchLocalIds = Patch.PatchLocalIds' Text Base32Hex HashJWT +type TempPatchLocalIds = Patch.PatchLocalIds' Text Base32Hex Base32Hex -type TempNamespaceFormat = Namespace.SyncBranchFormat' HashJWT Text HashJWT HashJWT (HashJWT, HashJWT) +type TempNamespaceFormat = Namespace.SyncBranchFormat' Base32Hex Text Base32Hex Base32Hex (Base32Hex, Base32Hex) -type TempNamespaceLocalIds = Namespace.BranchLocalIds' Text HashJWT HashJWT (HashJWT, HashJWT) +type TempNamespaceLocalIds = Namespace.BranchLocalIds' Text Base32Hex Base32Hex (Base32Hex, Base32Hex) -type TempCausalFormat = Causal.SyncCausalFormat' HashJWT HashJWT +type TempCausalFormat = Causal.SyncCausalFormat' Base32Hex Base32Hex diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 1e57ff9fb0..31836e9cfc 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -386,7 +386,7 @@ entityToTempEntity = \case PatchFormat.LocalIds { patchTextLookup = Vector.fromList textLookup, patchHashLookup = Vector.fromList (coerce @[Share.Hash] @[Base32Hex] oldHashLookup), - patchDefnLookup = Vector.fromList (coerce @[Share.HashJWT] @[TempEntity.HashJWT] newHashLookup) + patchDefnLookup = Vector.fromList (map jwt32 newHashLookup) } bytes ) @@ -395,22 +395,26 @@ entityToTempEntity = \case ( NamespaceFormat.SyncFull NamespaceFormat.LocalIds { branchTextLookup = Vector.fromList textLookup, - branchDefnLookup = Vector.fromList (coerce @[Share.HashJWT] @[TempEntity.HashJWT] defnLookup), - branchPatchLookup = Vector.fromList (coerce @[Share.HashJWT] @[TempEntity.HashJWT] patchLookup), - branchChildLookup = Vector.fromList (coerce @[(Share.HashJWT, Share.HashJWT)] @[(TempEntity.HashJWT, TempEntity.HashJWT)] childLookup) + branchDefnLookup = Vector.fromList (map jwt32 defnLookup), + branchPatchLookup = Vector.fromList (map jwt32 patchLookup), + branchChildLookup = Vector.fromList (map (\(x, y) -> (jwt32 x, jwt32 y)) childLookup) } bytes ) Share.C Share.Causal {namespaceHash, parents} -> TempEntity.C Causal.SyncCausalFormat - { valueHash = coerce @Share.HashJWT @TempEntity.HashJWT namespaceHash, - parents = Vector.fromList (coerce @[Share.HashJWT] @[TempEntity.HashJWT] (Set.toList parents)) + { valueHash = jwt32 namespaceHash, + parents = Vector.fromList (map jwt32 (Set.toList parents)) } where - mungeLocalIds :: Share.LocalIds Text Share.HashJWT -> LocalIds' Text TempEntity.HashJWT + mungeLocalIds :: Share.LocalIds Text Share.HashJWT -> LocalIds' Text Base32Hex mungeLocalIds Share.LocalIds {texts, hashes} = LocalIds { textLookup = Vector.fromList texts, - defnLookup = Vector.map Share.unHashJWT (Vector.fromList hashes) + defnLookup = Vector.map jwt32 (Vector.fromList hashes) } + + jwt32 :: Share.HashJWT -> Base32Hex + jwt32 = + Share.toBase32Hex . Share.hashJWTHash From 7315015302b50a281c594eeeb4fe2880a761e2d0 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 25 Apr 2022 16:04:54 -0400 Subject: [PATCH 154/529] unify ReadyEntity and TempEntity --- .../U/Codebase/Sqlite/Entity.hs | 34 +++++++++++++ .../U/Codebase/Sqlite/Queries.hs | 50 +++++++++---------- .../U/Codebase/Sqlite/ReadyEntity.hs | 15 ------ .../U/Codebase/Sqlite/Serialization.hs | 11 ++-- .../U/Codebase/Sqlite/TempEntity.hs | 28 ++++------- .../unison-codebase-sqlite.cabal | 2 +- unison-cli/src/Unison/Share/Sync.hs | 14 +++--- 7 files changed, 83 insertions(+), 71 deletions(-) create mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/Entity.hs delete mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/ReadyEntity.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Entity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Entity.hs new file mode 100644 index 0000000000..d3c5d194d4 --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Entity.hs @@ -0,0 +1,34 @@ +module U.Codebase.Sqlite.Entity where + +import qualified U.Codebase.Sqlite.Branch.Format as Namespace +import qualified U.Codebase.Sqlite.Causal as Causal +import U.Codebase.Sqlite.DbId (BranchHashId, BranchObjectId, CausalHashId, HashId, ObjectId, PatchObjectId, TextId) +import qualified U.Codebase.Sqlite.Decl.Format as Decl +import qualified U.Codebase.Sqlite.Patch.Format as Patch +import U.Codebase.Sqlite.TempEntityType (TempEntityType (..)) +import qualified U.Codebase.Sqlite.Term.Format as Term + +-- | +-- data SyncEntity +-- = TC SyncTermFormat +-- | DC SyncDeclFormat +-- | N SyncBranchFormat +-- | P SyncPatchFormat +-- | C SyncCausalFormat +type SyncEntity = + SyncEntity' TextId HashId ObjectId PatchObjectId BranchHashId BranchObjectId CausalHashId + +data SyncEntity' text hash defn patch branchh branch causal + = TC (Term.SyncTermFormat' text defn) + | DC (Decl.SyncDeclFormat' text defn) + | N (Namespace.SyncBranchFormat' branch text defn patch (branch, causal)) + | P (Patch.SyncPatchFormat' patch text hash defn) + | C (Causal.SyncCausalFormat' causal branchh) + +entityType :: SyncEntity' text hash defn patch branchh branch causal -> TempEntityType +entityType = \case + TC _ -> TermComponentType + DC _ -> DeclComponentType + N _ -> NamespaceType + P _ -> PatchType + C _ -> CausalType diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index f4f290def0..094e6cbdaf 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -126,7 +126,7 @@ module U.Codebase.Sqlite.Queries getMissingDependencyJwtsForTempEntity, tempToSyncEntity, insertTempEntity, - saveReadyEntity, + saveSyncEntity, deleteTempDependencies, -- * db misc @@ -176,12 +176,12 @@ import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat import U.Codebase.Sqlite.ObjectType (ObjectType (DeclComponent, Namespace, Patch, TermComponent)) import qualified U.Codebase.Sqlite.ObjectType as ObjectType import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat -import U.Codebase.Sqlite.ReadyEntity (ReadyEntity) -import qualified U.Codebase.Sqlite.ReadyEntity as ReadyEntity +import U.Codebase.Sqlite.Entity (SyncEntity) +import qualified U.Codebase.Sqlite.Entity as Entity import qualified U.Codebase.Sqlite.Reference as Reference import qualified U.Codebase.Sqlite.Referent as Referent import U.Codebase.Sqlite.Serialization as Serialization -import U.Codebase.Sqlite.TempEntity (HashJWT, TempEntity) +import U.Codebase.Sqlite.TempEntity (TempEntity) import qualified U.Codebase.Sqlite.TempEntity as TempEntity import U.Codebase.Sqlite.TempEntityType (TempEntityType) import qualified U.Codebase.Sqlite.TempEntityType as TempEntityType @@ -607,7 +607,7 @@ moveTempEntityToMain :: Base32Hex -> Transaction () moveTempEntityToMain b32 = do t <- expectTempEntity b32 r <- tempToSyncEntity t - _ <- saveReadyEntity b32 r + _ <- saveSyncEntity b32 r pure () expectTempEntity :: Base32Hex -> Transaction TempEntity @@ -615,28 +615,28 @@ expectTempEntity b32 = do queryOneRowCheck sql (Only b32) \(blob, typeId) -> case typeId of TempEntityType.TermComponentType -> - TempEntity.TC <$> getFromBytesOr "getTempTermFormat" Serialization.getTempTermFormat blob + Entity.TC <$> getFromBytesOr "getTempTermFormat" Serialization.getTempTermFormat blob TempEntityType.DeclComponentType -> - TempEntity.DC <$> getFromBytesOr "getTempDeclFormat" Serialization.getTempDeclFormat blob + Entity.DC <$> getFromBytesOr "getTempDeclFormat" Serialization.getTempDeclFormat blob TempEntityType.NamespaceType -> - TempEntity.N <$> getFromBytesOr "getTempNamespaceFormat" Serialization.getTempNamespaceFormat blob + Entity.N <$> getFromBytesOr "getTempNamespaceFormat" Serialization.getTempNamespaceFormat blob TempEntityType.PatchType -> - TempEntity.P <$> getFromBytesOr "getTempPatchFormat" Serialization.getTempPatchFormat blob + Entity.P <$> getFromBytesOr "getTempPatchFormat" Serialization.getTempPatchFormat blob TempEntityType.CausalType -> - TempEntity.C <$> getFromBytesOr "getTempCausalFormat" Serialization.getTempCausalFormat blob + Entity.C <$> getFromBytesOr "getTempCausalFormat" Serialization.getTempCausalFormat blob where sql = [here| SELECT (blob, type_id) FROM temp_entity WHERE hash = ? |] -tempToSyncEntity :: TempEntity -> Transaction ReadyEntity +tempToSyncEntity :: TempEntity -> Transaction SyncEntity tempToSyncEntity = \case - TempEntity.TC term -> ReadyEntity.TC <$> tempToSyncTermComponent term - TempEntity.DC decl -> ReadyEntity.DC <$> tempToSyncDeclComponent decl - TempEntity.N namespace -> ReadyEntity.N <$> tempToSyncNamespace namespace - TempEntity.P patch -> ReadyEntity.P <$> tempToSyncPatch patch - TempEntity.C causal -> ReadyEntity.C <$> tempToSyncCausal causal + Entity.TC term -> Entity.TC <$> tempToSyncTermComponent term + Entity.DC decl -> Entity.DC <$> tempToSyncDeclComponent decl + Entity.N namespace -> Entity.N <$> tempToSyncNamespace namespace + Entity.P patch -> Entity.P <$> tempToSyncPatch patch + Entity.C causal -> Entity.C <$> tempToSyncCausal causal where tempToSyncCausal :: TempEntity.TempCausalFormat -> Transaction Causal.SyncCausalFormat tempToSyncCausal Causal.SyncCausalFormat {valueHash, parents} = @@ -696,23 +696,23 @@ tempToSyncEntity = \case TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent <$> Lens.traverseOf (traverse . Lens._1) (bitraverse saveText expectObjectIdForHash32) terms -saveReadyEntity :: Base32Hex -> ReadyEntity -> Transaction (Either CausalHashId ObjectId) -saveReadyEntity b32Hex entity = do +saveSyncEntity :: Base32Hex -> SyncEntity -> Transaction (Either CausalHashId ObjectId) +saveSyncEntity b32Hex entity = do hashId <- saveHash b32Hex case entity of - ReadyEntity.TC stf -> do + Entity.TC stf -> do let bytes = runPutS (Serialization.recomposeTermFormat stf) Right <$> saveObject hashId ObjectType.TermComponent bytes - ReadyEntity.DC sdf -> do + Entity.DC sdf -> do let bytes = runPutS (Serialization.recomposeDeclFormat sdf) Right <$> saveObject hashId ObjectType.DeclComponent bytes - ReadyEntity.N sbf -> do + Entity.N sbf -> do let bytes = runPutS (Serialization.recomposeBranchFormat sbf) Right <$> saveObject hashId ObjectType.Namespace bytes - ReadyEntity.P spf -> do + Entity.P spf -> do let bytes = runPutS (Serialization.recomposePatchFormat spf) Right <$> saveObject hashId ObjectType.Patch bytes - ReadyEntity.C scf -> case scf of + Entity.C scf -> case scf of Sqlite.Causal.SyncCausalFormat{valueHash, parents} -> do let causalHashId = CausalHashId hashId saveCausal causalHashId valueHash (Foldable.toList parents) @@ -1210,7 +1210,7 @@ getMissingDependentsForTempEntity h = -- Preconditions: -- 1. The entity does not already exist in "main" storage (`object` / `causal`) -- 2. The entity does not already exist in `temp_entity`. -insertTempEntity :: Base32Hex -> TempEntity -> NESet (Base32Hex, HashJWT) -> Transaction () +insertTempEntity :: Base32Hex -> TempEntity -> NESet (Base32Hex, Text) -> Transaction () insertTempEntity entityHash entity missingDependencies = do execute [here| @@ -1232,7 +1232,7 @@ insertTempEntity entityHash entity missingDependencies = do entityType :: TempEntityType entityType = - TempEntity.tempEntityType entity + Entity.entityType entity -- | Delete a row from the `temp_entity` table, if it exists. deleteTempEntity :: Base32Hex -> Transaction () diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ReadyEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ReadyEntity.hs deleted file mode 100644 index 0c86561e1e..0000000000 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ReadyEntity.hs +++ /dev/null @@ -1,15 +0,0 @@ -module U.Codebase.Sqlite.ReadyEntity where - -import qualified U.Codebase.Sqlite.Branch.Format as Namespace -import qualified U.Codebase.Sqlite.Causal as Causal -import U.Codebase.Sqlite.DbId (BranchHashId, CausalHashId) -import qualified U.Codebase.Sqlite.Decl.Format as Decl -import qualified U.Codebase.Sqlite.Patch.Format as Patch -import qualified U.Codebase.Sqlite.Term.Format as Term - -data ReadyEntity - = TC Term.SyncTermFormat - | DC Decl.SyncDeclFormat - | N Namespace.SyncBranchFormat - | P Patch.SyncPatchFormat - | C (Causal.SyncCausalFormat' CausalHashId BranchHashId) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index 2d05fe0c22..87aa6f04cd 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -40,6 +40,7 @@ import qualified U.Codebase.Sqlite.Patch.TermEdit as TermEdit import qualified U.Codebase.Sqlite.Patch.TypeEdit as TypeEdit import U.Codebase.Sqlite.Symbol (Symbol (..)) import U.Codebase.Sqlite.TempEntity (TempEntity) +import qualified U.Codebase.Sqlite.Entity as Entity import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat import qualified U.Codebase.Term as Term @@ -729,23 +730,23 @@ recomposeBranchFormat = \case putTempEntity :: MonadPut m => TempEntity -> m () putTempEntity = \case - TempEntity.TC tc -> case tc of + Entity.TC tc -> case tc of TermFormat.SyncTerm term -> putWord8 0 *> putSyncTerm term - TempEntity.DC dc -> case dc of + Entity.DC dc -> case dc of DeclFormat.SyncDecl decl -> putWord8 0 *> putSyncDecl decl - TempEntity.P p -> case p of + Entity.P p -> case p of PatchFormat.SyncFull lids bytes -> putWord8 0 *> putSyncFullPatch lids bytes PatchFormat.SyncDiff parent lids bytes -> putWord8 1 *> putSyncDiffPatch parent lids bytes - TempEntity.N n -> case n of + Entity.N n -> case n of BranchFormat.SyncFull lids bytes -> putWord8 0 *> putSyncFullNamespace lids bytes BranchFormat.SyncDiff parent lids bytes -> putWord8 1 *> putSyncDiffNamespace parent lids bytes - TempEntity.C gdc -> + Entity.C gdc -> putSyncCausal gdc where putBase32Hex = putText . Base32Hex.toText diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index 7a48d761a7..f1336d2346 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -4,28 +4,20 @@ import qualified U.Codebase.Sqlite.Branch.Format as Namespace import qualified U.Codebase.Sqlite.Causal as Causal import qualified U.Codebase.Sqlite.Decl.Format as Decl import qualified U.Codebase.Sqlite.Patch.Format as Patch -import U.Codebase.Sqlite.TempEntityType (TempEntityType (..)) import qualified U.Codebase.Sqlite.Term.Format as Term +import qualified U.Codebase.Sqlite.Entity as Entity import U.Util.Base32Hex (Base32Hex) import Unison.Prelude --- should just newtype this somewhere -type HashJWT = Text - -data TempEntity - = TC TempTermFormat - | DC TempDeclFormat - | N TempNamespaceFormat - | P TempPatchFormat - | C TempCausalFormat - -tempEntityType :: TempEntity -> TempEntityType -tempEntityType = \case - TC _ -> TermComponentType - DC _ -> DeclComponentType - N _ -> NamespaceType - P _ -> PatchType - C _ -> CausalType +-- | +-- data TempEntity +-- = TC TempTermFormat +-- | DC TempDeclFormat +-- | N TempNamespaceFormat +-- | P TempPatchFormat +-- | C TempCausalFormat +type TempEntity = + Entity.SyncEntity' Text Base32Hex Base32Hex Base32Hex Base32Hex Base32Hex Base32Hex type TempTermFormat = Term.SyncTermFormat' Text Base32Hex diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index c9ddf3f017..582af018b5 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -25,6 +25,7 @@ library U.Codebase.Sqlite.Causal U.Codebase.Sqlite.DbId U.Codebase.Sqlite.Decl.Format + U.Codebase.Sqlite.Entity U.Codebase.Sqlite.LocalIds U.Codebase.Sqlite.LocalizeObject U.Codebase.Sqlite.ObjectType @@ -35,7 +36,6 @@ library U.Codebase.Sqlite.Patch.TermEdit U.Codebase.Sqlite.Patch.TypeEdit U.Codebase.Sqlite.Queries - U.Codebase.Sqlite.ReadyEntity U.Codebase.Sqlite.Reference U.Codebase.Sqlite.Referent U.Codebase.Sqlite.Serialization diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 31836e9cfc..c20fe26da2 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -26,11 +26,11 @@ import U.Codebase.HashTags (CausalHash (..)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import qualified U.Codebase.Sqlite.Causal as Causal import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat +import qualified U.Codebase.Sqlite.Entity as Entity import U.Codebase.Sqlite.LocalIds (LocalIds' (..)) import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat import qualified U.Codebase.Sqlite.Queries as Q import U.Codebase.Sqlite.TempEntity (TempEntity) -import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Hash as Hash @@ -342,7 +342,7 @@ elaborateHashes hashes outputs = insertEntity :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> Sqlite.Transaction () insertEntity hash entity = do readyEntity <- Q.tempToSyncEntity (entityToTempEntity entity) - _id <- Q.saveReadyEntity (Share.toBase32Hex hash) readyEntity + _id <- Q.saveSyncEntity (Share.toBase32Hex hash) readyEntity pure () -- | Insert an entity and its missing dependencies. @@ -372,16 +372,16 @@ entityToTempEntity = \case & Vector.map (Lens.over Lens._1 mungeLocalIds) & TermFormat.SyncLocallyIndexedComponent & TermFormat.SyncTerm - & TempEntity.TC + & Entity.TC Share.DC (Share.DeclComponent decls) -> decls & Vector.fromList & Vector.map (Lens.over Lens._1 mungeLocalIds) & DeclFormat.SyncLocallyIndexedComponent & DeclFormat.SyncDecl - & TempEntity.DC + & Entity.DC Share.P Share.Patch {textLookup, oldHashLookup, newHashLookup, bytes} -> - TempEntity.P + Entity.P ( PatchFormat.SyncFull PatchFormat.LocalIds { patchTextLookup = Vector.fromList textLookup, @@ -391,7 +391,7 @@ entityToTempEntity = \case bytes ) Share.N Share.Namespace {textLookup, defnLookup, patchLookup, childLookup, bytes} -> - TempEntity.N + Entity.N ( NamespaceFormat.SyncFull NamespaceFormat.LocalIds { branchTextLookup = Vector.fromList textLookup, @@ -402,7 +402,7 @@ entityToTempEntity = \case bytes ) Share.C Share.Causal {namespaceHash, parents} -> - TempEntity.C + Entity.C Causal.SyncCausalFormat { valueHash = jwt32 namespaceHash, parents = Vector.fromList (map jwt32 (Set.toList parents)) From b3be5d06e4fa6c8c4a5b8ccd447d42e2035442b0 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 25 Apr 2022 16:10:04 -0400 Subject: [PATCH 155/529] take a connection rather than a transaction-running function, for incremental pulls --- unison-cli/src/Unison/Share/Sync.hs | 32 ++++++++++++++--------------- 1 file changed, 16 insertions(+), 16 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index c20fe26da2..836c6a5766 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -84,8 +84,8 @@ push :: AuthorizedHttpClient -> -- | The Unison Share URL. BaseUrl -> - -- | SQLite statement-sending function, for reading entities to push. - (forall a. Sqlite.Transaction a -> IO a) -> + -- | SQLite connection, for reading entities to push. + Sqlite.Connection -> -- | The repo+path to push to. Share.RepoPath -> -- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error. @@ -94,7 +94,7 @@ push :: -- | The hash of our local causal to push. CausalHash -> IO (Either PushError ()) -push httpClient unisonShareUrl runDB repoPath expectedHash causalHash = do +push httpClient unisonShareUrl conn repoPath expectedHash causalHash = do -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs -- this causal (UpdatePathMissingDependencies). updatePath >>= \case @@ -102,7 +102,7 @@ push httpClient unisonShareUrl runDB repoPath expectedHash causalHash = do Share.UpdatePathHashMismatch mismatch -> pure (Left (PushErrorHashMismatch mismatch)) Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do -- Upload the causal and all of its dependencies. - upload httpClient unisonShareUrl runDB (Share.RepoPath.repoName repoPath) dependencies >>= \case + upload httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) dependencies >>= \case False -> pure (Left (PushErrorNoWritePermission repoPath)) True -> -- After uploading the causal and all of its dependencies, try setting the remote path again. @@ -149,17 +149,17 @@ push httpClient unisonShareUrl runDB repoPath expectedHash causalHash = do upload :: AuthorizedHttpClient -> BaseUrl -> - (forall a. Sqlite.Transaction a -> IO a) -> + Sqlite.Connection -> Share.RepoName -> NESet Share.Hash -> IO Bool -upload httpClient unisonShareUrl runDB repoName = +upload httpClient unisonShareUrl conn repoName = loop where loop :: NESet Share.Hash -> IO Bool loop (NESet.toAscList -> hashes) = do -- Get each entity that the server is missing out of the database. - entities <- traverse (runDB . resolveHashToEntity) hashes + entities <- Sqlite.runTransaction conn (traverse resolveHashToEntity hashes) let uploadEntities :: IO Share.UploadEntitiesResponse uploadEntities = @@ -191,19 +191,19 @@ pull :: AuthorizedHttpClient -> -- | The Unison Share URL. BaseUrl -> - -- | SQLite statement-sending function, for reading entities to push. - (forall a. Sqlite.Transaction a -> IO a) -> + -- | SQLite connection, for writing entities we pull. + Sqlite.Connection -> -- | The repo+path to pull from. Share.RepoPath -> IO (Either PullError (Maybe CausalHash)) -pull httpClient unisonShareUrl runDB repoPath = do +pull httpClient unisonShareUrl conn repoPath = do getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case Left err -> pure (Left (PullErrorGetCausalHashByPath err)) -- There's nothing at the remote path, so there's no causal to pull. Right Nothing -> pure (Right Nothing) Right (Just hashJwt) -> do let hash = Share.hashJWTHash hashJwt - runDB (entityLocation hash) >>= \case + Sqlite.runTransaction conn (entityLocation hash) >>= \case EntityInMainStorage -> pure () EntityInTempStorage missingDependencies -> doDownload missingDependencies EntityNotStored -> doDownload (NESet.singleton hashJwt) @@ -211,21 +211,21 @@ pull httpClient unisonShareUrl runDB repoPath = do where doDownload :: NESet Share.HashJWT -> IO () doDownload = - download httpClient unisonShareUrl runDB (Share.RepoPath.repoName repoPath) + download httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) -- Download a set of entities from Unison Share. download :: AuthorizedHttpClient -> BaseUrl -> - (forall a. Sqlite.Transaction a -> IO a) -> + Sqlite.Connection -> Share.RepoName -> -- FIXME mitchell: less decoding if this is a DecodedHashJWT NESet Share.HashJWT -> IO () -download httpClient unisonShareUrl runDB repoName = do +download httpClient unisonShareUrl conn repoName = do let loop :: NESet Share.DecodedHashJWT -> IO () loop hashes0 = do - runDB (elaborateHashes (NESet.toSet hashes0) Set.empty) >>= \case + Sqlite.runTransaction conn (elaborateHashes (NESet.toSet hashes0) Set.empty) >>= \case Nothing -> pure () Just hashes1 -> do Share.DownloadEntitiesResponse entities <- @@ -238,7 +238,7 @@ download httpClient unisonShareUrl runDB repoName = do } missingDependencies0 <- - runDB do + Sqlite.runTransaction conn do NEMap.toList entities & foldMapM \(hash, entity) -> do -- still trying to figure out missing dependencies of hash/entity. entityLocation hash >>= \case From e84d4fa1aaf89e86896bec4c5c6b770710fe8b12 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 25 Apr 2022 16:32:23 -0400 Subject: [PATCH 156/529] begin implementing expectEntity --- .../U/Codebase/Sqlite/Queries.hs | 46 ++++++++++++++++++- 1 file changed, 44 insertions(+), 2 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 094e6cbdaf..30e5b5ba76 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -66,6 +66,7 @@ module U.Codebase.Sqlite.Queries -- ** causal table saveCausal, isCausalHash, + expectCausal, loadCausalHashIdByCausalHash, expectCausalValueHashId, loadCausalByCausalHash, @@ -122,6 +123,7 @@ module U.Codebase.Sqlite.Queries garbageCollectWatchesWithoutObjects, -- * sync temp entities + expectEntity, getMissingDependentsForTempEntity, getMissingDependencyJwtsForTempEntity, tempToSyncEntity, @@ -155,6 +157,7 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import Data.String.Here.Uninterpolated (here, hereFile) import Data.Tuple.Only (Only (..)) +import qualified Data.Vector as Vector import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) import U.Codebase.Reference (Reference' (..)) import qualified U.Codebase.Reference as C.Reference @@ -173,11 +176,11 @@ import U.Codebase.Sqlite.DbId TextId, ) import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat +import U.Codebase.Sqlite.Entity (SyncEntity) +import qualified U.Codebase.Sqlite.Entity as Entity import U.Codebase.Sqlite.ObjectType (ObjectType (DeclComponent, Namespace, Patch, TermComponent)) import qualified U.Codebase.Sqlite.ObjectType as ObjectType import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat -import U.Codebase.Sqlite.Entity (SyncEntity) -import qualified U.Codebase.Sqlite.Entity as Entity import qualified U.Codebase.Sqlite.Reference as Reference import qualified U.Codebase.Sqlite.Referent as Referent import U.Codebase.Sqlite.Serialization as Serialization @@ -418,6 +421,12 @@ expectTermObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either expectTermObject oid = expectObjectOfType oid TermComponent +expectObjectWithType :: ObjectId -> Transaction (ObjectType, ByteString) +expectObjectWithType oId = queryOneRow sql (Only oId) + where sql = [here| + SELECT type_id, bytes FROM object WHERE id = ? + |] + expectObjectWithHashIdAndType :: ObjectId -> Transaction (HashId, ObjectType, ByteString) expectObjectWithHashIdAndType oId = queryOneRow sql (Only oId) where sql = [here| @@ -603,6 +612,39 @@ tryMoveTempEntityDependents dependencyBase32 = do ) |] +expectCausal :: CausalHashId -> Transaction Causal.SyncCausalFormat +expectCausal hashId = do + valueHash <- + queryOneCol + [here| + SELECT value_hash_id + FROM causal + WHERE self_hash_id = ? + |] + (Only hashId) + parents <- + fmap Vector.fromList do + -- is the random ordering from the database ok? (seems so, for now) + queryListCol + [here| + SELECT parent_id + FROM causal_parent + WHERE causal_id = ? + |] + (Only hashId) + pure Causal.SyncCausalFormat {parents, valueHash} + +-- | Read an entity out of main storage. +expectEntity :: Base32Hex -> Transaction SyncEntity +expectEntity hash = do + hashId <- expectHashId hash + -- We don't know if this is an object or a causal, so just try one, then the other. + loadObjectIdForPrimaryHashId hashId >>= \case + Nothing -> Entity.C <$> expectCausal (CausalHashId hashId) + Just objectId -> do + (typ, bytes) <- expectObjectWithType objectId + undefined + moveTempEntityToMain :: Base32Hex -> Transaction () moveTempEntityToMain b32 = do t <- expectTempEntity b32 From 3061ea936763f70b33f8b379302873c36b8ae973 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 25 Apr 2022 21:11:58 -0400 Subject: [PATCH 157/529] move sqlite decoders into their own module --- .../U/Codebase/Sqlite/Decode.hs | 129 ++++++++++++++++++ .../U/Codebase/Sqlite/Operations.hs | 35 +---- .../U/Codebase/Sqlite/Queries.hs | 37 +---- .../unison-codebase-sqlite.cabal | 1 + 4 files changed, 139 insertions(+), 63 deletions(-) create mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs new file mode 100644 index 0000000000..227a93e5b1 --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs @@ -0,0 +1,129 @@ +-- | This module contains decoders for blobs stored in SQLite. +module U.Codebase.Sqlite.Decode + ( DecodeError, + + -- * @object.bytes@ + decodeBranchFormat, + decodeComponentLengthOnly, + decodeDeclElement, + decodeDeclFormat, + decodePatchFormat, + decodeTermFormat, + decodeTermElementDiscardingTerm, + decodeTermElementDiscardingType, + decodeTermElementWithType, + + -- * @temp_entity.blob@ + decodeTempCausalFormat, + decodeTempDeclFormat, + decodeTempNamespaceFormat, + decodeTempPatchFormat, + decodeTempTermFormat, + + -- * @watch_result.result@ + decodeWatchResultFormat, + ) +where + +import Data.Bytes.Get (runGetS) +import qualified Data.Bytes.Get as Get +import qualified U.Codebase.Reference as C.Reference +import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat +import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat +import U.Codebase.Sqlite.LocalIds (LocalIds) +import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat +import U.Codebase.Sqlite.Serialization as Serialization +import U.Codebase.Sqlite.Symbol (Symbol) +import qualified U.Codebase.Sqlite.TempEntity as TempEntity +import qualified U.Codebase.Sqlite.Term.Format as TermFormat +import U.Util.Serialization (Get) +import qualified U.Util.Serialization as Serialization (lengthFramedArray) +import Unison.Prelude +import Unison.Sqlite + +------------------------------------------------------------------------------------------------------------------------ +-- Decode error + +data DecodeError = DecodeError + { decoder :: Text, -- the name of the decoder + err :: String -- the error message + } + deriving stock (Show) + deriving anyclass (SqliteExceptionReason) + +getFromBytesOr :: Text -> Get a -> ByteString -> Either DecodeError a +getFromBytesOr decoder get bs = case runGetS get bs of + Left err -> Left (DecodeError decoder err) + Right a -> Right a + +------------------------------------------------------------------------------------------------------------------------ +-- object.bytes + +decodeBranchFormat :: ByteString -> Either DecodeError NamespaceFormat.BranchFormat +decodeBranchFormat = + getFromBytesOr "getBranchFormat" Serialization.getBranchFormat + +decodeComponentLengthOnly :: ByteString -> Either DecodeError Word64 +decodeComponentLengthOnly = + getFromBytesOr "lengthFramedArray" (Get.skip 1 >> Serialization.lengthFramedArray) + +decodeDeclElement :: Word64 -> ByteString -> Either DecodeError (LocalIds, DeclFormat.Decl Symbol) +decodeDeclElement i = + getFromBytesOr ("lookupDeclElement " <> tShow i) (Serialization.lookupDeclElement i) + +decodeDeclFormat :: ByteString -> Either DecodeError DeclFormat.DeclFormat +decodeDeclFormat = + getFromBytesOr "getDeclFormat" Serialization.getDeclFormat + +decodePatchFormat :: ByteString -> Either DecodeError PatchFormat.PatchFormat +decodePatchFormat = + getFromBytesOr "getPatchFormat" Serialization.getPatchFormat + +decodeTermFormat :: ByteString -> Either DecodeError TermFormat.TermFormat +decodeTermFormat = + getFromBytesOr "getTermFormat" Serialization.getTermFormat + +decodeTermElementDiscardingTerm :: C.Reference.Pos -> ByteString -> Either DecodeError (LocalIds, TermFormat.Type) +decodeTermElementDiscardingTerm i = + getFromBytesOr ("lookupTermElementDiscardingTerm " <> tShow i) (Serialization.lookupTermElementDiscardingTerm i) + +decodeTermElementDiscardingType :: C.Reference.Pos -> ByteString -> Either DecodeError (LocalIds, TermFormat.Term) +decodeTermElementDiscardingType i = + getFromBytesOr ("lookupTermElementDiscardingType " <> tShow i) (Serialization.lookupTermElementDiscardingType i) + +decodeTermElementWithType :: + C.Reference.Pos -> + ByteString -> + Either DecodeError (LocalIds, TermFormat.Term, TermFormat.Type) +decodeTermElementWithType i = + getFromBytesOr ("lookupTermElement" <> tShow i) (Serialization.lookupTermElement i) + +------------------------------------------------------------------------------------------------------------------------ +-- temp_entity.blob + +decodeTempCausalFormat :: ByteString -> Either DecodeError TempEntity.TempCausalFormat +decodeTempCausalFormat = + getFromBytesOr "getTempCausalFormat" Serialization.getTempCausalFormat + +decodeTempDeclFormat :: ByteString -> Either DecodeError TempEntity.TempDeclFormat +decodeTempDeclFormat = + getFromBytesOr "getTempDeclFormat" Serialization.getTempDeclFormat + +decodeTempNamespaceFormat :: ByteString -> Either DecodeError TempEntity.TempNamespaceFormat +decodeTempNamespaceFormat = + getFromBytesOr "getTempNamespaceFormat" Serialization.getTempNamespaceFormat + +decodeTempPatchFormat :: ByteString -> Either DecodeError TempEntity.TempPatchFormat +decodeTempPatchFormat = + getFromBytesOr "getTempPatchFormat" Serialization.getTempPatchFormat + +decodeTempTermFormat :: ByteString -> Either DecodeError TempEntity.TempTermFormat +decodeTempTermFormat = + getFromBytesOr "getTempTermFormat" Serialization.getTempTermFormat + +------------------------------------------------------------------------------------------------------------------------ +-- watch_result.result + +decodeWatchResultFormat :: ByteString -> Either DecodeError TermFormat.WatchResultFormat +decodeWatchResultFormat = + getFromBytesOr "getWatchResultFormat" Serialization.getWatchResultFormat diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index f04dda9515..0f30ab4075 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -86,7 +86,6 @@ import Control.Monad.Writer (MonadWriter, runWriterT) import qualified Control.Monad.Writer as Writer import Data.Bifunctor (Bifunctor (bimap)) import Data.Bitraversable (Bitraversable (bitraverse)) -import qualified Data.Bytes.Get as Get import qualified Data.Foldable as Foldable import Data.Functor.Identity (Identity) import qualified Data.Map as Map @@ -118,6 +117,7 @@ import qualified U.Codebase.Sqlite.Branch.Full as S.Branch.Full import qualified U.Codebase.Sqlite.Branch.Full as S.MetadataSet import qualified U.Codebase.Sqlite.DbId as Db import qualified U.Codebase.Sqlite.Decl.Format as S.Decl +import U.Codebase.Sqlite.Decode import U.Codebase.Sqlite.LocalIds ( LocalDefnId (..), LocalIds, @@ -305,37 +305,6 @@ diffPatch (S.Patch fullTerms fullTypes) (S.Patch refTerms refTypes) = addDiffSet = Map.zipWithMatched (const Set.difference) removeDiffSet = Map.zipWithMatched (const (flip Set.difference)) --- * Deserialization helpers - -decodeBranchFormat :: ByteString -> Either Q.DecodeError S.BranchFormat.BranchFormat -decodeBranchFormat = Q.getFromBytesOr "getBranchFormat" S.getBranchFormat - -decodePatchFormat :: ByteString -> Either Q.DecodeError S.Patch.Format.PatchFormat -decodePatchFormat = Q.getFromBytesOr "getPatchFormat" S.getPatchFormat - -decodeTermFormat :: ByteString -> Either Q.DecodeError S.Term.TermFormat -decodeTermFormat = Q.getFromBytesOr "getTermFormat" S.getTermFormat - -decodeComponentLengthOnly :: ByteString -> Either Q.DecodeError Word64 -decodeComponentLengthOnly = Q.getFromBytesOr "lengthFramedArray" (Get.skip 1 >> S.lengthFramedArray) - -decodeTermElementWithType :: C.Reference.Pos -> ByteString -> Either Q.DecodeError (LocalIds, S.Term.Term, S.Term.Type) -decodeTermElementWithType i = Q.getFromBytesOr ("lookupTermElement" <> tShow i) (S.lookupTermElement i) - -decodeTermElementDiscardingTerm :: C.Reference.Pos -> ByteString -> Either Q.DecodeError (LocalIds, S.Term.Type) -decodeTermElementDiscardingTerm i = - Q.getFromBytesOr ("lookupTermElementDiscardingTerm " <> tShow i) (S.lookupTermElementDiscardingTerm i) - -decodeTermElementDiscardingType :: C.Reference.Pos -> ByteString -> Either Q.DecodeError (LocalIds, S.Term.Term) -decodeTermElementDiscardingType i = - Q.getFromBytesOr ("lookupTermElementDiscardingType " <> tShow i) (S.lookupTermElementDiscardingType i) - -decodeDeclFormat :: ByteString -> Either Q.DecodeError S.Decl.DeclFormat -decodeDeclFormat = Q.getFromBytesOr "getDeclFormat" S.getDeclFormat - -decodeDeclElement :: Word64 -> ByteString -> Either Q.DecodeError (LocalIds, S.Decl.Decl Symbol) -decodeDeclElement i = Q.getFromBytesOr ("lookupDeclElement " <> tShow i) (S.lookupDeclElement i) - getCycleLen :: H.Hash -> Transaction (Maybe Word64) getCycleLen h = do when debug $ traceM $ "\ngetCycleLen " ++ (Text.unpack . Base32Hex.toText $ H.toBase32Hex h) @@ -641,7 +610,7 @@ listWatches k = Q.loadWatchesByWatchKind k >>= traverse h2cReferenceId loadWatch :: WatchKind -> C.Reference.Id -> MaybeT Transaction (C.Term Symbol) loadWatch k r = do r' <- C.Reference.idH (lift . Q.saveHashHash) r - S.Term.WatchResult wlids t <- MaybeT (Q.loadWatch k r' (Q.getFromBytesOr "getWatchResultFormat" S.getWatchResultFormat)) + S.Term.WatchResult wlids t <- MaybeT (Q.loadWatch k r' decodeWatchResultFormat) lift (w2cTerm wlids t) saveWatch :: WatchKind -> C.Reference.Id -> C.Term Symbol -> Transaction () diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 30e5b5ba76..569dd6bd2a 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -137,16 +137,11 @@ module U.Codebase.Sqlite.Queries schemaVersion, expectSchemaVersion, setSchemaVersion, - - -- * errors - DecodeError, - getFromBytesOr, ) where import qualified Control.Lens as Lens import Data.Bitraversable (bitraverse) -import Data.Bytes.Get (runGetS) import Data.Bytes.Put (runPutS) import qualified Data.Foldable as Foldable import qualified Data.List.Extra as List @@ -176,6 +171,7 @@ import U.Codebase.Sqlite.DbId TextId, ) import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat +import U.Codebase.Sqlite.Decode import U.Codebase.Sqlite.Entity (SyncEntity) import qualified U.Codebase.Sqlite.Entity as Entity import U.Codebase.Sqlite.ObjectType (ObjectType (DeclComponent, Namespace, Patch, TermComponent)) @@ -195,7 +191,6 @@ import qualified U.Util.Alternative as Alternative import U.Util.Base32Hex (Base32Hex (..)) import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash -import U.Util.Serialization (Get) import Unison.Prelude import Unison.Sqlite @@ -652,20 +647,16 @@ moveTempEntityToMain b32 = do _ <- saveSyncEntity b32 r pure () +-- | Read an entity out of temp storage. expectTempEntity :: Base32Hex -> Transaction TempEntity expectTempEntity b32 = do queryOneRowCheck sql (Only b32) \(blob, typeId) -> case typeId of - TempEntityType.TermComponentType -> - Entity.TC <$> getFromBytesOr "getTempTermFormat" Serialization.getTempTermFormat blob - TempEntityType.DeclComponentType -> - Entity.DC <$> getFromBytesOr "getTempDeclFormat" Serialization.getTempDeclFormat blob - TempEntityType.NamespaceType -> - Entity.N <$> getFromBytesOr "getTempNamespaceFormat" Serialization.getTempNamespaceFormat blob - TempEntityType.PatchType -> - Entity.P <$> getFromBytesOr "getTempPatchFormat" Serialization.getTempPatchFormat blob - TempEntityType.CausalType -> - Entity.C <$> getFromBytesOr "getTempCausalFormat" Serialization.getTempCausalFormat blob + TempEntityType.TermComponentType -> Entity.TC <$> decodeTempTermFormat blob + TempEntityType.DeclComponentType -> Entity.DC <$> decodeTempDeclFormat blob + TempEntityType.NamespaceType -> Entity.N <$> decodeTempNamespaceFormat blob + TempEntityType.PatchType -> Entity.P <$> decodeTempPatchFormat blob + TempEntityType.CausalType -> Entity.C <$> decodeTempCausalFormat blob where sql = [here| SELECT (blob, type_id) FROM temp_entity @@ -1299,20 +1290,6 @@ deleteTempDependencies dependent (Foldable.toList -> dependencies) = AND dependency = ? |] --- * errors - -data DecodeError = DecodeError - { decoder :: Text, -- the name of the decoder - err :: String -- the error message - } - deriving stock (Show) - deriving anyclass (SqliteExceptionReason) - -getFromBytesOr :: Text -> Get a -> ByteString -> Either DecodeError a -getFromBytesOr decoder get bs = case runGetS get bs of - Left err -> Left (DecodeError decoder err) - Right a -> Right a - -- * orphan instances deriving via Text instance ToField Base32Hex diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 582af018b5..fdd763a5ac 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -25,6 +25,7 @@ library U.Codebase.Sqlite.Causal U.Codebase.Sqlite.DbId U.Codebase.Sqlite.Decl.Format + U.Codebase.Sqlite.Decode U.Codebase.Sqlite.Entity U.Codebase.Sqlite.LocalIds U.Codebase.Sqlite.LocalizeObject From d6c8ebca038b820c6b65b99d062f746c342a2ec3 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 25 Apr 2022 21:22:02 -0400 Subject: [PATCH 158/529] finish expectEntity --- .../U/Codebase/Sqlite/Decode.hs | 22 ++++++++++++++++++- .../U/Codebase/Sqlite/Queries.hs | 14 +++++++----- 2 files changed, 30 insertions(+), 6 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs index 227a93e5b1..cad34d552f 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs @@ -8,10 +8,14 @@ module U.Codebase.Sqlite.Decode decodeDeclElement, decodeDeclFormat, decodePatchFormat, - decodeTermFormat, + decodeSyncDeclFormat, + decodeSyncNamespaceFormat, + decodeSyncPatchFormat, + decodeSyncTermFormat, decodeTermElementDiscardingTerm, decodeTermElementDiscardingType, decodeTermElementWithType, + decodeTermFormat, -- * @temp_entity.blob@ decodeTempCausalFormat, @@ -79,6 +83,22 @@ decodePatchFormat :: ByteString -> Either DecodeError PatchFormat.PatchFormat decodePatchFormat = getFromBytesOr "getPatchFormat" Serialization.getPatchFormat +decodeSyncDeclFormat :: ByteString -> Either DecodeError DeclFormat.SyncDeclFormat +decodeSyncDeclFormat = + getFromBytesOr "decomposeDeclFormat" Serialization.decomposeDeclFormat + +decodeSyncNamespaceFormat :: ByteString -> Either DecodeError NamespaceFormat.SyncBranchFormat +decodeSyncNamespaceFormat = + getFromBytesOr "decomposeNamespaceFormat" Serialization.decomposeBranchFormat + +decodeSyncPatchFormat :: ByteString -> Either DecodeError PatchFormat.SyncPatchFormat +decodeSyncPatchFormat = + getFromBytesOr "decomposePatchFormat" Serialization.decomposePatchFormat + +decodeSyncTermFormat :: ByteString -> Either DecodeError TermFormat.SyncTermFormat +decodeSyncTermFormat = + getFromBytesOr "decomposeTermFormat" Serialization.decomposeTermFormat + decodeTermFormat :: ByteString -> Either DecodeError TermFormat.TermFormat decodeTermFormat = getFromBytesOr "getTermFormat" Serialization.getTermFormat diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 569dd6bd2a..33d3c4494e 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -416,8 +416,8 @@ expectTermObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either expectTermObject oid = expectObjectOfType oid TermComponent -expectObjectWithType :: ObjectId -> Transaction (ObjectType, ByteString) -expectObjectWithType oId = queryOneRow sql (Only oId) +expectObjectWithType :: SqliteExceptionReason e => ObjectId -> (ObjectType -> ByteString -> Either e a) -> Transaction a +expectObjectWithType oId check = queryOneRowCheck sql (Only oId) (\(typ, bytes) -> check typ bytes) where sql = [here| SELECT type_id, bytes FROM object WHERE id = ? |] @@ -636,9 +636,13 @@ expectEntity hash = do -- We don't know if this is an object or a causal, so just try one, then the other. loadObjectIdForPrimaryHashId hashId >>= \case Nothing -> Entity.C <$> expectCausal (CausalHashId hashId) - Just objectId -> do - (typ, bytes) <- expectObjectWithType objectId - undefined + Just objectId -> + expectObjectWithType objectId \typ bytes -> + case typ of + TermComponent -> Entity.TC <$> decodeSyncTermFormat bytes + DeclComponent -> Entity.DC <$> decodeSyncDeclFormat bytes + Namespace -> Entity.N <$> decodeSyncNamespaceFormat bytes + Patch -> Entity.P <$> decodeSyncPatchFormat bytes moveTempEntityToMain :: Base32Hex -> Transaction () moveTempEntityToMain b32 = do From cd122e526e059fe096ac3accdddfebd060817b71 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 25 Apr 2022 21:57:13 -0400 Subject: [PATCH 159/529] implement most of expectEntity in Share.Sync, except for handling local diff formats --- .../U/Codebase/Sqlite/Queries.hs | 67 +++++++++++++++ unison-cli/src/Unison/Share/Sync.hs | 81 +++++++++++++++++-- 2 files changed, 141 insertions(+), 7 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 33d3c4494e..963c7b0272 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -127,6 +127,7 @@ module U.Codebase.Sqlite.Queries getMissingDependentsForTempEntity, getMissingDependencyJwtsForTempEntity, tempToSyncEntity, + syncToTempEntity, insertTempEntity, saveSyncEntity, deleteTempDependencies, @@ -733,6 +734,72 @@ tempToSyncEntity = \case TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent <$> Lens.traverseOf (traverse . Lens._1) (bitraverse saveText expectObjectIdForHash32) terms +syncToTempEntity :: SyncEntity -> Transaction TempEntity +syncToTempEntity = \case + Entity.TC term -> Entity.TC <$> syncToTempTermComponent term + Entity.DC decl -> Entity.DC <$> syncToTempDeclComponent decl + Entity.N namespace -> Entity.N <$> syncToTempNamespace namespace + Entity.P patch -> Entity.P <$> syncToTempPatch patch + Entity.C causal -> Entity.C <$> syncToTempCausal causal + where + syncToTempCausal :: Causal.SyncCausalFormat -> Transaction TempEntity.TempCausalFormat + syncToTempCausal Causal.SyncCausalFormat {valueHash, parents} = + Causal.SyncCausalFormat + <$> expectHash32 (unBranchHashId valueHash) + <*> traverse (expectHash32 . unCausalHashId) parents + + syncToTempDeclComponent :: DeclFormat.SyncDeclFormat -> Transaction TempEntity.TempDeclFormat + syncToTempDeclComponent = \case + DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent decls) -> + DeclFormat.SyncDecl . DeclFormat.SyncLocallyIndexedComponent + <$> Lens.traverseOf (traverse . Lens._1) (bitraverse expectText expectPrimaryHash32ByObjectId) decls + + syncToTempNamespace :: NamespaceFormat.SyncBranchFormat -> Transaction TempEntity.TempNamespaceFormat + syncToTempNamespace = \case + NamespaceFormat.SyncFull localIds bytes -> + NamespaceFormat.SyncFull <$> syncToTempNamespaceLocalIds localIds <*> pure bytes + NamespaceFormat.SyncDiff parent localIds bytes -> + NamespaceFormat.SyncDiff + <$> expectPrimaryHash32ByObjectId (unBranchObjectId parent) + <*> syncToTempNamespaceLocalIds localIds + <*> pure bytes + + syncToTempNamespaceLocalIds :: NamespaceFormat.BranchLocalIds -> Transaction TempEntity.TempNamespaceLocalIds + syncToTempNamespaceLocalIds (NamespaceFormat.LocalIds texts defns patches children) = + NamespaceFormat.LocalIds + <$> traverse expectText texts + <*> traverse expectPrimaryHash32ByObjectId defns + <*> traverse (expectPrimaryHash32ByObjectId . unPatchObjectId) patches + <*> traverse + ( \(branch, causal) -> + (,) + <$> expectPrimaryHash32ByObjectId (unBranchObjectId branch) + <*> expectHash32 (unCausalHashId causal) + ) + children + + syncToTempPatch :: PatchFormat.SyncPatchFormat -> Transaction TempEntity.TempPatchFormat + syncToTempPatch = \case + PatchFormat.SyncFull localIds bytes -> PatchFormat.SyncFull <$> syncToTempPatchLocalIds localIds <*> pure bytes + PatchFormat.SyncDiff parent localIds bytes -> + PatchFormat.SyncDiff + <$> expectPrimaryHash32ByObjectId (unPatchObjectId parent) + <*> syncToTempPatchLocalIds localIds + <*> pure bytes + + syncToTempPatchLocalIds :: PatchFormat.PatchLocalIds -> Transaction TempEntity.TempPatchLocalIds + syncToTempPatchLocalIds (PatchFormat.LocalIds texts hashes defns) = + PatchFormat.LocalIds + <$> traverse expectText texts + <*> traverse expectHash32 hashes + <*> traverse expectPrimaryHash32ByObjectId defns + + syncToTempTermComponent :: TermFormat.SyncTermFormat -> Transaction TempEntity.TempTermFormat + syncToTempTermComponent = \case + TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent terms) -> + TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent + <$> Lens.traverseOf (traverse . Lens._1) (bitraverse expectText expectPrimaryHash32ByObjectId) terms + saveSyncEntity :: Base32Hex -> SyncEntity -> Transaction (Either CausalHashId ObjectId) saveSyncEntity b32Hex entity = do hashId <- saveHash b32Hex diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 836c6a5766..5bf1ad465b 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -20,6 +20,7 @@ import qualified Data.Map.NonEmpty as NEMap import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet +import Data.Vector (Vector) import qualified Data.Vector as Vector import Servant.Client (BaseUrl) import U.Codebase.HashTags (CausalHash (..)) @@ -159,7 +160,7 @@ upload httpClient unisonShareUrl conn repoName = loop :: NESet Share.Hash -> IO Bool loop (NESet.toAscList -> hashes) = do -- Get each entity that the server is missing out of the database. - entities <- Sqlite.runTransaction conn (traverse resolveHashToEntity hashes) + entities <- Sqlite.runTransaction conn (traverse expectEntity hashes) let uploadEntities :: IO Share.UploadEntitiesResponse uploadEntities = @@ -291,10 +292,6 @@ server sqlite db -} --- FIXME rename, etc -resolveHashToEntity :: Share.Hash -> Sqlite.Transaction (Share.Entity Text Share.Hash Share.Hash) -resolveHashToEntity = undefined - ------------------------------------------------------------------------------------------------------------------------ -- Database operations @@ -338,11 +335,18 @@ elaborateHashes hashes outputs = elaborateHashes (Set.union (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) hashes') outputs EntityInMainStorage -> elaborateHashes hashes' outputs +-- FIXME comment +expectEntity :: Share.Hash -> Sqlite.Transaction (Share.Entity Text Share.Hash Share.Hash) +expectEntity hash = do + syncEntity <- Q.expectEntity (Share.toBase32Hex hash) + tempEntity <- Q.syncToTempEntity syncEntity + pure (tempEntityToEntity tempEntity) + -- | Insert an entity that doesn't have any missing dependencies. insertEntity :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> Sqlite.Transaction () insertEntity hash entity = do - readyEntity <- Q.tempToSyncEntity (entityToTempEntity entity) - _id <- Q.saveSyncEntity (Share.toBase32Hex hash) readyEntity + syncEntity <- Q.tempToSyncEntity (entityToTempEntity entity) + _id <- Q.saveSyncEntity (Share.toBase32Hex hash) syncEntity pure () -- | Insert an entity and its missing dependencies. @@ -362,6 +366,9 @@ insertTempEntity hash entity missingDependencies = missingDependencies ) +------------------------------------------------------------------------------------------------------------------------ +-- Entity conversions + -- | Convert an entity that came over the wire from Unison Share into an equivalent type that we can store in the -- `temp_entity` table. entityToTempEntity :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity @@ -418,3 +425,63 @@ entityToTempEntity = \case jwt32 :: Share.HashJWT -> Base32Hex jwt32 = Share.toBase32Hex . Share.hashJWTHash + +tempEntityToEntity :: TempEntity -> Share.Entity Text Share.Hash Share.Hash +tempEntityToEntity = \case + Entity.TC (TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent terms)) -> + terms + & Vector.map (Lens.over Lens._1 mungeLocalIds) + & Vector.toList + & Share.TermComponent + & Share.TC + Entity.DC (DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent decls)) -> + decls + & Vector.map (Lens.over Lens._1 mungeLocalIds) + & Vector.toList + & Share.DeclComponent + & Share.DC + Entity.P format -> + case format of + PatchFormat.SyncFull PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} bytes -> + Share.P + Share.Patch + { textLookup = Vector.toList patchTextLookup, + oldHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchHashLookup), + newHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchDefnLookup), + bytes + } + PatchFormat.SyncDiff _ _ _ -> undefined + Entity.N format -> + case format of + NamespaceFormat.SyncFull + NamespaceFormat.LocalIds + { branchTextLookup, + branchDefnLookup, + branchPatchLookup, + branchChildLookup + } + bytes -> + Share.N + Share.Namespace + { textLookup = Vector.toList branchTextLookup, + defnLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchDefnLookup), + patchLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchPatchLookup), + childLookup = + Vector.toList + (coerce @(Vector (Base32Hex, Base32Hex)) @(Vector (Share.Hash, Share.Hash)) branchChildLookup), + bytes + } + NamespaceFormat.SyncDiff _ _ _ -> undefined + Entity.C Causal.SyncCausalFormat {valueHash, parents} -> + Share.C + Share.Causal + { namespaceHash = Share.Hash valueHash, + parents = Set.fromList (coerce @[Base32Hex] @[Share.Hash] (Vector.toList parents)) + } + where + mungeLocalIds :: LocalIds' Text Base32Hex -> Share.LocalIds Text Share.Hash + mungeLocalIds LocalIds {textLookup, defnLookup} = + Share.LocalIds + { texts = Vector.toList textLookup, + hashes = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) defnLookup) + } From 6ebfaa919d826f22844cfb2588c46f88cb6d54cd Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 26 Apr 2022 10:44:29 -0400 Subject: [PATCH 160/529] add patch diff to share api types --- .../U/Codebase/Sqlite/TempEntity.hs | 5 ++- unison-cli/src/Unison/Share/Sync.hs | 23 ++++++----- unison-share-api/src/Unison/Sync/Types.hs | 39 +++++++++++++++++++ 3 files changed, 56 insertions(+), 11 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index f1336d2346..aff0e5df8e 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -3,9 +3,10 @@ module U.Codebase.Sqlite.TempEntity where import qualified U.Codebase.Sqlite.Branch.Format as Namespace import qualified U.Codebase.Sqlite.Causal as Causal import qualified U.Codebase.Sqlite.Decl.Format as Decl +import qualified U.Codebase.Sqlite.Entity as Entity +import U.Codebase.Sqlite.LocalIds (LocalIds') import qualified U.Codebase.Sqlite.Patch.Format as Patch import qualified U.Codebase.Sqlite.Term.Format as Term -import qualified U.Codebase.Sqlite.Entity as Entity import U.Util.Base32Hex (Base32Hex) import Unison.Prelude @@ -19,6 +20,8 @@ import Unison.Prelude type TempEntity = Entity.SyncEntity' Text Base32Hex Base32Hex Base32Hex Base32Hex Base32Hex Base32Hex +type TempLocalIds = LocalIds' Text Base32Hex + type TempTermFormat = Term.SyncTermFormat' Text Base32Hex type TempDeclFormat = Decl.SyncDeclFormat' Text Base32Hex diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 5bf1ad465b..bce929dbdf 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -32,6 +32,7 @@ import U.Codebase.Sqlite.LocalIds (LocalIds' (..)) import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat import qualified U.Codebase.Sqlite.Queries as Q import U.Codebase.Sqlite.TempEntity (TempEntity) +import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Hash as Hash @@ -388,15 +389,9 @@ entityToTempEntity = \case & DeclFormat.SyncDecl & Entity.DC Share.P Share.Patch {textLookup, oldHashLookup, newHashLookup, bytes} -> - Entity.P - ( PatchFormat.SyncFull - PatchFormat.LocalIds - { patchTextLookup = Vector.fromList textLookup, - patchHashLookup = Vector.fromList (coerce @[Share.Hash] @[Base32Hex] oldHashLookup), - patchDefnLookup = Vector.fromList (map jwt32 newHashLookup) - } - bytes - ) + Entity.P (PatchFormat.SyncFull (mungePatchLocalIds textLookup oldHashLookup newHashLookup) bytes) + Share.PD Share.PatchDiff {parent, textLookup, oldHashLookup, newHashLookup, bytes} -> + Entity.P (PatchFormat.SyncDiff (jwt32 parent) (mungePatchLocalIds textLookup oldHashLookup newHashLookup) bytes) Share.N Share.Namespace {textLookup, defnLookup, patchLookup, childLookup, bytes} -> Entity.N ( NamespaceFormat.SyncFull @@ -415,13 +410,21 @@ entityToTempEntity = \case parents = Vector.fromList (map jwt32 (Set.toList parents)) } where - mungeLocalIds :: Share.LocalIds Text Share.HashJWT -> LocalIds' Text Base32Hex + mungeLocalIds :: Share.LocalIds Text Share.HashJWT -> TempEntity.TempLocalIds mungeLocalIds Share.LocalIds {texts, hashes} = LocalIds { textLookup = Vector.fromList texts, defnLookup = Vector.map jwt32 (Vector.fromList hashes) } + mungePatchLocalIds :: [Text] -> [Share.Hash] -> [Share.HashJWT] -> TempEntity.TempPatchLocalIds + mungePatchLocalIds textLookup oldHashLookup newHashLookup = + PatchFormat.LocalIds + { patchTextLookup = Vector.fromList textLookup, + patchHashLookup = Vector.fromList (coerce @[Share.Hash] @[Base32Hex] oldHashLookup), + patchDefnLookup = Vector.fromList (map jwt32 newHashLookup) + } + jwt32 :: Share.HashJWT -> Base32Hex jwt32 = Share.toBase32Hex . Share.hashJWTHash diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index f2d7194ca7..c471cdaf92 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -319,6 +319,7 @@ data Entity text noSyncHash hash = TC (TermComponent text hash) | DC (DeclComponent text hash) | P (Patch text noSyncHash hash) + | PD (PatchDiff text noSyncHash hash) | N (Namespace text hash) | C (Causal hash) deriving stock (Show, Eq, Ord) @@ -340,6 +341,11 @@ instance (ToJSON text, ToJSON noSyncHash, ToJSON hash) => ToJSON (Entity text no [ "type" .= PatchType, "object" .= patch ] + PD patch -> + object + [ "type" .= PatchDiffType, + "object" .= patch + ] N ns -> object [ "type" .= NamespaceType, @@ -358,6 +364,7 @@ instance (FromJSON text, FromJSON noSyncHash, FromJSON hash, Ord hash) => FromJS TermComponentType -> TC <$> obj .: "object" DeclComponentType -> DC <$> obj .: "object" PatchType -> P <$> obj .: "object" + PatchDiffType -> PD <$> obj .: "object" NamespaceType -> N <$> obj .: "object" CausalType -> C <$> obj .: "object" @@ -369,6 +376,7 @@ entityDependencies = \case TC (TermComponent terms) -> flip foldMap terms \(LocalIds {hashes}, _term) -> Set.fromList hashes DC (DeclComponent decls) -> flip foldMap decls \(LocalIds {hashes}, _decl) -> Set.fromList hashes P Patch {newHashLookup} -> Set.fromList newHashLookup + PD PatchDiff {parent, newHashLookup} -> Set.insert parent (Set.fromList newHashLookup) N Namespace {defnLookup, patchLookup, childLookup} -> Set.fromList defnLookup <> Set.fromList patchLookup <> foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup @@ -505,6 +513,34 @@ instance (FromJSON text, FromJSON oldHash, FromJSON newHash) => FromJSON (Patch Base64Bytes bytes <- obj .: "bytes" pure Patch {..} +data PatchDiff text oldHash hash = PatchDiff + { parent :: hash, + textLookup :: [text], + oldHashLookup :: [oldHash], + newHashLookup :: [hash], + bytes :: ByteString + } + deriving stock (Eq, Ord, Show) + +instance (ToJSON text, ToJSON oldHash, ToJSON hash) => ToJSON (PatchDiff text oldHash hash) where + toJSON (PatchDiff parent textLookup oldHashLookup newHashLookup bytes) = + object + [ "parent" .= parent, + "text_lookup" .= textLookup, + "optional_hash_lookup" .= oldHashLookup, + "hash_lookup" .= newHashLookup, + "bytes" .= Base64Bytes bytes + ] + +instance (FromJSON text, FromJSON oldHash, FromJSON hash) => FromJSON (PatchDiff text oldHash hash) where + parseJSON = Aeson.withObject "PatchDiff" \obj -> do + parent <- obj .: "parent" + textLookup <- obj .: "text_lookup" + oldHashLookup <- obj .: "optional_hash_lookup" + newHashLookup <- obj .: "hash_lookup" + Base64Bytes bytes <- obj .: "bytes" + pure PatchDiff {..} + data Namespace text hash = Namespace { textLookup :: [text], defnLookup :: [hash], @@ -573,6 +609,7 @@ data EntityType = TermComponentType | DeclComponentType | PatchType + | PatchDiffType | NamespaceType | CausalType deriving stock (Eq, Ord, Show) @@ -582,6 +619,7 @@ instance ToJSON EntityType where TermComponentType -> "term_component" DeclComponentType -> "decl_component" PatchType -> "patch" + PatchDiffType -> "patch_diff" NamespaceType -> "namespace" CausalType -> "causal" @@ -590,6 +628,7 @@ instance FromJSON EntityType where "term_component" -> pure TermComponentType "decl_component" -> pure DeclComponentType "patch" -> pure PatchType + "patch_diff" -> pure PatchDiffType "namespace" -> pure NamespaceType "causal" -> pure CausalType t -> failText $ "Unexpected entity type: " <> t From abdda222ac2ebe740518fa11c7486565deb6aa92 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 26 Apr 2022 10:46:04 -0400 Subject: [PATCH 161/529] tempEntityToEntity PatchDiff case --- unison-cli/src/Unison/Share/Sync.hs | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index bce929dbdf..70b80bc711 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -453,7 +453,15 @@ tempEntityToEntity = \case newHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchDefnLookup), bytes } - PatchFormat.SyncDiff _ _ _ -> undefined + PatchFormat.SyncDiff parent PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} bytes -> + Share.PD + Share.PatchDiff + { parent = Share.Hash parent, + textLookup = Vector.toList patchTextLookup, + oldHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchHashLookup), + newHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchDefnLookup), + bytes + } Entity.N format -> case format of NamespaceFormat.SyncFull From 78774590fae056135ae83fbeb8f574b549d1619c Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 26 Apr 2022 10:58:03 -0400 Subject: [PATCH 162/529] add namespace diff to share api types --- unison-cli/src/Unison/Share/Sync.hs | 47 +++++++++++++++---- unison-share-api/src/Unison/Sync/Types.hs | 55 ++++++++++++++++++++++- 2 files changed, 92 insertions(+), 10 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 70b80bc711..38e68862f4 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -393,14 +393,12 @@ entityToTempEntity = \case Share.PD Share.PatchDiff {parent, textLookup, oldHashLookup, newHashLookup, bytes} -> Entity.P (PatchFormat.SyncDiff (jwt32 parent) (mungePatchLocalIds textLookup oldHashLookup newHashLookup) bytes) Share.N Share.Namespace {textLookup, defnLookup, patchLookup, childLookup, bytes} -> + Entity.N (NamespaceFormat.SyncFull (mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup) bytes) + Share.ND Share.NamespaceDiff {parent, textLookup, defnLookup, patchLookup, childLookup, bytes} -> Entity.N - ( NamespaceFormat.SyncFull - NamespaceFormat.LocalIds - { branchTextLookup = Vector.fromList textLookup, - branchDefnLookup = Vector.fromList (map jwt32 defnLookup), - branchPatchLookup = Vector.fromList (map jwt32 patchLookup), - branchChildLookup = Vector.fromList (map (\(x, y) -> (jwt32 x, jwt32 y)) childLookup) - } + ( NamespaceFormat.SyncDiff + (jwt32 parent) + (mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup) bytes ) Share.C Share.Causal {namespaceHash, parents} -> @@ -417,6 +415,20 @@ entityToTempEntity = \case defnLookup = Vector.map jwt32 (Vector.fromList hashes) } + mungeNamespaceLocalIds :: + [Text] -> + [Share.HashJWT] -> + [Share.HashJWT] -> + [(Share.HashJWT, Share.HashJWT)] -> + TempEntity.TempNamespaceLocalIds + mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup = + NamespaceFormat.LocalIds + { branchTextLookup = Vector.fromList textLookup, + branchDefnLookup = Vector.fromList (map jwt32 defnLookup), + branchPatchLookup = Vector.fromList (map jwt32 patchLookup), + branchChildLookup = Vector.fromList (map (\(x, y) -> (jwt32 x, jwt32 y)) childLookup) + } + mungePatchLocalIds :: [Text] -> [Share.Hash] -> [Share.HashJWT] -> TempEntity.TempPatchLocalIds mungePatchLocalIds textLookup oldHashLookup newHashLookup = PatchFormat.LocalIds @@ -482,7 +494,26 @@ tempEntityToEntity = \case (coerce @(Vector (Base32Hex, Base32Hex)) @(Vector (Share.Hash, Share.Hash)) branchChildLookup), bytes } - NamespaceFormat.SyncDiff _ _ _ -> undefined + NamespaceFormat.SyncDiff + parent + NamespaceFormat.LocalIds + { branchTextLookup, + branchDefnLookup, + branchPatchLookup, + branchChildLookup + } + bytes -> + Share.ND + Share.NamespaceDiff + { parent = Share.Hash parent, + textLookup = Vector.toList branchTextLookup, + defnLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchDefnLookup), + patchLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchPatchLookup), + childLookup = + Vector.toList + (coerce @(Vector (Base32Hex, Base32Hex)) @(Vector (Share.Hash, Share.Hash)) branchChildLookup), + bytes + } Entity.C Causal.SyncCausalFormat {valueHash, parents} -> Share.C Share.Causal diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index c471cdaf92..6da3dd408b 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -321,6 +321,7 @@ data Entity text noSyncHash hash | P (Patch text noSyncHash hash) | PD (PatchDiff text noSyncHash hash) | N (Namespace text hash) + | ND (NamespaceDiff text hash) | C (Causal hash) deriving stock (Show, Eq, Ord) @@ -351,6 +352,11 @@ instance (ToJSON text, ToJSON noSyncHash, ToJSON hash) => ToJSON (Entity text no [ "type" .= NamespaceType, "object" .= ns ] + ND ns -> + object + [ "type" .= NamespaceDiffType, + "object" .= ns + ] C causal -> object [ "type" .= CausalType, @@ -366,6 +372,7 @@ instance (FromJSON text, FromJSON noSyncHash, FromJSON hash, Ord hash) => FromJS PatchType -> P <$> obj .: "object" PatchDiffType -> PD <$> obj .: "object" NamespaceType -> N <$> obj .: "object" + NamespaceDiffType -> ND <$> obj .: "object" CausalType -> C <$> obj .: "object" -- | Get the direct dependencies of an entity (which are actually sync'd). @@ -378,8 +385,18 @@ entityDependencies = \case P Patch {newHashLookup} -> Set.fromList newHashLookup PD PatchDiff {parent, newHashLookup} -> Set.insert parent (Set.fromList newHashLookup) N Namespace {defnLookup, patchLookup, childLookup} -> - Set.fromList defnLookup <> Set.fromList patchLookup - <> foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup + Set.unions + [ Set.fromList defnLookup, + Set.fromList patchLookup, + foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup + ] + ND NamespaceDiff {parent, defnLookup, patchLookup, childLookup} -> + Set.unions + [ Set.singleton parent, + Set.fromList defnLookup, + Set.fromList patchLookup, + foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup + ] C Causal {parents} -> parents data TermComponent text hash = TermComponent [(LocalIds text hash, ByteString)] @@ -584,6 +601,37 @@ instance (FromJSON text, FromJSON hash) => FromJSON (Namespace text hash) where Base64Bytes bytes <- obj .: "bytes" pure Namespace {..} +data NamespaceDiff text hash = NamespaceDiff + { parent :: hash, + textLookup :: [text], + defnLookup :: [hash], + patchLookup :: [hash], + childLookup :: [(hash, hash)], -- (namespace hash, causal hash) + bytes :: ByteString + } + deriving stock (Eq, Ord, Show) + +instance (ToJSON text, ToJSON hash) => ToJSON (NamespaceDiff text hash) where + toJSON (NamespaceDiff parent textLookup defnLookup patchLookup childLookup bytes) = + object + [ "parent" .= parent, + "text_lookup" .= textLookup, + "defn_lookup" .= defnLookup, + "patch_lookup" .= patchLookup, + "child_lookup" .= childLookup, + "bytes" .= Base64Bytes bytes + ] + +instance (FromJSON text, FromJSON hash) => FromJSON (NamespaceDiff text hash) where + parseJSON = Aeson.withObject "NamespaceDiff" \obj -> do + parent <- obj .: "parent" + textLookup <- obj .: "text_lookup" + defnLookup <- obj .: "defn_lookup" + patchLookup <- obj .: "patch_lookup" + childLookup <- obj .: "child_lookup" + Base64Bytes bytes <- obj .: "bytes" + pure NamespaceDiff {..} + -- Client _may_ choose not to download the namespace entity in the future, but -- we still send them the hash/hashjwt. data Causal hash = Causal @@ -611,6 +659,7 @@ data EntityType | PatchType | PatchDiffType | NamespaceType + | NamespaceDiffType | CausalType deriving stock (Eq, Ord, Show) @@ -621,6 +670,7 @@ instance ToJSON EntityType where PatchType -> "patch" PatchDiffType -> "patch_diff" NamespaceType -> "namespace" + NamespaceDiffType -> "namespace_diff" CausalType -> "causal" instance FromJSON EntityType where @@ -630,5 +680,6 @@ instance FromJSON EntityType where "patch" -> pure PatchType "patch_diff" -> pure PatchDiffType "namespace" -> pure NamespaceType + "namespace_diff" -> pure NamespaceDiffType "causal" -> pure CausalType t -> failText $ "Unexpected entity type: " <> t From d79e396c44665fc5dd963cda6c31695b464bf8d2 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 26 Apr 2022 09:41:31 -0600 Subject: [PATCH 163/529] Re-implement Browse API to avoid loading entire codebase root (#3054) Swap Browse API to use V2 branches. --- .../U/Codebase/Sqlite/Operations.hs | 24 +-- .../U/Codebase/Sqlite/Queries.hs | 13 ++ codebase2/codebase/U/Codebase/Branch.hs | 57 ++++++- codebase2/codebase/U/Codebase/Causal.hs | 18 ++- codebase2/util/src/U/Util/Hash.hs | 1 + parser-typechecker/src/Unison/Codebase.hs | 28 ++++ .../src/Unison/Codebase/Branch.hs | 8 +- .../src/Unison/Codebase/Path.hs | 12 +- .../src/Unison/Codebase/ShortBranchHash.hs | 8 +- .../src/Unison/Codebase/SqliteCodebase.hs | 96 +++++++----- .../Codebase/SqliteCodebase/Conversions.hs | 8 +- .../src/Unison/Codebase/Type.hs | 8 + .../src/Unison/CommandLine/OutputMessages.hs | 16 +- unison-share-api/package.yaml | 2 + unison-share-api/src/Unison/Server/Backend.hs | 145 +++++++++++++++--- .../src/Unison/Server/Endpoints/FuzzyFind.hs | 2 +- .../Server/Endpoints/NamespaceListing.hs | 67 ++++---- .../src/Unison/Server/Endpoints/Projects.hs | 17 +- unison-share-api/src/Unison/Server/Types.hs | 7 + unison-share-api/unison-share-api.cabal | 2 + 20 files changed, 401 insertions(+), 138 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index c4458b76a5..4ead3d308c 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -6,6 +6,7 @@ module U.Codebase.Sqlite.Operations expectRootCausal, saveBranch, loadCausalBranchByCausalHash, + expectCausalBranchByCausalHash, -- * terms saveTermComponent, @@ -857,7 +858,7 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = boId <- Q.expectBranchObjectIdByCausalHashId chId expectBranch boId -saveRootBranch :: C.Branch.Causal Transaction -> Transaction (Db.BranchObjectId, Db.CausalHashId) +saveRootBranch :: C.Branch.CausalBranch Transaction -> Transaction (Db.BranchObjectId, Db.CausalHashId) saveRootBranch c = do when debug $ traceM $ "Operations.saveRootBranch " ++ show (C.causalHash c) (boId, chId) <- saveBranch c @@ -903,7 +904,7 @@ saveRootBranch c = do -- References, but also values -- Shallow - Hash? representation of the database relationships -saveBranch :: C.Branch.Causal Transaction -> Transaction (Db.BranchObjectId, Db.CausalHashId) +saveBranch :: C.Branch.CausalBranch Transaction -> Transaction (Db.BranchObjectId, Db.CausalHashId) saveBranch (C.Causal hc he parents me) = do when debug $ traceM $ "\nOperations.saveBranch \n hc = " ++ show hc ++ ",\n he = " ++ show he ++ ",\n parents = " ++ show (Map.keys parents) @@ -961,25 +962,30 @@ saveBranchObject id@(Db.unBranchHashId -> hashId) li lBranch = do oId <- Q.saveObject hashId OT.Namespace bytes pure $ Db.BranchObjectId oId -expectRootCausal :: Transaction (C.Branch.Causal Transaction) -expectRootCausal = Q.expectNamespaceRoot >>= expectCausalByCausalHashId +expectRootCausal :: Transaction (C.Branch.CausalBranch Transaction) +expectRootCausal = Q.expectNamespaceRoot >>= expectCausalBranchByCausalHashId -loadCausalBranchByCausalHash :: CausalHash -> Transaction (Maybe (C.Branch.Causal Transaction)) +loadCausalBranchByCausalHash :: CausalHash -> Transaction (Maybe (C.Branch.CausalBranch Transaction)) loadCausalBranchByCausalHash hc = do Q.loadCausalHashIdByCausalHash hc >>= \case - Just chId -> Just <$> expectCausalByCausalHashId chId + Just chId -> Just <$> expectCausalBranchByCausalHashId chId Nothing -> pure Nothing -expectCausalByCausalHashId :: Db.CausalHashId -> Transaction (C.Branch.Causal Transaction) -expectCausalByCausalHashId id = do +expectCausalBranchByCausalHashId :: Db.CausalHashId -> Transaction (C.Branch.CausalBranch Transaction) +expectCausalBranchByCausalHashId id = do hc <- Q.expectCausalHash id hb <- expectValueHashByCausalHashId id parentHashIds <- Q.loadCausalParents id loadParents <- for parentHashIds \hId -> do h <- Q.expectCausalHash hId - pure (h, expectCausalByCausalHashId hId) + pure (h, expectCausalBranchByCausalHashId hId) pure $ C.Causal hc hb (Map.fromList loadParents) (expectBranchByCausalHashId id) +expectCausalBranchByCausalHash :: CausalHash -> Transaction (C.Branch.CausalBranch Transaction) +expectCausalBranchByCausalHash hash = do + chId <- Q.expectCausalHashIdByCausalHash hash + expectCausalBranchByCausalHashId chId + expectBranchByCausalHashId :: Db.CausalHashId -> Transaction (C.Branch.Branch Transaction) expectBranchByCausalHashId id = do boId <- Q.expectBranchObjectIdByCausalHashId id diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 190832c741..41c1023a67 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -66,8 +66,10 @@ module U.Codebase.Sqlite.Queries saveCausal, isCausalHash, loadCausalHashIdByCausalHash, + expectCausalHashIdByCausalHash, expectCausalValueHashId, loadCausalByCausalHash, + expectCausalByCausalHash, loadBranchObjectIdByCausalHashId, expectBranchObjectIdByCausalHashId, @@ -238,12 +240,23 @@ loadCausalHashIdByCausalHash ch = runMaybeT do hId <- MaybeT $ loadHashIdByHash (unCausalHash ch) Alternative.whenM (lift (isCausalHash hId)) (CausalHashId hId) +expectCausalHashIdByCausalHash :: CausalHash -> Transaction CausalHashId +expectCausalHashIdByCausalHash ch = do + hId <- expectHashIdByHash (unCausalHash ch) + pure (CausalHashId hId) + loadCausalByCausalHash :: CausalHash -> Transaction (Maybe (CausalHashId, BranchHashId)) loadCausalByCausalHash ch = runMaybeT do hId <- MaybeT $ loadHashIdByHash (unCausalHash ch) bhId <- MaybeT $ loadCausalValueHashId hId pure (CausalHashId hId, bhId) +expectCausalByCausalHash :: CausalHash -> Transaction (CausalHashId, BranchHashId) +expectCausalByCausalHash ch = do + hId <- expectCausalHashIdByCausalHash ch + bhId <- expectCausalValueHashId hId + pure (hId, bhId) + expectHashIdByHash :: Hash -> Transaction HashId expectHashIdByHash = expectHashId . Hash.toBase32Hex diff --git a/codebase2/codebase/U/Codebase/Branch.hs b/codebase2/codebase/U/Codebase/Branch.hs index bd78c820c3..232ae4692a 100644 --- a/codebase2/codebase/U/Codebase/Branch.hs +++ b/codebase2/codebase/U/Codebase/Branch.hs @@ -1,15 +1,31 @@ -module U.Codebase.Branch where +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} -import Data.Map (Map) +module U.Codebase.Branch + ( Branch (..), + CausalBranch, + Patch (..), + MetadataType, + MetadataValue, + MdValues (..), + NameSegment (..), + CausalHash, + childAt, + hoist, + hoistCausalBranch, + ) +where + +import Control.Lens (AsEmpty (..), nearly) import qualified Data.Map as Map -import Data.Set (Set) -import Data.Text (Text) -import qualified U.Codebase.Causal as C +import U.Codebase.Causal (Causal) +import qualified U.Codebase.Causal as Causal import U.Codebase.HashTags (BranchHash, CausalHash, PatchHash) import U.Codebase.Reference (Reference) import U.Codebase.Referent (Referent) import U.Codebase.TermEdit (TermEdit) import U.Codebase.TypeEdit (TypeEdit) +import Unison.Prelude newtype NameSegment = NameSegment {unNameSegment :: Text} deriving (Eq, Ord, Show) @@ -19,16 +35,23 @@ type MetadataValue = Reference data MdValues = MdValues (Map MetadataValue MetadataType) deriving (Eq, Ord, Show) -type Causal m = C.Causal m CausalHash BranchHash (Branch m) +type CausalBranch m = Causal m CausalHash BranchHash (Branch m) --- | V2.Branch is like V1.Branch0; I would rename it, at least temporarily, but too hard. +-- | A re-imagining of Unison.Codebase.Branch which is less eager in what it loads, +-- which can often speed up load times and keep fewer things in memory. data Branch m = Branch { terms :: Map NameSegment (Map Referent (m MdValues)), types :: Map NameSegment (Map Reference (m MdValues)), patches :: Map NameSegment (PatchHash, m Patch), - children :: Map NameSegment (Causal m) + children :: Map NameSegment (CausalBranch m) } +instance AsEmpty (Branch m) where + _Empty = + nearly + (Branch mempty mempty mempty mempty) + (\(Branch terms types patches children) -> null terms && null types && null patches && null children) + data Patch = Patch { termEdits :: Map Referent (Set TermEdit), typeEdits :: Map Reference (Set TypeEdit) @@ -43,3 +66,21 @@ instance Show (Branch m) where ++ show (fmap fst (patches b)) ++ ", children = " ++ show (Map.keys (children b)) + +childAt :: NameSegment -> Branch m -> Maybe (CausalBranch m) +childAt ns (Branch {children}) = Map.lookup ns children + +hoist :: Functor n => (forall x. m x -> n x) -> Branch m -> Branch n +hoist f Branch {..} = + Branch + { terms = (fmap . fmap) f terms, + types = (fmap . fmap) f types, + patches = (fmap . fmap) f patches, + children = fmap (fmap (hoist f) . Causal.hoist f) children + } + +hoistCausalBranch :: Functor n => (forall x. m x -> n x) -> CausalBranch m -> CausalBranch n +hoistCausalBranch f cb = + cb + & Causal.hoist f + & fmap (hoist f) diff --git a/codebase2/codebase/U/Codebase/Causal.hs b/codebase2/codebase/U/Codebase/Causal.hs index a60368801d..26eb4c0c2d 100644 --- a/codebase2/codebase/U/Codebase/Causal.hs +++ b/codebase2/codebase/U/Codebase/Causal.hs @@ -1,9 +1,14 @@ {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} -module U.Codebase.Causal where +module U.Codebase.Causal + ( Causal (..), + hoist, + ) +where -import Data.Map (Map) +import Unison.Prelude data Causal m hc he e = Causal { causalHash :: hc, @@ -11,3 +16,12 @@ data Causal m hc he e = Causal parents :: Map hc (m (Causal m hc he e)), value :: m e } + deriving (Functor) + +hoist :: Functor n => (forall x. m x -> n x) -> Causal m hc he e -> Causal n hc he e +hoist f (Causal {..}) = + Causal + { parents = parents & fmap f & (fmap . fmap) (hoist f), + value = f value, + .. + } diff --git a/codebase2/util/src/U/Util/Hash.hs b/codebase2/util/src/U/Util/Hash.hs index 6bdee966d5..97ca6d0fe7 100644 --- a/codebase2/util/src/U/Util/Hash.hs +++ b/codebase2/util/src/U/Util/Hash.hs @@ -6,6 +6,7 @@ module U.Util.Hash fromBase32Hex, fromByteString, toBase32Hex, + toBase32HexText, toByteString, ) where diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index a98d650db2..748aa169cb 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -7,6 +7,7 @@ module Unison.Codebase unsafeGetTermWithType, getTermComponentWithTypes, getTypeOfTerm, + getDeclType, unsafeGetTypeOfTermById, isTerm, putTerm, @@ -35,6 +36,9 @@ module Unison.Codebase branchHashesByPrefix, lca, beforeImpl, + shallowBranchAtPath, + getShallowBranchForHash, + getShallowRootBranch, -- * Root branch getRootBranch, @@ -99,6 +103,9 @@ import Control.Monad.Trans.Except (throwE) import Data.List as List import qualified Data.Map as Map import qualified Data.Set as Set +import qualified U.Codebase.Branch as V2 +import qualified U.Codebase.Branch as V2Branch +import qualified U.Codebase.Causal as V2Causal import U.Util.Timing (time) import qualified Unison.Builtin as Builtin import qualified Unison.Builtin.Terms as Builtin @@ -110,6 +117,9 @@ import Unison.Codebase.Editor.Git (withStatus) import qualified Unison.Codebase.Editor.Git as Git import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) import qualified Unison.Codebase.GitError as GitError +import Unison.Codebase.Path +import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import Unison.Codebase.SyncMode (SyncMode) import Unison.Codebase.Type ( Codebase (..), @@ -140,6 +150,24 @@ import qualified Unison.Util.Relation as Rel import Unison.Var (Var) import qualified Unison.WatchKind as WK +-- | Get the shallow representation of the root branches without loading the children or +-- history. +getShallowRootBranch :: Monad m => Codebase m v a -> m (V2.CausalBranch m) +getShallowRootBranch codebase = do + hash <- getRootBranchHash codebase + getShallowBranchForHash codebase hash + +-- | Recursively descend into shallow branches following the given path. +shallowBranchAtPath :: Monad m => Path -> V2Branch.CausalBranch m -> m (Maybe (V2Branch.CausalBranch m)) +shallowBranchAtPath path causal = do + case path of + Path.Empty -> pure (Just causal) + (ns Path.:< p) -> do + b <- V2Causal.value causal + case (V2Branch.childAt (Cv.namesegment1to2 ns) b) of + Nothing -> pure Nothing + Just childCausal -> shallowBranchAtPath p childCausal + -- | Get a branch from the codebase. getBranchForHash :: Monad m => Codebase m v a -> Branch.Hash -> m (Maybe (Branch m)) getBranchForHash codebase h = diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index 9bbd1466ca..56f452d91a 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -9,7 +9,7 @@ module Unison.Codebase.Branch Branch (..), UnwrappedBranch, Branch0 (..), - Raw (..), + Raw, Star, Hash, EditHash, @@ -88,7 +88,7 @@ import qualified Data.Map as Map import qualified Data.Semialign as Align import qualified Data.Set as Set import Data.These (These (..)) -import Unison.Codebase.Branch.Raw (Raw (Raw)) +import Unison.Codebase.Branch.Raw (Raw) import Unison.Codebase.Branch.Type ( Branch (..), Branch0 (..), @@ -617,13 +617,13 @@ addTypeName r new md = deleteTermName :: Referent -> NameSegment -> Branch0 m -> Branch0 m deleteTermName r n b | Star3.memberD1 (r, n) (view terms b) = - over terms (Star3.deletePrimaryD1 (r, n)) b + over terms (Star3.deletePrimaryD1 (r, n)) b deleteTermName _ _ b = b deleteTypeName :: TypeReference -> NameSegment -> Branch0 m -> Branch0 m deleteTypeName r n b | Star3.memberD1 (r, n) (view types b) = - over types (Star3.deletePrimaryD1 (r, n)) b + over types (Star3.deletePrimaryD1 (r, n)) b deleteTypeName _ _ b = b lca :: Monad m => Branch m -> Branch m -> m (Maybe (Branch m)) diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index df76ea0426..ce94277688 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ViewPatterns #-} module Unison.Codebase.Path @@ -11,6 +13,8 @@ module Unison.Codebase.Path Relative (..), Resolve (..), pattern Empty, + pattern (Lens.:<), + pattern (Lens.:>), singleton, Unison.Codebase.Path.uncons, empty, @@ -67,7 +71,7 @@ module Unison.Codebase.Path ) where -import Control.Lens hiding (Empty, cons, snoc, unsnoc) +import Control.Lens hiding (cons, snoc, unsnoc, pattern Empty) import qualified Control.Lens as Lens import qualified Data.Foldable as Foldable import Data.List.Extra (dropPrefix) @@ -270,6 +274,12 @@ toText' = \case Path' (Left (Absolute path)) -> Text.cons '.' (toText path) Path' (Right (Relative path)) -> toText path +{-# COMPLETE Empty, (:<) #-} + +{-# COMPLETE Empty, (:>) #-} + +deriving anyclass instance AsEmpty Path + instance Cons Path Path NameSegment NameSegment where _Cons = prism (uncurry cons) uncons where diff --git a/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs b/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs index 027f244302..973f2942eb 100644 --- a/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs +++ b/parser-typechecker/src/Unison/Codebase/ShortBranchHash.hs @@ -2,7 +2,6 @@ module Unison.Codebase.ShortBranchHash ( toString, toHash, fromHash, - fullFromHash, fromText, ShortBranchHash (..), ) @@ -26,16 +25,13 @@ fromHash :: Coercible h Hash.Hash => Int -> h -> ShortBranchHash fromHash len = ShortBranchHash . Text.take len . Hash.base32Hex . coerce -fullFromHash :: Coercible h Hash.Hash => h -> ShortBranchHash -fullFromHash = ShortBranchHash . Hash.base32Hex . coerce - -- abc -> SBH abc -- #abc -> SBH abc fromText :: Text -> Maybe ShortBranchHash fromText (Text.dropWhile (== '#') -> t) | Text.all (`Set.member` Hash.validBase32HexChars) t = - Just $ - ShortBranchHash t + Just $ + ShortBranchHash t fromText _ = Nothing instance Show ShortBranchHash where diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 828d95a7e0..0b067ef6b3 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -27,6 +27,7 @@ import qualified System.Console.ANSI as ANSI import System.FilePath (()) import qualified System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix +import qualified U.Codebase.Branch as V2Branch import U.Codebase.HashTags (CausalHash (CausalHash)) import qualified U.Codebase.Reference as C.Reference import qualified U.Codebase.Sqlite.Operations as Ops @@ -247,6 +248,16 @@ sqliteCodebase debugName root localOrRemote action = do putTypeDeclaration id decl = Sqlite.runTransaction conn (CodebaseOps.putTypeDeclaration termBuffer declBuffer id decl) + getRootBranchHash :: MonadIO m => m V2Branch.CausalHash + getRootBranchHash = do + Sqlite.runReadOnlyTransaction conn \run -> + run Ops.expectRootCausalHash + + getShallowBranchForHash :: MonadIO m => V2Branch.CausalHash -> m (V2Branch.CausalBranch m) + getShallowBranchForHash bh = + Sqlite.runReadOnlyTransaction conn \run -> do + V2Branch.hoistCausalBranch run <$> run (Ops.expectCausalBranchByCausalHash bh) + getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> m (Branch m) getRootBranch rootBranchCache = Sqlite.runReadOnlyTransaction conn \run -> @@ -433,47 +444,50 @@ sqliteCodebase debugName root localOrRemote action = do Sqlite.runTransaction conn (CodebaseOps.sqlLca h1 h2) let codebase = C.Codebase - (Cache.applyDefined termCache getTerm) - (Cache.applyDefined typeOfTermCache getTypeOfTermImpl) - (Cache.applyDefined declCache getTypeDeclaration) - putTerm - putTypeDeclaration - -- _getTermComponent - getTermComponentWithTypes - getDeclComponent - getCycleLength - (getRootBranch rootBranchCache) - getRootBranchExists - (putRootBranch rootBranchCache) - (rootBranchUpdates rootBranchCache) - getBranchForHash - putBranch - isCausalHash - getPatch - putPatch - patchExists - dependentsImpl - dependentsOfComponentImpl - syncFromDirectory - syncToDirectory - viewRemoteBranch' - (\r opts action -> pushGitBranch conn r opts action) - watches - getWatch - putWatch - clearWatches - getReflog - appendReflog - termsOfTypeImpl - termsMentioningTypeImpl - hashLength - termReferencesByPrefix - declReferencesByPrefix - referentsByPrefix - branchHashLength - branchHashesByPrefix - (Just sqlLca) - (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r) + { getTerm = (Cache.applyDefined termCache getTerm), + getTypeOfTermImpl = (Cache.applyDefined typeOfTermCache getTypeOfTermImpl), + getTypeDeclaration = (Cache.applyDefined declCache getTypeDeclaration), + getDeclType = \r -> Sqlite.runReadOnlyTransaction conn \run -> run (getDeclType r), + putTerm = putTerm, + putTypeDeclaration = putTypeDeclaration, + getTermComponentWithTypes = getTermComponentWithTypes, + getDeclComponent = getDeclComponent, + getComponentLength = getCycleLength, + getRootBranch = (getRootBranch rootBranchCache), + getRootBranchHash = getRootBranchHash, + getRootBranchExists = getRootBranchExists, + putRootBranch = (putRootBranch rootBranchCache), + rootBranchUpdates = (rootBranchUpdates rootBranchCache), + getShallowBranchForHash = getShallowBranchForHash, + getBranchForHashImpl = getBranchForHash, + putBranch = putBranch, + branchExists = isCausalHash, + getPatch = getPatch, + putPatch = putPatch, + patchExists = patchExists, + dependentsImpl = dependentsImpl, + dependentsOfComponentImpl = dependentsOfComponentImpl, + syncFromDirectory = syncFromDirectory, + syncToDirectory = syncToDirectory, + viewRemoteBranch' = viewRemoteBranch', + pushGitBranch = (\r opts action -> pushGitBranch conn r opts action), + watches = watches, + getWatch = getWatch, + putWatch = putWatch, + clearWatches = clearWatches, + getReflog = getReflog, + appendReflog = appendReflog, + termsOfTypeImpl = termsOfTypeImpl, + termsMentioningTypeImpl = termsMentioningTypeImpl, + hashLength = hashLength, + termReferencesByPrefix = termReferencesByPrefix, + typeReferencesByPrefix = declReferencesByPrefix, + termReferentsByPrefix = referentsByPrefix, + branchHashLength = branchHashLength, + branchHashesByPrefix = branchHashesByPrefix, + lcaImpl = (Just sqlLca), + beforeImpl = (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r) + } let finalizer :: MonadIO m => m () finalizer = do decls <- readTVarIO declBuffer diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs index 68bcd1c920..4bf1b25fb9 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs @@ -410,10 +410,10 @@ type1to2' convertRef = V1.Kind.Arrow i o -> V2.Kind.Arrow (convertKind i) (convertKind o) -- | forces loading v1 branches even if they may not exist -causalbranch2to1 :: Monad m => (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.Branch m) +causalbranch2to1 :: Monad m => (V2.Reference -> m CT.ConstructorType) -> V2.Branch.CausalBranch m -> m (V1.Branch.Branch m) causalbranch2to1 lookupCT = fmap V1.Branch.Branch . causalbranch2to1' lookupCT -causalbranch2to1' :: Monad m => (V2.Reference -> m CT.ConstructorType) -> V2.Branch.Causal m -> m (V1.Branch.UnwrappedBranch m) +causalbranch2to1' :: Monad m => (V2.Reference -> m CT.ConstructorType) -> V2.Branch.CausalBranch m -> m (V1.Branch.UnwrappedBranch m) causalbranch2to1' lookupCT (V2.Causal hc _he (Map.toList -> parents) me) = do let currentHash = causalHash2to1 hc case parents of @@ -428,7 +428,7 @@ causalbranch2to1' lookupCT (V2.Causal hc _he (Map.toList -> parents) me) = do e <- me V1.Causal.UnsafeMerge currentHash <$> branch2to1 lookupCT e <*> pure (Map.fromList tailsList) -causalbranch1to2 :: forall m. Monad m => V1.Branch.Branch m -> V2.Branch.Causal m +causalbranch1to2 :: forall m. Monad m => V1.Branch.Branch m -> V2.Branch.CausalBranch m causalbranch1to2 (V1.Branch.Branch c) = causal1to2' hash1to2cb hash1to2c branch1to2 c where hash1to2cb :: V1.Branch.Hash -> (V2.CausalHash, V2.BranchHash) @@ -491,7 +491,7 @@ causalbranch1to2 (V1.Branch.Branch c) = causal1to2' hash1to2cb hash1to2c branch1 doPatches :: Map V1.NameSegment (V1.Branch.EditHash, m V1.Patch) -> Map V2.Branch.NameSegment (V2.PatchHash, m V2.Branch.Patch) doPatches = Map.bimap namesegment1to2 (bimap edithash1to2 (fmap patch1to2)) - doChildren :: Map V1.NameSegment (V1.Branch.Branch m) -> Map V2.Branch.NameSegment (V2.Branch.Causal m) + doChildren :: Map V1.NameSegment (V1.Branch.Branch m) -> Map V2.Branch.NameSegment (V2.Branch.CausalBranch m) doChildren = Map.bimap namesegment1to2 causalbranch1to2 patch2to1 :: V2.Branch.Patch -> V1.Patch diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index cfd9f63045..b99fb15865 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -12,6 +12,8 @@ module Unison.Codebase.Type ) where +import qualified U.Codebase.Branch as V2 +import qualified U.Codebase.Reference as V2 import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Editor.Git as Git @@ -24,6 +26,7 @@ import Unison.Codebase.ShortBranchHash (ShortBranchHash) import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..)) import Unison.Codebase.SyncMode (SyncMode) import Unison.CodebasePath (CodebasePath) +import qualified Unison.ConstructorType as CT import Unison.DataDeclaration (Decl) import Unison.Hash (Hash) import Unison.Prelude @@ -58,6 +61,8 @@ data Codebase m v a = Codebase -- Note that it is possible to call 'putTypeDeclaration', then 'getTypeDeclaration', and receive @Nothing@, per the -- semantics of 'putTypeDeclaration'. getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)), + -- | Get the type of a given decl. + getDeclType :: V2.Reference -> m CT.ConstructorType, -- | Enqueue the put of a user-defined term (with its type) into the codebase, if it doesn't already exist. The -- implementation may choose to delay the put until all of the term's (and its type's) references are stored as -- well. @@ -69,6 +74,8 @@ data Codebase m v a = Codebase getTermComponentWithTypes :: Hash -> m (Maybe [(Term v a, Type v a)]), getDeclComponent :: Hash -> m (Maybe [Decl v a]), getComponentLength :: Hash -> m (Maybe Reference.CycleSize), + -- | Get the root branch Hash. + getRootBranchHash :: m V2.CausalHash, -- | Get the root branch. getRootBranch :: m (Branch m), -- | Get whether the root branch exists. @@ -76,6 +83,7 @@ data Codebase m v a = Codebase -- | Like 'putBranch', but also adjusts the root branch pointer afterwards. putRootBranch :: Branch m -> m (), rootBranchUpdates :: m (IO (), IO (Set Branch.Hash)), + getShallowBranchForHash :: V2.CausalHash -> m (V2.CausalBranch m), getBranchForHashImpl :: Branch.Hash -> m (Maybe (Branch m)), -- | Put a branch into the codebase, which includes its children, its patches, and the branch itself, if they don't -- already exist. diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 9a5ff22c64..3bb4632aa8 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -31,6 +31,7 @@ import System.Directory getHomeDirectory, ) import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) +import qualified U.Util.Hash as Hash import qualified U.Util.Monoid as Monoid import qualified Unison.ABT as ABT import qualified Unison.Auth.Types as Auth @@ -622,8 +623,8 @@ notifyUser dir o = case o of CachedTests 0 _ -> pure . P.callout "๐Ÿ˜ถ" $ "No tests to run." CachedTests n n' | n == n' -> - pure $ - P.lines [cache, "", displayTestResults True ppe oks fails] + pure $ + P.lines [cache, "", displayTestResults True ppe oks fails] CachedTests _n m -> pure $ if m == 0 @@ -632,7 +633,6 @@ notifyUser dir o = case o of P.indentN 2 $ P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "โœ… "] where - NewlyComputed -> do clearCurrentLine pure $ @@ -892,8 +892,9 @@ notifyUser dir o = case o of ShallowBranchEntry ns _ count -> ( (P.syntaxToColor . prettyName . Name.fromSegment) ns <> "/", case count of - 1 -> P.lit "(1 definition)" - _n -> P.lit "(" <> P.shown count <> P.lit " definitions)" + Nothing -> "(namespace)" + Just 1 -> P.lit "(1 definition)" + Just n -> P.lit "(" <> P.shown n <> P.lit " definitions)" ) ShallowPatchEntry ns -> ( (P.syntaxToColor . prettyName . Name.fromSegment) ns, @@ -1631,6 +1632,9 @@ prettyAbsolute = P.blue . P.shown prettySBH :: IsString s => ShortBranchHash -> P.Pretty s prettySBH hash = P.group $ "#" <> P.text (SBH.toText hash) +prettyCausalHash :: IsString s => Causal.RawHash x -> P.Pretty s +prettyCausalHash hash = P.group $ "#" <> P.text (Hash.toBase32HexText . Causal.unRawHash $ hash) + formatMissingStuff :: (Show tm, Show typ) => [(HQ.HashQualified Name, tm)] -> @@ -2161,7 +2165,7 @@ showDiffNamespace :: (Pretty, NumberedArgs) showDiffNamespace _ _ _ _ diffOutput | OBD.isEmpty diffOutput = - ("The namespaces are identical.", mempty) + ("The namespaces are identical.", mempty) showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = (P.sepNonEmpty "\n\n" p, toList args) where diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index f17ce35258..b7a1aa120a 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -18,6 +18,7 @@ dependencies: - aeson - memory - unison-util-relation + - unison-codebase - unison-core1 - unison-prelude - unison-parser-typechecker @@ -44,6 +45,7 @@ dependencies: - utf8-string - async - regex-tdfa + - unison-util ghc-options: -Wall diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index dcfc466412..ae2cdb6c30 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -10,13 +10,12 @@ module Unison.Server.Backend where import Control.Error.Util (hush, (??)) -import Control.Lens (over, (^.), _2) -import Control.Lens.Cons +import Control.Lens hiding ((??)) import Control.Monad.Except ( ExceptT (..), throwError, ) -import Data.Bifunctor (bimap, first) +import Data.Bifunctor (first) import Data.Containers.ListUtils (nubOrdOn) import qualified Data.List as List import Data.List.Extra (nubOrd) @@ -31,6 +30,9 @@ import qualified Lucid import System.Directory import System.FilePath import qualified Text.FuzzyFind as FZF +import qualified U.Codebase.Branch as V2Branch +import qualified U.Codebase.Causal as V2Causal +import qualified U.Codebase.Referent as V2 import qualified Unison.ABT as ABT import qualified Unison.Builtin as B import qualified Unison.Builtin.Decls as Decls @@ -50,6 +52,7 @@ import Unison.Codebase.ShortBranchHash ( ShortBranchHash, ) import qualified Unison.Codebase.ShortBranchHash as SBH +import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import Unison.ConstructorReference (GConstructorReference (..)) import qualified Unison.ConstructorReference as ConstructorReference import qualified Unison.DataDeclaration as DD @@ -65,7 +68,7 @@ import qualified Unison.Name as Name import qualified Unison.NamePrinter as NP import Unison.NameSegment (NameSegment (..)) import qualified Unison.NameSegment as NameSegment -import Unison.Names (Names) +import Unison.Names (Names (Names)) import qualified Unison.Names as Names import Unison.NamesWithHistory (NamesWithHistory (..)) import qualified Unison.NamesWithHistory as NamesWithHistory @@ -103,6 +106,7 @@ import qualified Unison.Util.Monoid as Monoid import Unison.Util.Pretty (Width) import qualified Unison.Util.Pretty as Pretty import qualified Unison.Util.Relation as R +import qualified Unison.Util.Set as Set import qualified Unison.Util.Star3 as Star3 import qualified Unison.Util.SyntaxText as UST import Unison.Var (Var) @@ -113,8 +117,9 @@ type SyntaxText = UST.SyntaxText' Reference data ShallowListEntry v a = ShallowTermEntry (TermEntry v a) | ShallowTypeEntry TypeEntry - | -- The integer here represents the number of children - ShallowBranchEntry NameSegment ShortBranchHash Int + | -- The integer here represents the number of children. + -- it may be omitted depending on the context the query is run in. + ShallowBranchEntry NameSegment Branch.Hash (Maybe Int) | ShallowPatchEntry NameSegment deriving (Eq, Ord, Show, Generic) @@ -183,6 +188,32 @@ basicSuffixifiedNames hashLength root nameScope = basicPrettyPrintNames :: Branch m -> NameScoping -> Names basicPrettyPrintNames root = snd . basicNames' root +shallowPPE :: Monad m => Codebase m v a -> V2Branch.Branch m -> m PPE.PrettyPrintEnv +shallowPPE codebase b = do + hashLength <- Codebase.hashLength codebase + names <- shallowNames codebase b + pure $ PPE.suffixifiedPPE . PPE.fromNamesDecl hashLength $ NamesWithHistory names mempty + +-- | A 'Names' which only includes mappings for things _directly_ accessible from the branch. +-- +-- I.e. names in nested children are omitted. +-- This should probably live elsewhere, but the package dependency graph makes it hard to find +-- a good place. +shallowNames :: forall m v a. Monad m => Codebase m v a -> V2Branch.Branch m -> m Names +shallowNames codebase b = do + newTerms <- + V2Branch.terms b + & Map.mapKeys (Name.fromSegment . Cv.namesegment2to1) + & fmap Map.keysSet + & traverse . Set.traverse %%~ Cv.referent2to1 (Codebase.getDeclType codebase) + + let newTypes = + V2Branch.types b + & Map.mapKeys (Name.fromSegment . Cv.namesegment2to1) + & fmap Map.keysSet + & traverse . Set.traverse %~ Cv.reference2to1 + pure (Names (R.fromMultimap newTerms) (R.fromMultimap newTypes)) + basicParseNames :: Branch m -> NameScoping -> Names basicParseNames root = fst . basicNames' root @@ -277,7 +308,7 @@ findShallow codebase path' = do let mayb = Branch.getAt path root case mayb of Nothing -> pure [] - Just b -> findShallowInBranch codebase b + Just b -> lsBranch codebase b findShallowReadmeInBranchAndRender :: Width -> @@ -321,16 +352,12 @@ isDoc' typeOfTerm = do termListEntry :: Monad m => Codebase m Symbol Ann -> - Branch0 m -> + Bool -> Referent -> HQ'.HQSegment -> m (TermEntry Symbol Ann) -termListEntry codebase b0 r n = do +termListEntry codebase isTest r n = do ot <- loadReferentType codebase r - - -- A term is a test if it has a link of type `IsTest`. - let isTest = Metadata.hasMetadataWithType' r Decls.isTestRef $ Branch.deepTermMetadata b0 - let tag = if (isDoc' ot) then Just Doc @@ -341,6 +368,20 @@ termListEntry codebase b0 r n = do pure $ TermEntry r n ot tag +checkIsTestForBranch :: Branch0 m -> Referent -> Bool +checkIsTestForBranch b0 r = + Metadata.hasMetadataWithType' r Decls.isTestRef $ Branch.deepTermMetadata b0 + +checkIsTestForV2Branch :: Monad m => V2Branch.Branch m -> V2.Referent -> m Bool +checkIsTestForV2Branch b r = do + -- TODO: Should V2Branch use some sort of relation here? + or <$> for (toList $ V2Branch.terms b) \metaMap -> do + case Map.lookup r metaMap of + Nothing -> pure False + Just getMdValues -> do + V2Branch.MdValues mdValues <- getMdValues + pure $ elem (Cv.reference1to2 Decls.isTestRef) mdValues + typeListEntry :: Monad m => Var v => @@ -408,12 +449,15 @@ typeEntryToNamedType (TypeEntry r name tag) = typeTag = tag } -findShallowInBranch :: +-- | Find all definitions and children reachable from the given branch. +-- Note: this differs from 'lsShallowBranch' in that it takes a fully loaded 'Branch' object, +-- and thus can include definition counts for child namespaces. +lsBranch :: Monad m => Codebase m Symbol Ann -> Branch m -> m [ShallowListEntry Symbol Ann] -findShallowInBranch codebase b = do +lsBranch codebase b = do hashLength <- Codebase.hashLength codebase let hqTerm b0 ns r = let refs = Star3.lookupD1 ns . Branch._terms $ b0 @@ -430,14 +474,14 @@ findShallowInBranch codebase b = do + (R.size . Branch.deepTypes $ Branch.head b) b0 = Branch.head b termEntries <- for (R.toList . Star3.d1 $ Branch._terms b0) $ \(r, ns) -> - ShallowTermEntry <$> termListEntry codebase b0 r (hqTerm b0 ns r) + ShallowTermEntry <$> termListEntry codebase (checkIsTestForBranch b0 r) r (hqTerm b0 ns r) typeEntries <- for (R.toList . Star3.d1 $ Branch._types b0) $ \(r, ns) -> ShallowTypeEntry <$> typeListEntry codebase r (hqType b0 ns r) let branchEntries = [ ShallowBranchEntry ns - (SBH.fullFromHash $ Branch.headHash b) - (defnCount b) + (Branch.headHash b) + (Just $ defnCount b) | (ns, b) <- Map.toList $ Branch.nonEmptyChildren b0 ] patchEntries = @@ -451,6 +495,66 @@ findShallowInBranch codebase b = do ++ branchEntries ++ patchEntries +-- | Find all definitions and children reachable from the given 'V2Branch.Branch', +-- Note: this differs from 'lsBranch' in that it takes a shallow v2 branch, +-- As a result, it omits definition counts from child-namespaces in its results, +-- but doesn't require loading the entire sub-tree to do so. +lsShallowBranch :: + Monad m => + Codebase m Symbol Ann -> + V2Branch.Branch m -> + m [ShallowListEntry Symbol Ann] +lsShallowBranch codebase b0 = do + hashLength <- Codebase.hashLength codebase + let hqTerm :: + ( V2Branch.Branch m -> + V2Branch.NameSegment -> + Referent -> + HQ'.HashQualified NameSegment + ) + hqTerm b ns r = + let refs = Map.lookup ns . V2Branch.terms $ b + in case length refs of + 1 -> HQ'.fromName (Cv.namesegment2to1 ns) + _ -> HQ'.take hashLength $ HQ'.fromNamedReferent (Cv.namesegment2to1 ns) r + hqType :: + ( V2Branch.Branch m -> + V2Branch.NameSegment -> + Reference -> + (HQ'.HashQualified NameSegment) + ) + hqType b ns r = + let refs = Map.lookup ns . V2Branch.types $ b + in case length refs of + 1 -> HQ'.fromName (Cv.namesegment2to1 ns) + _ -> HQ'.take hashLength $ HQ'.fromNamedReference (Cv.namesegment2to1 ns) r + let flattenRefs :: Map V2Branch.NameSegment (Map ref v) -> [(ref, V2Branch.NameSegment)] + flattenRefs m = do + (ns, refs) <- Map.toList m + r <- Map.keys refs + pure (r, ns) + termEntries <- for (flattenRefs $ V2Branch.terms b0) $ \(r, ns) -> do + isTest <- checkIsTestForV2Branch b0 r + v1Ref <- Cv.referent2to1 (Codebase.getDeclType codebase) r + ShallowTermEntry <$> termListEntry codebase isTest v1Ref (hqTerm b0 ns v1Ref) + typeEntries <- for (flattenRefs $ V2Branch.types b0) \(r, ns) -> do + let v1Ref = Cv.reference2to1 r + ShallowTypeEntry <$> typeListEntry codebase v1Ref (hqType b0 ns v1Ref) + let branchEntries = + [ ShallowBranchEntry (Cv.namesegment2to1 ns) (Cv.causalHash2to1 . V2Causal.causalHash $ h) Nothing + | (ns, h) <- Map.toList $ V2Branch.children b0 + ] + patchEntries = + [ ShallowPatchEntry (Cv.namesegment2to1 ns) + | (ns, _h) <- Map.toList $ V2Branch.patches b0 + ] + pure + . List.sortOn listEntryName + $ termEntries + ++ typeEntries + ++ branchEntries + ++ patchEntries + termReferencesByShortHash :: Monad m => Codebase m v a -> ShortHash -> m (Set Reference) @@ -757,6 +861,7 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod ExceptT BackendError IO TermDefinition ) mkTermDefinition r tm = do + let referent = Referent.Ref r ts <- lift (Codebase.getTypeOfTerm codebase r) let bn = bestNameForTerm @Symbol (PPE.suffixifiedPPE ppe) width (Referent.Ref r) tag <- @@ -764,8 +869,8 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod ( termEntryTag <$> termListEntry codebase - (Branch.head branch) - (Referent.Ref r) + (checkIsTestForBranch (Branch.head branch) referent) + referent (HQ'.NameOnly (NameSegment bn)) ) docs <- lift (docResults [r] $ docNames (NamesWithHistory.termName hqLength (Referent.Ref r) printNames)) diff --git a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs index 59a47eaded..d9a9ec8224 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs @@ -164,7 +164,7 @@ serveFuzzyFind codebase mayRoot relativePath limit typeWidth query = $ Backend.termEntryToNamedTerm ppe typeWidth te ) ) - <$> Backend.termListEntry codebase b0 r n + <$> Backend.termListEntry codebase (Backend.checkIsTestForBranch b0 r) r n Backend.FoundTypeRef r -> do te <- Backend.typeListEntry codebase r n let namedType = Backend.typeEntryToNamedType te diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs index 8fce94c048..8ad529b5af 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs @@ -9,7 +9,6 @@ module Unison.Server.Endpoints.NamespaceListing where -import Control.Error.Util ((??)) import Control.Monad.Except import Data.Aeson import Data.OpenApi (ToSchema) @@ -25,17 +24,22 @@ import Servant.Docs ToSample (..), ) import Servant.OpenApi () +import qualified U.Codebase.Branch as V2Branch +import qualified U.Codebase.Causal as V2Causal +import qualified U.Util.Hash as Hash import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase -import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch as V1Branch +import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Path.Parse as Path import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import qualified Unison.Codebase.ShortBranchHash as SBH +import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import qualified Unison.NameSegment as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude import qualified Unison.PrettyPrintEnv as PPE +import Unison.Server.Backend (Backend) import qualified Unison.Server.Backend as Backend import Unison.Server.Types ( APIGet, @@ -43,10 +47,9 @@ import Unison.Server.Types NamedTerm (..), NamedType (..), NamespaceFQN, - Size, UnisonHash, UnisonName, - branchToUnisonHash, + v2CausalBranchToUnisonHash, ) import Unison.Symbol (Symbol) import Unison.Util.Pretty (Width) @@ -73,7 +76,7 @@ instance ToSample NamespaceListing where NamespaceListing "." "#gjlk0dna8dongct6lsd19d1o9hi5n642t8jttga5e81e91fviqjdffem0tlddj7ahodjo5" - [Subnamespace $ NamedNamespace "base" "#19d1o9hi5n642t8jttg" 1244] + [Subnamespace $ NamedNamespace "base" "#19d1o9hi5n642t8jttg"] ) ] @@ -103,8 +106,7 @@ deriving instance ToSchema NamespaceObject data NamedNamespace = NamedNamespace { namespaceName :: UnisonName, - namespaceHash :: UnisonHash, - namespaceSize :: Size + namespaceHash :: UnisonHash } deriving (Generic, Show) @@ -137,12 +139,11 @@ backendListEntryToNamespaceObject ppe typeWidth = \case Backend.ShallowTermEntry te -> TermObject $ Backend.termEntryToNamedTerm ppe typeWidth te Backend.ShallowTypeEntry te -> TypeObject $ Backend.typeEntryToNamedType te - Backend.ShallowBranchEntry name hash size -> + Backend.ShallowBranchEntry name hash _size -> Subnamespace $ NamedNamespace { namespaceName = NameSegment.toText name, - namespaceHash = "#" <> SBH.toText hash, - namespaceSize = size + namespaceHash = "#" <> Hash.toBase32HexText (Causal.unRawHash hash) } Backend.ShallowPatchEntry name -> PatchObject . NamedPatch $ NameSegment.toText name @@ -153,14 +154,26 @@ serve :: Maybe NamespaceFQN -> Maybe NamespaceFQN -> Backend.Backend IO NamespaceListing -serve codebase mayRoot mayRelativeTo mayNamespaceName = +serve codebase mayRootHash mayRelativeTo mayNamespaceName = let -- Various helpers errFromEither f = either (throwError . f) pure + parsePath :: String -> Backend IO Path.Path' parsePath p = errFromEither (`Backend.BadNamespace` p) $ Path.parsePath' p - findShallow branch = Backend.findShallowInBranch codebase branch - + findShallow :: + ( V2Branch.Branch IO -> + IO [Backend.ShallowListEntry Symbol Ann] + ) + findShallow branch = Backend.lsShallowBranch codebase branch + + makeNamespaceListing :: + ( PPE.PrettyPrintEnv -> + UnisonName -> + UnisonHash -> + [Backend.ShallowListEntry Symbol a] -> + ExceptT Backend.BackendError IO NamespaceListing + ) makeNamespaceListing ppe fqn hash entries = pure . NamespaceListing fqn hash $ fmap @@ -168,15 +181,13 @@ serve codebase mayRoot mayRelativeTo mayNamespaceName = entries -- Lookup paths, root and listing and construct response + namespaceListing :: Backend IO NamespaceListing namespaceListing = do - root <- case mayRoot of - Nothing -> lift (Codebase.getRootBranch codebase) + shallowRoot <- case mayRootHash of + Nothing -> liftIO (Codebase.getShallowRootBranch codebase) Just sbh -> do - ea <- liftIO . runExceptT $ do - h <- Backend.expandShortBranchHash codebase sbh - mayBranch <- lift $ Codebase.getBranchForHash codebase h - mayBranch ?? Backend.CouldntLoadBranch h - liftEither ea + h <- Backend.expandShortBranchHash codebase sbh + liftIO $ Codebase.getShallowBranchForHash codebase (Cv.branchHash1to2 h) -- Relative and Listing Path resolution -- @@ -197,14 +208,14 @@ serve codebase mayRoot mayRelativeTo mayNamespaceName = let path = Path.fromPath' relativeToPath' <> Path.fromPath' namespacePath' let path' = Path.toPath' path - -- Actually construct the NamespaceListing - - let listingBranch = Branch.getAt' path root - hashLength <- liftIO $ Codebase.hashLength codebase - - let shallowPPE = Backend.basicSuffixifiedNames hashLength root $ (Backend.Within $ Path.fromPath' path') + listingCausal <- + (liftIO $ Codebase.shallowBranchAtPath path shallowRoot) >>= \case + Nothing -> pure $ Cv.causalbranch1to2 (V1Branch.empty) + Just lc -> pure lc + listingBranch <- liftIO $ V2Causal.value listingCausal + shallowPPE <- liftIO $ Backend.shallowPPE codebase listingBranch let listingFQN = Path.toText . Path.unabsolute . either id (Path.Absolute . Path.unrelative) $ Path.unPath' path' - let listingHash = branchToUnisonHash listingBranch + let listingHash = v2CausalBranchToUnisonHash listingCausal listingEntries <- lift (findShallow listingBranch) makeNamespaceListing shallowPPE listingFQN listingHash listingEntries diff --git a/unison-share-api/src/Unison/Server/Endpoints/Projects.hs b/unison-share-api/src/Unison/Server/Endpoints/Projects.hs index d8bbc6ace3..05061e3fa1 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/Projects.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/Projects.hs @@ -25,13 +25,14 @@ import Servant.Docs ToParam (..), ToSample (..), ) +import qualified U.Util.Hash as Hash import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Causal.Type as Causal import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Path.Parse as Path import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import qualified Unison.Codebase.ShortBranchHash as SBH import qualified Unison.NameSegment as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude @@ -103,12 +104,12 @@ backendListEntryToProjectListing :: Backend.ShallowListEntry Symbol a -> Maybe ProjectListing backendListEntryToProjectListing owner = \case - Backend.ShallowBranchEntry name hash _ -> + Backend.ShallowBranchEntry name hash _size -> Just $ ProjectListing { owner = owner, name = NameSegment.toText name, - hash = "#" <> SBH.toText hash + hash = "#" <> Hash.toBase32HexText (Causal.unRawHash hash) } _ -> Nothing @@ -116,7 +117,7 @@ entryToOwner :: Backend.ShallowListEntry Symbol a -> Maybe ProjectOwner entryToOwner = \case - Backend.ShallowBranchEntry name _ _ -> + Backend.ShallowBranchEntry name _ _size -> Just $ ProjectOwner $ NameSegment.toText name _ -> Nothing @@ -140,7 +141,7 @@ serve codebase mayRoot mayOwner = projects mayBranch ?? Backend.CouldntLoadBranch h liftEither ea - ownerEntries <- findShallow root + ownerEntries <- lift $ findShallow root -- If an owner is provided, we only want projects belonging to them let owners = case mayOwner of @@ -154,14 +155,14 @@ serve codebase mayRoot mayOwner = projects ownerPath' <- (parsePath . Text.unpack) ownerName let path = Path.fromPath' ownerPath' let ownerBranch = Branch.getAt' path root - entries <- findShallow ownerBranch + entries <- lift $ findShallow ownerBranch pure $ mapMaybe (backendListEntryToProjectListing owner) entries -- Minor helpers - findShallow :: Branch.Branch m -> Backend m [Backend.ShallowListEntry Symbol Ann] + findShallow :: Branch.Branch m -> m [Backend.ShallowListEntry Symbol Ann] findShallow branch = - lift (Backend.findShallowInBranch codebase branch) + Backend.lsBranch codebase branch parsePath :: String -> Backend m Path.Path' parsePath p = diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 6769447cc6..60b9c26b0f 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -27,6 +27,9 @@ import Servant.API JSON, addHeader, ) +import qualified U.Codebase.Branch as V2Branch +import qualified U.Codebase.Causal as V2Causal +import qualified U.Codebase.HashTags as V2 import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Causal as Causal import Unison.Codebase.Editor.DisplayObject @@ -265,3 +268,7 @@ setCacheControl = addHeader @"Cache-Control" "public" branchToUnisonHash :: Branch.Branch m -> UnisonHash branchToUnisonHash b = ("#" <>) . Hash.base32Hex . Causal.unRawHash $ Branch.headHash b + +v2CausalBranchToUnisonHash :: V2Branch.CausalBranch m -> UnisonHash +v2CausalBranchToUnisonHash b = + ("#" <>) . Hash.base32Hex . V2.unCausalHash $ V2Causal.causalHash b diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index ba2d81fc7d..a12104d52f 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -93,10 +93,12 @@ library , servant-server , text , transformers + , unison-codebase , unison-core1 , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-util , unison-util-relation , unliftio , uri-encode From 044f6ad727ef81258b279728581b01b6e5a8f008 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 26 Apr 2022 11:46:12 -0400 Subject: [PATCH 164/529] some misc cleanup in sync code --- lib/unison-prelude/src/Unison/Prelude.hs | 10 ++ unison-cli/src/Unison/Share/Sync.hs | 159 +++++++++++------------ 2 files changed, 87 insertions(+), 82 deletions(-) diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index 83025193c9..e9b5b77db5 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -11,6 +11,8 @@ module Unison.Prelude -- * @Maybe@ control flow onNothing, whenNothing, + whenJust, + whenJustM, eitherToMaybe, maybeToEither, @@ -76,6 +78,14 @@ onNothing m may = maybe m pure may whenNothing :: Applicative m => Maybe a -> m a -> m a whenNothing may m = maybe m pure may +whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () +whenJust mx f = + maybe (pure ()) f mx + +whenJustM :: Monad m => m (Maybe a) -> (a -> m ()) -> m () +whenJustM mx f = do + mx >>= maybe (pure ()) f + whenLeft :: Applicative m => Either a b -> (a -> m b) -> m b whenLeft = \case Left a -> \f -> f a diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 38e68862f4..c9296aacb5 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -16,6 +16,7 @@ where import qualified Control.Lens as Lens import Control.Monad.Extra ((||^)) import qualified Data.List.NonEmpty as List.NonEmpty +import Data.Map.NonEmpty (NEMap) import qualified Data.Map.NonEmpty as NEMap import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) @@ -221,77 +222,31 @@ download :: BaseUrl -> Sqlite.Connection -> Share.RepoName -> - -- FIXME mitchell: less decoding if this is a DecodedHashJWT NESet Share.HashJWT -> IO () -download httpClient unisonShareUrl conn repoName = do - let loop :: NESet Share.DecodedHashJWT -> IO () - loop hashes0 = do - Sqlite.runTransaction conn (elaborateHashes (NESet.toSet hashes0) Set.empty) >>= \case - Nothing -> pure () - Just hashes1 -> do - Share.DownloadEntitiesResponse entities <- - Share.downloadEntitiesHandler - httpClient - unisonShareUrl - Share.DownloadEntitiesRequest - { repoName, - hashes = hashes1 - } - - missingDependencies0 <- - Sqlite.runTransaction conn do - NEMap.toList entities & foldMapM \(hash, entity) -> do - -- still trying to figure out missing dependencies of hash/entity. - entityLocation hash >>= \case - EntityInMainStorage -> pure Set.empty - EntityInTempStorage missingDependencies -> - pure (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) - EntityNotStored -> do - -- if it has missing dependencies, add it to temp storage; - -- otherwise add it to main storage. - missingDependencies0 <- - Set.filterM - (entityExists . Share.decodedHashJWTHash) - (Set.map Share.decodeHashJWT (Share.entityDependencies entity)) - case NESet.nonEmptySet missingDependencies0 of - Nothing -> insertEntity hash entity - Just missingDependencies -> insertTempEntity hash entity missingDependencies - pure missingDependencies0 - - case NESet.nonEmptySet missingDependencies0 of - Nothing -> pure () - Just missingDependencies -> loop missingDependencies - in loop . NESet.map Share.decodeHashJWT - ---------- - --- Some remaining work: --- --- [ ] Write resolveHashToEntity - -{- -server sqlite db - -> sqlite object bytes - -> U.Codebase.Sqlite.decomposedComponent [(LocalIds' TextId ObjectId, ByteString)] - -> Sync.Types.Entity.TermComponent - -> cbor bytes - -> network - -> cbor bytes - -> Sync.Types.Entity.TermComponent - |-> temp_entity_missing_dependencies - | - |-> U.Codebase.Sqlite.decomposedComponent [(LocalIds' Text HashJWT, ByteString)] - (not Unison.Sync.Types.LocallyIndexedComponent) - -> serialize -> temp_entity (bytes) - -> time to move to MAIN table!!!! - -> deserialize -> U.Codebase.Sqlite.decomposedComponent [(LocalIds' Text HashJWT, ByteString)] - -> traverse -> U.Codebase.Sqlite.decomposedComponent [(LocalIds' TextId ObjectId, ByteString)] - -> serialize -> sqlite object bytes - --- if we just have a hash for the localids (as opposed to a TypedHash) - --} +download httpClient unisonShareUrl conn repoName = + loop . NESet.map Share.decodeHashJWT + where + loop :: NESet Share.DecodedHashJWT -> IO () + loop hashes0 = + whenJustM (Sqlite.runTransaction conn (elaborateHashes hashes0)) \hashes1 -> do + entities <- doDownload hashes1 + + missingDependencies0 <- + Sqlite.runTransaction conn do + NEMap.toList entities & foldMapM \(hash, entity) -> + upsertEntitySomewhere hash entity + + whenJust (NESet.nonEmptySet missingDependencies0) loop + + doDownload :: NESet Share.HashJWT -> IO (NEMap Share.Hash (Share.Entity Text Share.Hash Share.HashJWT)) + doDownload hashes = do + Share.DownloadEntitiesResponse entities <- + Share.downloadEntitiesHandler + httpClient + unisonShareUrl + Share.DownloadEntitiesRequest {repoName, hashes} + pure entities ------------------------------------------------------------------------------------------------------------------------ -- Database operations @@ -324,25 +279,65 @@ entityLocation hash = Nothing -> EntityNotStored Just missingDependencies -> EntityInTempStorage (NESet.map Share.HashJWT missingDependencies) --- FIXME comment -elaborateHashes :: Set Share.DecodedHashJWT -> Set Share.HashJWT -> Sqlite.Transaction (Maybe (NESet Share.HashJWT)) -elaborateHashes hashes outputs = - case Set.minView hashes of - Nothing -> pure (NESet.nonEmptySet outputs) - Just (Share.DecodedHashJWT (Share.HashJWTClaims {hash}) jwt, hashes') -> - entityLocation hash >>= \case - EntityNotStored -> elaborateHashes hashes' (Set.insert jwt outputs) - EntityInTempStorage missingDependencies -> - elaborateHashes (Set.union (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) hashes') outputs - EntityInMainStorage -> elaborateHashes hashes' outputs - --- FIXME comment +-- | "Elaborate" a set of hashes that we are considering downloading from Unison Share. +-- +-- For each hash, we determine whether we already have that entity in main storage, temp storage, or nowhere: +-- +-- 1. If it's nowhere, we should indeed proceed to download this hash from Unison Share. +-- 2. If it's in temp storage, then we ought to instead download its missing dependencies (which themselves are +-- elaborated by this same procedure, in case we have any of *them* already in temp storage, too. +-- 3. If it's in main storage, we should ignore it. +-- +-- In the end, we return a set of hashes that correspond to entities we actually need to download. +elaborateHashes :: NESet Share.DecodedHashJWT -> Sqlite.Transaction (Maybe (NESet Share.HashJWT)) +elaborateHashes = + let loop hashes outputs = + case Set.minView hashes of + Nothing -> pure (NESet.nonEmptySet outputs) + Just (Share.DecodedHashJWT (Share.HashJWTClaims {hash}) jwt, hashes') -> + entityLocation hash >>= \case + EntityNotStored -> loop hashes' (Set.insert jwt outputs) + EntityInTempStorage missingDependencies -> + loop (Set.union (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) hashes') outputs + EntityInMainStorage -> loop hashes' outputs + in \hashes -> loop (NESet.toSet hashes) Set.empty + +-- | Read an entity out of the database that we know is in main storage. expectEntity :: Share.Hash -> Sqlite.Transaction (Share.Entity Text Share.Hash Share.Hash) expectEntity hash = do syncEntity <- Q.expectEntity (Share.toBase32Hex hash) tempEntity <- Q.syncToTempEntity syncEntity pure (tempEntityToEntity tempEntity) +-- | Upsert a downloaded entity "somewhere" - +-- +-- 1. Nowhere if we already had the entity (in main or temp storage). +-- 2. In main storage if we already have all of its dependencies in main storage. +-- 3. In temp storage otherwise. +-- +-- Returns the set of dependencies we still need to store the entity in main storage (which will be empty if either it +-- was already in main storage, or we just put it in main storage). +upsertEntitySomewhere :: + Share.Hash -> + Share.Entity Text Share.Hash Share.HashJWT -> + Sqlite.Transaction (Set Share.DecodedHashJWT) +upsertEntitySomewhere hash entity = + entityLocation hash >>= \case + EntityInMainStorage -> pure Set.empty + EntityInTempStorage missingDependencies -> + pure (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) + EntityNotStored -> do + -- if it has missing dependencies, add it to temp storage; + -- otherwise add it to main storage. + missingDependencies0 <- + Set.filterM + (entityExists . Share.decodedHashJWTHash) + (Set.map Share.decodeHashJWT (Share.entityDependencies entity)) + case NESet.nonEmptySet missingDependencies0 of + Nothing -> insertEntity hash entity + Just missingDependencies -> insertTempEntity hash entity missingDependencies + pure missingDependencies0 + -- | Insert an entity that doesn't have any missing dependencies. insertEntity :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> Sqlite.Transaction () insertEntity hash entity = do From a6ff8ff8ed49f4f0f7cfe7012cf13040f3c2e9b9 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 27 Apr 2022 16:58:50 -0400 Subject: [PATCH 165/529] add the codebase to LoopState --- .../Codebase/Editor/HandleInput/LoopState.hs | 15 +++++++++++---- .../src/Unison/Codebase/TranscriptParser.hs | 1 + unison-cli/src/Unison/CommandLine/Main.hs | 1 + 3 files changed, 13 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs index 67ce4d5461..ac5d7f3959 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs @@ -13,6 +13,7 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel import qualified Network.HTTP.Client as HTTP import Unison.Auth.CredentialManager (CredentialManager) +import Unison.Codebase (Codebase) import Unison.Codebase.Branch ( Branch (..), ) @@ -28,18 +29,19 @@ import qualified Unison.Util.Free as Free type F m i v = Free (Command m i v) -data Env = Env +data Env m v = Env { authHTTPClient :: HTTP.Manager, + codebase :: Codebase m v Ann, credentialManager :: CredentialManager } -newtype Action m i v a = Action {unAction :: MaybeT (ReaderT Env (StateT (LoopState m v) (F m i v))) a} - deriving newtype (Functor, Applicative, Alternative, Monad, MonadIO, MonadState (LoopState m v), MonadReader Env) +newtype Action m i v a = Action {unAction :: MaybeT (ReaderT (Env m v) (StateT (LoopState m v) (F m i v))) a} + deriving newtype (Functor, Applicative, Alternative, Monad, MonadIO, MonadState (LoopState m v), MonadReader (Env m v)) -- We should likely remove this MonadFail instance since it's really hard to debug, -- but it's currently in use. deriving newtype (MonadFail) -runAction :: Env -> LoopState m v -> Action m i v a -> (F m i v (Maybe a, LoopState m v)) +runAction :: Env m v -> LoopState m v -> Action m i v a -> (F m i v (Maybe a, LoopState m v)) runAction env state (Action m) = m & runMaybeT @@ -116,3 +118,8 @@ respondNumbered output = do args <- eval $ NotifyNumbered output unless (null args) $ numberedArgs .= toList args + +-- | Get the codebase out of the environment. +askCodebase :: Action m i v (Codebase m v Ann) +askCodebase = + asks codebase diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 686f8fe60f..754316d8b3 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -378,6 +378,7 @@ run dir stanzas codebase runtime config ucmVersion = UnliftIO.try $ do let env = LoopState.Env { LoopState.authHTTPClient = error "Error: No access to authorized requests from transcripts.", + LoopState.codebase = codebase, LoopState.credentialManager = error "Error: No access to credentials from transcripts." } let free = LoopState.runAction env state $ HandleInput.loop diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 6d1d89d3e8..70d51fcb0a 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -196,6 +196,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba let env = LoopState.Env { LoopState.authHTTPClient = authorizedHTTPClient, + LoopState.codebase = codebase, LoopState.credentialManager = credMan } let free = LoopState.runAction env state HandleInput.loop From a030736e0acb4773c96477c4a0f65e7b55586378 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 27 Apr 2022 21:23:55 -0400 Subject: [PATCH 166/529] expose sqlite connection in codebase object --- parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs | 3 ++- parser-typechecker/src/Unison/Codebase/Type.hs | 9 ++++++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 0b067ef6b3..ad28c8c556 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -486,7 +486,8 @@ sqliteCodebase debugName root localOrRemote action = do branchHashLength = branchHashLength, branchHashesByPrefix = branchHashesByPrefix, lcaImpl = (Just sqlLca), - beforeImpl = (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r) + beforeImpl = (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r), + connection = conn } let finalizer :: MonadIO m => m () finalizer = do diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index b99fb15865..f760e59807 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -34,6 +34,7 @@ import Unison.Reference (Reference) import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent import Unison.ShortHash (ShortHash) +import qualified Unison.Sqlite as Sqlite import Unison.Term (Term) import Unison.Type (Type) import qualified Unison.WatchKind as WK @@ -164,7 +165,13 @@ data Codebase m v a = Codebase -- `beforeImpl b1 b2` is undefined if `b2` not in the codebase -- -- Use `Codebase.before` which wraps this in a nice API. - beforeImpl :: Maybe (Branch.Hash -> Branch.Hash -> m Bool) + beforeImpl :: Maybe (Branch.Hash -> Branch.Hash -> m Bool), + -- | The SQLite connection this codebase closes over. + -- + -- At one time the codebase was meant to abstract over the storage layer, but it has been cumbersome. Now we prefer + -- to interact with SQLite directly, and so provide this temporary escape hatch, until we can eliminate this + -- interface entirely. + connection :: Sqlite.Connection } -- | Whether a codebase is local or remote. From 607f14a7a28643f3afa69204b0eb6c41bf3ade3b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 27 Apr 2022 21:59:23 -0400 Subject: [PATCH 167/529] sketch out pushing to unison share from HandleInput --- .../src/Unison/Codebase/Editor/HandleInput.hs | 32 ++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f4a6ee941e..207c058dda 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -81,7 +81,7 @@ import qualified Unison.Codebase.SyncMode as SyncMode import Unison.Codebase.TermEdit (TermEdit (..)) import qualified Unison.Codebase.TermEdit as TermEdit import qualified Unison.Codebase.TermEdit.Typing as TermEdit -import Unison.Codebase.Type (GitError) +import Unison.Codebase.Type (Codebase (..), GitError) import qualified Unison.Codebase.TypeEdit as TypeEdit import qualified Unison.Codebase.Verbosity as Verbosity import qualified Unison.CommandLine.DisplayValues as DisplayValues @@ -126,8 +126,11 @@ import Unison.Server.QueryResult import Unison.Server.SearchResult (SearchResult) import qualified Unison.Server.SearchResult as SR import qualified Unison.Server.SearchResult' as SR' +import qualified Unison.Share.Sync as Share import qualified Unison.ShortHash as SH +import qualified Unison.Sqlite as Sqlite import Unison.Symbol (Symbol) +import qualified Unison.Sync.Types as Share (RepoName (..), RepoPath (..), hashJWTHash) import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) @@ -1758,6 +1761,33 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch) PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) +handlePushToUnisonShare :: MonadIO m => Text -> Path -> Action' m v () +handlePushToUnisonShare remoteRepo remotePath = do + let repoPath = Share.RepoPath (Share.RepoName remoteRepo) (coerce @[NameSegment] @[Text] (Path.toList remotePath)) + Codebase {connection} <- LoopState.askCodebase + + liftIO (Share.getCausalHashByPath httpClient unisonShareUrl repoPath) >>= \case + Left err -> undefined + Right causalHashJwt -> do + localCausalHash <- do + localPath <- use LoopState.currentPath + Sqlite.runTransaction connection (undefined (Path.toList (Path.unabsolute localPath))) + liftIO + ( Share.push + httpClient + unisonShareUrl + connection + repoPath + (Share.hashJWTHash <$> causalHashJwt) + localCausalHash + ) + >>= \case + Left pushError -> undefined + Right () -> pure () + where + httpClient = undefined + unisonShareUrl = undefined + -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: forall m v. From 2bbeeaca0e612c7dca7ad852430cc98e62705257 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 28 Apr 2022 11:26:46 -0400 Subject: [PATCH 168/529] decode hash jwts --- unison-share-api/package.yaml | 2 ++ unison-share-api/src/Unison/Sync/Types.hs | 35 +++++++++++++++++++---- unison-share-api/unison-share-api.cabal | 2 ++ 3 files changed, 33 insertions(+), 6 deletions(-) diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 7b35594f8f..c1444162c8 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -19,6 +19,7 @@ dependencies: - fuzzyfind - http-media - http-types + - jwt - lens - lucid - memory @@ -42,6 +43,7 @@ dependencies: - unison-util-base32hex - unison-util-relation - unliftio + - unordered-containers - uri-encode - utf8-string - wai diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 6da3dd408b..4df8e31b14 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -10,16 +10,16 @@ import Data.Bifoldable import Data.Bifunctor import Data.Bitraversable import Data.ByteArray.Encoding (Base (Base64), convertFromBase, convertToBase) -import Data.ByteString (ByteString) -import Data.Function ((&)) +import qualified Data.HashMap.Strict as HashMap import Data.Map.NonEmpty (NEMap) -import Data.Set (Set) +import qualified Data.Map.Strict as Map import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) -import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import U.Util.Base32Hex (Base32Hex (..)) +import Unison.Prelude +import qualified Web.JWT as JWT -- | A newtype for JSON encoding binary data. newtype Base64Bytes = Base64Bytes ByteString @@ -53,11 +53,34 @@ data DecodedHashJWT = DecodedHashJWT -- | Decode a hash JWT. decodeHashJWT :: HashJWT -> DecodedHashJWT -decodeHashJWT = undefined +decodeHashJWT hashJWT = + DecodedHashJWT + { claims = decodeHashJWTClaims hashJWT, + hashJWT + } + +-- | Decode the claims out of a hash JWT. +decodeHashJWTClaims :: HashJWT -> HashJWTClaims +decodeHashJWTClaims (HashJWT text) = + case JWT.decode text of + Nothing -> error "bad JWT" + Just jwt -> + let object = + jwt + & JWT.claims + & JWT.unregisteredClaims + & JWT.unClaimsMap + & Map.toList + & HashMap.fromList + & Aeson.Object + in case Aeson.fromJSON object of + Aeson.Error err -> error ("bad JWT: " ++ err) + Aeson.Success claims -> claims -- | Grab the hash out of a decoded hash JWT. decodedHashJWTHash :: DecodedHashJWT -> Hash -decodedHashJWTHash = undefined +decodedHashJWTHash DecodedHashJWT {claims = HashJWTClaims {hash}} = + hash data HashJWTClaims = HashJWTClaims { hash :: Hash, diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index 7900734310..d443f5d519 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -79,6 +79,7 @@ library , fuzzyfind , http-media , http-types + , jwt , lens , lucid , memory @@ -102,6 +103,7 @@ library , unison-util-base32hex , unison-util-relation , unliftio + , unordered-containers , uri-encode , utf8-string , wai From 5e8f1101f93e85cc852f160dc2f6b182a0aecfab Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 28 Apr 2022 12:00:44 -0400 Subject: [PATCH 169/529] add unison share url to loop state env --- unison-cli/src/Unison/Auth/HTTPClient.hs | 4 ++-- .../src/Unison/Codebase/Editor/HandleInput/LoopState.hs | 9 ++++++--- unison-cli/src/Unison/Codebase/TranscriptParser.hs | 3 ++- unison-cli/src/Unison/CommandLine/Main.hs | 3 ++- 4 files changed, 12 insertions(+), 7 deletions(-) diff --git a/unison-cli/src/Unison/Auth/HTTPClient.hs b/unison-cli/src/Unison/Auth/HTTPClient.hs index 60f22db599..26765332dc 100644 --- a/unison-cli/src/Unison/Auth/HTTPClient.hs +++ b/unison-cli/src/Unison/Auth/HTTPClient.hs @@ -16,14 +16,14 @@ newtype AuthorizedHttpClient = AuthorizedHttpClient HTTP.Manager -- | Returns a new http manager which applies the appropriate Authorization header to -- any hosts our UCM is authenticated with. -newAuthorizedHTTPClient :: MonadIO m => CredentialManager -> UCMVersion -> m HTTP.Manager +newAuthorizedHTTPClient :: MonadIO m => CredentialManager -> UCMVersion -> m AuthorizedHttpClient newAuthorizedHTTPClient credsMan ucmVersion = liftIO $ do let tokenProvider = newTokenProvider credsMan let managerSettings = HTTP.tlsManagerSettings & HTTP.addRequestMiddleware (authMiddleware tokenProvider) & HTTP.setUserAgent (HTTP.ucmUserAgent ucmVersion) - HTTP.newTlsManagerWith managerSettings + AuthorizedHttpClient <$> HTTP.newTlsManagerWith managerSettings -- | Adds Bearer tokens to requests according to their host. -- If a CredentialFailure occurs (failure to refresh a token), auth is simply omitted, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs index ac5d7f3959..3118ec5fac 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs @@ -11,8 +11,9 @@ import Control.Monad.State import Data.Configurator () import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel -import qualified Network.HTTP.Client as HTTP +import Servant.Client (BaseUrl) import Unison.Auth.CredentialManager (CredentialManager) +import Unison.Auth.HTTPClient (AuthorizedHttpClient) import Unison.Codebase (Codebase) import Unison.Codebase.Branch ( Branch (..), @@ -30,9 +31,11 @@ import qualified Unison.Util.Free as Free type F m i v = Free (Command m i v) data Env m v = Env - { authHTTPClient :: HTTP.Manager, + { authHTTPClient :: AuthorizedHttpClient, codebase :: Codebase m v Ann, - credentialManager :: CredentialManager + credentialManager :: CredentialManager, + -- | The URL to Unison Share + unisonShareUrl :: BaseUrl } newtype Action m i v a = Action {unAction :: MaybeT (ReaderT (Env m v) (StateT (LoopState m v) (F m i v))) a} diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 754316d8b3..8093639cf7 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -379,7 +379,8 @@ run dir stanzas codebase runtime config ucmVersion = UnliftIO.try $ do LoopState.Env { LoopState.authHTTPClient = error "Error: No access to authorized requests from transcripts.", LoopState.codebase = codebase, - LoopState.credentialManager = error "Error: No access to credentials from transcripts." + LoopState.credentialManager = error "Error: No access to credentials from transcripts.", + LoopState.unisonShareUrl = error "Error: No access to Unison Share from transcripts." } let free = LoopState.runAction env state $ HandleInput.loop rng i = pure $ Random.drgNewSeed (Random.seedFromInteger (fromIntegral i)) diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 70d51fcb0a..480b297783 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -197,7 +197,8 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba LoopState.Env { LoopState.authHTTPClient = authorizedHTTPClient, LoopState.codebase = codebase, - LoopState.credentialManager = credMan + LoopState.credentialManager = credMan, + LoopState.unisonShareUrl = error "TODO: wire in Unison Share URL" } let free = LoopState.runAction env state HandleInput.loop let handleCommand = From 8efc0152e475bc9542a93e94349cd1e59ec6c294 Mon Sep 17 00:00:00 2001 From: Phil de Joux Date: Thu, 28 Apr 2022 14:30:00 -0400 Subject: [PATCH 170/529] Add missing packages to cabal.project. --- contrib/cabal.project | 57 +++++++++++++++++++++++++++++++++---------- 1 file changed, 44 insertions(+), 13 deletions(-) diff --git a/contrib/cabal.project b/contrib/cabal.project index ac1976c6cb..f66dd97297 100644 --- a/contrib/cabal.project +++ b/contrib/cabal.project @@ -1,17 +1,22 @@ packages: - yaks/easytest - parser-typechecker - unison-core - unison-cli - lib/unison-prelude - lib/unison-util-relation - codebase2/codebase - codebase2/codebase-sqlite - codebase2/codebase-sync - codebase2/core - codebase2/util - codebase2/util-serialization - codebase2/util-term + yaks/easytest + parser-typechecker + unison-core + unison-cli + unison-share-api + + codebase2/codebase + codebase2/codebase-sqlite + codebase2/codebase-sync + codebase2/core + codebase2/util + codebase2/util-serialization + codebase2/util-term + + lib/unison-prelude + lib/unison-sqlite + lib/unison-util-relation + lib/unison-pretty-printer source-repository-package type: git @@ -28,6 +33,11 @@ source-repository-package location: https://github.com/unisonweb/megaparsec.git tag: c4463124c578e8d1074c04518779b5ce5957af6b +source-repository-package + type: git + location: https://github.com/unisonweb/shellmet.git + tag: 2fd348592c8f51bb4c0ca6ba4bc8e38668913746 + allow-newer: haskeline:base @@ -39,6 +49,15 @@ package easytest package parser-typechecker ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info +package unison-core + ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info + +package unison-cli + ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info + +package unison-share-api + ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info + package codebase ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info @@ -60,6 +79,18 @@ package util-serialization package util-term ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info +package unison-prelude + ghc-options: -Wall -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info + +package unison-sqlite + ghc-options: -Wall -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info + +package unison-util-relation + ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info + +package unison-pretty-printer + ghc-options: -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info + -- This options are applied to all packages, local ones and also external dependencies. package * ghc-options: -haddock From 422ee31a2916dd45d378127a8077bd4a18c5dffa Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 29 Apr 2022 16:15:15 -0400 Subject: [PATCH 171/529] write loadCausalHashAtPath --- .../U/Codebase/Sqlite/Operations.hs | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index b48790bfea..5a370cd680 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -4,6 +4,7 @@ module U.Codebase.Sqlite.Operations loadRootCausalHash, expectRootCausalHash, expectRootCausal, + loadCausalHashAtPath, saveBranch, loadCausalBranchByCausalHash, expectCausalBranchByCausalHash, @@ -196,6 +197,23 @@ loadRootCausalHash = runMaybeT $ lift . Q.expectCausalHash =<< MaybeT Q.loadNamespaceRoot +-- | Load the causal hash at the given path from the root. +-- +-- FIXME should we move some Path type here? +loadCausalHashAtPath :: [Text] -> Transaction (Maybe CausalHash) +loadCausalHashAtPath = + let go :: Db.CausalHashId -> [Text] -> MaybeT Transaction CausalHash + go hashId = \case + [] -> lift (Q.expectCausalHash hashId) + t : ts -> do + tid <- MaybeT (Q.loadTextId t) + S.Branch{children} <- MaybeT (loadDbBranchByCausalHashId hashId) + (_, hashId') <- MaybeT (pure (Map.lookup tid children)) + go hashId' ts + in \path -> do + hashId <- Q.expectNamespaceRoot + runMaybeT (go hashId path) + -- * Reference transformations -- ** read existing references @@ -946,6 +964,13 @@ expectBranchByCausalHashId id = do boId <- Q.expectBranchObjectIdByCausalHashId id expectBranch boId +-- | Load a branch value given its causal hash id. +loadDbBranchByCausalHashId :: Db.CausalHashId -> Transaction (Maybe S.DbBranch) +loadDbBranchByCausalHashId causalHashId = + Q.loadBranchObjectIdByCausalHashId causalHashId >>= \case + Nothing -> pure Nothing + Just branchObjectId -> Just <$> expectDbBranch branchObjectId + expectDbBranch :: Db.BranchObjectId -> Transaction S.DbBranch expectDbBranch id = deserializeBranchObject id >>= \case From d8f1a7870b3728c3d1434ada32c618e77f682138 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 29 Apr 2022 19:06:53 -0400 Subject: [PATCH 172/529] restore `-Wtype-defaults` --- parser-typechecker/src/Unison/Codebase.hs | 3 ++- .../src/Unison/Codebase/SqliteCodebase.hs | 2 +- .../src/Unison/Codebase/SqliteCodebase/Conversions.hs | 2 +- parser-typechecker/src/Unison/Lexer.hs | 2 +- parser-typechecker/src/Unison/Runtime/ANF.hs | 3 ++- parser-typechecker/src/Unison/Runtime/Serialize.hs | 2 +- parser-typechecker/src/Unison/TermParser.hs | 6 +++--- parser-typechecker/src/Unison/Typechecker/Context.hs | 10 +++++----- stack.yaml | 2 +- unison-cli/src/Unison/Codebase/Editor/Propagate.hs | 10 +++++----- unison-cli/src/Unison/Codebase/TranscriptParser.hs | 2 +- unison-cli/src/Unison/CommandLine/OutputMessages.hs | 1 + unison-core/src/Unison/HashQualified.hs | 7 ++++--- unison-core/src/Unison/Reference.hs | 2 +- 14 files changed, 29 insertions(+), 25 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 748aa169cb..2df71adab6 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -173,7 +173,8 @@ getBranchForHash :: Monad m => Codebase m v a -> Branch.Hash -> m (Maybe (Branch getBranchForHash codebase h = -- Attempt to find the Branch in the current codebase cache and root up to 3 levels deep -- If not found, attempt to find it in the Codebase (sqlite) - let nestedChildrenForDepth depth b = + let nestedChildrenForDepth :: Int -> Branch m -> [Branch m] + nestedChildrenForDepth depth b = if depth == 0 then [] else b : (Map.elems (Branch._children (Branch.head b)) >>= nestedChildrenForDepth (depth - 1)) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 0b067ef6b3..d614e64f2d 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -240,7 +240,7 @@ sqliteCodebase debugName root localOrRemote action = do -- option 3: switch from putTerm to putTermComponent -- needs to buffer dependencies non-locally (or require application to manage + die horribly) putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m () - putTerm id tm tp | debug && trace (show "SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined + putTerm id tm tp | debug && trace ("SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined putTerm id tm tp = Sqlite.runTransaction conn (CodebaseOps.putTerm termBuffer declBuffer id tm tp) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs index 4bf1b25fb9..2a1a0f0066 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs @@ -219,7 +219,7 @@ decl2to1 h (V2.Decl.DataDeclaration dt m bound cts) = goCT = \case V2.Decl.Data -> Right V2.Decl.Effect -> Left . V1.Decl.EffectDeclaration - cts' = map mkCtor (zip cts [0 ..]) + cts' = map mkCtor (zip cts [0 :: V2.Decl.ConstructorId ..]) mkCtor (type1, i) = (Ann.External, V1.symbol . pack $ "Constructor" ++ show i, type2) where diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 4a48a170e8..a683bce06c 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -830,7 +830,7 @@ lexemes' eof = where intOrNat = P.try $ num <$> sign <*> LP.decimal float = do - _ <- P.try (P.lookAhead (sign >> LP.decimal >> (char '.' <|> char 'e' <|> char 'E'))) -- commit after this + _ <- P.try (P.lookAhead (sign >> (LP.decimal :: P Int) >> (char '.' <|> char 'e' <|> char 'E'))) -- commit after this start <- pos sign <- fromMaybe "" <$> sign base <- P.takeWhile1P (Just "base") isDigit diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index f7406a6624..befffdc9b2 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -1716,7 +1716,7 @@ prettyBranches ind bs = case bs of s (mapToList $ snd <$> m) ) - (prettyCase ind (prettyReq 0 0) df id) + (prettyCase ind (prettyReq (0::Int) (0::Int)) df id) (Map.toList bs) MatchSum bs -> foldr @@ -1725,6 +1725,7 @@ prettyBranches ind bs = case bs of (mapToList $ snd <$> bs) -- _ -> error "prettyBranches: todo" where + -- prettyReq :: Reference -> CTag -> ShowS prettyReq r c = showString "REQ(" . shows r diff --git a/parser-typechecker/src/Unison/Runtime/Serialize.hs b/parser-typechecker/src/Unison/Runtime/Serialize.hs index 5e0a68f48e..735f2a418b 100644 --- a/parser-typechecker/src/Unison/Runtime/Serialize.hs +++ b/parser-typechecker/src/Unison/Runtime/Serialize.hs @@ -41,7 +41,7 @@ unknownTag t w = exn $ "unknown " ++ t ++ " word: " ++ show w ++ " (" - ++ show (fromIntegral r) + ++ show (fromIntegral @_ @Int r) ++ " bytes remaining)" class Tag t where diff --git a/parser-typechecker/src/Unison/TermParser.hs b/parser-typechecker/src/Unison/TermParser.hs index 0a412846d7..84c2802a85 100644 --- a/parser-typechecker/src/Unison/TermParser.hs +++ b/parser-typechecker/src/Unison/TermParser.hs @@ -1073,9 +1073,9 @@ data BlockElement v | Action (Term v Ann) instance Show v => Show (BlockElement v) where - show (Binding ((pos, name), _)) = show ("binding: ", pos, name) - show (DestructuringBind (pos, _)) = show ("destructuring bind: ", pos) - show (Action tm) = show ("action: ", ann tm) + show (Binding ((pos, name), _)) = show ("binding: " :: Text, pos, name) + show (DestructuringBind (pos, _)) = show ("destructuring bind: " :: Text, pos) + show (Action tm) = show ("action: " :: Text, ann tm) -- subst -- use Foo.Bar + blah diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index ff6938ef07..1c552407f3 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -1942,7 +1942,7 @@ defaultAbility _ = pure False -- Expects a fully substituted type, so that it is unnecessary to -- check if an existential in the type has been solved. discardCovariant :: Var v => Set v -> Type v loc -> Type v loc -discardCovariant _ ty | debugShow ("discardCovariant", ty) = undefined +discardCovariant _ ty | debugShow ("discardCovariant" :: Text, ty) = undefined discardCovariant gens ty = ABT.rewriteDown (strip $ keepVarsT True ty) ty where @@ -2385,7 +2385,7 @@ refineEffectVar :: Type v loc -> M v loc () refineEffectVar _ es _ v _ - | debugShow ("refineEffectVar", es, v) = undefined + | debugShow ("refineEffectVar" :: Text, es, v) = undefined refineEffectVar _ [] _ _ _ = pure () refineEffectVar l es blank v tv | ev <- TypeVar.Existential blank v, @@ -2595,7 +2595,7 @@ pruneAbilities :: [Type v loc] -> M v loc (Wanted v loc) pruneAbilities want0 have0 - | debugShow ("pruneAbilities", want0, have0) = undefined + | debugShow ("pruneAbilities" :: Text, want0, have0) = undefined pruneAbilities want0 have0 = do pwant <- pruneConcrete missing [] want0 have0 if pwant /= want0 @@ -2645,7 +2645,7 @@ equateAbilities :: [Type v loc] -> M v loc () equateAbilities abs1 abs2 - | debugShow ("equateAbilities", abs1, abs2) = undefined + | debugShow ("equateAbilities" :: Text, abs1, abs2) = undefined equateAbilities ls rs = matchAbilities ls rs >>= \(com, ls, rs) -> let (vls, cls) = partition isExistential ls @@ -2704,7 +2704,7 @@ subAbilities :: [Type v loc] -> M v loc () subAbilities want have - | debugShow ("subAbilities", want, have) = undefined + | debugShow ("subAbilities" :: Text, want, have) = undefined subAbilities want have = do want <- expandWanted want have <- expandAbilities have diff --git a/stack.yaml b/stack.yaml index 1abc629fee..b640805574 100644 --- a/stack.yaml +++ b/stack.yaml @@ -53,7 +53,7 @@ extra-deps: ghc-options: # All packages - "$locals": -Wall -Werror -Wno-name-shadowing -Wno-type-defaults -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info #-freverse-errors + "$locals": -Wall -Werror -Wno-name-shadowing -Wno-missing-pattern-synonym-signatures -fprint-expanded-synonyms -fwrite-ide-info #-freverse-errors # See https://github.com/haskell/haskell-language-server/issues/208 "$everything": -haddock diff --git a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs index 923ed22378..76d1210052 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Propagate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Propagate.hs @@ -133,7 +133,7 @@ propagateCtorMapping oldComponent newComponent = let oldCon = Referent.Con (ConstructorReference oldR oldC) t newCon = Referent.Con (ConstructorReference newR newC) t ] - in if debugMode then traceShow ("constructorMappings", r) r else r + in if debugMode then traceShow ("constructorMappings" :: Text, r) r else r -- TODO: Use of this function will go away soon, once constructor mappings can be -- added directly to the patch. @@ -160,7 +160,7 @@ genInitialCtorMapping rootNames initialTypeReplacements = do -- True if the unqualified versions of the names in the two sets overlap -- ex: {foo.bar, foo.baz} matches the set {blah.bar}. unqualifiedNamesMatch :: Set Name.Name -> Set Name.Name -> Bool - unqualifiedNamesMatch n1 n2 | debugMode && traceShow ("namesMatch", n1, n2) False = undefined + unqualifiedNamesMatch n1 n2 | debugMode && traceShow ("namesMatch" :: Text, n1, n2) False = undefined unqualifiedNamesMatch n1 n2 = (not . Set.null) ( Set.intersection @@ -200,7 +200,7 @@ genInitialCtorMapping rootNames initialTypeReplacements = do || (isSingleton (Decl.asDataDecl oldDecl) && isSingleton newDecl), oldR /= newR ] - in if debugMode then traceShow ("constructorMappings", r) r else r + in if debugMode then traceShow ("constructorMappings" :: Text, r) r else r debugMode :: Bool debugMode = False @@ -300,7 +300,7 @@ propagate rootNames patch b = case validatePatch patch of [ referentName old <> " -> " <> referentName new | (old, new) <- Map.toList constructorReplacements ] - go r _ | debugMode && traceShow ("Rewriting: ", refName r) False = undefined + go r _ | debugMode && traceShow ("Rewriting: " :: Text, refName r) False = undefined go _ _ | debugMode && trace ("** Constructor replacements:\n\n" <> debugCtors) False = undefined go r todo = if Map.member r termEdits || Set.member r seen || Map.member r typeEdits @@ -373,7 +373,7 @@ propagate rootNames patch b = case validatePatch patch of traverse_ (\(Reference.DerivedId id, tp) -> eval $ PutDecl id tp) !newCtorMappings = let r = propagateCtorMapping componentMap hashedComponents' - in if debugMode then traceShow ("constructorMappings: ", r) r else r + in if debugMode then traceShow ("constructorMappings: " :: Text, r) r else r constructorReplacements' = constructorReplacements <> newCtorMappings writeTypes $ Map.toList newNewTypes pure diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 686f8fe60f..aa26a808da 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -204,7 +204,7 @@ run dir stanzas codebase runtime config ucmVersion = UnliftIO.try $ do allowErrors <- newIORef False hasErrors <- newIORef False mStanza <- newIORef Nothing - traverse_ (atomically . Q.enqueue inputQueue) (stanzas `zip` [1 ..]) + traverse_ (atomically . Q.enqueue inputQueue) (stanzas `zip` [1 :: Int ..]) let patternMap = Map.fromList $ validInputs diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 3bb4632aa8..9fd15eed6b 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -350,6 +350,7 @@ notifyNumbered o = case o of toSBH :: Branch.Hash -> ShortBranchHash toSBH h = SBH.fromHash sbhLength h reversedHistory = reverse history + showNum :: Int -> Pretty showNum n = P.shown n <> ". " handleTail :: Int -> (Pretty, [Branch.Hash]) handleTail n = case tail of diff --git a/unison-core/src/Unison/HashQualified.hs b/unison-core/src/Unison/HashQualified.hs index e26db8e917..feec8ebad7 100644 --- a/unison-core/src/Unison/HashQualified.hs +++ b/unison-core/src/Unison/HashQualified.hs @@ -54,9 +54,10 @@ toName = \case sortByLength :: [HashQualified Name] -> [HashQualified Name] sortByLength hs = sortOn f hs where - f (NameOnly n) = (length (Name.reverseSegments n), 0, Left n) - f (HashQualified n _h) = (length (Name.reverseSegments n), 1, Left n) - f (HashOnly h) = (maxBound, 0, Right h) + f :: HashQualified Name -> (Int, Int) + f (NameOnly n) = (length (Name.reverseSegments n), 0) + f (HashQualified n _h) = (length (Name.reverseSegments n), 1) + f (HashOnly _h) = (maxBound, 0) hasName, hasHash :: HashQualified Name -> Bool hasName = isJust . toName diff --git a/unison-core/src/Unison/Reference.hs b/unison-core/src/Unison/Reference.hs index 6f8df4919b..7ba416e9f7 100644 --- a/unison-core/src/Unison/Reference.hs +++ b/unison-core/src/Unison/Reference.hs @@ -149,7 +149,7 @@ type CycleSize = Word64 -- enumerate the `a`s and associates them with corresponding `Reference.Id`s componentFor :: H.Hash -> [a] -> [(Id, a)] -componentFor h as = [(Id h i, a) | (fromIntegral -> i, a) <- zip [0 ..] as] +componentFor h as = [(Id h i, a) | (i, a) <- zip [0 ..] as] componentFromLength :: H.Hash -> CycleSize -> Set Id componentFromLength h size = Set.fromList [Id h i | i <- [0 .. size - 1]] From 1d90f451694eb5dabe15bd62984e5238575d21eb Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 30 Apr 2022 11:36:25 -0400 Subject: [PATCH 173/529] add sha256 hash for fuzzyfind-3.0.0 --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 1abc629fee..a8fb1e37fc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -43,7 +43,7 @@ extra-deps: - prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 - sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 - strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 -- fuzzyfind-3.0.0 +- fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 - monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 - NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 # not in lts-18.13 From e1bb80722afcf3c7ea4936dc4d0d2c08ec6eb622 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 30 Apr 2022 13:03:53 -0400 Subject: [PATCH 174/529] more push.share work --- .../U/Codebase/Sqlite/Operations.hs | 24 +++++++++++++++++++ .../src/Unison/Codebase/Editor/HandleInput.hs | 20 ++++++++++------ 2 files changed, 37 insertions(+), 7 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 5a370cd680..e741143ab8 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -5,6 +5,7 @@ module U.Codebase.Sqlite.Operations expectRootCausalHash, expectRootCausal, loadCausalHashAtPath, + expectCausalHashAtPath, saveBranch, loadCausalBranchByCausalHash, expectCausalBranchByCausalHash, @@ -214,6 +215,23 @@ loadCausalHashAtPath = hashId <- Q.expectNamespaceRoot runMaybeT (go hashId path) +-- | Expect the causal hash at the given path from the root. +-- +-- FIXME should we move some Path type here? +expectCausalHashAtPath :: [Text] -> Transaction CausalHash +expectCausalHashAtPath = + let go :: Db.CausalHashId -> [Text] -> Transaction CausalHash + go hashId = \case + [] -> Q.expectCausalHash hashId + t : ts -> do + tid <- Q.expectTextId t + S.Branch{children} <- expectDbBranchByCausalHashId hashId + let (_, hashId') = children Map.! tid + go hashId' ts + in \path -> do + hashId <- Q.expectNamespaceRoot + go hashId path + -- * Reference transformations -- ** read existing references @@ -971,6 +989,12 @@ loadDbBranchByCausalHashId causalHashId = Nothing -> pure Nothing Just branchObjectId -> Just <$> expectDbBranch branchObjectId +-- | Expect a branch value given its causal hash id. +expectDbBranchByCausalHashId :: Db.CausalHashId -> Transaction S.DbBranch +expectDbBranchByCausalHashId causalHashId = do + branchObjectId <- Q.expectBranchObjectIdByCausalHashId causalHashId + expectDbBranch branchObjectId + expectDbBranch :: Db.BranchObjectId -> Transaction S.DbBranch expectDbBranch id = deserializeBranchObject id >>= \case diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 207c058dda..36f34b940b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -11,6 +11,7 @@ where import qualified Control.Error.Util as ErrorUtil import Control.Lens import Control.Monad.Except (ExceptT (..), runExceptT, throwError, withExceptT) +import Control.Monad.Reader (ask) import Control.Monad.State (StateT) import qualified Control.Monad.State as State import Data.Bifunctor (first, second) @@ -27,11 +28,13 @@ import qualified Data.Set.NonEmpty as NESet import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) import qualified Text.Megaparsec as P +import U.Codebase.HashTags (CausalHash) import U.Util.Timing (unsafeTime) import qualified Unison.ABT as ABT import Unison.Auth.Types (Host (Host)) import qualified Unison.Builtin as Builtin import qualified Unison.Builtin.Decls as DD +import qualified U.Codebase.Sqlite.Operations as Ops import qualified Unison.Builtin.Terms as Builtin import Unison.Codebase (Preprocessing (..), PushGitBranchOpts (..)) import Unison.Codebase.Branch (Branch (..), Branch0 (..)) @@ -1764,17 +1767,23 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do handlePushToUnisonShare :: MonadIO m => Text -> Path -> Action' m v () handlePushToUnisonShare remoteRepo remotePath = do let repoPath = Share.RepoPath (Share.RepoName remoteRepo) (coerce @[NameSegment] @[Text] (Path.toList remotePath)) - Codebase {connection} <- LoopState.askCodebase - liftIO (Share.getCausalHashByPath httpClient unisonShareUrl repoPath) >>= \case + LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask + + -- First, get the remote causal's hash at the requested path. This effectively gives `push.share` force-push + -- semantics, as the user doesn't provide the expected remote hash themselves, ala `git push --force-with-lease`. + -- Then, with our trusty remote causal hash, do the push. + + liftIO (Share.getCausalHashByPath authHTTPClient unisonShareUrl repoPath) >>= \case Left err -> undefined Right causalHashJwt -> do localCausalHash <- do localPath <- use LoopState.currentPath - Sqlite.runTransaction connection (undefined (Path.toList (Path.unabsolute localPath))) + Sqlite.runTransaction connection do + Ops.expectCausalHashAtPath (coerce @[NameSegment] @[Text] (Path.toList (Path.unabsolute localPath))) liftIO ( Share.push - httpClient + authHTTPClient unisonShareUrl connection repoPath @@ -1784,9 +1793,6 @@ handlePushToUnisonShare remoteRepo remotePath = do >>= \case Left pushError -> undefined Right () -> pure () - where - httpClient = undefined - unisonShareUrl = undefined -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: From 17b133c833378860a055e7d2538b1bde63cb4ec9 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 30 Apr 2022 13:11:07 -0400 Subject: [PATCH 175/529] add some type annotations on tests --- parser-typechecker/tests/Unison/Core/Test/Name.hs | 3 ++- parser-typechecker/tests/Unison/Test/ANF.hs | 15 +++++++++------ parser-typechecker/tests/Unison/Test/Cache.hs | 2 +- 3 files changed, 12 insertions(+), 8 deletions(-) diff --git a/parser-typechecker/tests/Unison/Core/Test/Name.hs b/parser-typechecker/tests/Unison/Core/Test/Name.hs index 981c299fa6..55e2c24ab5 100644 --- a/parser-typechecker/tests/Unison/Core/Test/Name.hs +++ b/parser-typechecker/tests/Unison/Core/Test/Name.hs @@ -74,7 +74,8 @@ testSuffixes = testSuffixSearch :: [Test ()] testSuffixSearch = [ do - let rel = + let rel :: R.Relation Name Int + rel = R.fromList [ (n "base.List.map", 1), (n "base.Set.map", 2), diff --git a/parser-typechecker/tests/Unison/Test/ANF.hs b/parser-typechecker/tests/Unison/Test/ANF.hs index b6403008c8..714616f283 100644 --- a/parser-typechecker/tests/Unison/Test/ANF.hs +++ b/parser-typechecker/tests/Unison/Test/ANF.hs @@ -1,10 +1,12 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE TypeApplications #-} module Unison.Test.ANF where import Control.Monad.Reader (ReaderT (..)) import Control.Monad.State (evalState) +import Data.Int (Int64) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Word (Word64) @@ -88,7 +90,7 @@ denormalize (TApp f args) | FCon r 0 <- f, r `elem` [Ty.natRef, Ty.intRef], [v] <- args = - Term.var () v + Term.var () v denormalize (TApp f args) = Term.apps' df (Term.var () <$> args) where df = case f of @@ -120,16 +122,16 @@ denormalizeMatch :: denormalizeMatch b | MatchEmpty <- b = [] | MatchIntegral m df <- b = - (dcase (ipat Ty.intRef) <$> mapToList m) ++ dfcase df + (dcase (ipat @Int64 Ty.intRef) <$> mapToList m) ++ dfcase df | MatchText m df <- b = - (dcase (const $ P.Text () . Util.Text.toText) <$> Map.toList m) ++ dfcase df + (dcase (const $ P.Text () . Util.Text.toText) <$> Map.toList m) ++ dfcase df | MatchData r cs Nothing <- b, [(0, ([UN], zb))] <- mapToList cs, TAbs i (TMatch j (MatchIntegral m df)) <- zb, i == j = - (dcase (ipat r) <$> mapToList m) ++ dfcase df + (dcase (ipat r) <$> mapToList m) ++ dfcase df | MatchData r m df <- b = - (dcase (dpat r) . fmap snd <$> mapToList m) ++ dfcase df + (dcase (dpat r) . fmap snd <$> mapToList m) ++ dfcase df | MatchRequest hs df <- b = denormalizeHandler hs df | MatchSum _ <- b = error "MatchSum not a compilation target" where @@ -141,6 +143,7 @@ denormalizeMatch b where (n, dbr) = denormalizeBranch br + ipat :: Integral a => Reference -> p -> a -> P.Pattern () ipat r _ i | r == Ty.natRef = P.Nat () $ fromIntegral i | otherwise = P.Int () $ fromIntegral i @@ -170,7 +173,7 @@ denormalizeHandler cs df = dcs db ] where - (_, db) = denormalizeBranch df + (_, db) = denormalizeBranch @Int df rf r rcs = foldMapWithKey (cf r) rcs cf r t b = [ Term.MatchCase diff --git a/parser-typechecker/tests/Unison/Test/Cache.hs b/parser-typechecker/tests/Unison/Test/Cache.hs index 6f031a9f2f..df0522a4bf 100644 --- a/parser-typechecker/tests/Unison/Test/Cache.hs +++ b/parser-typechecker/tests/Unison/Test/Cache.hs @@ -59,7 +59,7 @@ test = -- fully populated, concurrent reads should generate no further misses concurrent mkCache = do cache <- io $ mkCache - misses <- io $ newTVarIO 0 + misses :: TVar Int <- io $ newTVarIO 0 let f x = do atomically $ modifyTVar misses (+ 1) pure x From ca006c6f7c4209fc011de014373dca15d3ad2f31 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 30 Apr 2022 18:31:59 -0400 Subject: [PATCH 176/529] push/pull work --- .../src/Unison/Codebase/Editor/HandleInput.hs | 64 +++++++++++++------ 1 file changed, 44 insertions(+), 20 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 36f34b940b..68b43ff011 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -29,12 +29,12 @@ import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) import qualified Text.Megaparsec as P import U.Codebase.HashTags (CausalHash) +import qualified U.Codebase.Sqlite.Operations as Ops import U.Util.Timing (unsafeTime) import qualified Unison.ABT as ABT import Unison.Auth.Types (Host (Host)) import qualified Unison.Builtin as Builtin import qualified Unison.Builtin.Decls as DD -import qualified U.Codebase.Sqlite.Operations as Ops import qualified Unison.Builtin.Terms as Builtin import Unison.Codebase (Preprocessing (..), PushGitBranchOpts (..)) import Unison.Codebase.Branch (Branch (..), Branch0 (..)) @@ -133,7 +133,14 @@ import qualified Unison.Share.Sync as Share import qualified Unison.ShortHash as SH import qualified Unison.Sqlite as Sqlite import Unison.Symbol (Symbol) -import qualified Unison.Sync.Types as Share (RepoName (..), RepoPath (..), hashJWTHash) +import qualified Unison.Sync.Types as Share + ( Hash, + HashMismatch (..), + RepoName (..), + RepoPath (..), + hashJWTHash, + ) +import qualified Unison.Sync.Types as Share.TypedHash (TypedHash (..)) import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) @@ -1696,6 +1703,18 @@ handleGist :: MonadUnliftIO m => GistInput -> Action' m v () handleGist (GistInput repo) = doPushRemoteBranch repo Path.relativeEmpty' SyncMode.ShortCircuit Nothing +handlePullFromUnisonShare :: MonadIO m => Text -> Path -> Action' m v () +handlePullFromUnisonShare remoteRepo remotePath = do + let repoPath = Share.RepoPath (Share.RepoName remoteRepo) (coerce @[NameSegment] @[Text] (Path.toList remotePath)) + + LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask + + liftIO (Share.pull authHTTPClient unisonShareUrl connection repoPath) >>= \case + Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined + Right Nothing -> undefined + Right (Just causalHash) -> do + undefined + -- | Handle a @push@ command. handlePushRemoteBranch :: forall m v. @@ -1774,26 +1793,31 @@ handlePushToUnisonShare remoteRepo remotePath = do -- semantics, as the user doesn't provide the expected remote hash themselves, ala `git push --force-with-lease`. -- Then, with our trusty remote causal hash, do the push. - liftIO (Share.getCausalHashByPath authHTTPClient unisonShareUrl repoPath) >>= \case - Left err -> undefined - Right causalHashJwt -> do - localCausalHash <- do - localPath <- use LoopState.currentPath - Sqlite.runTransaction connection do - Ops.expectCausalHashAtPath (coerce @[NameSegment] @[Text] (Path.toList (Path.unabsolute localPath))) - liftIO - ( Share.push - authHTTPClient - unisonShareUrl - connection - repoPath - (Share.hashJWTHash <$> causalHashJwt) - localCausalHash - ) - >>= \case - Left pushError -> undefined + localCausalHash <- do + localPath <- use LoopState.currentPath + Sqlite.runTransaction connection do + Ops.expectCausalHashAtPath (coerce @[NameSegment] @[Text] (Path.toList (Path.unabsolute localPath))) + + let doPush :: Maybe Share.Hash -> IO () + doPush expectedHash = + Share.push authHTTPClient unisonShareUrl connection repoPath expectedHash localCausalHash >>= \case + Left pushError -> + case pushError of + -- Race condition: inbetween getting the remote causal hash and attempting to overwrite it, it changed. + -- So, because this push has force-push semantics anyway, just loop again with the latest known remote + -- causal hash and attempt the push again. + Share.PushErrorHashMismatch Share.HashMismatch {actualHash} -> + doPush (Share.TypedHash.hash <$> actualHash) + Share.PushErrorNoWritePermission _ -> undefined + -- Meh; bug in client or server? Even though we (thought we) pushed all of the entities we were supposed + -- to, the server still said it was missing some when we tried to set the remote causal hash. + Share.PushErrorServerMissingDependencies missingDependencies -> undefined Right () -> pure () + liftIO (Share.getCausalHashByPath authHTTPClient unisonShareUrl repoPath) >>= \case + Left (Share.GetCausalHashByPathErrorNoReadPermission _) -> undefined + Right causalHashJwt -> liftIO (doPush (Share.hashJWTHash <$> causalHashJwt)) + -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: forall m v. From 0a53bd1c4f7c483436ec70c977bb2ebdf18a3c7b Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 30 Apr 2022 22:30:40 -0400 Subject: [PATCH 177/529] forgot to include stack.yaml.lock --- stack.yaml.lock | 76 ++++++++++++++++++++++++------------------------- 1 file changed, 38 insertions(+), 38 deletions(-) diff --git a/stack.yaml.lock b/stack.yaml.lock index a052f7bd63..07ed778d63 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,122 +5,122 @@ packages: - completed: + sha256: d4fd87fb7bfc5d8e9fbc3e4ee7302c6b1500cdc00fdb9b659d0f4849b6ebe2d5 + name: configurator size: 15989 url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz - name: configurator - version: 0.3.0.0 - sha256: d4fd87fb7bfc5d8e9fbc3e4ee7302c6b1500cdc00fdb9b659d0f4849b6ebe2d5 pantry-tree: - size: 955 sha256: 90547cd983fd15ebdc803e057d3ef8735fe93a75e29a00f8a74eadc13ee0f6e9 + size: 955 + version: 0.3.0.0 original: url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz - completed: + sha256: 6d44207a4e94a16bc99d13dccbbb79bf676190c0476436b03235eeeaf6c72f9d + name: haskeline size: 75098 url: https://github.com/unisonweb/haskeline/archive/2944b11d19ee034c48276edc991736105c9d6143.tar.gz - name: haskeline - version: 0.7.5.0 - sha256: 6d44207a4e94a16bc99d13dccbbb79bf676190c0476436b03235eeeaf6c72f9d pantry-tree: - size: 3717 sha256: 878c7fb5801ec7418761a49b529ca3fdab274f22707c7d2759f2b3a2df06c3ea + size: 3717 + version: 0.7.5.0 original: url: https://github.com/unisonweb/haskeline/archive/2944b11d19ee034c48276edc991736105c9d6143.tar.gz - completed: + sha256: 94f9573735fefda868371ff735a6b1f52bea22b9e52289abeb8114c99bbf8832 + name: megaparsec size: 92490 url: https://github.com/unisonweb/megaparsec/archive/c4463124c578e8d1074c04518779b5ce5957af6b.tar.gz - name: megaparsec - version: 6.5.0 - sha256: 94f9573735fefda868371ff735a6b1f52bea22b9e52289abeb8114c99bbf8832 pantry-tree: - size: 2635 sha256: 7d3f8b23c862d878b4adce628caaf7bc337f0ac10b2556e1cdf0913c28a45929 + size: 2635 + version: 6.5.0 original: url: https://github.com/unisonweb/megaparsec/archive/c4463124c578e8d1074c04518779b5ce5957af6b.tar.gz - completed: + sha256: 6e642163070a217cc3363bdbefde571ff6c1878f4fc3d92e9c910db7fa88eaf2 + name: shellmet size: 10460 url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz - name: shellmet - version: 0.0.4.0 - sha256: 6e642163070a217cc3363bdbefde571ff6c1878f4fc3d92e9c910db7fa88eaf2 pantry-tree: - size: 654 sha256: 05a169a7a6b68100630e885054dc1821d31cd06571b0317ec90c75ac2c41aeb7 + size: 654 + version: 0.0.4.0 original: url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz - completed: - hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 pantry-tree: - size: 364 sha256: a33838b7b1c54f6ac3e1b436b25674948713a4189658e4d82e639b9a689bc90d + size: 364 + hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 original: hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 - completed: - hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 pantry-tree: - size: 476 sha256: a03f60a1250c9d0daaf208ba58ccf24e05e0807f2e3dc7892fad3f2f3a196f7f + size: 476 + hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 original: hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 - completed: - hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 pantry-tree: - size: 3455 sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350 + size: 3455 + hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 original: hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 - completed: - hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 pantry-tree: - size: 212 sha256: 876e5a679244143e2a7e74357427c7522a8d61f68a4cc3ae265fe4960b75a2e2 + size: 212 + hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 original: hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 - completed: - hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 pantry-tree: - size: 542 sha256: 0e6c6d4f89083c8385de5adc4f36ad01b2b0ff45261b47f7d90d919969c8b5ed + size: 542 + hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 original: - hackage: fuzzyfind-3.0.0 + hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 - completed: - hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 pantry-tree: - size: 713 sha256: 8e049bd12ce2bd470909578f2ee8eb80b89d5ff88860afa30e29dd4eafecfa3e + size: 713 + hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 original: hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 - completed: - hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 pantry-tree: - size: 363 sha256: d33d603a2f0d1a220ff0d5e7edb6273def89120e6bb958c2d836cae89e788334 + size: 363 + hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 original: hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 - completed: - hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 pantry-tree: - size: 2410 sha256: d87d84c3f760c1b2540f74e4a301cd4e8294df891e8e4262e8bdd313bc8e0bfd + size: 2410 + hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 original: hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 - completed: - hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 pantry-tree: - size: 718 sha256: 3634593ce191e82793ea0e060598ab3cf67f2ef2fe1d65345dc9335ad529d25f + size: 718 + hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 original: hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 - completed: - hackage: http-client-0.7.11@sha256:3f59ac8ffe2a3768846cdda040a0d1df2a413960529ba61c839861c948871967,5756 pantry-tree: - size: 2547 sha256: 8372e84e9c710097f4f80f2016ca15a5a0cd7884b8ac5ce70f26b3110f4401bd + size: 2547 + hackage: http-client-0.7.11@sha256:3f59ac8ffe2a3768846cdda040a0d1df2a413960529ba61c839861c948871967,5756 original: hackage: http-client-0.7.11 snapshots: - completed: + sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 size: 590100 url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml - sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 original: lts-18.28 From c073117871e4c75a1cfdc5c86e160d966f9c3811 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 2 May 2022 09:55:15 -0600 Subject: [PATCH 178/529] Allow testing Share API in transcripts (#3062) * Support API calls in transcripts --- unison-cli/package.yaml | 1 + .../src/Unison/Codebase/TranscriptParser.hs | 118 ++++++-- unison-cli/unison-cli.cabal | 5 + .../src/Unison/Server/CodebaseServer.hs | 13 +- unison-src/transcripts/api-find.md | 26 ++ unison-src/transcripts/api-find.output.md | 253 ++++++++++++++++++ unison-src/transcripts/api-getDefinition.md | 22 ++ .../transcripts/api-getDefinition.output.md | 220 +++++++++++++++ .../transcripts/api-namespace-details.md | 20 ++ .../api-namespace-details.output.md | 56 ++++ unison-src/transcripts/api-namespace-list.md | 22 ++ .../transcripts/api-namespace-list.output.md | 130 +++++++++ unison-src/transcripts/api-projects.md | 18 ++ unison-src/transcripts/api-projects.output.md | 72 +++++ 14 files changed, 947 insertions(+), 29 deletions(-) create mode 100644 unison-src/transcripts/api-find.md create mode 100644 unison-src/transcripts/api-find.output.md create mode 100644 unison-src/transcripts/api-getDefinition.md create mode 100644 unison-src/transcripts/api-getDefinition.output.md create mode 100644 unison-src/transcripts/api-namespace-details.md create mode 100644 unison-src/transcripts/api-namespace-details.output.md create mode 100644 unison-src/transcripts/api-namespace-list.md create mode 100644 unison-src/transcripts/api-namespace-list.output.md create mode 100644 unison-src/transcripts/api-projects.md create mode 100644 unison-src/transcripts/api-projects.output.md diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 21f9113063..2fee4e8047 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -45,6 +45,7 @@ dependencies: - unliftio - network-uri - aeson + - aeson-pretty - http-client >= 0.7.6 - http-client-tls - http-types diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 686f8fe60f..2e37d8d6a6 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -21,6 +21,9 @@ where import Control.Concurrent.STM (atomically) import Control.Lens (view) import qualified Crypto.Random as Random +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Encode.Pretty as Aeson +import qualified Data.ByteString.Lazy.Char8 as BL import qualified Data.Char as Char import qualified Data.Configurator as Configurator import Data.Configurator.Types (Config) @@ -28,6 +31,7 @@ import Data.IORef import Data.List (isSubsequenceOf) import qualified Data.Map as Map import qualified Data.Text as Text +import qualified Network.HTTP.Client as HTTP import System.Directory (doesFileExist) import System.Exit (die) import qualified System.IO as IO @@ -54,14 +58,15 @@ import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal import qualified Unison.Runtime.Interface as RTI +import qualified Unison.Server.CodebaseServer as Server import Unison.Symbol (Symbol) -import qualified Unison.Util.Pretty as P +import qualified Unison.Util.Pretty as Pretty import qualified Unison.Util.TQueue as Q import qualified UnliftIO import Prelude hiding (readFile, writeFile) -- | Render transcript errors at a width of 65 chars. -terminalWidth :: P.Width +terminalWidth :: Pretty.Width terminalWidth = 65 type ExpectingError = Bool @@ -77,9 +82,18 @@ data UcmLine = UcmCommand Path.Absolute Text | UcmComment Text -- Text does not include the '--' prefix. +data APIRequest + = GetRequest Text + | APIComment Text + +instance Show APIRequest where + show (GetRequest txt) = "GET " <> Text.unpack txt + show (APIComment txt) = "-- " <> Text.unpack txt + data Stanza = Ucm Hidden ExpectingError [UcmLine] | Unison Hidden ExpectingError (Maybe ScratchFileName) Text + | API [APIRequest] | UnprocessedFence FenceType Text | Unfenced Text @@ -110,6 +124,13 @@ instance Show Stanza where "" ] ] + API apiRequests -> + "```api\n" + <> ( apiRequests + & fmap (\(GetRequest txt) -> Text.unpack txt) + & unlines + ) + <> "```\n" UnprocessedFence typ txt -> unlines [ "```" <> Text.unpack typ, @@ -150,10 +171,11 @@ withTranscriptRunner :: withTranscriptRunner ucmVersion configFile action = do withRuntime $ \runtime -> withConfig $ \config -> do action $ \transcriptName transcriptSrc (codebaseDir, codebase) -> do - let parsed = parse transcriptName transcriptSrc - result <- for parsed $ \stanzas -> do - liftIO $ run codebaseDir stanzas codebase runtime config ucmVersion - pure $ join @(Either TranscriptError) result + Server.startServer Server.defaultCodebaseServerOpts runtime codebase $ \baseUrl -> do + let parsed = parse transcriptName transcriptSrc + result <- for parsed $ \stanzas -> do + liftIO $ run codebaseDir stanzas codebase runtime config ucmVersion (tShow baseUrl) + pure $ join @(Either TranscriptError) result where withRuntime :: ((Runtime.Runtime Symbol -> m a) -> m a) withRuntime action = @@ -181,11 +203,13 @@ run :: Runtime.Runtime Symbol -> Maybe Config -> UCMVersion -> + Text -> IO (Either TranscriptError Text) -run dir stanzas codebase runtime config ucmVersion = UnliftIO.try $ do +run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do + httpManager <- HTTP.newManager HTTP.defaultManagerSettings let initialPath = Path.absoluteEmpty putPrettyLn $ - P.lines + Pretty.lines [ asciiartUnison, "", "Running the provided transcript file...", @@ -224,6 +248,22 @@ run dir stanzas codebase runtime config ucmVersion = UnliftIO.try $ do output = output' False outputEcho = output' True + apiRequest :: APIRequest -> IO () + apiRequest req = do + output (show req <> "\n") + case req of + (APIComment {}) -> pure () + (GetRequest path) -> do + req <- case HTTP.parseRequest (Text.unpack $ baseURL <> path) of + Left err -> dieWithMsg (show err) + Right req -> pure req + respBytes <- HTTP.httpLbs req httpManager + case Aeson.eitherDecode (HTTP.responseBody respBytes) of + Right (v :: Aeson.Value) -> do + let prettyBytes = Aeson.encodePretty' (Aeson.defConfig {Aeson.confCompare = compare}) v + output . (<> "\n") . BL.unpack $ prettyBytes + Left err -> dieWithMsg ("Error decoding response from " <> Text.unpack path <> ": " <> err) + awaitInput :: IO (Either Event Input) awaitInput = do cmd <- atomically (Q.tryDequeue cmdQueue) @@ -257,7 +297,7 @@ run dir stanzas codebase runtime config ucmVersion = UnliftIO.try $ do currentRoot <- Branch.head <$> readIORef rootBranchRef case parseInput currentRoot curPath numberedArgs patternMap args of -- invalid command is treated as a failure - Left msg -> dieWithMsg $ P.toPlain terminalWidth msg + Left msg -> dieWithMsg $ Pretty.toPlain terminalWidth msg Right input -> pure $ Right input Nothing -> do dieUnexpectedSuccess @@ -290,6 +330,11 @@ run dir stanzas codebase runtime config ucmVersion = UnliftIO.try $ do atomically . Q.enqueue cmdQueue $ Nothing modifyIORef' unisonFiles (Map.insert (fromMaybe "scratch.u" filename) txt) pure $ Left (UnisonFileChanged (fromMaybe "scratch.u" filename) txt) + API apiRequests -> do + output "```api\n" + for_ apiRequests apiRequest + output "```" + awaitInput Ucm hide errOk cmds -> do writeIORef hidden hide writeIORef allowErrors errOk @@ -317,7 +362,7 @@ run dir stanzas codebase runtime config ucmVersion = UnliftIO.try $ do print o = do msg <- notifyUser dir o errOk <- readIORef allowErrors - let rendered = P.toPlain terminalWidth (P.border 2 msg) + let rendered = Pretty.toPlain terminalWidth (Pretty.border 2 msg) output rendered when (Output.isFailure o) $ if errOk @@ -327,7 +372,7 @@ run dir stanzas codebase runtime config ucmVersion = UnliftIO.try $ do printNumbered o = do let (msg, numberedArgs) = notifyNumbered o errOk <- readIORef allowErrors - let rendered = P.toPlain terminalWidth (P.border 2 msg) + let rendered = Pretty.toPlain terminalWidth (Pretty.border 2 msg) output rendered when (Output.isNumberedFailure o) $ if errOk @@ -441,31 +486,50 @@ ucmLine = ucmCommand <|> ucmComment line <- P.takeWhileP Nothing (/= '\n') <* spaces pure $ UcmComment line +apiRequest :: P APIRequest +apiRequest = do + apiComment <|> getRequest + where + getRequest = do + word "GET" + spaces + path <- P.takeWhile1P Nothing (/= '\n') + spaces + pure (GetRequest path) + apiComment = do + word "--" + comment <- P.takeWhileP Nothing (/= '\n') + spaces + pure (APIComment comment) + fenced :: P Stanza fenced = do fence - fenceType <- lineToken (word "ucm" <|> word "unison" <|> language) + fenceType <- lineToken (word "ucm" <|> word "unison" <|> word "api" <|> language) stanza <- - if fenceType == "ucm" - then do + case fenceType of + "ucm" -> do hide <- hidden err <- expectingError _ <- spaces cmds <- many ucmLine pure $ Ucm hide err cmds - else - if fenceType == "unison" - then do - -- todo: this has to be more interesting - -- ```unison:hide - -- ```unison - -- ```unison:hide:all scratch.u - hide <- lineToken hidden - err <- lineToken expectingError - fileName <- optional untilSpace1 - blob <- spaces *> untilFence - pure $ Unison hide err fileName blob - else UnprocessedFence fenceType <$> untilFence + "unison" -> + do + -- todo: this has to be more interesting + -- ```unison:hide + -- ```unison + -- ```unison:hide:all scratch.u + hide <- lineToken hidden + err <- lineToken expectingError + fileName <- optional untilSpace1 + blob <- spaces *> untilFence + pure $ Unison hide err fileName blob + "api" -> do + _ <- spaces + apiRequests <- many apiRequest + pure $ API apiRequests + _ -> UnprocessedFence fenceType <$> untilFence fence pure stanza diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index ce3084f964..488edb9c88 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -92,6 +92,7 @@ library build-depends: ListLike , aeson + , aeson-pretty , async , base , bytestring @@ -181,6 +182,7 @@ executable cli-integration-tests build-depends: ListLike , aeson + , aeson-pretty , async , base , bytestring @@ -268,6 +270,7 @@ executable transcripts build-depends: ListLike , aeson + , aeson-pretty , async , base , bytestring @@ -359,6 +362,7 @@ executable unison build-depends: ListLike , aeson + , aeson-pretty , async , base , bytestring @@ -455,6 +459,7 @@ test-suite cli-tests build-depends: ListLike , aeson + , aeson-pretty , async , base , bytestring diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index d5a34cd6e6..2a9e90ef0d 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -248,13 +248,22 @@ data CodebaseServerOpts = CodebaseServerOpts } deriving (Show, Eq) +defaultCodebaseServerOpts :: CodebaseServerOpts +defaultCodebaseServerOpts = + CodebaseServerOpts + { token = Nothing, + host = Nothing, + port = Nothing, + codebaseUIPath = Nothing + } + -- The auth token required for accessing the server is passed to the function k startServer :: CodebaseServerOpts -> Rt.Runtime Symbol -> Codebase IO Symbol Ann -> - (BaseUrl -> IO ()) -> - IO () + (BaseUrl -> IO a) -> + IO a startServer opts rt codebase onStart = do -- the `canonicalizePath` resolves symlinks exePath <- canonicalizePath =<< getExecutablePath diff --git a/unison-src/transcripts/api-find.md b/unison-src/transcripts/api-find.md new file mode 100644 index 0000000000..a82568e053 --- /dev/null +++ b/unison-src/transcripts/api-find.md @@ -0,0 +1,26 @@ +# find api + +```unison +rachel.filesystem.x = 42 +ross.httpClient.y = 43 +joey.httpServer.z = 44 +joey.yaml.zz = 45 +``` + +```ucm +.> add +``` + +```api +-- Namespace segment prefix search +GET /api/find?query=http + +-- Namespace segment suffix search +GET /api/find?query=Server + +-- Substring search +GET /api/find?query=lesys + +-- Cross-segment search +GET /api/find?query=joey.http +``` diff --git a/unison-src/transcripts/api-find.output.md b/unison-src/transcripts/api-find.output.md new file mode 100644 index 0000000000..e24f1683e7 --- /dev/null +++ b/unison-src/transcripts/api-find.output.md @@ -0,0 +1,253 @@ +# find api + +```unison +rachel.filesystem.x = 42 +ross.httpClient.y = 43 +joey.httpServer.z = 44 +joey.yaml.zz = 45 +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + joey.httpServer.z : ##Nat + joey.yaml.zz : ##Nat + rachel.filesystem.x : ##Nat + ross.httpClient.y : ##Nat + +``` +```ucm +.> add + + โŸ I've added these definitions: + + joey.httpServer.z : ##Nat + joey.yaml.zz : ##Nat + rachel.filesystem.x : ##Nat + ross.httpClient.y : ##Nat + +``` +```api +-- Namespace segment prefix search +GET /api/find?query=http +[ + [ + { + "result": { + "segments": [ + { + "contents": "ross.", + "tag": "Gap" + }, + { + "contents": "http", + "tag": "Match" + }, + { + "contents": "Client.y", + "tag": "Gap" + } + ] + }, + "score": 156 + }, + { + "contents": { + "bestFoundTermName": "y", + "namedTerm": { + "termHash": "#emomp74i93h6ps0b5sukke0tci0ooba3f9jk21qm919a7act9u7asani84c0mqbdk4lcjrdvr9olpedp23p6df78r4trqlg0cciadc8", + "termName": "ross.httpClient.y", + "termTag": null, + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + } + }, + "tag": "FoundTermResult" + } + ], + [ + { + "result": { + "segments": [ + { + "contents": "joey.", + "tag": "Gap" + }, + { + "contents": "http", + "tag": "Match" + }, + { + "contents": "Server.z", + "tag": "Gap" + } + ] + }, + "score": 156 + }, + { + "contents": { + "bestFoundTermName": "z", + "namedTerm": { + "termHash": "#a84tg4er4kfl9k2p250vp2o1dsp5kmn9a7q8g2bo723qbtbf9sagrl28fa4q0j5f2cv4alsjik6rf487ss646qt95gbm3dd13k7e1fo", + "termName": "joey.httpServer.z", + "termTag": null, + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + } + }, + "tag": "FoundTermResult" + } + ] +] +-- Namespace segment suffix search +GET /api/find?query=Server +[ + [ + { + "result": { + "segments": [ + { + "contents": "joey.http", + "tag": "Gap" + }, + { + "contents": "Server", + "tag": "Match" + }, + { + "contents": ".z", + "tag": "Gap" + } + ] + }, + "score": 223 + }, + { + "contents": { + "bestFoundTermName": "z", + "namedTerm": { + "termHash": "#a84tg4er4kfl9k2p250vp2o1dsp5kmn9a7q8g2bo723qbtbf9sagrl28fa4q0j5f2cv4alsjik6rf487ss646qt95gbm3dd13k7e1fo", + "termName": "joey.httpServer.z", + "termTag": null, + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + } + }, + "tag": "FoundTermResult" + } + ] +] +-- Substring search +GET /api/find?query=lesys +[ + [ + { + "result": { + "segments": [ + { + "contents": "rachel.fi", + "tag": "Gap" + }, + { + "contents": "lesys", + "tag": "Match" + }, + { + "contents": "tem.x", + "tag": "Gap" + } + ] + }, + "score": 175 + }, + { + "contents": { + "bestFoundTermName": "x", + "namedTerm": { + "termHash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", + "termName": "rachel.filesystem.x", + "termTag": null, + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + } + }, + "tag": "FoundTermResult" + } + ] +] +-- Cross-segment search +GET /api/find?query=joey.http +[ + [ + { + "result": { + "segments": [ + { + "contents": "joey.http", + "tag": "Match" + }, + { + "contents": "Server.z", + "tag": "Gap" + } + ] + }, + "score": 300 + }, + { + "contents": { + "bestFoundTermName": "z", + "namedTerm": { + "termHash": "#a84tg4er4kfl9k2p250vp2o1dsp5kmn9a7q8g2bo723qbtbf9sagrl28fa4q0j5f2cv4alsjik6rf487ss646qt95gbm3dd13k7e1fo", + "termName": "joey.httpServer.z", + "termTag": null, + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + } + }, + "tag": "FoundTermResult" + } + ] +] +``` \ No newline at end of file diff --git a/unison-src/transcripts/api-getDefinition.md b/unison-src/transcripts/api-getDefinition.md new file mode 100644 index 0000000000..b9f875d80f --- /dev/null +++ b/unison-src/transcripts/api-getDefinition.md @@ -0,0 +1,22 @@ +# Get Definitions Test + +```ucm:hide +.> builtins.mergeio +``` + +```unison +{{ Documentation }} +nested.names.x = 42 +``` + +```ucm +.> add +``` + +```api +-- Should find names by suffix +GET /api/getDefinition?names=x + +-- Term names should strip relativeTo prefix. +GET /api/getDefinition?names=x&relativeTo=nested +``` diff --git a/unison-src/transcripts/api-getDefinition.output.md b/unison-src/transcripts/api-getDefinition.output.md new file mode 100644 index 0000000000..9666adf6d6 --- /dev/null +++ b/unison-src/transcripts/api-getDefinition.output.md @@ -0,0 +1,220 @@ +# Get Definitions Test + +```unison +{{ Documentation }} +nested.names.x = 42 +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + nested.names.x : Nat + nested.names.x.doc : Doc2 + +``` +```ucm +.> add + + โŸ I've added these definitions: + + nested.names.x : Nat + nested.names.x.doc : Doc2 + +``` +```api +-- Should find names by suffix +GET /api/getDefinition?names=x +{ + "missingDefinitions": [], + "termDefinitions": { + "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": { + "bestTermName": "x", + "defnTermTag": null, + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "42" + } + ], + "tag": "UserObject" + }, + "termDocs": [ + [ + "doc", + "#ulr9f75rpcrv79d7sfo2ep2tvbntu3e360lfomird2bdpj4bnea230e8o5j0b9our8vggocpa7eck3pus14fcfajlttat1bg71t6rbg", + { + "contents": [ + { + "contents": "Documentation", + "tag": "Word" + } + ], + "tag": "Paragraph" + } + ] + ], + "termNames": [ + "nested.names.x" + ] + } + }, + "typeDefinitions": {} +} +-- Term names should strip relativeTo prefix. +GET /api/getDefinition?names=x&relativeTo=nested +{ + "missingDefinitions": [], + "termDefinitions": { + "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": { + "bestTermName": "x", + "defnTermTag": null, + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "42" + } + ], + "tag": "UserObject" + }, + "termDocs": [ + [ + "doc", + "#ulr9f75rpcrv79d7sfo2ep2tvbntu3e360lfomird2bdpj4bnea230e8o5j0b9our8vggocpa7eck3pus14fcfajlttat1bg71t6rbg", + { + "contents": [ + { + "contents": "Documentation", + "tag": "Word" + } + ], + "tag": "Paragraph" + } + ] + ], + "termNames": [ + "names.x" + ] + } + }, + "typeDefinitions": {} +} +``` \ No newline at end of file diff --git a/unison-src/transcripts/api-namespace-details.md b/unison-src/transcripts/api-namespace-details.md new file mode 100644 index 0000000000..dde5101e9c --- /dev/null +++ b/unison-src/transcripts/api-namespace-details.md @@ -0,0 +1,20 @@ +# Namespace details api + +```ucm:hide +.> builtins.mergeio +``` + +```unison +{{ Documentation }} +nested.names.x = 42 + +nested.names.readme = {{ I'm a readme! }} +``` + +```ucm +.> add +``` + +```api +GET /api/namespaces/nested.names +``` diff --git a/unison-src/transcripts/api-namespace-details.output.md b/unison-src/transcripts/api-namespace-details.output.md new file mode 100644 index 0000000000..2234c30d88 --- /dev/null +++ b/unison-src/transcripts/api-namespace-details.output.md @@ -0,0 +1,56 @@ +# Namespace details api + +```unison +{{ Documentation }} +nested.names.x = 42 + +nested.names.readme = {{ I'm a readme! }} +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + nested.names.readme : Doc2 + nested.names.x : Nat + nested.names.x.doc : Doc2 + +``` +```ucm +.> add + + โŸ I've added these definitions: + + nested.names.readme : Doc2 + nested.names.x : Nat + nested.names.x.doc : Doc2 + +``` +```api +GET /api/namespaces/nested.names +{ + "fqn": "nested.names", + "hash": "#oms19b4f9s3c8tb5skeb8jii95ij35n3hdg038pu6rv5b0fikqe4gd7lnu6a1i6aq5tdh2opdo4s0sfrupvk6vfkr9lf0n752gbl8o0", + "readme": { + "contents": [ + { + "contents": "I'm", + "tag": "Word" + }, + { + "contents": "a", + "tag": "Word" + }, + { + "contents": "readme!", + "tag": "Word" + } + ], + "tag": "Paragraph" + } +} +``` \ No newline at end of file diff --git a/unison-src/transcripts/api-namespace-list.md b/unison-src/transcripts/api-namespace-list.md new file mode 100644 index 0000000000..59d7512fb5 --- /dev/null +++ b/unison-src/transcripts/api-namespace-list.md @@ -0,0 +1,22 @@ +# Namespace list api + +```ucm:hide +.> builtins.mergeio +``` + +```unison +{{ Documentation }} +nested.names.x = 42 + +nested.names.readme = {{ I'm a readme! }} +``` + +```ucm +.> add +``` + +```api +GET /api/list?namespace=nested.names + +GET /api/list?namespace=names&relativeTo=nested +``` diff --git a/unison-src/transcripts/api-namespace-list.output.md b/unison-src/transcripts/api-namespace-list.output.md new file mode 100644 index 0000000000..b610eedeaf --- /dev/null +++ b/unison-src/transcripts/api-namespace-list.output.md @@ -0,0 +1,130 @@ +# Namespace list api + +```unison +{{ Documentation }} +nested.names.x = 42 + +nested.names.readme = {{ I'm a readme! }} +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + nested.names.readme : Doc2 + nested.names.x : Nat + nested.names.x.doc : Doc2 + +``` +```ucm +.> add + + โŸ I've added these definitions: + + nested.names.readme : Doc2 + nested.names.x : Nat + nested.names.x.doc : Doc2 + +``` +```api +GET /api/list?namespace=nested.names +{ + "namespaceListingChildren": [ + { + "contents": { + "termHash": "#ddmmatmmiqsts2ku0i02kntd0s7rvcui4nn1cusio8thp9oqhbtilvcnhen52ibv43kr5q83f5er5q9h56s807k17tnelnrac7cch8o", + "termName": "readme", + "termTag": "Doc", + "termType": [ + { + "annotation": { + "contents": "#ej86si0ur1", + "tag": "HashQualifier" + }, + "segment": "#ej86si0ur1" + } + ] + }, + "tag": "TermObject" + }, + { + "contents": { + "termHash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", + "termName": "x", + "termTag": null, + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + }, + "tag": "TermObject" + }, + { + "contents": { + "namespaceHash": "#n1egracfeljprftoktbjcase2hs4f4p8idbhs5ujipl42agld1810hrq9t7p7ped16aagni2cm1fjcjhho770jh80ipthhmg0cnsur0", + "namespaceName": "x" + }, + "tag": "Subnamespace" + } + ], + "namespaceListingFQN": "nested.names", + "namespaceListingHash": "#oms19b4f9s3c8tb5skeb8jii95ij35n3hdg038pu6rv5b0fikqe4gd7lnu6a1i6aq5tdh2opdo4s0sfrupvk6vfkr9lf0n752gbl8o0" +} +GET /api/list?namespace=names&relativeTo=nested +{ + "namespaceListingChildren": [ + { + "contents": { + "termHash": "#ddmmatmmiqsts2ku0i02kntd0s7rvcui4nn1cusio8thp9oqhbtilvcnhen52ibv43kr5q83f5er5q9h56s807k17tnelnrac7cch8o", + "termName": "readme", + "termTag": "Doc", + "termType": [ + { + "annotation": { + "contents": "#ej86si0ur1", + "tag": "HashQualifier" + }, + "segment": "#ej86si0ur1" + } + ] + }, + "tag": "TermObject" + }, + { + "contents": { + "termHash": "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8", + "termName": "x", + "termTag": null, + "termType": [ + { + "annotation": { + "contents": "##Nat", + "tag": "HashQualifier" + }, + "segment": "##Nat" + } + ] + }, + "tag": "TermObject" + }, + { + "contents": { + "namespaceHash": "#n1egracfeljprftoktbjcase2hs4f4p8idbhs5ujipl42agld1810hrq9t7p7ped16aagni2cm1fjcjhho770jh80ipthhmg0cnsur0", + "namespaceName": "x" + }, + "tag": "Subnamespace" + } + ], + "namespaceListingFQN": "nested.names", + "namespaceListingHash": "#oms19b4f9s3c8tb5skeb8jii95ij35n3hdg038pu6rv5b0fikqe4gd7lnu6a1i6aq5tdh2opdo4s0sfrupvk6vfkr9lf0n752gbl8o0" +} +``` \ No newline at end of file diff --git a/unison-src/transcripts/api-projects.md b/unison-src/transcripts/api-projects.md new file mode 100644 index 0000000000..8d0851538a --- /dev/null +++ b/unison-src/transcripts/api-projects.md @@ -0,0 +1,18 @@ +# projects api + +```unison +rachel.filesystem.x = 42 +ross.http.y = 43 +joey.json.z = 44 +joey.yaml.zz = 45 +``` + +```ucm +.> add +``` + +```api +GET /api/projects + +GET /api/projects?owner=joey +``` diff --git a/unison-src/transcripts/api-projects.output.md b/unison-src/transcripts/api-projects.output.md new file mode 100644 index 0000000000..c3b15b4c21 --- /dev/null +++ b/unison-src/transcripts/api-projects.output.md @@ -0,0 +1,72 @@ +# projects api + +```unison +rachel.filesystem.x = 42 +ross.http.y = 43 +joey.json.z = 44 +joey.yaml.zz = 45 +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + joey.json.z : ##Nat + joey.yaml.zz : ##Nat + rachel.filesystem.x : ##Nat + ross.http.y : ##Nat + +``` +```ucm +.> add + + โŸ I've added these definitions: + + joey.json.z : ##Nat + joey.yaml.zz : ##Nat + rachel.filesystem.x : ##Nat + ross.http.y : ##Nat + +``` +```api +GET /api/projects +[ + { + "hash": "#vjmnhfbas8pejgpgsh26255ebaolepuc56juiifft4b9bg8u43nmmhe2skfncrfvin3std4grbfa7io846nskq3j5b3819rvaddnbn0", + "name": "json", + "owner": "joey" + }, + { + "hash": "#plgokdvco3iu26r56u20faojs7pv0r0114pkd5aumt7ucd567t307bcuv92ejtkcvvmp0tg4e2g5d3btqbggn54pifbvql2kd9hlg48", + "name": "yaml", + "owner": "joey" + }, + { + "hash": "#sbh98idno2b9ide5ue7bcj01ftu7u9msm57g3jn7q9efsbo0bdtnaei5i8sq4p3gb6p8alkqrp8gttp4ptvq9f45c8stkf39l9pvb2g", + "name": "filesystem", + "owner": "rachel" + }, + { + "hash": "#1l4rfnjpsut79lc0kcv7aa4m6elk1lj7nse69ptaipb4gvlfa7kcnqrte56opeeb5ahrr6tvms2052e9fjjjuh97glkll6hp3lam788", + "name": "http", + "owner": "ross" + } +] +GET /api/projects?owner=joey +[ + { + "hash": "#vjmnhfbas8pejgpgsh26255ebaolepuc56juiifft4b9bg8u43nmmhe2skfncrfvin3std4grbfa7io846nskq3j5b3819rvaddnbn0", + "name": "json", + "owner": "joey" + }, + { + "hash": "#plgokdvco3iu26r56u20faojs7pv0r0114pkd5aumt7ucd567t307bcuv92ejtkcvvmp0tg4e2g5d3btqbggn54pifbvql2kd9hlg48", + "name": "yaml", + "owner": "joey" + } +] +``` \ No newline at end of file From ee8329424f547482ee5dcd80a3a25f472f6026d6 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 3 May 2022 11:23:37 -0400 Subject: [PATCH 179/529] ANF.hs --- parser-typechecker/tests/Unison/Test/ANF.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/parser-typechecker/tests/Unison/Test/ANF.hs b/parser-typechecker/tests/Unison/Test/ANF.hs index 714616f283..3981fd97a8 100644 --- a/parser-typechecker/tests/Unison/Test/ANF.hs +++ b/parser-typechecker/tests/Unison/Test/ANF.hs @@ -6,7 +6,6 @@ module Unison.Test.ANF where import Control.Monad.Reader (ReaderT (..)) import Control.Monad.State (evalState) -import Data.Int (Int64) import qualified Data.Map as Map import qualified Data.Set as Set import Data.Word (Word64) @@ -122,14 +121,14 @@ denormalizeMatch :: denormalizeMatch b | MatchEmpty <- b = [] | MatchIntegral m df <- b = - (dcase (ipat @Int64 Ty.intRef) <$> mapToList m) ++ dfcase df + (dcase (ipat @Word64 @Integer Ty.intRef) <$> mapToList m) ++ dfcase df | MatchText m df <- b = - (dcase (const $ P.Text () . Util.Text.toText) <$> Map.toList m) ++ dfcase df + (dcase (const @_ @Integer $ P.Text () . Util.Text.toText) <$> Map.toList m) ++ dfcase df | MatchData r cs Nothing <- b, [(0, ([UN], zb))] <- mapToList cs, TAbs i (TMatch j (MatchIntegral m df)) <- zb, i == j = - (dcase (ipat r) <$> mapToList m) ++ dfcase df + (dcase (ipat @Word64 @Integer r) <$> mapToList m) ++ dfcase df | MatchData r m df <- b = (dcase (dpat r) . fmap snd <$> mapToList m) ++ dfcase df | MatchRequest hs df <- b = denormalizeHandler hs df From 59eccc8cd11327af7338b895309f15dc659d8ee1 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 3 May 2022 10:19:03 -0600 Subject: [PATCH 180/529] Add 'version' command --- .../src/Unison/Codebase/Editor/HandleInput.hs | 4 ++++ unison-cli/src/Unison/Codebase/Editor/Input.hs | 1 + unison-cli/src/Unison/Codebase/Editor/Output.hs | 2 ++ .../src/Unison/CommandLine/InputPatterns.hs | 17 ++++++++++++++++- .../src/Unison/CommandLine/OutputMessages.hs | 1 + 5 files changed, 24 insertions(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f4a6ee941e..f510e966f3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -464,6 +464,7 @@ loop = do "delete.term-replacement" <> HQ.toText src <> " " <> opatch p RemoveTypeReplacementI src p -> "delete.type-replacement" <> HQ.toText src <> " " <> opatch p + VersionI -> "version" where hp' = either (Text.pack . show) p' p' = Text.pack . show . resolveToAbsolute @@ -1641,6 +1642,9 @@ loop = do case mayHost of Nothing -> respond (UnknownCodeServer codeServer) Just host -> authLogin (Just $ Host host) + VersionI -> do + ucmVersion <- eval UCMVersion + respond $ PrintVersion ucmVersion where notImplemented = eval $ Notify NotImplemented success = respond Success diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index da6d9cdde8..96bb1effc7 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -186,6 +186,7 @@ data Input | DocsToHtmlI Path' FilePath | GistI GistInput | AuthLoginI (Maybe CodebaseServerName) + | VersionI deriving (Eq, Show) -- | @"gist repo"@ pushes the contents of the current namespace to @repo@. diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index f0bc11f731..ca0251f1e8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -254,6 +254,7 @@ data Output v InitiateAuthFlow URI | UnknownCodeServer Text | CredentialFailureMsg CredentialFailure + | PrintVersion Text data ReflogEntry = ReflogEntry {hash :: ShortBranchHash, reason :: Text} deriving (Show) @@ -379,6 +380,7 @@ isFailure o = case o of InitiateAuthFlow {} -> False UnknownCodeServer {} -> True CredentialFailureMsg {} -> True + PrintVersion {} -> False isNumberedFailure :: NumberedOutput v -> Bool isNumberedFailure = \case diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 39c77f1c10..3cd2b042cb 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -2030,6 +2030,20 @@ authLogin = _ -> Left (showPatternHelp authLogin) ) +printVersion :: InputPattern +printVersion = + InputPattern + "version" + [] + I.Visible + [] + ( P.wrap "Print the version of unison you're running" + ) + ( \case + [] -> Right $ Input.VersionI + _ -> Left (showPatternHelp printVersion) + ) + validInputs :: [InputPattern] validInputs = sortOn @@ -2119,7 +2133,8 @@ validInputs = debugDumpNamespaceSimple, debugClearWatchCache, gist, - authLogin + authLogin, + printVersion ] visibleInputs :: [InputPattern] diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 3bb4632aa8..dd07272160 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1578,6 +1578,7 @@ notifyUser dir o = case o of [ "Failed to parse a URI from the hostname: " <> P.text host <> ".", "Host names should NOT include a schema or path." ] + PrintVersion ucmVersion -> pure (P.text ucmVersion) where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" From adff263d9e7a8579db7d87d49dac9d9dbfc0bb7d Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 4 May 2022 12:14:27 -0400 Subject: [PATCH 181/529] add fast-forward path api --- unison-cli/src/Unison/Sync/HTTP.hs | 11 ++- unison-share-api/src/Unison/Sync/API.hs | 5 ++ unison-share-api/src/Unison/Sync/Types.hs | 81 ++++++++++++++++++++++- 3 files changed, 95 insertions(+), 2 deletions(-) diff --git a/unison-cli/src/Unison/Sync/HTTP.hs b/unison-cli/src/Unison/Sync/HTTP.hs index da00125bd1..3903b8c7a1 100644 --- a/unison-cli/src/Unison/Sync/HTTP.hs +++ b/unison-cli/src/Unison/Sync/HTTP.hs @@ -8,6 +8,7 @@ module Unison.Sync.HTTP ( getPathHandler, + fastForwardPathHandler, updatePathHandler, downloadEntitiesHandler, uploadEntitiesHandler, @@ -28,20 +29,28 @@ data SyncError deriving anyclass (Exception) getPathHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse +fastForwardPathHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> FastForwardPathRequest -> IO FastForwardPathResponse updatePathHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> UpdatePathRequest -> IO UpdatePathResponse downloadEntitiesHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> DownloadEntitiesRequest -> IO DownloadEntitiesResponse uploadEntitiesHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> UploadEntitiesRequest -> IO UploadEntitiesResponse ( getPathHandler, + fastForwardPathHandler, updatePathHandler, downloadEntitiesHandler, uploadEntitiesHandler ) = let ( getPathHandler + :<|> fastForwardPathHandler :<|> updatePathHandler :<|> downloadEntitiesHandler :<|> uploadEntitiesHandler ) = hoistClient Sync.api hoist (client Sync.api) - in (uncurryReaderT getPathHandler, uncurryReaderT updatePathHandler, uncurryReaderT downloadEntitiesHandler, uncurryReaderT uploadEntitiesHandler) + in ( uncurryReaderT getPathHandler, + uncurryReaderT fastForwardPathHandler, + uncurryReaderT updatePathHandler, + uncurryReaderT downloadEntitiesHandler, + uncurryReaderT uploadEntitiesHandler + ) where hoist :: forall a. ClientM a -> ReaderT (Auth.AuthorizedHttpClient, BaseUrl) IO a hoist m = do diff --git a/unison-share-api/src/Unison/Sync/API.hs b/unison-share-api/src/Unison/Sync/API.hs index a5eab3677e..754931f8b1 100644 --- a/unison-share-api/src/Unison/Sync/API.hs +++ b/unison-share-api/src/Unison/Sync/API.hs @@ -11,6 +11,7 @@ api = Proxy type API = "path" :> "get" :> GetCausalHashByPathEndpoint + :<|> "path" :> "fast-forward" :> FastForwardPathEndpoint :<|> "path" :> "update" :> UpdatePathEndpoint :<|> "entities" :> "download" :> DownloadEntitiesEndpoint :<|> "entities" :> "upload" :> UploadEntitiesEndpoint @@ -19,6 +20,10 @@ type GetCausalHashByPathEndpoint = ReqBody '[JSON] GetCausalHashByPathRequest :> Post '[JSON] GetCausalHashByPathResponse +type FastForwardPathEndpoint = + ReqBody '[JSON] FastForwardPathRequest + :> Post '[JSON] FastForwardPathResponse + type UpdatePathEndpoint = ReqBody '[JSON] UpdatePathRequest :> Post '[JSON] UpdatePathResponse diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 4df8e31b14..8f8688ef4f 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -209,6 +209,85 @@ instance FromJSON DownloadEntitiesResponse where parseJSON = Aeson.withObject "DownloadEntitiesResponse" $ \obj -> do DownloadEntitiesResponse <$> obj .: "entities" +------------------------------------------------------------------------------------------------------------------------ +-- Fast-forward path + +-- | A non-empty list of causal hashes, latest first, that show the lineage from wherever the client wants to +-- fast-forward to back to wherever the (client believes the) server is (not including the server head). +-- +-- For example, if the client wants to update +-- +-- @ +-- A -> B -> C +-- @ +-- +-- to +-- +-- @ +-- A -> B -> C -> D -> E -> F +-- @ +-- +-- then it would send hashes +-- +-- @ +-- [F, E, D] +-- @ +-- +-- Note that if the client wants to begin a history at a new path on the server, it would use the "update path" endpoint +-- instead. +data FastForwardPathRequest = FastForwardPathRequest + { hashes :: [Hash], + -- | The repo + path to fast-forward. + path :: RepoPath + } + deriving stock (Show) + +instance ToJSON FastForwardPathRequest where + toJSON FastForwardPathRequest {hashes, path} = + object + [ "hashes" .= hashes, + "path" .= path + ] + +instance FromJSON FastForwardPathRequest where + parseJSON = + Aeson.withObject "FastForwardPathRequest" \o -> do + hashes <- o .: "hashes" + path <- o .: "path" + pure FastForwardPathRequest {hashes, path} + +data FastForwardPathResponse + = FastForwardPathSuccess + | FastForwardPathMissingDependencies (NeedDependencies Hash) + | FastForwardPathNoWritePermission RepoPath + | -- | This wasn't a fast-forward. Here's a JWT to download the causal head, if you want it. + FastForwardPathNotFastForward HashJWT + | -- | There was no history at this path; the client should use the "update path" endpoint instead. + FastForwardPathNoHistory + deriving stock (Show) + +instance ToJSON FastForwardPathResponse where + toJSON = \case + FastForwardPathSuccess -> jsonUnion "success" (Object mempty) + FastForwardPathMissingDependencies deps -> jsonUnion "missing_dependencies" deps + FastForwardPathNoWritePermission repoPath -> jsonUnion "no_write_permission" repoPath + FastForwardPathNotFastForward hashJwt -> jsonUnion "not_fast_forward" hashJwt + FastForwardPathNoHistory -> jsonUnion "no_history" (Object mempty) + +instance FromJSON FastForwardPathResponse where + parseJSON = + Aeson.withObject "FastForwardPathResponse" \o -> + o .: "type" >>= Aeson.withText "type" \case + "success" -> pure FastForwardPathSuccess + "missing_dependencies" -> FastForwardPathMissingDependencies <$> o .: "payload" + "no_write_permission" -> FastForwardPathNoWritePermission <$> o .: "payload" + "not_fast_forward" -> FastForwardPathNotFastForward <$> o .: "payload" + "no_history" -> pure FastForwardPathNoHistory + t -> failText $ "Unexpected FastForwardPathResponse type: " <> t + +------------------------------------------------------------------------------------------------------------------------ +-- Update path + data UpdatePathRequest = UpdatePathRequest { path :: RepoPath, expectedHash :: Maybe TypedHash, -- Nothing requires empty history at destination @@ -254,7 +333,7 @@ instance ToJSON UpdatePathResponse where instance FromJSON UpdatePathResponse where parseJSON v = - v & Aeson.withObject "UploadEntitiesResponse" \obj -> + v & Aeson.withObject "UpdatePathResponse" \obj -> obj .: "type" >>= Aeson.withText "type" \case "success" -> pure UpdatePathSuccess "hash_mismatch" -> UpdatePathHashMismatch <$> obj .: "payload" From 55b7d318a5c362c6995922c31f65aebe45406ac0 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 4 May 2022 18:04:48 -0400 Subject: [PATCH 182/529] start implementing fast-forward push --- .../src/Unison/Codebase/Editor/HandleInput.hs | 2 +- unison-cli/src/Unison/Share/Sync.hs | 230 ++++++++++++------ unison-share-api/src/Unison/Sync/Types.hs | 3 +- 3 files changed, 165 insertions(+), 70 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 68b43ff011..197e7cc966 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1800,7 +1800,7 @@ handlePushToUnisonShare remoteRepo remotePath = do let doPush :: Maybe Share.Hash -> IO () doPush expectedHash = - Share.push authHTTPClient unisonShareUrl connection repoPath expectedHash localCausalHash >>= \case + Share.checkAndSetPush authHTTPClient unisonShareUrl connection repoPath expectedHash localCausalHash >>= \case Left pushError -> case pushError of -- Race condition: inbetween getting the remote causal hash and attempting to overwrite it, it changed. diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index c9296aacb5..c1b91059fc 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -1,20 +1,33 @@ module Unison.Share.Sync - ( -- * Get causal hash by path - getCausalHashByPath, - GetCausalHashByPathError (..), + ( -- * High-level API - -- * Push - push, + -- ** Push + checkAndSetPush, PushError (..), + fastForwardPush, - -- * Pull + -- ** Pull pull, PullError (..), + + -- * Low-level API + + -- ** Get causal hash by path + getCausalHashByPath, + GetCausalHashByPathError (..), + + -- ** Upload entities + uploadEntities, + + -- ** Download entities + downloadEntities, ) where import qualified Control.Lens as Lens import Control.Monad.Extra ((||^)) +import Data.List.NonEmpty (pattern (:|)) +import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as List.NonEmpty import Data.Map.NonEmpty (NEMap) import qualified Data.Map.NonEmpty as NEMap @@ -42,6 +55,7 @@ import Unison.Prelude import qualified Unison.Sqlite as Sqlite import qualified Unison.Sync.HTTP as Share ( downloadEntitiesHandler, + fastForwardPathHandler, getPathHandler, updatePathHandler, uploadEntitiesHandler, @@ -51,38 +65,19 @@ import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set ------------------------------------------------------------------------------------------------------------------------- --- Get causal hash by path - --- | An error occurred when getting causal hash by path. -data GetCausalHashByPathError - = -- | The user does not have permission to read this path. - GetCausalHashByPathErrorNoReadPermission Share.RepoPath - --- | Get the causal hash of a path hosted on Unison Share. -getCausalHashByPath :: - -- | The HTTP client to use for Unison Share requests. - AuthorizedHttpClient -> - -- | The Unison Share URL. - BaseUrl -> - Share.RepoPath -> - IO (Either GetCausalHashByPathError (Maybe Share.HashJWT)) -getCausalHashByPath httpClient unisonShareUrl repoPath = - Share.getPathHandler httpClient unisonShareUrl (Share.GetCausalHashByPathRequest repoPath) <&> \case - Share.GetCausalHashByPathSuccess maybeHashJwt -> Right maybeHashJwt - Share.GetCausalHashByPathNoReadPermission _ -> Left (GetCausalHashByPathErrorNoReadPermission repoPath) - ------------------------------------------------------------------------------------------------------------------------ -- Push -- | An error occurred while pushing code to Unison Share. +-- FIXME rename CheckAndSetPushError data PushError = PushErrorHashMismatch Share.HashMismatch | PushErrorNoWritePermission Share.RepoPath | PushErrorServerMissingDependencies (NESet Share.Hash) -- | Push a causal to Unison Share. -push :: +-- FIXME reword this +checkAndSetPush :: -- | The HTTP client to use for Unison Share requests. AuthorizedHttpClient -> -- | The Unison Share URL. @@ -97,7 +92,7 @@ push :: -- | The hash of our local causal to push. CausalHash -> IO (Either PushError ()) -push httpClient unisonShareUrl conn repoPath expectedHash causalHash = do +checkAndSetPush httpClient unisonShareUrl conn repoPath expectedHash causalHash = do -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs -- this causal (UpdatePathMissingDependencies). updatePath >>= \case @@ -105,7 +100,7 @@ push httpClient unisonShareUrl conn repoPath expectedHash causalHash = do Share.UpdatePathHashMismatch mismatch -> pure (Left (PushErrorHashMismatch mismatch)) Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do -- Upload the causal and all of its dependencies. - upload httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) dependencies >>= \case + uploadEntities httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) dependencies >>= \case False -> pure (Left (PushErrorNoWritePermission repoPath)) True -> -- After uploading the causal and all of its dependencies, try setting the remote path again. @@ -137,49 +132,80 @@ push httpClient unisonShareUrl conn repoPath expectedHash causalHash = do }, newHash = Share.TypedHash - { hash = - causalHash - & unCausalHash - & Hash.toBase32Hex - & Share.Hash, + { hash = causalHashToHash causalHash, entityType = Share.CausalType } } --- Upload a set of entities to Unison Share. If the server responds that it cannot yet store any hash(es) due to missing --- dependencies, send those dependencies too, and on and on, until the server stops responding that it's missing --- anything. -upload :: +-- | An error occurred while fast-forward pushing code to Unison Share. +data FastForwardPushError + = FastForwardPushErrorNoHistory Share.RepoPath + | FastForwardPushErrorNoReadPermission Share.RepoPath + | FastForwardPushErrorNotFastForward + | FastForwardPushErrorNoWritePermission Share.RepoPath + | FastForwardPushErrorServerMissingDependencies (NESet Share.Hash) + +-- | Push a causal to Unison Share. +-- FIXME reword this +fastForwardPush :: + -- | The HTTP client to use for Unison Share requests. AuthorizedHttpClient -> + -- | The Unison Share URL. BaseUrl -> + -- | SQLite connection, for reading entities to push. Sqlite.Connection -> - Share.RepoName -> - NESet Share.Hash -> - IO Bool -upload httpClient unisonShareUrl conn repoName = - loop + -- | The repo+path to push to. + Share.RepoPath -> + -- | The hash of our local causal to push. + CausalHash -> + IO (Either FastForwardPushError ()) +fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = + getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case + Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission repoPath)) + Right Nothing -> pure (Left (FastForwardPushErrorNoHistory repoPath)) + Right (Just (Share.hashJWTHash -> remoteHeadHash)) -> + Sqlite.runTransaction conn (fancyBfs localHeadHash remoteHeadHash) >>= \case + -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a + -- fast-forward push, so we don't bother trying - just report the error now. + Nothing -> pure (Left FastForwardPushErrorNotFastForward) + Just localTailHashes -> + doUpload (localHeadHash :| localTailHashes) >>= \case + False -> pure (Left (FastForwardPushErrorNoWritePermission repoPath)) + True -> + doFastForwardPath (localHeadHash : localTailHashes) <&> \case + Share.FastForwardPathSuccess -> Right () + Share.FastForwardPathMissingDependencies (Share.NeedDependencies dependencies) -> + Left (FastForwardPushErrorServerMissingDependencies dependencies) + -- Weird: someone must have force-pushed no history here, or something. We observed a history at this + -- path but moments ago! + Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory repoPath) + Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission repoPath) + Share.FastForwardPathNotFastForward _ -> Left FastForwardPushErrorNotFastForward where - loop :: NESet Share.Hash -> IO Bool - loop (NESet.toAscList -> hashes) = do - -- Get each entity that the server is missing out of the database. - entities <- Sqlite.runTransaction conn (traverse expectEntity hashes) + doUpload :: List.NonEmpty CausalHash -> IO Bool + -- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes", but we + -- don't have that API yet. So, we only upload the head causal entity (which we don't even know for sure the server + -- doesn't have yet), and will (eventually) end up uploading the casuals in the tail that the server needs. + doUpload (headHash :| _tailHashes) = + uploadEntities + httpClient + unisonShareUrl + conn + (Share.RepoPath.repoName repoPath) + (NESet.singleton (causalHashToHash headHash)) - let uploadEntities :: IO Share.UploadEntitiesResponse - uploadEntities = - Share.uploadEntitiesHandler - httpClient - unisonShareUrl - Share.UploadEntitiesRequest - { entities = NEMap.fromAscList (List.NonEmpty.zip hashes entities), - repoName - } + doFastForwardPath :: [CausalHash] -> IO Share.FastForwardPathResponse + doFastForwardPath causalSpine = + Share.fastForwardPathHandler + httpClient + unisonShareUrl + Share.FastForwardPathRequest + { hashes = map causalHashToHash causalSpine, + path = repoPath + } - -- Upload all of the entities we know the server needs, and if the server responds that it needs yet more, loop to - -- upload those too. - uploadEntities >>= \case - Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> loop moreHashes - Share.UploadEntitiesNoWritePermission _ -> pure False - Share.UploadEntitiesSuccess -> pure True + fancyBfs :: CausalHash -> Share.Hash -> Sqlite.Transaction (Maybe [CausalHash]) + fancyBfs = undefined ------------------------------------------------------------------------------------------------------------------------ -- Pull @@ -214,17 +240,41 @@ pull httpClient unisonShareUrl conn repoPath = do where doDownload :: NESet Share.HashJWT -> IO () doDownload = - download httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) + downloadEntities httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) + +------------------------------------------------------------------------------------------------------------------------ +-- Get causal hash by path + +-- | An error occurred when getting causal hash by path. +data GetCausalHashByPathError + = -- | The user does not have permission to read this path. + GetCausalHashByPathErrorNoReadPermission Share.RepoPath + +-- | Get the causal hash of a path hosted on Unison Share. +getCausalHashByPath :: + -- | The HTTP client to use for Unison Share requests. + AuthorizedHttpClient -> + -- | The Unison Share URL. + BaseUrl -> + Share.RepoPath -> + IO (Either GetCausalHashByPathError (Maybe Share.HashJWT)) +getCausalHashByPath httpClient unisonShareUrl repoPath = + Share.getPathHandler httpClient unisonShareUrl (Share.GetCausalHashByPathRequest repoPath) <&> \case + Share.GetCausalHashByPathSuccess maybeHashJwt -> Right maybeHashJwt + Share.GetCausalHashByPathNoReadPermission _ -> Left (GetCausalHashByPathErrorNoReadPermission repoPath) + +------------------------------------------------------------------------------------------------------------------------ +-- Download entities --- Download a set of entities from Unison Share. -download :: +-- | Download a set of entities from Unison Share. +downloadEntities :: AuthorizedHttpClient -> BaseUrl -> Sqlite.Connection -> Share.RepoName -> NESet Share.HashJWT -> IO () -download httpClient unisonShareUrl conn repoName = +downloadEntities httpClient unisonShareUrl conn repoName = loop . NESet.map Share.decodeHashJWT where loop :: NESet Share.DecodedHashJWT -> IO () @@ -248,6 +298,46 @@ download httpClient unisonShareUrl conn repoName = Share.DownloadEntitiesRequest {repoName, hashes} pure entities +------------------------------------------------------------------------------------------------------------------------ +-- Upload entities + +-- | Upload a set of entities to Unison Share. If the server responds that it cannot yet store any hash(es) due to +-- missing dependencies, send those dependencies too, and on and on, until the server stops responding that it's missing +-- anything. +-- +-- Returns true on success, false on failure (because the user does not have write permission). +uploadEntities :: + AuthorizedHttpClient -> + BaseUrl -> + Sqlite.Connection -> + Share.RepoName -> + NESet Share.Hash -> + IO Bool +uploadEntities httpClient unisonShareUrl conn repoName = + loop + where + loop :: NESet Share.Hash -> IO Bool + loop (NESet.toAscList -> hashes) = do + -- Get each entity that the server is missing out of the database. + entities <- Sqlite.runTransaction conn (traverse expectEntity hashes) + + let uploadEntities :: IO Share.UploadEntitiesResponse + uploadEntities = + Share.uploadEntitiesHandler + httpClient + unisonShareUrl + Share.UploadEntitiesRequest + { entities = NEMap.fromAscList (List.NonEmpty.zip hashes entities), + repoName + } + + -- Upload all of the entities we know the server needs, and if the server responds that it needs yet more, loop to + -- upload those too. + uploadEntities >>= \case + Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> loop moreHashes + Share.UploadEntitiesNoWritePermission _ -> pure False + Share.UploadEntitiesSuccess -> pure True + ------------------------------------------------------------------------------------------------------------------------ -- Database operations @@ -363,7 +453,11 @@ insertTempEntity hash entity missingDependencies = ) ------------------------------------------------------------------------------------------------------------------------ --- Entity conversions +-- Conversions to/from Share API types + +causalHashToHash :: CausalHash -> Share.Hash +causalHashToHash = + Share.Hash . Hash.toBase32Hex . unCausalHash -- | Convert an entity that came over the wire from Unison Share into an equivalent type that we can store in the -- `temp_entity` table. diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 8f8688ef4f..fb884a07fd 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -236,7 +236,8 @@ instance FromJSON DownloadEntitiesResponse where -- Note that if the client wants to begin a history at a new path on the server, it would use the "update path" endpoint -- instead. data FastForwardPathRequest = FastForwardPathRequest - { hashes :: [Hash], + { -- TODO non-empty + hashes :: [Hash], -- | The repo + path to fast-forward. path :: RepoPath } From fe1eed145f7d35363be992700e0628ed952591df Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 4 May 2022 21:13:00 -0400 Subject: [PATCH 183/529] sketch out pretty naive dag BFS algorithm --- unison-cli/src/Unison/Share/Sync.hs | 79 ++++++++++++++++++++++++++++- 1 file changed, 78 insertions(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index c1b91059fc..5a00e336da 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -26,6 +26,7 @@ where import qualified Control.Lens as Lens import Control.Monad.Extra ((||^)) +import qualified Data.Foldable as Foldable (find) import Data.List.NonEmpty (pattern (:|)) import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as List.NonEmpty @@ -176,7 +177,7 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = Share.FastForwardPathSuccess -> Right () Share.FastForwardPathMissingDependencies (Share.NeedDependencies dependencies) -> Left (FastForwardPushErrorServerMissingDependencies dependencies) - -- Weird: someone must have force-pushed no history here, or something. We observed a history at this + -- Weird: someone must have force-pushed no history here, or something. We observed a history at this -- path but moments ago! Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory repoPath) Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission repoPath) @@ -207,6 +208,82 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = fancyBfs :: CausalHash -> Share.Hash -> Sqlite.Transaction (Maybe [CausalHash]) fancyBfs = undefined +dagbfs :: forall a m. Monad m => (a -> Bool) -> (a -> m [a]) -> a -> m (Maybe (List.NonEmpty a)) +dagbfs goal children = + let -- The loop state: all distinct paths from the root to the frontier, in reverse order, with the invariant that we + -- haven't found a goal state yet. (Otherwise, we wouldn't still be in this loop, we'd return!). + -- + -- For example, say we are exploring the tree + -- + -- 1 + -- / \ + -- 2 3 + -- / \ \ + -- 4 5 6 + -- + -- Graphically, the frontier here is the nodes 4, 5, and 3; we know that, because I haven't drawn any nodes below + -- them. (This is a BFS algorithm that discovers children on-the-fly, so maybe node 5 (for example) has children, + -- and maybe it doesn't). + -- + -- The loop state, in this case, would be these three paths: + -- + -- [ 4, 2, 1 ] + -- [ 5, 2, 1 ] + -- [ 6, 3, 1 ] + go :: List.NonEmpty (List.NonEmpty a) -> m (Maybe (List.NonEmpty a)) + go (path :| paths) = do + -- Get the children of the first path (in the above example, [ 4, 2, 1 ]). + ys0 <- children (List.NonEmpty.head path) + case List.NonEmpty.nonEmpty ys0 of + -- If node 4 had no more children, we can toss that whole path: it didn't end in a goal. Now we either keep + -- searching (as we would in the example, since we have two more paths to continue from), or we don't, because + -- this was the only remaining path. + Nothing -> + case List.NonEmpty.nonEmpty paths of + Nothing -> pure Nothing + Just paths' -> go paths' + -- If node 4 did have children, then maybe the search tree now looks like this. + -- + -- 1 + -- / \ + -- 2 3 + -- / \ \ + -- 4 5 6 + -- / \ + -- 7 8 + -- + -- There are two cases to handle: + -- + -- 1. One of the children we just discovered (say 7) is a goal node. So we're done, and we'd return the path + -- + -- [ 7, 4, 2, 1 ] + -- + -- 2. No child we just discovered (7 nor 8) were a goal node. So we loop, putting our new path(s) at the end + -- of the list (so we search paths fairly). In this case, we'd re-enter the loop with the following four + -- paths: + -- + -- [ 5, 2, 1 ] \ these two are are variable 'paths', the tail of the loop state. + -- [ 6, 3, 1 ] / + -- [ 7, 4, 2, 1 ] \ these two are new, just constructed by prepending each of [ 4, 2, 1 ]'s children + -- [ 8, 4, 2, 1 ] / to itself, making two new paths to search + Just ys -> + case Foldable.find goal ys of + Nothing -> go (append paths ((\y -> cons y path) <$> ys)) + Just y -> pure (Just (cons y path)) + in \source -> go ((source :| []) :| []) + where + -- Cons an element onto the head of a non-empty list. + cons :: x -> List.NonEmpty x -> List.NonEmpty x + cons x (y :| ys) = + x :| y : ys + + -- Concatenate a list and a non-empty list. + append :: [x] -> List.NonEmpty x -> List.NonEmpty x + append xs0 ys = + case List.NonEmpty.nonEmpty xs0 of + Nothing -> ys + Just xs -> xs <> ys + ------------------------------------------------------------------------------------------------------------------------ -- Pull From ebd76c1b8280f06db9de1bab76b6d3a514665937 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 4 May 2022 21:15:00 -0400 Subject: [PATCH 184/529] typo --- unison-cli/src/Unison/Share/Sync.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 5a00e336da..ce7b2b2d65 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -221,7 +221,7 @@ dagbfs goal children = -- / \ \ -- 4 5 6 -- - -- Graphically, the frontier here is the nodes 4, 5, and 3; we know that, because I haven't drawn any nodes below + -- Graphically, the frontier here is the nodes 4, 5, and 6; we know that, because I haven't drawn any nodes below -- them. (This is a BFS algorithm that discovers children on-the-fly, so maybe node 5 (for example) has children, -- and maybe it doesn't). -- From 702c7da551cecdbd90efee4fc49a30db2943b308 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 5 May 2022 10:43:26 -0400 Subject: [PATCH 185/529] switch bfs path accumulator to support O(log n) append --- unison-cli/src/Unison/Share/Sync.hs | 30 +++++++++++++---------------- 1 file changed, 13 insertions(+), 17 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index ce7b2b2d65..d14d257975 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -32,12 +32,15 @@ import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as List.NonEmpty import Data.Map.NonEmpty (NEMap) import qualified Data.Map.NonEmpty as NEMap +import Data.Sequence.NonEmpty (NESeq ((:<||))) +import qualified Data.Sequence.NonEmpty as NESeq (fromList, nonEmptySeq, singleton, (><|)) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import Data.Vector (Vector) import qualified Data.Vector as Vector import Servant.Client (BaseUrl) +import qualified Text.Regex.TDFA.CorePattern as List import U.Codebase.HashTags (CausalHash (..)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import qualified U.Codebase.Sqlite.Causal as Causal @@ -230,8 +233,8 @@ dagbfs goal children = -- [ 4, 2, 1 ] -- [ 5, 2, 1 ] -- [ 6, 3, 1 ] - go :: List.NonEmpty (List.NonEmpty a) -> m (Maybe (List.NonEmpty a)) - go (path :| paths) = do + go :: NESeq (List.NonEmpty a) -> m (Maybe (List.NonEmpty a)) + go (path :<|| paths) = do -- Get the children of the first path (in the above example, [ 4, 2, 1 ]). ys0 <- children (List.NonEmpty.head path) case List.NonEmpty.nonEmpty ys0 of @@ -239,7 +242,7 @@ dagbfs goal children = -- searching (as we would in the example, since we have two more paths to continue from), or we don't, because -- this was the only remaining path. Nothing -> - case List.NonEmpty.nonEmpty paths of + case NESeq.nonEmptySeq paths of Nothing -> pure Nothing Just paths' -> go paths' -- If node 4 did have children, then maybe the search tree now looks like this. @@ -268,21 +271,14 @@ dagbfs goal children = -- [ 8, 4, 2, 1 ] / to itself, making two new paths to search Just ys -> case Foldable.find goal ys of - Nothing -> go (append paths ((\y -> cons y path) <$> ys)) - Just y -> pure (Just (cons y path)) - in \source -> go ((source :| []) :| []) + Nothing -> go (append paths ((\y -> List.NonEmpty.cons y path) <$> NESeq.fromList ys)) + Just y -> pure (Just (List.NonEmpty.cons y path)) + in -- lts-18.28 doesn't have List.NonEmpty.singleton + \source -> go (NESeq.singleton (source :| [])) where - -- Cons an element onto the head of a non-empty list. - cons :: x -> List.NonEmpty x -> List.NonEmpty x - cons x (y :| ys) = - x :| y : ys - - -- Concatenate a list and a non-empty list. - append :: [x] -> List.NonEmpty x -> List.NonEmpty x - append xs0 ys = - case List.NonEmpty.nonEmpty xs0 of - Nothing -> ys - Just xs -> xs <> ys + -- Concatenate a seq and a non-empty seq. + append :: Seq x -> NESeq x -> NESeq x + append = (NESeq.><|) ------------------------------------------------------------------------------------------------------------------------ -- Pull From 28b3c59772562e79dc6b6257a57f4c9d20d83abd Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 5 May 2022 11:43:47 -0400 Subject: [PATCH 186/529] replace force push with fast-forward push --- .../src/Unison/Codebase/Editor/HandleInput.hs | 32 ++++++------------- unison-cli/src/Unison/Share/Sync.hs | 1 + 2 files changed, 10 insertions(+), 23 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 197e7cc966..05c83b5e73 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1789,34 +1789,20 @@ handlePushToUnisonShare remoteRepo remotePath = do LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask - -- First, get the remote causal's hash at the requested path. This effectively gives `push.share` force-push - -- semantics, as the user doesn't provide the expected remote hash themselves, ala `git push --force-with-lease`. - -- Then, with our trusty remote causal hash, do the push. - localCausalHash <- do localPath <- use LoopState.currentPath Sqlite.runTransaction connection do Ops.expectCausalHashAtPath (coerce @[NameSegment] @[Text] (Path.toList (Path.unabsolute localPath))) - let doPush :: Maybe Share.Hash -> IO () - doPush expectedHash = - Share.checkAndSetPush authHTTPClient unisonShareUrl connection repoPath expectedHash localCausalHash >>= \case - Left pushError -> - case pushError of - -- Race condition: inbetween getting the remote causal hash and attempting to overwrite it, it changed. - -- So, because this push has force-push semantics anyway, just loop again with the latest known remote - -- causal hash and attempt the push again. - Share.PushErrorHashMismatch Share.HashMismatch {actualHash} -> - doPush (Share.TypedHash.hash <$> actualHash) - Share.PushErrorNoWritePermission _ -> undefined - -- Meh; bug in client or server? Even though we (thought we) pushed all of the entities we were supposed - -- to, the server still said it was missing some when we tried to set the remote causal hash. - Share.PushErrorServerMissingDependencies missingDependencies -> undefined - Right () -> pure () - - liftIO (Share.getCausalHashByPath authHTTPClient unisonShareUrl repoPath) >>= \case - Left (Share.GetCausalHashByPathErrorNoReadPermission _) -> undefined - Right causalHashJwt -> liftIO (doPush (Share.hashJWTHash <$> causalHashJwt)) + liftIO (Share.fastForwardPush authHTTPClient unisonShareUrl connection repoPath localCausalHash) >>= \case + Left err -> + case err of + Share.FastForwardPushErrorNoHistory _repoPath -> undefined + Share.FastForwardPushErrorNoReadPermission _repoPath -> undefined + Share.FastForwardPushErrorNotFastForward -> undefined + Share.FastForwardPushErrorNoWritePermission _repoPath -> undefined + Share.FastForwardPushErrorServerMissingDependencies _dependencies -> undefined + Right () -> pure () -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index d14d257975..6e47459723 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -5,6 +5,7 @@ module Unison.Share.Sync checkAndSetPush, PushError (..), fastForwardPush, + FastForwardPushError (..), -- ** Pull pull, From e8ad5e6a1790392a2bd82427dbf908f600481c43 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 5 May 2022 11:19:09 -0600 Subject: [PATCH 187/529] Load names from index for faster definition and find endpoints (#3059) Allow using names index to back the backend so we can call it faster from Enlil. --- .../U/Codebase/Sqlite/NamedRef.hs | 38 +++ .../U/Codebase/Sqlite/Operations.hs | 45 +++- .../U/Codebase/Sqlite/Orphans.hs | 65 +++++ .../U/Codebase/Sqlite/Queries.hs | 117 +++++++-- .../U/Codebase/Sqlite/Reference.hs | 33 ++- .../U/Codebase/Sqlite/Referent.hs | 19 +- codebase2/codebase-sqlite/package.yaml | 2 + .../unison-codebase-sqlite.cabal | 4 + codebase2/codebase/U/Codebase/Referent.hs | 5 + codebase2/util/src/U/Util/Hash.hs | 7 + lib/unison-prelude/src/Unison/Prelude.hs | 1 + .../src/Unison/Util/Pretty.hs | 1 - lib/unison-sqlite/package.yaml | 2 + lib/unison-sqlite/unison-sqlite.cabal | 2 + parser-typechecker/src/Unison/Codebase.hs | 2 + .../src/Unison/Codebase/SqliteCodebase.hs | 12 +- .../Codebase/SqliteCodebase/Conversions.hs | 10 + .../Codebase/SqliteCodebase/Operations.hs | 78 ++++++ .../src/Unison/Codebase/Type.hs | 12 +- parser-typechecker/src/Unison/Result.hs | 1 - .../src/Unison/Runtime/IOSource.hs | 1 - .../src/Unison/Util/TransitiveClosure.hs | 1 - .../Unison/Codebase/Editor/HandleCommand.hs | 11 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 6 +- .../Codebase/Editor/HandleInput/LoopState.hs | 11 +- .../src/Unison/Codebase/TranscriptParser.hs | 3 +- unison-cli/unison/Main.hs | 3 +- unison-core/src/Unison/ABT.hs | 39 ++- unison-core/src/Unison/Name.hs | 28 +++ unison-core/src/Unison/Names.hs | 4 + unison-core/src/Unison/Names/Scoped.hs | 24 ++ unison-core/src/Unison/NamesWithHistory.hs | 3 + unison-core/src/Unison/Reference.hs | 2 +- unison-core/src/Unison/Referent'.hs | 2 +- unison-core/src/Unison/Type.hs | 3 +- unison-core/unison-core1.cabal | 1 + unison-share-api/src/Unison/Server/Backend.hs | 230 ++++++++++-------- .../src/Unison/Server/CodebaseServer.hs | 33 +-- .../src/Unison/Server/Endpoints/FuzzyFind.hs | 29 ++- .../Unison/Server/Endpoints/GetDefinitions.hs | 30 +-- .../Server/Endpoints/NamespaceDetails.hs | 6 +- .../Server/Endpoints/NamespaceListing.hs | 2 +- .../src/Unison/Server/Endpoints/Projects.hs | 9 +- unison-src/transcripts/api-getDefinition.md | 6 + .../transcripts/api-getDefinition.output.md | 190 +++++++++++++++ 45 files changed, 896 insertions(+), 237 deletions(-) create mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs create mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/Orphans.hs create mode 100644 unison-core/src/Unison/Names/Scoped.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs new file mode 100644 index 0000000000..ff0a959e85 --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs @@ -0,0 +1,38 @@ +module U.Codebase.Sqlite.NamedRef where + +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text as Text +import Unison.Prelude +import Unison.Sqlite (FromField (..), FromRow (..), SQLData (..), ToField (..), ToRow (..), field) + +type ReversedSegments = NonEmpty Text + +data ConstructorType + = DataConstructor + | EffectConstructor + +instance ToField (ConstructorType) where + toField ct = case ct of + DataConstructor -> (SQLInteger 0) + EffectConstructor -> (SQLInteger 1) + +instance FromField (ConstructorType) where + fromField f = + fromField @Int f >>= \case + 0 -> pure DataConstructor + 1 -> pure EffectConstructor + _ -> fail "Invalid ConstructorType" + +data NamedRef ref = NamedRef {reversedSegments :: ReversedSegments, ref :: ref} + deriving stock (Show, Functor, Foldable, Traversable) + +instance ToRow ref => ToRow (NamedRef ref) where + toRow (NamedRef {reversedSegments = segments, ref}) = + [toField (Text.intercalate "." . toList $ segments)] <> toRow ref + +instance FromRow ref => FromRow (NamedRef ref) where + fromRow = do + reversedSegments <- NonEmpty.fromList . Text.splitOn "." <$> field + ref <- fromRow + pure (NamedRef {reversedSegments, ref}) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 4ead3d308c..9246f48800 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -60,6 +60,10 @@ module U.Codebase.Sqlite.Operations addTypeMentionsToIndexForTerm, termsMentioningType, + -- ** name lookup index + rebuildNameIndex, + rootBranchNames, + -- * low-level stuff expectDbBranch, expectDbPatch, @@ -90,13 +94,12 @@ import Data.Bitraversable (Bitraversable (bitraverse)) import Data.Bytes.Get (runGetS) import qualified Data.Bytes.Get as Get import qualified Data.Foldable as Foldable -import Data.Functor.Identity (Identity) import qualified Data.Map as Map import qualified Data.Map.Merge.Lazy as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as Text -import Data.Tuple.Extra (uncurry3) +import Data.Tuple.Extra (uncurry3, (***)) import qualified Data.Vector as Vector import qualified U.Codebase.Branch as C.Branch import qualified U.Codebase.Causal as C @@ -129,6 +132,7 @@ import U.Codebase.Sqlite.LocalIds ) import qualified U.Codebase.Sqlite.LocalIds as LocalIds import qualified U.Codebase.Sqlite.LocalizeObject as LocalizeObject +import qualified U.Codebase.Sqlite.NamedRef as S import qualified U.Codebase.Sqlite.ObjectType as OT import qualified U.Codebase.Sqlite.Patch.Diff as S import qualified U.Codebase.Sqlite.Patch.Format as S @@ -220,9 +224,15 @@ loadRootCausalHash = c2sReference :: C.Reference -> Transaction S.Reference c2sReference = bitraverse Q.saveText Q.expectObjectIdForPrimaryHash +c2sTextReference :: C.Reference -> S.TextReference +c2sTextReference = bimap id H.toBase32Hex + s2cReference :: S.Reference -> Transaction C.Reference s2cReference = bitraverse Q.expectText Q.expectPrimaryHashByObjectId +s2cTextReference :: S.TextReference -> C.Reference +s2cTextReference = bimap id H.fromBase32Hex + c2sReferenceId :: C.Reference.Id -> Transaction S.Reference.Id c2sReferenceId = C.Reference.idH Q.expectObjectIdForPrimaryHash @@ -241,12 +251,28 @@ c2hReference = bitraverse (MaybeT . Q.loadTextId) (MaybeT . Q.loadHashIdByHash) s2cReferent :: S.Referent -> Transaction C.Referent s2cReferent = bitraverse s2cReference s2cReference +s2cTextReferent :: S.TextReferent -> C.Referent +s2cTextReferent = bimap s2cTextReference s2cTextReference + +s2cConstructorType :: S.ConstructorType -> C.ConstructorType +s2cConstructorType = \case + S.DataConstructor -> C.DataConstructor + S.EffectConstructor -> C.EffectConstructor + +c2sConstructorType :: C.ConstructorType -> S.ConstructorType +c2sConstructorType = \case + C.DataConstructor -> S.DataConstructor + C.EffectConstructor -> S.EffectConstructor + s2cReferentId :: S.Referent.Id -> Transaction C.Referent.Id s2cReferentId = bitraverse Q.expectPrimaryHashByObjectId Q.expectPrimaryHashByObjectId c2sReferent :: C.Referent -> Transaction S.Referent c2sReferent = bitraverse c2sReference c2sReference +c2sTextReferent :: C.Referent -> S.TextReferent +c2sTextReferent = bimap c2sTextReference c2sTextReference + c2sReferentId :: C.Referent.Id -> Transaction S.Referent.Id c2sReferentId = bitraverse Q.expectObjectIdForPrimaryHash Q.expectObjectIdForPrimaryHash @@ -1274,3 +1300,18 @@ derivedDependencies cid = do sids <- Q.getDependencyIdsForDependent sid cids <- traverse s2cReferenceId sids pure $ Set.fromList cids + +-- | Given the list of term and type names from the root branch, rebuild the name lookup +-- table. +rebuildNameIndex :: [S.NamedRef (C.Referent, Maybe C.ConstructorType)] -> [S.NamedRef C.Reference] -> Transaction () +rebuildNameIndex termNames typeNames = do + Q.resetNameLookupTables + Q.insertTermNames ((fmap (c2sTextReferent *** fmap c2sConstructorType) <$> termNames)) + Q.insertTypeNames ((fmap c2sTextReference <$> typeNames)) + +-- | Get all the term and type names for the root namespace from the lookup table. +rootBranchNames :: Transaction ([S.NamedRef (C.Referent, Maybe C.ConstructorType)], [S.NamedRef C.Reference]) +rootBranchNames = do + termNames <- Q.rootTermNames + typeNames <- Q.rootTypeNames + pure (fmap (bimap s2cTextReferent (fmap s2cConstructorType)) <$> termNames, fmap s2cTextReference <$> typeNames) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Orphans.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Orphans.hs new file mode 100644 index 0000000000..5279212d51 --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Orphans.hs @@ -0,0 +1,65 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module U.Codebase.Sqlite.Orphans where + +import Control.Applicative +import qualified U.Codebase.Reference as C.Reference +import qualified U.Codebase.Referent as C.Referent +import U.Codebase.WatchKind (WatchKind) +import qualified U.Codebase.WatchKind as WatchKind +import U.Util.Base32Hex +import qualified U.Util.Hash as Hash +import Unison.Prelude +import Unison.Sqlite + +-- Newtype for avoiding orphan instances +newtype AsSqlite a = AsSqlite {fromSQLite :: a} + deriving (Show) + +instance ToRow (AsSqlite C.Reference.Reference) where + toRow (AsSqlite ref) = case ref of + C.Reference.ReferenceBuiltin txt -> [SQLText txt, SQLNull, SQLNull] + C.Reference.ReferenceDerived (C.Reference.Id h p) -> [SQLNull, toField $ Hash.toBase32HexText h, toField p] + +instance ToRow (AsSqlite C.Referent.Referent) where + toRow (AsSqlite ref) = case ref of + C.Referent.Ref ref' -> toRow (AsSqlite ref') <> [SQLNull] + C.Referent.Con ref' conId -> toRow (AsSqlite ref') <> [toField conId] + +instance FromRow (AsSqlite C.Referent.Referent) where + fromRow = do + AsSqlite reference <- fromRow + field >>= \case + Nothing -> pure $ AsSqlite (C.Referent.Ref reference) + Just conId -> pure $ AsSqlite (C.Referent.Con reference conId) + +instance FromRow (AsSqlite C.Reference.Reference) where + fromRow = do + liftA3 (,,) field field field >>= \case + (Just builtin, Nothing, Nothing) -> pure . AsSqlite $ (C.Reference.ReferenceBuiltin builtin) + (Nothing, Just (AsSqlite hash), Just pos) -> pure . AsSqlite $ C.Reference.ReferenceDerived (C.Reference.Id hash pos) + p -> error $ "Invalid Reference parameters" <> show p + +instance ToField (AsSqlite Hash.Hash) where + toField (AsSqlite h) = toField (Hash.toBase32HexText h) + +instance FromField (AsSqlite Hash.Hash) where + fromField f = + fromField @Text f <&> \txt -> + AsSqlite $ (Hash.unsafeFromBase32HexText txt) + +deriving via Text instance ToField Base32Hex + +deriving via Text instance FromField Base32Hex + +instance ToField WatchKind where + toField = \case + WatchKind.RegularWatch -> SQLInteger 0 + WatchKind.TestWatch -> SQLInteger 1 + +instance FromField WatchKind where + fromField = + fromField @Int8 <&> fmap \case + 0 -> WatchKind.RegularWatch + 1 -> WatchKind.TestWatch + tag -> error $ "Unknown WatchKind id " ++ show tag diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 41c1023a67..4898123275 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -Wno-orphans #-} - -- | Some naming conventions used in this module: -- -- * @32@: the base32 representation of a hash @@ -118,6 +116,13 @@ module U.Codebase.Sqlite.Queries namespaceHashIdByBase32Prefix, causalHashIdByBase32Prefix, + -- * Name Lookup + resetNameLookupTables, + insertTermNames, + insertTypeNames, + rootTermNames, + rootTypeNames, + -- * garbage collection garbageCollectObjectsWithoutHashes, garbageCollectWatchesWithoutObjects, @@ -150,11 +155,12 @@ import U.Codebase.Sqlite.DbId SchemaVersion, TextId, ) +import qualified U.Codebase.Sqlite.NamedRef as S import U.Codebase.Sqlite.ObjectType (ObjectType (DeclComponent, Namespace, Patch, TermComponent)) +import U.Codebase.Sqlite.Orphans () import qualified U.Codebase.Sqlite.Reference as Reference import qualified U.Codebase.Sqlite.Referent as Referent import U.Codebase.WatchKind (WatchKind) -import qualified U.Codebase.WatchKind as WatchKind import qualified U.Util.Alternative as Alternative import U.Util.Base32Hex (Base32Hex (..)) import U.Util.Hash (Hash) @@ -904,6 +910,93 @@ removeHashObjectsByHashingVersion hashVersion = WHERE hash_version = ? |] +-- | Drop and recreate the name lookup tables. Use this when resetting names to a new branch. +resetNameLookupTables :: Transaction () +resetNameLookupTables = do + execute_ "DROP TABLE IF EXISTS term_name_lookup" + execute_ "DROP TABLE IF EXISTS type_name_lookup" + execute_ + [here| + CREATE TABLE term_name_lookup ( + reversed_name TEXT NOT NULL, -- e.g. map.List.base + referent_builtin INTEGER NULL, + referent_object_id INTEGER NULL, + referent_component_index INTEGER NULL, + referent_constructor_index INTEGER NULL, + referent_constructor_type INTEGER NULL, + PRIMARY KEY (reversed_name, referent_builtin, referent_object_id, referent_component_index, referent_constructor_index) + ) + |] + -- Don't need this index at the moment, but will likely be useful later. + -- execute_ + -- [here| + -- CREATE INDEX IF NOT EXISTS term_name_by_referent_lookup ON term_name_lookup(referent_builtin, referent_object_id, referent_component_index, referent_constructor_index) + -- |] + execute_ + [here| + CREATE TABLE type_name_lookup ( + reversed_name TEXT NOT NULL, -- e.g. map.List.base + reference_builtin INTEGER NULL, + reference_object_id INTEGER NULL, + reference_component_index INTEGER NULL, + PRIMARY KEY (reversed_name, reference_builtin, reference_object_id, reference_component_index) + ); + |] + +-- Don't need this index at the moment, but will likely be useful later. +-- execute_ +-- [here| +-- CREATE INDEX IF NOT EXISTS type_name_by_reference_lookup ON type_name_lookup(reference_builtin, reference_object_id, reference_component_index); +-- |] + +-- | Insert the given set of term names into the name lookup table +insertTermNames :: [S.NamedRef (Referent.TextReferent, Maybe S.ConstructorType)] -> Transaction () +insertTermNames names = do + executeMany sql (fmap asRow <$> names) + where + asRow (a, b) = a :. Only b + sql = + [here| + INSERT INTO term_name_lookup (reversed_name, referent_builtin, referent_object_id, referent_component_index, referent_constructor_index, referent_constructor_type) + VALUES (?, ?, ?, ?, ?, ?) + ON CONFLICT DO NOTHING + |] + +-- | Insert the given set of type names into the name lookup table +insertTypeNames :: [S.NamedRef (Reference.TextReference)] -> Transaction () +insertTypeNames names = + executeMany sql names + where + sql = + [here| + INSERT INTO type_name_lookup (reversed_name, reference_builtin, reference_object_id, reference_component_index) + VALUES (?, ?, ?, ?) + ON CONFLICT DO NOTHING + |] + +-- | Get the list of a term names in the root namespace according to the name lookup index +rootTermNames :: Transaction [S.NamedRef (Referent.TextReferent, Maybe S.ConstructorType)] +rootTermNames = do + (fmap . fmap) unRow <$> queryListRow_ sql + where + unRow (a :. Only b) = (a, b) + sql = + [here| + SELECT reversed_name, referent_builtin, referent_object_id, referent_component_index, referent_constructor_index, referent_constructor_type FROM term_name_lookup + ORDER BY reversed_name ASC + |] + +-- | Get the list of a type names in the root namespace according to the name lookup index +rootTypeNames :: Transaction [S.NamedRef Reference.TextReference] +rootTypeNames = do + queryListRow_ sql + where + sql = + [here| + SELECT reversed_name, reference_builtin, reference_object_id, reference_component_index FROM type_name_lookup + ORDER BY reversed_name ASC + |] + before :: CausalHashId -> CausalHashId -> Transaction Bool before chId1 chId2 = queryOneCol sql (chId2, chId1) where @@ -954,21 +1047,3 @@ ancestorSql = ) SELECT * FROM ancestor |] - --- * orphan instances - -deriving via Text instance ToField Base32Hex - -deriving via Text instance FromField Base32Hex - -instance ToField WatchKind where - toField = \case - WatchKind.RegularWatch -> SQLInteger 0 - WatchKind.TestWatch -> SQLInteger 1 - -instance FromField WatchKind where - fromField = - fromField @Int8 <&> fmap \case - 0 -> WatchKind.RegularWatch - 1 -> WatchKind.TestWatch - tag -> error $ "Unknown WatchKind id " ++ show tag diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs index a54fe9279d..fac223e1f6 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs @@ -4,15 +4,21 @@ module U.Codebase.Sqlite.Reference where -import Control.Applicative (liftA3) import Data.Tuple.Only (Only (..)) import U.Codebase.Reference (Id' (Id), Reference' (ReferenceBuiltin, ReferenceDerived)) import U.Codebase.Sqlite.DbId (HashId, ObjectId, TextId) import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalHashId, LocalTextId) +import U.Codebase.Sqlite.Orphans () +import U.Util.Base32Hex +import Unison.Prelude import Unison.Sqlite (FromField, FromRow (fromRow), RowParser, SQLData (SQLNull), ToField, ToRow (toRow), field) type Reference = Reference' TextId ObjectId +-- | The name lookup table uses this because normalizing/denormalizing hashes to ids is slower +-- than we'd like when writing/reading the entire name lookup table. +type TextReference = Reference' Text Base32Hex + type Id = Id' ObjectId type LocalReferenceH = Reference' LocalTextId LocalHashId @@ -25,17 +31,27 @@ type ReferenceH = Reference' TextId HashId type IdH = Id' HashId --- * Orphan instances +instance ToRow (Reference' Text Base32Hex) where + toRow = referenceToRow instance ToRow (Reference' TextId HashId) where - toRow = \case - ReferenceBuiltin t -> toRow (Only t) ++ [SQLNull, SQLNull] - ReferenceDerived (Id h i) -> SQLNull : toRow (Only h) ++ toRow (Only i) + toRow = referenceToRow + +instance ToRow Reference where + toRow = referenceToRow + +referenceToRow :: (ToField t, ToField h) => Reference' t h -> [SQLData] +referenceToRow = \case + ReferenceBuiltin t -> toRow (Only t) ++ [SQLNull, SQLNull] + ReferenceDerived (Id h i) -> SQLNull : toRow (Only h) ++ toRow (Only i) instance FromRow (Reference' TextId HashId) where fromRow = referenceFromRow' -instance FromRow (Reference' TextId ObjectId) where +instance FromRow (Reference) where + fromRow = referenceFromRow' + +instance FromRow (Reference' Text Base32Hex) where fromRow = referenceFromRow' referenceFromRow' :: (FromField t, FromField h, Show t, Show h) => RowParser (Reference' t h) @@ -50,11 +66,6 @@ referenceFromRow' = liftA3 mkRef field field field where str = "(" ++ show t ++ ", " ++ show h ++ ", " ++ show i ++ ")" -instance ToRow (Reference' TextId ObjectId) where - toRow = \case - ReferenceBuiltin t -> toRow (Only t) ++ [SQLNull, SQLNull] - ReferenceDerived (Id h i) -> SQLNull : toRow (Only h) ++ toRow (Only i) - instance ToField h => ToRow (Id' h) where toRow = \case Id h i -> toRow (Only h) ++ toRow (Only i) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs index 80a34ec3f2..9a9a641132 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs @@ -12,10 +12,14 @@ import U.Codebase.Referent (Id', Referent') import qualified U.Codebase.Referent as Referent import U.Codebase.Sqlite.DbId (ObjectId) import qualified U.Codebase.Sqlite.Reference as Sqlite -import Unison.Sqlite (FromRow (..), SQLData (..), ToRow (..), field) +import Unison.Sqlite (FromRow (..), SQLData (..), ToField (toField), ToRow (..), field) type Referent = Referent' Sqlite.Reference Sqlite.Reference +-- | The name lookup table uses this because normalizing/denormalizing hashes to ids is slower +-- than we'd like when writing/reading the entire name lookup table. +type TextReferent = Referent' Sqlite.TextReference Sqlite.TextReference + type ReferentH = Referent' Sqlite.ReferenceH Sqlite.ReferenceH type Id = Id' ObjectId ObjectId @@ -35,3 +39,16 @@ instance FromRow Id where mkId h i mayCid = case mayCid of Nothing -> Referent.RefId (Reference.Id h i) Just cid -> Referent.ConId (Reference.Id h i) cid + +instance (ToRow (Reference.Reference' t h)) => ToRow (Referent' (Reference.Reference' t h) (Reference.Reference' t h)) where + toRow = \case + Referent.Ref ref -> toRow ref <> [SQLNull] + Referent.Con ref conId -> toRow ref <> [toField conId] + +instance (FromRow (Reference.Reference' t h)) => FromRow (Referent' (Reference.Reference' t h) (Reference.Reference' t h)) where + fromRow = do + ref <- fromRow + mayCid <- field + case mayCid of + Nothing -> pure $ Referent.Ref ref + Just cid -> pure $ Referent.Con ref cid diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index 3ffaed340a..91f633de87 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -40,6 +40,8 @@ default-extensions: - ConstraintKinds - DeriveAnyClass - DeriveFunctor + - DeriveFoldable + - DeriveTraversable - DeriveGeneric - DerivingStrategies - DerivingVia diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index b6f82f8121..1fba325b10 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -26,8 +26,10 @@ library U.Codebase.Sqlite.Decl.Format U.Codebase.Sqlite.LocalIds U.Codebase.Sqlite.LocalizeObject + U.Codebase.Sqlite.NamedRef U.Codebase.Sqlite.ObjectType U.Codebase.Sqlite.Operations + U.Codebase.Sqlite.Orphans U.Codebase.Sqlite.Patch.Diff U.Codebase.Sqlite.Patch.Format U.Codebase.Sqlite.Patch.Full @@ -51,6 +53,8 @@ library ConstraintKinds DeriveAnyClass DeriveFunctor + DeriveFoldable + DeriveTraversable DeriveGeneric DerivingStrategies DerivingVia diff --git a/codebase2/codebase/U/Codebase/Referent.hs b/codebase2/codebase/U/Codebase/Referent.hs index a869f992f9..6f9652bbfa 100644 --- a/codebase2/codebase/U/Codebase/Referent.hs +++ b/codebase2/codebase/U/Codebase/Referent.hs @@ -18,6 +18,11 @@ import qualified U.Codebase.Reference as Reference import U.Util.Hash (Hash) import Unison.Prelude +data ConstructorType + = DataConstructor + | EffectConstructor + deriving (Show, Eq, Ord) + type Referent = Referent' Reference Reference type ReferentH = Referent' (Reference' Text (Maybe Hash)) (Reference' Text Hash) diff --git a/codebase2/util/src/U/Util/Hash.hs b/codebase2/util/src/U/Util/Hash.hs index 97ca6d0fe7..c05921f26b 100644 --- a/codebase2/util/src/U/Util/Hash.hs +++ b/codebase2/util/src/U/Util/Hash.hs @@ -3,6 +3,7 @@ module U.Util.Hash ( Hash (Hash, toShort), + unsafeFromBase32HexText, fromBase32Hex, fromByteString, toBase32Hex, @@ -31,6 +32,12 @@ toBase32HexText = Base32Hex.toText . toBase32Hex fromBase32Hex :: Base32Hex -> Hash fromBase32Hex = Hash . B.Short.toShort . Base32Hex.toByteString +-- | Constructs a hash from base32 checks without any validation. +-- Note that this converts Text -> ByteString -> ShortByteString and so is slower than +-- we'd prefer. +unsafeFromBase32HexText :: Text -> Hash +unsafeFromBase32HexText = fromBase32Hex . Base32Hex.UnsafeFromText + toByteString :: Hash -> ByteString toByteString = fromShort . toShort diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index 83025193c9..cb6a525c81 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -40,6 +40,7 @@ import Data.Either.Extra (eitherToMaybe, maybeToEither) import Data.Foldable as X (asum, fold, foldl', for_, toList, traverse_) import Data.Function as X ((&)) import Data.Functor as X +import Data.Functor.Identity as X import Data.Int as X import Data.List as X (foldl1', sortOn) import Data.Map as X (Map) diff --git a/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs b/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs index 886b5003d5..ce475c3453 100644 --- a/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs +++ b/lib/unison-pretty-printer/src/Unison/Util/Pretty.hs @@ -142,7 +142,6 @@ module Unison.Util.Pretty ) where -import Control.Monad.Identity (Identity (..), runIdentity) import Data.Bifunctor (second) import Data.Char (isSpace) import Data.List (intersperse) diff --git a/lib/unison-sqlite/package.yaml b/lib/unison-sqlite/package.yaml index 470387298a..bd2c6917c1 100644 --- a/lib/unison-sqlite/package.yaml +++ b/lib/unison-sqlite/package.yaml @@ -33,6 +33,8 @@ default-extensions: - ConstraintKinds - DeriveAnyClass - DeriveFunctor + - DeriveFoldable + - DeriveTraversable - DerivingStrategies - DerivingVia - DoAndIfThenElse diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 67e02d8e98..9c3ffa8a4e 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -33,6 +33,8 @@ library ConstraintKinds DeriveAnyClass DeriveFunctor + DeriveFoldable + DeriveTraversable DerivingStrategies DerivingVia DoAndIfThenElse diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 748aa169cb..8ff32e876f 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -43,8 +43,10 @@ module Unison.Codebase -- * Root branch getRootBranch, getRootBranchExists, + getRootBranchHash, putRootBranch, rootBranchUpdates, + namesAtPath, -- * Patches patchExists, diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 0b067ef6b3..2097a3e53c 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -41,6 +41,7 @@ import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase1 import Unison.Codebase.Branch (Branch (..)) import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Names as Branch import qualified Unison.Codebase.Causal.Type as Causal import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo) import qualified Unison.Codebase.Editor.Git as Git @@ -268,8 +269,8 @@ sqliteCodebase debugName root localOrRemote action = do Sqlite.runTransaction conn CodebaseOps.getRootBranchExists putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> Branch m -> m () - putRootBranch rootBranchCache branch1 = - withRunInIO \runInIO -> + putRootBranch rootBranchCache branch1 = do + withRunInIO \runInIO -> do Sqlite.runTransaction conn do CodebaseOps.putRootBranch rootBranchCache (Branch.transform (Sqlite.unsafeIO . runInIO) branch1) @@ -486,7 +487,12 @@ sqliteCodebase debugName root localOrRemote action = do branchHashLength = branchHashLength, branchHashesByPrefix = branchHashesByPrefix, lcaImpl = (Just sqlLca), - beforeImpl = (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r) + beforeImpl = (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r), + namesAtPath = \path -> Sqlite.runReadOnlyTransaction conn \runTx -> + runTx (CodebaseOps.namesAtPath path), + updateNameLookup = Sqlite.runTransaction conn $ do + root <- (CodebaseOps.getRootBranch getDeclType rootBranchCache) + CodebaseOps.saveRootNamesIndex (Branch.toNames . Branch.head $ root) } let finalizer :: MonadIO m => m () finalizer = do diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs index 4bf1b25fb9..99a9f63f9a 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs @@ -344,6 +344,16 @@ referentid2to1 lookupCT = \case V2.ConId r i -> V1.ConId (V1.ConstructorReference (referenceid2to1 r) (fromIntegral i)) <$> lookupCT (V2.ReferenceDerived r) +constructorType1to2 :: CT.ConstructorType -> V2.ConstructorType +constructorType1to2 = \case + CT.Data -> V2.DataConstructor + CT.Effect -> V2.EffectConstructor + +constructorType2to1 :: V2.ConstructorType -> CT.ConstructorType +constructorType2to1 = \case + V2.DataConstructor -> CT.Data + V2.EffectConstructor -> CT.Effect + hash2to1 :: V2.Hash.Hash -> Hash hash2to1 (V2.Hash.Hash sbs) = V1.Hash sbs diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index f80889c3f8..c71059104b 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -19,6 +19,7 @@ import U.Codebase.HashTags (CausalHash (unCausalHash)) import qualified U.Codebase.Reference as C.Reference import qualified U.Codebase.Referent as C.Referent import U.Codebase.Sqlite.DbId (ObjectId) +import qualified U.Codebase.Sqlite.NamedRef as S import qualified U.Codebase.Sqlite.ObjectType as OT import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Q @@ -28,6 +29,8 @@ import Unison.Codebase.Branch (Branch (..)) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Causal.Type as Causal import Unison.Codebase.Patch (Patch) +import Unison.Codebase.Path (Path) +import qualified Unison.Codebase.Path as Path import Unison.Codebase.ShortBranchHash (ShortBranchHash) import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import Unison.ConstructorReference (GConstructorReference (..)) @@ -36,6 +39,12 @@ import Unison.DataDeclaration (Decl) import qualified Unison.DataDeclaration as Decl import Unison.Hash (Hash) import qualified Unison.Hashing.V2.Convert as Hashing +import Unison.Name (Name) +import qualified Unison.Name as Name +import Unison.NameSegment (NameSegment (..)) +import Unison.Names (Names (Names)) +import qualified Unison.Names as Names +import Unison.Names.Scoped (ScopedNames (..)) import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Reference (Reference) @@ -51,6 +60,7 @@ import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) import qualified Unison.Type as Type +import qualified Unison.Util.Relation as Rel import qualified Unison.Util.Set as Set import qualified Unison.WatchKind as UF import UnliftIO.STM @@ -524,3 +534,71 @@ declExists = termExists before :: Branch.Hash -> Branch.Hash -> Transaction (Maybe Bool) before h1 h2 = Ops.before (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) + +-- | Construct a 'ScopedNames' which can produce names which are relative to the provided +-- Path. +namesAtPath :: + Path -> + Transaction ScopedNames +namesAtPath path = do + (termNames, typeNames) <- Ops.rootBranchNames + let allTerms :: [(Name, Referent.Referent)] + allTerms = + termNames <&> \(S.NamedRef {reversedSegments, ref = (ref, ct)}) -> + let v1ref = runIdentity $ Cv.referent2to1 (const . pure . Cv.constructorType2to1 . fromMaybe (error "Required constructor type for constructor but it was null") $ ct) ref + in (Name.fromReverseSegments (coerce reversedSegments), v1ref) + let allTypes :: [(Name, Reference.Reference)] + allTypes = + typeNames <&> \(S.NamedRef {reversedSegments, ref}) -> + (Name.fromReverseSegments (coerce reversedSegments), Cv.reference2to1 ref) + let rootTerms = Rel.fromList allTerms + let rootTypes = Rel.fromList allTypes + let absoluteRootNames = Names {terms = rootTerms, types = rootTypes} + let (relativeScopedNames, absoluteExternalNames) = + case path of + Path.Empty -> (absoluteRootNames, mempty) + p -> + let reversedPathSegments = reverse . Path.toList $ p + (relativeTerms, externalTerms) = foldMap (partitionByPathPrefix reversedPathSegments) allTerms + (relativeTypes, externalTypes) = foldMap (partitionByPathPrefix reversedPathSegments) allTypes + in ( Names {terms = Rel.fromList relativeTerms, types = Rel.fromList relativeTypes}, + Names {terms = Rel.fromList externalTerms, types = Rel.fromList externalTypes} + ) + pure $ + ScopedNames + { absoluteExternalNames, + relativeScopedNames, + absoluteRootNames + } + where + -- If the given prefix matches the given name, the prefix is stripped and it's collected + -- on the left, otherwise it's left as-is and collected on the right. + -- >>> partitionByPathPrefix ["b", "a"] ("a.b.c", ()) + -- ([(c,())],[]) + -- + -- >>> partitionByPathPrefix ["y", "x"] ("a.b.c", ()) + -- ([],[(a.b.c,())]) + partitionByPathPrefix :: [NameSegment] -> (Name, r) -> ([(Name, r)], [(Name, r)]) + partitionByPathPrefix reversedPathSegments (n, ref) = + case Name.stripReversedPrefix n reversedPathSegments of + Nothing -> (mempty, [(n, ref)]) + Just stripped -> ([(Name.makeRelative stripped, ref)], mempty) + +saveRootNamesIndex :: Names -> Transaction () +saveRootNamesIndex Names {Names.terms, Names.types} = do + let termNames :: [(S.NamedRef (C.Referent.Referent, Maybe C.Referent.ConstructorType))] + termNames = Rel.toList terms <&> \(name, ref) -> S.NamedRef {reversedSegments = nameSegments name, ref = splitReferent ref} + let typeNames :: [(S.NamedRef C.Reference.Reference)] + typeNames = + Rel.toList types + <&> ( \(name, ref) -> + S.NamedRef {reversedSegments = nameSegments name, ref = Cv.reference1to2 ref} + ) + Ops.rebuildNameIndex termNames typeNames + where + nameSegments :: Name -> NonEmpty Text + nameSegments = coerce @(NonEmpty NameSegment) @(NonEmpty Text) . Name.reverseSegments + splitReferent :: Referent.Referent -> (C.Referent.Referent, Maybe C.Referent.ConstructorType) + splitReferent referent = case referent of + Referent.Ref {} -> (Cv.referent1to2 referent, Nothing) + Referent.Con _ref ct -> (Cv.referent1to2 referent, Just (Cv.constructorType1to2 ct)) diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index b99fb15865..5558d35b8d 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -21,6 +21,7 @@ import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRe import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError) import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..)) import Unison.Codebase.Patch (Patch) +import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Reflog as Reflog import Unison.Codebase.ShortBranchHash (ShortBranchHash) import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..)) @@ -29,6 +30,7 @@ import Unison.CodebasePath (CodebasePath) import qualified Unison.ConstructorType as CT import Unison.DataDeclaration (Decl) import Unison.Hash (Hash) +import Unison.Names.Scoped (ScopedNames) import Unison.Prelude import Unison.Reference (Reference) import qualified Unison.Reference as Reference @@ -164,7 +166,15 @@ data Codebase m v a = Codebase -- `beforeImpl b1 b2` is undefined if `b2` not in the codebase -- -- Use `Codebase.before` which wraps this in a nice API. - beforeImpl :: Maybe (Branch.Hash -> Branch.Hash -> m Bool) + beforeImpl :: Maybe (Branch.Hash -> Branch.Hash -> m Bool), + -- Use the name lookup index to build a 'Names' for all names found within 'Path' of the current root namespace. + -- + -- NOTE: this method requires an up-to-date name lookup index, which is + -- currently not kept up-to-date automatically (because it's slow to do so). + namesAtPath :: Path -> m ScopedNames, + -- Updates the root namespace names index. + -- This isn't run automatically because it can be a bit slow. + updateNameLookup :: m () } -- | Whether a codebase is local or remote. diff --git a/parser-typechecker/src/Unison/Result.hs b/parser-typechecker/src/Unison/Result.hs index 53daeede68..b3d2e138b6 100644 --- a/parser-typechecker/src/Unison/Result.hs +++ b/parser-typechecker/src/Unison/Result.hs @@ -12,7 +12,6 @@ import Control.Monad.Writer WriterT (..), runWriterT, ) -import Data.Functor.Identity import Unison.Name (Name) import qualified Unison.Names.ResolutionResult as Names import qualified Unison.Parser as Parser diff --git a/parser-typechecker/src/Unison/Runtime/IOSource.hs b/parser-typechecker/src/Unison/Runtime/IOSource.hs index ece163115f..211caa0ab1 100644 --- a/parser-typechecker/src/Unison/Runtime/IOSource.hs +++ b/parser-typechecker/src/Unison/Runtime/IOSource.hs @@ -7,7 +7,6 @@ module Unison.Runtime.IOSource where import Control.Lens (view, _1) -import Control.Monad.Identity (Identity, runIdentity) import Control.Monad.Morph (hoist) import Data.List (elemIndex, genericIndex) import qualified Data.Map as Map diff --git a/parser-typechecker/src/Unison/Util/TransitiveClosure.hs b/parser-typechecker/src/Unison/Util/TransitiveClosure.hs index e668d2678b..666187cdd4 100644 --- a/parser-typechecker/src/Unison/Util/TransitiveClosure.hs +++ b/parser-typechecker/src/Unison/Util/TransitiveClosure.hs @@ -1,6 +1,5 @@ module Unison.Util.TransitiveClosure where -import Data.Functor.Identity (runIdentity) import qualified Data.Set as Set import Unison.Prelude diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs index 9e3a67559c..0419d1c279 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs @@ -30,6 +30,7 @@ import qualified Unison.Codebase.Runtime as Runtime import qualified Unison.CommandLine.FuzzySelect as Fuzzy import Unison.FileParsers (parseAndSynthesizeFile, synthesizeFile') import qualified Unison.Hashing.V2.Convert as Hashing +import qualified Unison.NamesWithHistory as NamesWithHistory import qualified Unison.Parser as Parser import Unison.Parser.Ann (Ann) import qualified Unison.Parser.Ann as Ann @@ -209,12 +210,18 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour LoadReflog -> lift $ Codebase.getReflog codebase CreateAuthorInfo t -> AuthorInfo.createAuthorInfo Ann.External t HQNameQuery mayPath branch query -> do + hqLength <- lift $ Codebase.hashLength codebase let namingScope = Backend.AllNames $ fromMaybe Path.empty mayPath - lift $ Backend.hqNameQuery namingScope branch codebase query + let parseNames = Backend.parseNamesForBranch branch namingScope + let nameSearch = Backend.makeNameSearch hqLength (NamesWithHistory.fromCurrentNames parseNames) + lift $ Backend.hqNameQuery codebase nameSearch query LoadSearchResults srs -> lift $ Backend.loadSearchResults codebase srs GetDefinitionsBySuffixes mayPath branch includeCycles query -> do + hqLength <- lift $ Codebase.hashLength codebase let namingScope = Backend.AllNames $ fromMaybe Path.empty mayPath - lift (Backend.definitionsBySuffixes namingScope branch codebase includeCycles query) + let parseNames = Backend.parseNamesForBranch branch namingScope + let nameSearch = Backend.makeNameSearch hqLength (NamesWithHistory.fromCurrentNames parseNames) + lift (Backend.definitionsBySuffixes codebase nameSearch includeCycles query) FindShallow path -> liftIO $ Backend.findShallow codebase path MakeStandalone ppe ref out -> lift $ do let cl = Codebase.toCodeLookup codebase diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f510e966f3..5782308195 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -204,7 +204,7 @@ loop = do basicPrettyPrintNames :: Names basicPrettyPrintNames = - Backend.basicPrettyPrintNames root' (Backend.AllNames $ Path.unabsolute currentPath') + Backend.prettyNamesForBranch root' (Backend.AllNames $ Path.unabsolute currentPath') resolveHHQS'Types :: HashOrHQSplit' -> Action' m v (Set Reference) resolveHHQS'Types = @@ -3140,7 +3140,7 @@ basicNames' :: (Functor m) => (Path -> Backend.NameScoping) -> Action m i v (Nam basicNames' nameScoping = do root' <- use LoopState.root currentPath' <- use LoopState.currentPath - pure $ Backend.basicNames' root' (nameScoping $ Path.unabsolute currentPath') + pure $ Backend.prettyAndParseNamesForBranch root' (nameScoping $ Path.unabsolute currentPath') data AddRunMainResult v = NoTermWithThatName @@ -3260,7 +3260,7 @@ diffHelperCmd :: diffHelperCmd currentRoot currentPath before after = do hqLength <- eval CodebaseHashLength diff <- eval . Eval $ BranchDiff.diff0 before after - let (_parseNames, prettyNames0) = Backend.basicNames' currentRoot (Backend.AllNames $ Path.unabsolute currentPath) + let (_parseNames, prettyNames0) = Backend.prettyAndParseNamesForBranch currentRoot (Backend.AllNames $ Path.unabsolute currentPath) ppe <- PPE.suffixifiedPPE <$> prettyPrintEnvDecl (NamesWithHistory prettyNames0 mempty) (ppe,) <$> OBranchDiff.toOutput diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs index 67ce4d5461..8c36b9df10 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs @@ -106,7 +106,16 @@ currentPath :: Getter (LoopState m v) Path.Absolute currentPath = currentPathStack . to Nel.head loopState0 :: Branch m -> Path.Absolute -> LoopState m v -loopState0 b p = LoopState b b (pure p) Nothing Nothing Nothing [] +loopState0 b p = + LoopState + { _root = b, + _lastSavedRoot = b, + _currentPathStack = (pure p), + _latestFile = Nothing, + _latestTypecheckedFile = Nothing, + _lastInput = Nothing, + _numberedArgs = [] + } respond :: MonadCommand n m i v => Output v -> n () respond output = eval $ Notify output diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 2e37d8d6a6..87e83f5dda 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -58,6 +58,7 @@ import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyTerminal import qualified Unison.Runtime.Interface as RTI +import qualified Unison.Server.Backend as Backend import qualified Unison.Server.CodebaseServer as Server import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as Pretty @@ -171,7 +172,7 @@ withTranscriptRunner :: withTranscriptRunner ucmVersion configFile action = do withRuntime $ \runtime -> withConfig $ \config -> do action $ \transcriptName transcriptSrc (codebaseDir, codebase) -> do - Server.startServer Server.defaultCodebaseServerOpts runtime codebase $ \baseUrl -> do + Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) Server.defaultCodebaseServerOpts runtime codebase $ \baseUrl -> do let parsed = parse transcriptName transcriptSrc result <- for parsed $ \stanzas -> do liftIO $ run codebaseDir stanzas codebase runtime config ucmVersion (tShow baseUrl) diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index d7bab5276b..2dfabfb76c 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -69,6 +69,7 @@ import Unison.Prelude import qualified Unison.PrettyTerminal as PT import Unison.Runtime.Exception (RuntimeExn (..)) import qualified Unison.Runtime.Interface as RTI +import qualified Unison.Server.Backend as Backend import qualified Unison.Server.CodebaseServer as Server import Unison.Symbol (Symbol) import qualified Unison.Util.Pretty as P @@ -209,7 +210,7 @@ main = withCP65001 do Launch isHeadless codebaseServerOpts downloadBase -> do getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do runtime <- RTI.startRuntime RTI.Persistent Version.gitDescribeWithDate - Server.startServer codebaseServerOpts runtime theCodebase $ \baseUrl -> do + Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts runtime theCodebase $ \baseUrl -> do case isHeadless of Headless -> do PT.putPrettyLn $ diff --git a/unison-core/src/Unison/ABT.hs b/unison-core/src/Unison/ABT.hs index 949289ab8a..817423f86b 100644 --- a/unison-core/src/Unison/ABT.hs +++ b/unison-core/src/Unison/ABT.hs @@ -91,7 +91,6 @@ where import Control.Lens (Lens', lens, use, (%%~), (.=)) import Control.Monad.State (MonadState) import qualified Data.Foldable as Foldable -import Data.Functor.Identity (Identity (Identity), runIdentity) import Data.List hiding (cycle, find) import qualified Data.Map as Map import qualified Data.Set as Set @@ -320,17 +319,17 @@ renames rn0 t0@(Term fvs ann t) | Map.null rn = t0 | Var v <- t, Just u <- Map.lookup v rn = - annotatedVar ann u + annotatedVar ann u | Cycle body <- t = - cycle' ann (renames rn body) + cycle' ann (renames rn body) | Abs v t <- t, -- rename iterated variables all at once to avoid a capture issue AbsNA' (unzip -> (as, vs)) body <- t, (rn, us) <- mangle (freeVars body) rn (v : vs), not $ Map.null rn = - absChain' (zip (ann : as) us) (renames rn body) + absChain' (zip (ann : as) us) (renames rn body) | Tm body <- t = - tm' ann (renames rn <$> body) + tm' ann (renames rn <$> body) | otherwise = t0 where rn = Map.restrictKeys rn0 fvs @@ -340,7 +339,7 @@ renames rn0 t0@(Term fvs ann t) mangle1 avs m v | any (== v) vs, u <- freshIn (avs <> Set.fromList vs) v = - (Map.insert v u m, u) + (Map.insert v u m, u) | otherwise = (Map.delete v m, v) where vs = toList m @@ -404,20 +403,20 @@ subst' :: (Foldable f, Functor f, Var v) => (a -> Term f v a) -> v -> Set v -> T subst' replace v r t2@(Term fvs ann body) | Set.notMember v fvs = t2 -- subtrees not containing the var can be skipped | otherwise = case body of - Var v' - | v == v' -> replace ann -- var match; perform replacement - | otherwise -> t2 -- var did not match one being substituted; ignore - Cycle body -> cycle' ann (subst' replace v r body) - Abs x _ | x == v -> t2 -- x shadows v; ignore subtree - Abs x e -> abs' ann x' e' - where - x' = freshIn (fvs `Set.union` r) x - -- rename x to something that cannot be captured by `r` - e' = - if x /= x' - then subst' replace v r (rename x x' e) - else subst' replace v r e - Tm body -> tm' ann (fmap (subst' replace v r) body) + Var v' + | v == v' -> replace ann -- var match; perform replacement + | otherwise -> t2 -- var did not match one being substituted; ignore + Cycle body -> cycle' ann (subst' replace v r body) + Abs x _ | x == v -> t2 -- x shadows v; ignore subtree + Abs x e -> abs' ann x' e' + where + x' = freshIn (fvs `Set.union` r) x + -- rename x to something that cannot be captured by `r` + e' = + if x /= x' + then subst' replace v r (rename x x' e) + else subst' replace v r e + Tm body -> tm' ann (fmap (subst' replace v r) body) -- Like `subst`, but the annotation of the replacement is inherited from -- the previous annotation at each replacement point. diff --git a/unison-core/src/Unison/Name.hs b/unison-core/src/Unison/Name.hs index 3c419b3140..f7687161da 100644 --- a/unison-core/src/Unison/Name.hs +++ b/unison-core/src/Unison/Name.hs @@ -8,6 +8,7 @@ module Unison.Name joinDot, fromSegment, fromSegments, + fromReverseSegments, -- ** Unsafe construction unsafeFromString, @@ -20,6 +21,7 @@ module Unison.Name isPrefixOf, endsWithReverseSegments, endsWithSegments, + stripReversedPrefix, reverseSegments, segments, suffixes, @@ -56,6 +58,7 @@ where import Control.Lens (mapped, over, _1, _2) import qualified Control.Lens as Lens import qualified Data.List as List +import qualified Data.List.Extra as List import Data.List.NonEmpty (NonEmpty ((:|))) import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as List.NonEmpty @@ -177,10 +180,25 @@ endsWithSegments name ss = -- | Like 'endsWithSegments', but accepts a list of name segments in reverse order. -- -- Slightly more efficient than 'endsWithSegments'. +-- +-- >>> endsWithReverseSegments "a.b.c" ["c", "b"] +-- True endsWithReverseSegments :: Name -> [NameSegment] -> Bool endsWithReverseSegments (Name _ ss0) ss1 = List.NonEmpty.isPrefixOf ss1 ss0 +-- >>> stripReversedPrefix "a.b.c" ["b", "a"] +-- Just c +-- >>> stripReversedPrefix "x.y" ["b", "a"] +-- Nothing +-- >>> stripReversedPrefix "a.b" ["b", "a"] +-- Nothing +stripReversedPrefix :: Name -> [NameSegment] -> Maybe Name +stripReversedPrefix (Name p segs) suffix = do + stripped <- List.stripSuffix suffix (toList segs) + nonEmptyStripped <- List.NonEmpty.nonEmpty stripped + pure $ Name p nonEmptyStripped + -- | Is this name absolute? -- -- /O(1)/. @@ -268,6 +286,16 @@ fromSegments :: NonEmpty NameSegment -> Name fromSegments ss = Name Relative (List.NonEmpty.reverse ss) +-- | Construct a relative name from a list of name segments which are in reverse order +-- +-- >>> fromReverseSegments ("c" :| ["b", "a"]) +-- a.b.c +-- +-- /O(1)/ +fromReverseSegments :: NonEmpty NameSegment -> Name +fromReverseSegments rs = + Name Relative rs + -- | Return the name segments of a name, in reverse order. -- -- >>> reverseSegments "a.b.c" diff --git a/unison-core/src/Unison/Names.hs b/unison-core/src/Unison/Names.hs index bf2de39810..e862b5174e 100644 --- a/unison-core/src/Unison/Names.hs +++ b/unison-core/src/Unison/Names.hs @@ -18,6 +18,7 @@ module Unison.Names filterTypes, map, makeAbsolute, + makeRelative, fuzzyFind, hqName, hqTermName, @@ -113,6 +114,9 @@ map f (Names {terms, types}) = Names terms' types' makeAbsolute :: Names -> Names makeAbsolute = map Name.makeAbsolute +makeRelative :: Names -> Names +makeRelative = map Name.makeRelative + -- Finds names that are supersequences of all the given strings, ordered by -- score and grouped by name. fuzzyFind :: diff --git a/unison-core/src/Unison/Names/Scoped.hs b/unison-core/src/Unison/Names/Scoped.hs new file mode 100644 index 0000000000..85c5049e40 --- /dev/null +++ b/unison-core/src/Unison/Names/Scoped.hs @@ -0,0 +1,24 @@ +module Unison.Names.Scoped where + +import Unison.Names (Names) +import qualified Unison.Names as Names + +-- | Contains all useful permutations of names scoped to a given branch. +data ScopedNames = ScopedNames + { absoluteExternalNames :: Names, + relativeScopedNames :: Names, + absoluteRootNames :: Names + } + +-- | Return all names contained in the path, relative to that path. +namesAtPath :: ScopedNames -> Names +namesAtPath (ScopedNames {relativeScopedNames}) = relativeScopedNames + +-- | Includes ALL absolute names AND includes relative names for anything in the path. +parseNames :: ScopedNames -> Names +parseNames (ScopedNames {relativeScopedNames, absoluteRootNames}) = relativeScopedNames <> absoluteRootNames + +-- | Includes includes relative names for anything in the path, and absolute names for +-- everything else. +prettyNames :: ScopedNames -> Names +prettyNames (ScopedNames {relativeScopedNames, absoluteExternalNames}) = relativeScopedNames `Names.unionLeft` absoluteExternalNames diff --git a/unison-core/src/Unison/NamesWithHistory.hs b/unison-core/src/Unison/NamesWithHistory.hs index 581b4ee622..31e3621cb3 100644 --- a/unison-core/src/Unison/NamesWithHistory.hs +++ b/unison-core/src/Unison/NamesWithHistory.hs @@ -37,6 +37,9 @@ data NamesWithHistory = NamesWithHistory } deriving (Show) +fromCurrentNames :: Names -> NamesWithHistory +fromCurrentNames n = NamesWithHistory {currentNames = n, oldNames = mempty} + filterTypes :: (Name -> Bool) -> Names -> Names filterTypes = Names.filterTypes diff --git a/unison-core/src/Unison/Reference.hs b/unison-core/src/Unison/Reference.hs index 6f8df4919b..43e5d78852 100644 --- a/unison-core/src/Unison/Reference.hs +++ b/unison-core/src/Unison/Reference.hs @@ -129,7 +129,7 @@ readSuffix = \case pos | Text.all isDigit pos, Just pos' <- readMaybe (Text.unpack pos) -> - Right pos' + Right pos' t -> Left $ "Invalid reference suffix: " <> show t isPrefixOf :: ShortHash -> Reference -> Bool diff --git a/unison-core/src/Unison/Referent'.hs b/unison-core/src/Unison/Referent'.hs index d2a2c6f266..b65b75e09d 100644 --- a/unison-core/src/Unison/Referent'.hs +++ b/unison-core/src/Unison/Referent'.hs @@ -35,7 +35,7 @@ import Unison.Prelude -- -- When @Con'@ then @r@ is a type declaration. data Referent' r = Ref' r | Con' (GConstructorReference r) ConstructorType - deriving (Show, Ord, Eq, Functor, Generic) + deriving (Show, Eq, Ord, Functor, Generic) -- | A lens onto the reference in a referent. reference_ :: Lens (Referent' r) (Referent' r') r r' diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index 508908076f..59463b5843 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -10,7 +10,6 @@ module Unison.Type where import Control.Lens (Prism') import qualified Control.Monad.Writer.Strict as Writer -import Data.Functor.Identity (runIdentity) import Data.Generics.Sum (_Ctor) import Data.List.Extra (nubOrd) import qualified Data.Map as Map @@ -596,7 +595,7 @@ removePureEffects :: ABT.Var v => Type v a -> Type v a removePureEffects t | not Settings.removePureEffects = t | otherwise = - generalize vs $ removeEffectVars fvs tu + generalize vs $ removeEffectVars fvs tu where (vs, tu) = unforall' t vss = Set.fromList vs diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index 1975f49c30..dbebb68187 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -40,6 +40,7 @@ library Unison.Name Unison.Names Unison.Names.ResolutionResult + Unison.Names.Scoped Unison.NameSegment Unison.NamesWithHistory Unison.Pattern diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index ae2cdb6c30..b3b1f1da34 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -9,12 +10,10 @@ module Unison.Server.Backend where -import Control.Error.Util (hush, (??)) +import Control.Error.Util (hush) import Control.Lens hiding ((??)) import Control.Monad.Except - ( ExceptT (..), - throwError, - ) +import Control.Monad.Reader import Data.Bifunctor (first) import Data.Containers.ListUtils (nubOrdOn) import qualified Data.List as List @@ -32,19 +31,18 @@ import System.FilePath import qualified Text.FuzzyFind as FZF import qualified U.Codebase.Branch as V2Branch import qualified U.Codebase.Causal as V2Causal -import qualified U.Codebase.Referent as V2 +import qualified U.Codebase.HashTags as V2.Hash import qualified Unison.ABT as ABT import qualified Unison.Builtin as B import qualified Unison.Builtin.Decls as Decls import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase -import Unison.Codebase.Branch (Branch, Branch0) +import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Branch.Names as Branch -import qualified Unison.Codebase.Causal.Type (RawHash (RawHash)) +import qualified Unison.Codebase.Causal.Type as Causal import Unison.Codebase.Editor.DisplayObject import qualified Unison.Codebase.Editor.DisplayObject as DisplayObject -import qualified Unison.Codebase.Metadata as Metadata import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Runtime as Rt @@ -70,6 +68,7 @@ import Unison.NameSegment (NameSegment (..)) import qualified Unison.NameSegment as NameSegment import Unison.Names (Names (Names)) import qualified Unison.Names as Names +import qualified Unison.Names.Scoped as ScopedNames import Unison.NamesWithHistory (NamesWithHistory (..)) import qualified Unison.NamesWithHistory as NamesWithHistory import Unison.Parser.Ann (Ann) @@ -144,11 +143,24 @@ data BackendError | CouldntLoadBranch Branch.Hash | MissingSignatureForTerm Reference -type Backend m a = ExceptT BackendError m a +data BackendEnv = BackendEnv + { -- | Whether to use the sqlite name-lookup table to generate Names objects rather than building Names from the root branch. + useNamesIndex :: Bool + } + +newtype Backend m a = Backend {runBackend :: ReaderT BackendEnv (ExceptT BackendError m) a} + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader BackendEnv, MonadError BackendError) + +instance MonadTrans Backend where + lift m = Backend (lift . lift $ m) --- implementation detail of basicParseNames and basicPrettyPrintNames -basicNames' :: Branch m -> NameScoping -> (Names, Names) -basicNames' root scope = +suffixifyNames :: Int -> Names -> PPE.PrettyPrintEnv +suffixifyNames hashLength names = + PPE.suffixifiedPPE . PPE.fromNamesDecl hashLength $ NamesWithHistory.fromCurrentNames names + +-- implementation detail of parseNamesForBranch and prettyNamesForBranch +prettyAndParseNamesForBranch :: Branch m -> NameScoping -> (Names, Names) +prettyAndParseNamesForBranch root scope = (parseNames0, prettyPrintNames0) where path :: Path @@ -182,11 +194,14 @@ basicNames' root scope = basicSuffixifiedNames :: Int -> Branch m -> NameScoping -> PPE.PrettyPrintEnv basicSuffixifiedNames hashLength root nameScope = - let names0 = basicPrettyPrintNames root nameScope - in PPE.suffixifiedPPE . PPE.fromNamesDecl hashLength $ NamesWithHistory names0 mempty + let names0 = prettyNamesForBranch root nameScope + in suffixifyNames hashLength names0 + +parseNamesForBranch :: Branch m -> NameScoping -> Names +parseNamesForBranch root = fst . prettyAndParseNamesForBranch root -basicPrettyPrintNames :: Branch m -> NameScoping -> Names -basicPrettyPrintNames root = snd . basicNames' root +prettyNamesForBranch :: Branch m -> NameScoping -> Names +prettyNamesForBranch root = snd . prettyAndParseNamesForBranch root shallowPPE :: Monad m => Codebase m v a -> V2Branch.Branch m -> m PPE.PrettyPrintEnv shallowPPE codebase b = do @@ -214,9 +229,6 @@ shallowNames codebase b = do & traverse . Set.traverse %~ Cv.reference2to1 pure (Names (R.fromMultimap newTerms) (R.fromMultimap newTypes)) -basicParseNames :: Branch m -> NameScoping -> Names -basicParseNames root = fst . basicNames' root - loadReferentType :: Applicative m => Codebase m Symbol Ann -> @@ -267,16 +279,11 @@ data FoundRef -- we dedupe on the found refs to avoid having several rows of a -- definition with different names in the result set. fuzzyFind :: - Monad m => - Path -> - Branch m -> + Names -> String -> [(FZF.Alignment, UnisonName, [FoundRef])] -fuzzyFind path branch query = - let printNames = - basicPrettyPrintNames branch (Within path) - - fzfNames = +fuzzyFind printNames query = + let fzfNames = Names.fuzzyFind (words query) printNames toFoundRef = @@ -345,43 +352,40 @@ isDoc' typeOfTerm = do -- A term is a dococ if its type conforms to the `Doc` type. case typeOfTerm of Just t -> - Typechecker.isSubtype t (Type.ref mempty Decls.docRef) - || Typechecker.isSubtype t (Type.ref mempty DD.doc2Ref) + Typechecker.isSubtype t doc1Type + || Typechecker.isSubtype t doc2Type Nothing -> False +doc1Type :: (Ord v, Monoid a) => Type v a +doc1Type = Type.ref mempty Decls.docRef + +doc2Type :: (Ord v, Monoid a) => Type v a +doc2Type = Type.ref mempty DD.doc2Ref + +isTestResultList :: forall v a. (Var v, Monoid a) => Maybe (Type v a) -> Bool +isTestResultList typ = case typ of + Nothing -> False + Just t -> Typechecker.isSubtype t resultListType + +resultListType :: (Ord v, Monoid a) => Type v a +resultListType = Type.app mempty (Type.list mempty) (Type.ref mempty Decls.testResultRef) + termListEntry :: Monad m => Codebase m Symbol Ann -> - Bool -> Referent -> HQ'.HQSegment -> m (TermEntry Symbol Ann) -termListEntry codebase isTest r n = do +termListEntry codebase r n = do ot <- loadReferentType codebase r let tag = - if (isDoc' ot) - then Just Doc - else - if isTest - then Just Test - else Nothing + if + | isDoc' ot -> Just Doc + | isTestResultList ot -> Just Test + | otherwise -> Nothing pure $ TermEntry r n ot tag -checkIsTestForBranch :: Branch0 m -> Referent -> Bool -checkIsTestForBranch b0 r = - Metadata.hasMetadataWithType' r Decls.isTestRef $ Branch.deepTermMetadata b0 - -checkIsTestForV2Branch :: Monad m => V2Branch.Branch m -> V2.Referent -> m Bool -checkIsTestForV2Branch b r = do - -- TODO: Should V2Branch use some sort of relation here? - or <$> for (toList $ V2Branch.terms b) \metaMap -> do - case Map.lookup r metaMap of - Nothing -> pure False - Just getMdValues -> do - V2Branch.MdValues mdValues <- getMdValues - pure $ elem (Cv.reference1to2 Decls.isTestRef) mdValues - typeListEntry :: Monad m => Var v => @@ -474,7 +478,7 @@ lsBranch codebase b = do + (R.size . Branch.deepTypes $ Branch.head b) b0 = Branch.head b termEntries <- for (R.toList . Star3.d1 $ Branch._terms b0) $ \(r, ns) -> - ShallowTermEntry <$> termListEntry codebase (checkIsTestForBranch b0 r) r (hqTerm b0 ns r) + ShallowTermEntry <$> termListEntry codebase r (hqTerm b0 ns r) typeEntries <- for (R.toList . Star3.d1 $ Branch._types b0) $ \(r, ns) -> ShallowTypeEntry <$> typeListEntry codebase r (hqType b0 ns r) let branchEntries = @@ -534,9 +538,8 @@ lsShallowBranch codebase b0 = do r <- Map.keys refs pure (r, ns) termEntries <- for (flattenRefs $ V2Branch.terms b0) $ \(r, ns) -> do - isTest <- checkIsTestForV2Branch b0 r v1Ref <- Cv.referent2to1 (Codebase.getDeclType codebase) r - ShallowTermEntry <$> termListEntry codebase isTest v1Ref (hqTerm b0 ns v1Ref) + ShallowTermEntry <$> termListEntry codebase v1Ref (hqTerm b0 ns v1Ref) typeEntries <- for (flattenRefs $ V2Branch.types b0) \(r, ns) -> do let v1Ref = Cv.reference2to1 r ShallowTypeEntry <$> typeListEntry codebase v1Ref (hqType b0 ns v1Ref) @@ -607,11 +610,11 @@ toAllNames (Within p) = AllNames p getCurrentPrettyNames :: NameScoping -> Branch m -> NamesWithHistory getCurrentPrettyNames scope root = - NamesWithHistory (basicPrettyPrintNames root scope) mempty + NamesWithHistory (prettyNamesForBranch root scope) mempty getCurrentParseNames :: NameScoping -> Branch m -> NamesWithHistory getCurrentParseNames scope root = - NamesWithHistory (basicParseNames root scope) mempty + NamesWithHistory (parseNamesForBranch root scope) mempty -- Any absolute names in the input which have `root` as a prefix -- are converted to names relative to current path. All other names are @@ -634,11 +637,16 @@ fixupNamesRelative root = Names.map fixName -- Construct a 'Search' with 'makeTypeSearch' or 'makeTermSearch', and eliminate it with 'applySearch'. data Search r = Search { lookupNames :: r -> Set (HQ'.HashQualified Name), - lookupRelativeHQRefs' :: HQ'.HashQualified Name -> Set r, + lookupRelativeHQRefs' :: HQ'.HashQualified Name -> (Set r), makeResult :: HQ.HashQualified Name -> r -> Set (HQ'.HashQualified Name) -> SR.SearchResult, matchesNamedRef :: Name -> r -> HQ'.HashQualified Name -> Bool } +data NameSearch = NameSearch + { typeSearch :: Search Reference, + termSearch :: Search Referent + } + -- | Make a type search, given a short hash length and names to search in. makeTypeSearch :: Int -> NamesWithHistory -> Search Reference makeTypeSearch len names = @@ -659,9 +667,16 @@ makeTermSearch len names = makeResult = SR.termResult } +makeNameSearch :: Int -> NamesWithHistory -> NameSearch +makeNameSearch hashLength names = + NameSearch + { typeSearch = makeTypeSearch hashLength names, + termSearch = makeTermSearch hashLength names + } + -- | Interpret a 'Search' as a function from name to search results. -applySearch :: Show r => Search r -> HQ'.HashQualified Name -> [SR.SearchResult] -applySearch Search {lookupNames, lookupRelativeHQRefs', makeResult, matchesNamedRef} query = +applySearch :: (Show r) => Search r -> HQ'.HashQualified Name -> [SR.SearchResult] +applySearch Search {lookupNames, lookupRelativeHQRefs', makeResult, matchesNamedRef} query = do -- a bunch of references will match a HQ ref. toList (lookupRelativeHQRefs' query) <&> \ref -> let -- Precondition: the input set is non-empty @@ -672,21 +687,21 @@ applySearch Search {lookupNames, lookupRelativeHQRefs', makeResult, matchesNamed >>> List.uncons >>> fromMaybe (error (reportBug "E839404" ("query = " ++ show query ++ ", ref = " ++ show ref))) >>> over _2 Set.fromList + names = lookupNames ref (primaryName, aliases) = -- The precondition of `prioritize` should hold here because we are passing in the set of names that are -- related to this ref, which is itself one of the refs that the query name was related to! (Hence it should -- be non-empty). - prioritize (lookupNames ref) + prioritize names in makeResult (HQ'.toHQ primaryName) ref aliases hqNameQuery :: Monad m => - NameScoping -> - Branch m -> Codebase m v Ann -> + NameSearch -> [HQ.HashQualified Name] -> m QueryResult -hqNameQuery namesScope root codebase hqs = do +hqNameQuery codebase (NameSearch {typeSearch, termSearch}) hqs = do -- Split the query into hash-only and hash-qualified-name queries. let (hashes, hqnames) = partitionEithers (map HQ'.fromHQ2 hqs) -- Find the terms with those hashes. @@ -702,11 +717,7 @@ hqNameQuery namesScope root codebase hqs = do (typeReferencesByShortHash codebase) hashes -- Now do the name queries. - -- The hq-name search needs a hash-qualifier length - hqLength <- Codebase.hashLength codebase - -- We need to construct the names that we want to use / search by. - let parseNames = getCurrentParseNames namesScope root - mkTermResult sh r = SR.termResult (HQ.HashOnly sh) r Set.empty + let mkTermResult sh r = SR.termResult (HQ.HashOnly sh) r Set.empty mkTypeResult sh r = SR.typeResult (HQ.HashOnly sh) r Set.empty -- Transform the hash results a bit termResults = @@ -714,12 +725,7 @@ hqNameQuery namesScope root codebase hqs = do typeResults = (\(sh, tps) -> mkTypeResult sh <$> toList tps) <$> typeRefs -- Now do the actual name query - resultss = - let typeSearch :: Search Reference - typeSearch = makeTypeSearch hqLength parseNames - termSearch :: Search Referent - termSearch = makeTermSearch hqLength parseNames - in map (\name -> applySearch typeSearch name <> applySearch termSearch name) hqnames + resultss = map (\name -> applySearch typeSearch name <> applySearch termSearch name) hqnames (misses, hits) = zip hqnames resultss & map (\(hqname, results) -> if null results then Left hqname else Right results) @@ -780,7 +786,7 @@ mungeSyntaxText :: mungeSyntaxText = fmap Syntax.convertElement prettyDefinitionsBySuffixes :: - NameScoping -> + Path -> Maybe Branch.Hash -> Maybe Width -> Suffixify -> @@ -788,25 +794,18 @@ prettyDefinitionsBySuffixes :: Codebase IO Symbol Ann -> [HQ.HashQualified Name] -> Backend IO DefinitionDisplayResults -prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt codebase query = do - branch <- resolveBranchHash root codebase - DefinitionResults terms types misses <- - lift (definitionsBySuffixes namesScope branch codebase DontIncludeCycles query) +prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase query = do hqLength <- lift $ Codebase.hashLength codebase + (_parseNames, printNames) <- scopedNamesForBranchHash codebase root path + let nameSearch :: NameSearch + nameSearch = makeNameSearch hqLength (NamesWithHistory.fromCurrentNames printNames) + DefinitionResults terms types misses <- + lift (definitionsBySuffixes codebase nameSearch DontIncludeCycles query) -- We might like to make sure that the user search terms get used as -- the names in the pretty-printer, but the current implementation -- doesn't. - let -- We use printNames for names in source and parseNames to lookup - -- definitions, thus printNames use the allNames scope, to ensure - -- external references aren't hashes. - printNames = - getCurrentPrettyNames (toAllNames namesScope) branch - - parseNames = - getCurrentParseNames namesScope branch - - ppe = - PPE.fromNamesDecl hqLength printNames + let ppe = + PPE.fromNamesDecl hqLength (NamesWithHistory.fromCurrentNames printNames) width = mayDefaultWidth renderWidth @@ -814,7 +813,7 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod termFqns :: Map Reference (Set Text) termFqns = Map.mapWithKey f terms where - rel = Names.terms $ currentNames parseNames + rel = Names.terms printNames f k _ = Set.fromList . fmap Name.toText . toList $ R.lookupRan (Referent.Ref k) rel @@ -822,7 +821,7 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod typeFqns :: Map Reference (Set Text) typeFqns = Map.mapWithKey f types where - rel = Names.types $ currentNames parseNames + rel = Names.types printNames f k _ = Set.fromList . fmap Name.toText . toList $ R.lookupRan k rel @@ -846,7 +845,7 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod -- you get both its source and its rendered form docResults :: [Reference] -> [Name] -> IO [(HashQualifiedName, UnisonHash, Doc.Doc)] docResults rs0 docs = do - let refsFor n = NamesWithHistory.lookupHQTerm (HQ.NameOnly n) parseNames + let refsFor n = NamesWithHistory.lookupHQTerm (HQ.NameOnly n) (NamesWithHistory.fromCurrentNames printNames) let rs = Set.unions (refsFor <$> docs) <> Set.fromList (Referent.Ref <$> rs0) -- lookup the type of each, make sure it's a doc docs <- selectDocs (toList rs) @@ -858,7 +857,7 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod DisplayObject (AnnotatedText (UST.Element Reference)) (AnnotatedText (UST.Element Reference)) -> - ExceptT BackendError IO TermDefinition + Backend IO TermDefinition ) mkTermDefinition r tm = do let referent = Referent.Ref r @@ -869,11 +868,10 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod ( termEntryTag <$> termListEntry codebase - (checkIsTestForBranch (Branch.head branch) referent) referent (HQ'.NameOnly (NameSegment bn)) ) - docs <- lift (docResults [r] $ docNames (NamesWithHistory.termName hqLength (Referent.Ref r) printNames)) + docs <- lift (docResults [r] $ docNames (NamesWithHistory.termName hqLength (Referent.Ref r) (NamesWithHistory.fromCurrentNames printNames))) mk docs ts bn tag where mk _ Nothing _ _ = throwError $ MissingSignatureForTerm r @@ -894,7 +892,7 @@ prettyDefinitionsBySuffixes namesScope root renderWidth suffixifyBindings rt cod codebase r (HQ'.NameOnly (NameSegment bn)) - docs <- docResults [] $ docNames (NamesWithHistory.typeName hqLength r printNames) + docs <- docResults [] $ docNames (NamesWithHistory.typeName hqLength r (NamesWithHistory.fromCurrentNames printNames)) pure $ TypeDefinition (flatten $ Map.lookup r typeFqns) @@ -968,8 +966,9 @@ docsInBranchToHtmlFiles runtime codebase root currentPath directory = do docTermsWithNames <- filterM (isDoc codebase . fst) allTerms let docNamesByRef = Map.fromList docTermsWithNames hqLength <- Codebase.hashLength codebase - let printNames = getCurrentPrettyNames (AllNames currentPath) root - let ppe = PPE.fromNamesDecl hqLength printNames + let printNames = prettyNamesForBranch root (AllNames currentPath) + let printNamesWithHistory = NamesWithHistory {currentNames = printNames, oldNames = mempty} + let ppe = PPE.fromNamesDecl hqLength printNamesWithHistory docs <- for docTermsWithNames (renderDoc' ppe runtime codebase) liftIO $ traverse_ (renderDocToHtmlFile docNamesByRef directory) docs where @@ -1049,16 +1048,36 @@ bestNameForType ppe width = . TypePrinter.pretty0 @v ppe mempty (-1) . Type.ref () +scopedNamesForBranchHash :: forall m v a. Monad m => Codebase m v a -> Maybe Branch.Hash -> Path -> Backend m (Names, Names) +scopedNamesForBranchHash codebase mbh path = do + shouldUseNamesIndex <- asks useNamesIndex + case mbh of + Nothing + | shouldUseNamesIndex -> indexPrettyAndParseNames + | otherwise -> do + rootBranch <- lift $ Codebase.getRootBranch codebase + pure $ prettyAndParseNamesForBranch rootBranch (AllNames path) + Just bh -> do + rootHash <- lift $ Codebase.getRootBranchHash codebase + if (Causal.unRawHash bh == V2.Hash.unCausalHash rootHash) && shouldUseNamesIndex + then indexPrettyAndParseNames + else flip prettyAndParseNamesForBranch (AllNames path) <$> resolveBranchHash (Just bh) codebase + where + indexPrettyAndParseNames :: Backend m (Names, Names) + indexPrettyAndParseNames = do + names <- lift $ Codebase.namesAtPath codebase path + pure (ScopedNames.parseNames names, ScopedNames.prettyNames names) + resolveBranchHash :: - Monad m => Maybe Branch.Hash -> Codebase m v Ann -> Backend m (Branch m) + Monad m => Maybe Branch.Hash -> Codebase m v a -> Backend m (Branch m) resolveBranchHash h codebase = case h of Nothing -> lift (Codebase.getRootBranch codebase) Just bhash -> do mayBranch <- lift $ Codebase.getBranchForHash codebase bhash - mayBranch ?? NoBranchForHash bhash + whenNothing mayBranch (throwError $ NoBranchForHash bhash) resolveRootBranchHash :: - Monad m => Maybe ShortBranchHash -> Codebase m v Ann -> Backend m (Branch m) + Monad m => Maybe ShortBranchHash -> Codebase m v a -> Backend m (Branch m) resolveRootBranchHash mayRoot codebase = case mayRoot of Nothing -> lift (Codebase.getRootBranch codebase) @@ -1074,14 +1093,13 @@ data IncludeCycles definitionsBySuffixes :: forall m. MonadIO m => - NameScoping -> - Branch m -> Codebase m Symbol Ann -> + NameSearch -> IncludeCycles -> [HQ.HashQualified Name] -> m (DefinitionResults Symbol) -definitionsBySuffixes namesScope branch codebase includeCycles query = do - QueryResult misses results <- hqNameQuery namesScope branch codebase query +definitionsBySuffixes codebase nameSearch includeCycles query = do + QueryResult misses results <- hqNameQuery codebase nameSearch query -- todo: remember to replace this with getting components directly, -- and maybe even remove getComponentLength from Codebase interface altogether terms <- do diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index 2a9e90ef0d..b58dc31e4d 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -12,6 +12,7 @@ import Control.Concurrent (newEmptyMVar, putMVar, readMVar) import Control.Concurrent.Async (race) import Control.Exception (ErrorCall (..), throwIO) import Control.Lens ((.~)) +import Control.Monad.Reader import Control.Monad.Trans.Except import Data.Aeson () import qualified Data.ByteString as Strict @@ -86,7 +87,7 @@ import Unison.Codebase (Codebase) import qualified Unison.Codebase.Runtime as Rt import Unison.Parser.Ann (Ann) import Unison.Prelude -import Unison.Server.Backend (Backend) +import Unison.Server.Backend (Backend, BackendEnv, runBackend) import Unison.Server.Endpoints.FuzzyFind (FuzzyFindAPI, serveFuzzyFind) import Unison.Server.Endpoints.GetDefinitions ( DefinitionsAPI, @@ -198,13 +199,14 @@ appAPI :: Proxy AppAPI appAPI = Proxy app :: + BackendEnv -> Rt.Runtime Symbol -> Codebase IO Symbol Ann -> FilePath -> Strict.ByteString -> Application -app rt codebase uiPath expectedToken = - serve appAPI $ server rt codebase uiPath expectedToken +app env rt codebase uiPath expectedToken = + serve appAPI $ server env rt codebase uiPath expectedToken -- | The Token is used to help prevent multiple users on a machine gain access to -- each others codebases. @@ -259,12 +261,13 @@ defaultCodebaseServerOpts = -- The auth token required for accessing the server is passed to the function k startServer :: + BackendEnv -> CodebaseServerOpts -> Rt.Runtime Symbol -> Codebase IO Symbol Ann -> (BaseUrl -> IO a) -> IO a -startServer opts rt codebase onStart = do +startServer env opts rt codebase onStart = do -- the `canonicalizePath` resolves symlinks exePath <- canonicalizePath =<< getExecutablePath envUI <- canonicalizePath $ fromMaybe (FilePath.takeDirectory exePath "ui") (codebaseUIPath opts) @@ -276,7 +279,7 @@ startServer opts rt codebase onStart = do defaultSettings & maybe id setPort (port opts) & maybe id (setHost . fromString) (host opts) - let a = app rt codebase envUI token + let a = app env rt codebase envUI token case port opts of Nothing -> withApplicationSettings settings (pure a) (onStart . baseUrl) Just p -> do @@ -313,23 +316,24 @@ serveUI :: FilePath -> Server WebUI serveUI path _ = serveIndex path server :: + BackendEnv -> Rt.Runtime Symbol -> Codebase IO Symbol Ann -> FilePath -> Strict.ByteString -> Server AppAPI -server rt codebase uiPath expectedToken = +server backendEnv rt codebase uiPath expectedToken = serveDirectoryWebApp (uiPath "static") :<|> hoistWithAuth serverAPI expectedToken serveServer where serveServer :: Server ServerAPI serveServer = ( serveUI uiPath - :<|> serveUnisonAndDocs rt codebase + :<|> serveUnisonAndDocs backendEnv rt codebase ) -serveUnisonAndDocs :: Rt.Runtime Symbol -> Codebase IO Symbol Ann -> Server UnisonAndDocsAPI -serveUnisonAndDocs rt codebase = serveUnison codebase rt :<|> serveOpenAPI :<|> Tagged serveDocs +serveUnisonAndDocs :: BackendEnv -> Rt.Runtime Symbol -> Codebase IO Symbol Ann -> Server UnisonAndDocsAPI +serveUnisonAndDocs env rt codebase = serveUnison env codebase rt :<|> serveOpenAPI :<|> Tagged serveDocs serveDocs :: Application serveDocs _ respond = respond $ responseLBS ok200 [plain] docsBS @@ -344,17 +348,18 @@ hoistWithAuth :: forall api. HasServer api '[] => Proxy api -> ByteString -> Ser hoistWithAuth api expectedToken server token = hoistServer @api @Handler @Handler api (\h -> handleAuth expectedToken token *> h) server serveUnison :: + BackendEnv -> Codebase IO Symbol Ann -> Rt.Runtime Symbol -> Server UnisonAPI -serveUnison codebase rt = - hoistServer (Proxy @UnisonAPI) backendHandler $ +serveUnison env codebase rt = + hoistServer (Proxy @UnisonAPI) (backendHandler env) $ (\root rel name -> setCacheControl <$> NamespaceListing.serve codebase root rel name) :<|> (\namespaceName mayRoot mayWidth -> setCacheControl <$> NamespaceDetails.serve rt codebase namespaceName mayRoot mayWidth) :<|> (\mayRoot mayOwner -> setCacheControl <$> Projects.serve codebase mayRoot mayOwner) :<|> (\mayRoot relativePath rawHqns width suff -> setCacheControl <$> serveDefinitions rt codebase mayRoot relativePath rawHqns width suff) :<|> (\mayRoot relativePath limit typeWidth query -> setCacheControl <$> serveFuzzyFind codebase mayRoot relativePath limit typeWidth query) -backendHandler :: Backend IO a -> Handler a -backendHandler m = - Handler $ withExceptT backendError m +backendHandler :: BackendEnv -> Backend IO a -> Handler a +backendHandler env m = + Handler $ withExceptT backendError (runReaderT (runBackend m) env) diff --git a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs index d9a9ec8224..8cd79dd433 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs @@ -29,7 +29,6 @@ import Servant.OpenApi () import qualified Text.FuzzyFind as FZF import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase -import qualified Unison.Codebase.Branch as Branch import Unison.Codebase.Editor.DisplayObject import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Path.Parse as Path @@ -45,6 +44,7 @@ import Unison.Server.Types HashQualifiedName, NamedTerm, NamedType, + UnisonName, mayDefaultWidth, ) import Unison.Symbol (Symbol) @@ -141,18 +141,21 @@ serveFuzzyFind codebase mayRoot relativePath limit typeWidth query = maybe mempty Path.fromPath' <$> traverse (parsePath . Text.unpack) relativePath hashLength <- lift $ Codebase.hashLength codebase - ea <- lift . runExceptT $ do - root <- traverse (Backend.expandShortBranchHash codebase) mayRoot - branch <- Backend.resolveBranchHash root codebase - let b0 = Branch.head branch - alignments = - take (fromMaybe 10 limit) $ Backend.fuzzyFind rel branch (fromMaybe "" query) - -- Use AllNames to render source - ppe = Backend.basicSuffixifiedNames hashLength branch (Backend.AllNames rel) - lift (join <$> traverse (loadEntry ppe b0) alignments) - liftEither ea + rootHash <- traverse (Backend.expandShortBranchHash codebase) mayRoot + (_parseNames, prettyNames) <- Backend.scopedNamesForBranchHash codebase rootHash rel + let alignments :: + ( [ ( FZF.Alignment, + UnisonName, + [Backend.FoundRef] + ) + ] + ) + alignments = + take (fromMaybe 10 limit) $ Backend.fuzzyFind prettyNames (fromMaybe "" query) + ppe = Backend.suffixifyNames hashLength prettyNames + lift (join <$> traverse (loadEntry ppe) alignments) where - loadEntry ppe b0 (a, HQ'.NameOnly . NameSegment -> n, refs) = + loadEntry ppe (a, HQ'.NameOnly . NameSegment -> n, refs) = for refs $ \case Backend.FoundTermRef r -> @@ -164,7 +167,7 @@ serveFuzzyFind codebase mayRoot relativePath limit typeWidth query = $ Backend.termEntryToNamedTerm ppe typeWidth te ) ) - <$> Backend.termListEntry codebase (Backend.checkIsTestForBranch b0 r) r n + <$> Backend.termListEntry codebase r n Backend.FoundTypeRef r -> do te <- Backend.typeListEntry codebase r n let namedType = Backend.typeEntryToNamedType te diff --git a/unison-share-api/src/Unison/Server/Endpoints/GetDefinitions.hs b/unison-share-api/src/Unison/Server/Endpoints/GetDefinitions.hs index cd04d4d940..589bcbafee 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/GetDefinitions.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/GetDefinitions.hs @@ -105,7 +105,6 @@ instance ToSample DefinitionDisplayResults where toSamples _ = noSamples serveDefinitions :: - MonadIO m => Rt.Runtime Symbol -> Codebase IO Symbol Ann -> Maybe ShortBranchHash -> @@ -113,28 +112,21 @@ serveDefinitions :: [HashQualifiedName] -> Maybe Width -> Maybe Suffixify -> - Backend.Backend m DefinitionDisplayResults + Backend.Backend IO DefinitionDisplayResults serveDefinitions rt codebase mayRoot relativePath rawHqns width suff = do rel <- fmap Path.fromPath' <$> traverse (parsePath . Text.unpack) relativePath - ea <- liftIO . runExceptT $ do - root <- traverse (Backend.expandShortBranchHash codebase) mayRoot - let hqns = HQ.unsafeFromText <$> rawHqns - scope = case hqns of - -- TODO: Change this API to support being queried by just 1 name/hash - HQ.HashOnly _ : _ -> Backend.AllNames . fromMaybe Path.empty $ rel - _ -> Backend.Within . fromMaybe Path.empty $ rel - - Backend.prettyDefinitionsBySuffixes - scope - root - width - (fromMaybe (Suffixify True) suff) - rt - codebase - hqns - liftEither ea + root <- traverse (Backend.expandShortBranchHash codebase) mayRoot + let hqns = HQ.unsafeFromText <$> rawHqns + Backend.prettyDefinitionsBySuffixes + (fromMaybe Path.empty rel) + root + width + (fromMaybe (Suffixify True) suff) + rt + codebase + hqns where parsePath p = errFromEither (`Backend.BadNamespace` p) $ Path.parsePath' p errFromEither f = either (throwError . f) pure diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs index ff89f52f2b..b2e15d75bc 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs @@ -22,6 +22,7 @@ import qualified Unison.Codebase.Path as Path import Unison.Codebase.Path.Parse (parsePath') import qualified Unison.Codebase.Runtime as Rt import Unison.Codebase.ShortBranchHash (ShortBranchHash) +import Unison.NamesWithHistory (NamesWithHistory (..)) import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Server.Backend @@ -96,18 +97,17 @@ serve runtime codebase namespaceName mayRoot mayWidth = root <- Backend.resolveRootBranchHash mayRoot codebase let namespaceBranch = Branch.getAt' namespacePath root - -- Names used in the README should not be confined to the namespace -- of the README (since it could be referencing definitions from all -- over the codebase) - let printNames = Backend.getCurrentPrettyNames (Backend.AllNames namespacePath) root + let printNames = Backend.prettyNamesForBranch root (Backend.AllNames namespacePath) readme <- Backend.findShallowReadmeInBranchAndRender width runtime codebase - printNames + (NamesWithHistory {currentNames = printNames, oldNames = mempty}) namespaceBranch pure $ NamespaceDetails namespaceName (branchToUnisonHash namespaceBranch) readme diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs index 8ad529b5af..42b34d8414 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs @@ -172,7 +172,7 @@ serve codebase mayRootHash mayRelativeTo mayNamespaceName = UnisonName -> UnisonHash -> [Backend.ShallowListEntry Symbol a] -> - ExceptT Backend.BackendError IO NamespaceListing + Backend IO NamespaceListing ) makeNamespaceListing ppe fqn hash entries = pure . NamespaceListing fqn hash $ diff --git a/unison-share-api/src/Unison/Server/Endpoints/Projects.hs b/unison-share-api/src/Unison/Server/Endpoints/Projects.hs index 05061e3fa1..52d36b58c8 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/Projects.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/Projects.hs @@ -8,7 +8,6 @@ module Unison.Server.Endpoints.Projects where -import Control.Error.Util ((??)) import Control.Monad.Except import Data.Aeson import Data.Char @@ -135,11 +134,9 @@ serve codebase mayRoot mayOwner = projects root <- case mayRoot of Nothing -> lift (Codebase.getRootBranch codebase) Just sbh -> do - ea <- lift . runExceptT $ do - h <- Backend.expandShortBranchHash codebase sbh - mayBranch <- lift $ Codebase.getBranchForHash codebase h - mayBranch ?? Backend.CouldntLoadBranch h - liftEither ea + h <- Backend.expandShortBranchHash codebase sbh + mayBranch <- lift $ Codebase.getBranchForHash codebase h + whenNothing mayBranch (throwError $ Backend.CouldntLoadBranch h) ownerEntries <- lift $ findShallow root -- If an owner is provided, we only want projects belonging to them diff --git a/unison-src/transcripts/api-getDefinition.md b/unison-src/transcripts/api-getDefinition.md index b9f875d80f..0ac910b441 100644 --- a/unison-src/transcripts/api-getDefinition.md +++ b/unison-src/transcripts/api-getDefinition.md @@ -19,4 +19,10 @@ GET /api/getDefinition?names=x -- Term names should strip relativeTo prefix. GET /api/getDefinition?names=x&relativeTo=nested + +-- Should find definitions by hash, names should be relative +GET /api/getDefinition?names=%23qkhkl0n238&relativeTo=nested + +-- Should find definitions by hash, using global names if no names in specified path. +GET /api/getDefinition?names=%23qkhkl0n238&relativeTo=emptypath ``` diff --git a/unison-src/transcripts/api-getDefinition.output.md b/unison-src/transcripts/api-getDefinition.output.md index 9666adf6d6..2c612abd43 100644 --- a/unison-src/transcripts/api-getDefinition.output.md +++ b/unison-src/transcripts/api-getDefinition.output.md @@ -217,4 +217,194 @@ GET /api/getDefinition?names=x&relativeTo=nested }, "typeDefinitions": {} } +-- Should find definitions by hash, names should be relative +GET /api/getDefinition?names=%23qkhkl0n238&relativeTo=nested +{ + "missingDefinitions": [], + "termDefinitions": { + "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": { + "bestTermName": "x", + "defnTermTag": null, + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "42" + } + ], + "tag": "UserObject" + }, + "termDocs": [ + [ + "doc", + "#ulr9f75rpcrv79d7sfo2ep2tvbntu3e360lfomird2bdpj4bnea230e8o5j0b9our8vggocpa7eck3pus14fcfajlttat1bg71t6rbg", + { + "contents": [ + { + "contents": "Documentation", + "tag": "Word" + } + ], + "tag": "Paragraph" + } + ] + ], + "termNames": [ + "names.x" + ] + } + }, + "typeDefinitions": {} +} +-- Should find definitions by hash, using global names if no names in specified path. +GET /api/getDefinition?names=%23qkhkl0n238&relativeTo=emptypath +{ + "missingDefinitions": [], + "termDefinitions": { + "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": { + "bestTermName": "x", + "defnTermTag": null, + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "42" + } + ], + "tag": "UserObject" + }, + "termDocs": [ + [ + "doc", + "#ulr9f75rpcrv79d7sfo2ep2tvbntu3e360lfomird2bdpj4bnea230e8o5j0b9our8vggocpa7eck3pus14fcfajlttat1bg71t6rbg", + { + "contents": [ + { + "contents": "Documentation", + "tag": "Word" + } + ], + "tag": "Paragraph" + } + ] + ], + "termNames": [ + ".nested.names.x" + ] + } + }, + "typeDefinitions": {} +} ``` \ No newline at end of file From bf54ffbba6eb0f144c727c9633f9bbef3a177047 Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Thu, 5 May 2022 13:33:50 -0400 Subject: [PATCH 188/529] remove redundante language pragma --- parser-typechecker/tests/Unison/Test/ANF.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/parser-typechecker/tests/Unison/Test/ANF.hs b/parser-typechecker/tests/Unison/Test/ANF.hs index 3981fd97a8..dd10facba3 100644 --- a/parser-typechecker/tests/Unison/Test/ANF.hs +++ b/parser-typechecker/tests/Unison/Test/ANF.hs @@ -1,6 +1,5 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE PatternGuards #-} -{-# LANGUAGE TypeApplications #-} module Unison.Test.ANF where From 664ca67f1d1404d435134ed5b64f75982c1c6aa2 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 5 May 2022 15:17:08 -0400 Subject: [PATCH 189/529] push.create to share --- .../src/Unison/Codebase/Editor/HandleInput.hs | 35 +++++++++++++------ 1 file changed, 24 insertions(+), 11 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 07cbbb8339..b0e158c528 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1787,8 +1787,8 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch) PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) -handlePushToUnisonShare :: MonadIO m => Text -> Path -> Action' m v () -handlePushToUnisonShare remoteRepo remotePath = do +handlePushToUnisonShare :: MonadIO m => Text -> Path -> PushBehavior -> Action' m v () +handlePushToUnisonShare remoteRepo remotePath behavior = do let repoPath = Share.RepoPath (Share.RepoName remoteRepo) (coerce @[NameSegment] @[Text] (Path.toList remotePath)) LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask @@ -1798,15 +1798,28 @@ handlePushToUnisonShare remoteRepo remotePath = do Sqlite.runTransaction connection do Ops.expectCausalHashAtPath (coerce @[NameSegment] @[Text] (Path.toList (Path.unabsolute localPath))) - liftIO (Share.fastForwardPush authHTTPClient unisonShareUrl connection repoPath localCausalHash) >>= \case - Left err -> - case err of - Share.FastForwardPushErrorNoHistory _repoPath -> undefined - Share.FastForwardPushErrorNoReadPermission _repoPath -> undefined - Share.FastForwardPushErrorNotFastForward -> undefined - Share.FastForwardPushErrorNoWritePermission _repoPath -> undefined - Share.FastForwardPushErrorServerMissingDependencies _dependencies -> undefined - Right () -> pure () + case behavior of + PushBehavior.RequireEmpty -> + liftIO (Share.checkAndSetPush authHTTPClient unisonShareUrl connection repoPath Nothing localCausalHash) >>= \case + Left err -> + case err of + Share.PushErrorHashMismatch _mismatch -> error "remote not empty" + Share.PushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath + Share.PushErrorServerMissingDependencies deps -> errServerMissingDependencies deps + Right () -> pure () + PushBehavior.RequireNonEmpty -> + liftIO (Share.fastForwardPush authHTTPClient unisonShareUrl connection repoPath localCausalHash) >>= \case + Left err -> + case err of + Share.FastForwardPushErrorNoHistory _repoPath -> error "no history" + Share.FastForwardPushErrorNoReadPermission _repoPath -> error "no read permission" + Share.FastForwardPushErrorNotFastForward -> error "not fast-forward" + Share.FastForwardPushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath + Share.FastForwardPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps + Right () -> pure () + where + errNoWritePermission _repoPath = error "no write permission" + errServerMissingDependencies _dependencies = error "server missing dependencies" -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: From 785d924b5e487f57e2c8f58f899858db7ead8e1b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 5 May 2022 15:18:54 -0400 Subject: [PATCH 190/529] PushError -> CheckAndSetPushError --- .../src/Unison/Codebase/Editor/HandleInput.hs | 6 ++--- unison-cli/src/Unison/Share/Sync.hs | 25 +++++++++---------- 2 files changed, 15 insertions(+), 16 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index b0e158c528..645e84420a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1803,9 +1803,9 @@ handlePushToUnisonShare remoteRepo remotePath behavior = do liftIO (Share.checkAndSetPush authHTTPClient unisonShareUrl connection repoPath Nothing localCausalHash) >>= \case Left err -> case err of - Share.PushErrorHashMismatch _mismatch -> error "remote not empty" - Share.PushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath - Share.PushErrorServerMissingDependencies deps -> errServerMissingDependencies deps + Share.CheckAndSetPushErrorHashMismatch _mismatch -> error "remote not empty" + Share.CheckAndSetPushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath + Share.CheckAndSetPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps Right () -> pure () PushBehavior.RequireNonEmpty -> liftIO (Share.fastForwardPush authHTTPClient unisonShareUrl connection repoPath localCausalHash) >>= \case diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 6e47459723..0208a23451 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -3,7 +3,7 @@ module Unison.Share.Sync -- ** Push checkAndSetPush, - PushError (..), + CheckAndSetPushError (..), fastForwardPush, FastForwardPushError (..), @@ -74,11 +74,10 @@ import qualified Unison.Util.Set as Set -- Push -- | An error occurred while pushing code to Unison Share. --- FIXME rename CheckAndSetPushError -data PushError - = PushErrorHashMismatch Share.HashMismatch - | PushErrorNoWritePermission Share.RepoPath - | PushErrorServerMissingDependencies (NESet Share.Hash) +data CheckAndSetPushError + = CheckAndSetPushErrorHashMismatch Share.HashMismatch + | CheckAndSetPushErrorNoWritePermission Share.RepoPath + | CheckAndSetPushErrorServerMissingDependencies (NESet Share.Hash) -- | Push a causal to Unison Share. -- FIXME reword this @@ -96,31 +95,31 @@ checkAndSetPush :: Maybe Share.Hash -> -- | The hash of our local causal to push. CausalHash -> - IO (Either PushError ()) + IO (Either CheckAndSetPushError ()) checkAndSetPush httpClient unisonShareUrl conn repoPath expectedHash causalHash = do -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs -- this causal (UpdatePathMissingDependencies). updatePath >>= \case Share.UpdatePathSuccess -> pure (Right ()) - Share.UpdatePathHashMismatch mismatch -> pure (Left (PushErrorHashMismatch mismatch)) + Share.UpdatePathHashMismatch mismatch -> pure (Left (CheckAndSetPushErrorHashMismatch mismatch)) Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do -- Upload the causal and all of its dependencies. uploadEntities httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) dependencies >>= \case - False -> pure (Left (PushErrorNoWritePermission repoPath)) + False -> pure (Left (CheckAndSetPushErrorNoWritePermission repoPath)) True -> -- After uploading the causal and all of its dependencies, try setting the remote path again. updatePath <&> \case Share.UpdatePathSuccess -> Right () -- Between the initial updatePath attempt and this one, someone else managed to update the path. That's ok; -- we still managed to upload our causal, but the push has indeed failed overall. - Share.UpdatePathHashMismatch mismatch -> Left (PushErrorHashMismatch mismatch) + Share.UpdatePathHashMismatch mismatch -> Left (CheckAndSetPushErrorHashMismatch mismatch) -- Unexpected, but possible: we thought we uploaded all we needed to, yet the server still won't accept our -- causal. Bug in the client because we didn't upload enough? Bug in the server because we weren't told to -- upload some dependency? Who knows. Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> - Left (PushErrorServerMissingDependencies dependencies) - Share.UpdatePathNoWritePermission _ -> Left (PushErrorNoWritePermission repoPath) - Share.UpdatePathNoWritePermission _ -> pure (Left (PushErrorNoWritePermission repoPath)) + Left (CheckAndSetPushErrorServerMissingDependencies dependencies) + Share.UpdatePathNoWritePermission _ -> Left (CheckAndSetPushErrorNoWritePermission repoPath) + Share.UpdatePathNoWritePermission _ -> pure (Left (CheckAndSetPushErrorNoWritePermission repoPath)) where updatePath :: IO Share.UpdatePathResponse updatePath = From 2d0c8d55b1c671106db13954e3d5af1fdd2a6b12 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 5 May 2022 15:37:46 -0400 Subject: [PATCH 191/529] organize share types module --- unison-share-api/src/Unison/Sync/Types.hs | 1193 +++++++++++---------- 1 file changed, 625 insertions(+), 568 deletions(-) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index fb884a07fd..8708256969 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -1,7 +1,62 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} -module Unison.Sync.Types where +module Unison.Sync.Types + ( -- * Misc. types + Base64Bytes (..), + RepoName (..), + RepoPath (..), + + -- ** Hash types + Hash (..), + TypedHash (..), + HashJWT (..), + hashJWTHash, + HashJWTClaims (..), + DecodedHashJWT (..), + decodeHashJWT, + decodeHashJWTClaims, + decodedHashJWTHash, + + -- ** Entity types + Entity (..), + TermComponent (..), + DeclComponent (..), + Patch (..), + PatchDiff (..), + Namespace (..), + NamespaceDiff (..), + Causal (..), + LocalIds (..), + entityDependencies, + EntityType (..), + + -- * Request/response types + + -- ** Get causal hash by path + GetCausalHashByPathRequest (..), + GetCausalHashByPathResponse (..), + + -- ** Download entities + DownloadEntitiesRequest (..), + DownloadEntitiesResponse (..), + + -- ** Upload entities + UploadEntitiesRequest (..), + UploadEntitiesResponse (..), + + -- ** Fast-forward path + FastForwardPathRequest (..), + FastForwardPathResponse (..), + + -- ** Update path + UpdatePathRequest (..), + UpdatePathResponse (..), + + -- * Error types + HashMismatch (..), + NeedDependencies (..), + ) +where import Data.Aeson import qualified Data.Aeson as Aeson @@ -21,6 +76,9 @@ import U.Util.Base32Hex (Base32Hex (..)) import Unison.Prelude import qualified Web.JWT as JWT +------------------------------------------------------------------------------------------------------------------------ +-- Misc. types + -- | A newtype for JSON encoding binary data. newtype Base64Bytes = Base64Bytes ByteString @@ -28,12 +86,56 @@ instance ToJSON Base64Bytes where toJSON (Base64Bytes bytes) = String . Text.decodeUtf8 $ convertToBase Base64 bytes instance FromJSON Base64Bytes where - parseJSON = Aeson.withText "Base64" $ \txt -> do + parseJSON = Aeson.withText "Base64" \txt -> do either fail (pure . Base64Bytes) $ convertFromBase Base64 (Text.encodeUtf8 txt) newtype RepoName = RepoName Text deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) +data RepoPath = RepoPath + { repoName :: RepoName, + pathSegments :: [Text] + } + deriving stock (Show, Eq, Ord) + +instance ToJSON RepoPath where + toJSON (RepoPath name segments) = + object + [ "repo_name" .= name, + "path" .= segments + ] + +instance FromJSON RepoPath where + parseJSON = Aeson.withObject "RepoPath" \obj -> do + repoName <- obj .: "repo_name" + pathSegments <- obj .: "path" + pure RepoPath {..} + +------------------------------------------------------------------------------------------------------------------------ +-- Hash types + +newtype Hash = Hash {toBase32Hex :: Base32Hex} + deriving (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey) via (Text) + +data TypedHash = TypedHash + { hash :: Hash, + entityType :: EntityType + } + deriving stock (Show, Eq, Ord) + +instance ToJSON TypedHash where + toJSON (TypedHash hash entityType) = + object + [ "hash" .= hash, + "type" .= entityType + ] + +instance FromJSON TypedHash where + parseJSON = Aeson.withObject "TypedHash" \obj -> do + hash <- obj .: "hash" + entityType <- obj .: "type" + pure TypedHash {..} + newtype HashJWT = HashJWT {unHashJWT :: Text} deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) @@ -44,6 +146,25 @@ hashJWTHash :: HashJWT -> Hash hashJWTHash = decodedHashJWTHash . decodeHashJWT +data HashJWTClaims = HashJWTClaims + { hash :: Hash, + entityType :: EntityType + } + deriving stock (Show, Eq, Ord) + +instance ToJSON HashJWTClaims where + toJSON (HashJWTClaims hash entityType) = + object + [ "h" .= hash, + "t" .= entityType + ] + +instance FromJSON HashJWTClaims where + parseJSON = Aeson.withObject "HashJWTClaims" \obj -> do + hash <- obj .: "h" + entityType <- obj .: "t" + pure HashJWTClaims {..} + -- | A decoded hash JWT that retains the original encoded JWT. data DecodedHashJWT = DecodedHashJWT { claims :: HashJWTClaims, @@ -82,301 +203,428 @@ decodedHashJWTHash :: DecodedHashJWT -> Hash decodedHashJWTHash DecodedHashJWT {claims = HashJWTClaims {hash}} = hash -data HashJWTClaims = HashJWTClaims - { hash :: Hash, - entityType :: EntityType - } +------------------------------------------------------------------------------------------------------------------------ +-- Entity types + +data Entity text noSyncHash hash + = TC (TermComponent text hash) + | DC (DeclComponent text hash) + | P (Patch text noSyncHash hash) + | PD (PatchDiff text noSyncHash hash) + | N (Namespace text hash) + | ND (NamespaceDiff text hash) + | C (Causal hash) deriving stock (Show, Eq, Ord) -instance ToJSON HashJWTClaims where - toJSON (HashJWTClaims hash entityType) = - object - [ "h" .= hash, - "t" .= entityType - ] +instance (ToJSON text, ToJSON noSyncHash, ToJSON hash) => ToJSON (Entity text noSyncHash hash) where + toJSON = \case + TC tc -> go TermComponentType tc + DC dc -> go DeclComponentType dc + P patch -> go PatchType patch + PD patch -> go PatchDiffType patch + N ns -> go NamespaceType ns + ND ns -> go NamespaceDiffType ns + C causal -> go CausalType causal + where + go :: ToJSON a => EntityType -> a -> Aeson.Value + go typ obj = object ["type" .= typ, "object" .= obj] -instance FromJSON HashJWTClaims where - parseJSON = Aeson.withObject "HashJWTClaims" $ \obj -> do - hash <- obj .: "h" - entityType <- obj .: "t" - pure HashJWTClaims {..} +instance (FromJSON text, FromJSON noSyncHash, FromJSON hash, Ord hash) => FromJSON (Entity text noSyncHash hash) where + parseJSON = Aeson.withObject "Entity" \obj -> + obj .: "type" >>= \case + TermComponentType -> TC <$> obj .: "object" + DeclComponentType -> DC <$> obj .: "object" + PatchType -> P <$> obj .: "object" + PatchDiffType -> PD <$> obj .: "object" + NamespaceType -> N <$> obj .: "object" + NamespaceDiffType -> ND <$> obj .: "object" + CausalType -> C <$> obj .: "object" -newtype Hash = Hash {toBase32Hex :: Base32Hex} - deriving (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey) via (Text) +-- | Get the direct dependencies of an entity (which are actually sync'd). +-- +-- FIXME use generic-lens here? (typed @hash) +entityDependencies :: Ord hash => Entity text noSyncHash hash -> Set hash +entityDependencies = \case + TC (TermComponent terms) -> flip foldMap terms \(LocalIds {hashes}, _term) -> Set.fromList hashes + DC (DeclComponent decls) -> flip foldMap decls \(LocalIds {hashes}, _decl) -> Set.fromList hashes + P Patch {newHashLookup} -> Set.fromList newHashLookup + PD PatchDiff {parent, newHashLookup} -> Set.insert parent (Set.fromList newHashLookup) + N Namespace {defnLookup, patchLookup, childLookup} -> + Set.unions + [ Set.fromList defnLookup, + Set.fromList patchLookup, + foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup + ] + ND NamespaceDiff {parent, defnLookup, patchLookup, childLookup} -> + Set.unions + [ Set.singleton parent, + Set.fromList defnLookup, + Set.fromList patchLookup, + foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup + ] + C Causal {parents} -> parents -data TypedHash = TypedHash - { hash :: Hash, - entityType :: EntityType - } +data TermComponent text hash = TermComponent [(LocalIds text hash, ByteString)] deriving stock (Show, Eq, Ord) -instance ToJSON TypedHash where - toJSON (TypedHash hash entityType) = - object - [ "hash" .= hash, - "type" .= entityType - ] +instance Bifoldable TermComponent where + bifoldMap = bifoldMapDefault -instance FromJSON TypedHash where - parseJSON = Aeson.withObject "TypedHash" $ \obj -> do - hash <- obj .: "hash" - entityType <- obj .: "type" - pure $ TypedHash {..} +instance Bifunctor TermComponent where + bimap = bimapDefault -data RepoPath = RepoPath - { repoName :: RepoName, - pathSegments :: [Text] - } - deriving stock (Show, Eq, Ord) +instance Bitraversable TermComponent where + bitraverse f g (TermComponent xs) = + TermComponent <$> bitraverseComponents f g xs -instance ToJSON RepoPath where - toJSON (RepoPath name segments) = +instance (ToJSON text, ToJSON hash) => ToJSON (TermComponent text hash) where + toJSON (TermComponent components) = object - [ "repo_name" .= name, - "path" .= segments + [ "terms" .= (encodeComponentPiece <$> components) ] -instance FromJSON RepoPath where - parseJSON = Aeson.withObject "RepoPath" $ \obj -> do - repoName <- obj .: "repo_name" - pathSegments <- obj .: "path" - pure RepoPath {..} +bitraverseComponents :: + Applicative f => + (a -> f a') -> + (b -> f b') -> + [(LocalIds a b, ByteString)] -> + f [(LocalIds a' b', ByteString)] +bitraverseComponents f g = + traverse . _1 $ bitraverse f g + where + _1 f (l, r) = (,r) <$> f l -newtype GetCausalHashByPathRequest = GetCausalHashByPathRequest - { repoPath :: RepoPath - } - deriving stock (Show, Eq, Ord) +encodeComponentPiece :: (ToJSON text, ToJSON hash) => (LocalIds text hash, ByteString) -> Value +encodeComponentPiece (localIDs, bytes) = + object + [ "local_ids" .= localIDs, + "bytes" .= Base64Bytes bytes + ] -instance ToJSON GetCausalHashByPathRequest where - toJSON (GetCausalHashByPathRequest repoPath) = - object - [ "repo_path" .= repoPath - ] +decodeComponentPiece :: (FromJSON text, FromJSON hash) => Value -> Aeson.Parser (LocalIds text hash, ByteString) +decodeComponentPiece = Aeson.withObject "Component Piece" \obj -> do + localIDs <- obj .: "local_ids" + Base64Bytes bytes <- obj .: "local_ids" + pure (localIDs, bytes) -instance FromJSON GetCausalHashByPathRequest where - parseJSON = Aeson.withObject "GetCausalHashByPathRequest" $ \obj -> do - repoPath <- obj .: "repo_path" - pure GetCausalHashByPathRequest {..} +instance (FromJSON text, FromJSON hash) => FromJSON (TermComponent text hash) where + parseJSON = Aeson.withObject "TermComponent" \obj -> do + pieces <- obj .: "terms" + terms <- traverse decodeComponentPiece pieces + pure (TermComponent terms) -data GetCausalHashByPathResponse - = GetCausalHashByPathSuccess (Maybe HashJWT) - | GetCausalHashByPathNoReadPermission RepoPath +data DeclComponent text hash = DeclComponent [(LocalIds text hash, ByteString)] deriving stock (Show, Eq, Ord) -instance ToJSON GetCausalHashByPathResponse where - toJSON = \case - GetCausalHashByPathSuccess hashJWT -> jsonUnion "success" hashJWT - GetCausalHashByPathNoReadPermission repoPath -> jsonUnion "no_read_permission" repoPath +instance Bifoldable DeclComponent where + bifoldMap = bifoldMapDefault -instance FromJSON GetCausalHashByPathResponse where - parseJSON = Aeson.withObject "GetCausalHashByPathResponse" \obj -> do - obj .: "type" >>= Aeson.withText "type" \case - "success" -> GetCausalHashByPathSuccess <$> obj .: "payload" - "no_read_permission" -> GetCausalHashByPathNoReadPermission <$> obj .: "payload" - t -> failText $ "Unexpected GetCausalHashByPathResponse type: " <> t +instance Bifunctor DeclComponent where + bimap = bimapDefault -data DownloadEntitiesRequest = DownloadEntitiesRequest - { repoName :: RepoName, - hashes :: NESet HashJWT - } - deriving stock (Show, Eq, Ord) +instance Bitraversable DeclComponent where + bitraverse f g (DeclComponent xs) = + DeclComponent <$> bitraverseComponents f g xs -instance ToJSON DownloadEntitiesRequest where - toJSON (DownloadEntitiesRequest repoName hashes) = +instance (ToJSON text, ToJSON hash) => ToJSON (DeclComponent text hash) where + toJSON (DeclComponent components) = object - [ "repo_name" .= repoName, - "hashes" .= hashes + [ "decls" .= (encodeComponentPiece <$> components) ] -instance FromJSON DownloadEntitiesRequest where - parseJSON = Aeson.withObject "DownloadEntitiesRequest" $ \obj -> do - repoName <- obj .: "repo_name" - hashes <- obj .: "hashes" - pure DownloadEntitiesRequest {..} +instance (FromJSON text, FromJSON hash) => FromJSON (DeclComponent text hash) where + parseJSON = Aeson.withObject "DeclComponent" \obj -> do + pieces <- obj .: "decls" + terms <- traverse decodeComponentPiece pieces + pure (DeclComponent terms) -data DownloadEntitiesResponse = DownloadEntitiesResponse - { entities :: NEMap Hash (Entity Text Hash HashJWT) +data LocalIds text hash = LocalIds + { texts :: [text], + hashes :: [hash] } deriving stock (Show, Eq, Ord) -instance ToJSON DownloadEntitiesResponse where - toJSON (DownloadEntitiesResponse entities) = - object - [ "entities" .= entities - ] +instance Bifoldable LocalIds where + bifoldMap = bifoldMapDefault -instance FromJSON DownloadEntitiesResponse where - parseJSON = Aeson.withObject "DownloadEntitiesResponse" $ \obj -> do - DownloadEntitiesResponse <$> obj .: "entities" +instance Bifunctor LocalIds where + bimap = bimapDefault ------------------------------------------------------------------------------------------------------------------------- --- Fast-forward path +instance Bitraversable LocalIds where + bitraverse f g (LocalIds texts hashes) = + LocalIds <$> traverse f texts <*> traverse g hashes --- | A non-empty list of causal hashes, latest first, that show the lineage from wherever the client wants to --- fast-forward to back to wherever the (client believes the) server is (not including the server head). --- --- For example, if the client wants to update --- --- @ --- A -> B -> C --- @ --- --- to --- --- @ --- A -> B -> C -> D -> E -> F --- @ --- --- then it would send hashes --- --- @ --- [F, E, D] --- @ --- --- Note that if the client wants to begin a history at a new path on the server, it would use the "update path" endpoint --- instead. -data FastForwardPathRequest = FastForwardPathRequest - { -- TODO non-empty - hashes :: [Hash], - -- | The repo + path to fast-forward. - path :: RepoPath +instance (ToJSON text, ToJSON hash) => ToJSON (LocalIds text hash) where + toJSON (LocalIds texts hashes) = + object + [ "texts" .= texts, + "hashes" .= hashes + ] + +instance (FromJSON text, FromJSON hash) => FromJSON (LocalIds text hash) where + parseJSON = Aeson.withObject "LocalIds" \obj -> do + texts <- obj .: "texts" + hashes <- obj .: "hashes" + pure LocalIds {..} + +data Patch text oldHash newHash = Patch + { textLookup :: [text], + oldHashLookup :: [oldHash], + newHashLookup :: [newHash], + bytes :: ByteString } - deriving stock (Show) + deriving stock (Show, Eq, Ord) -instance ToJSON FastForwardPathRequest where - toJSON FastForwardPathRequest {hashes, path} = +instance (ToJSON text, ToJSON oldHash, ToJSON newHash) => ToJSON (Patch text oldHash newHash) where + toJSON (Patch textLookup oldHashLookup newHashLookup bytes) = object - [ "hashes" .= hashes, - "path" .= path + [ "text_lookup" .= textLookup, + "optional_hash_lookup" .= oldHashLookup, + "hash_lookup" .= newHashLookup, + "bytes" .= Base64Bytes bytes ] -instance FromJSON FastForwardPathRequest where - parseJSON = - Aeson.withObject "FastForwardPathRequest" \o -> do - hashes <- o .: "hashes" - path <- o .: "path" - pure FastForwardPathRequest {hashes, path} +instance (FromJSON text, FromJSON oldHash, FromJSON newHash) => FromJSON (Patch text oldHash newHash) where + parseJSON = Aeson.withObject "Patch" \obj -> do + textLookup <- obj .: "text_lookup" + oldHashLookup <- obj .: "optional_hash_lookup" + newHashLookup <- obj .: "hash_lookup" + Base64Bytes bytes <- obj .: "bytes" + pure Patch {..} -data FastForwardPathResponse - = FastForwardPathSuccess - | FastForwardPathMissingDependencies (NeedDependencies Hash) - | FastForwardPathNoWritePermission RepoPath - | -- | This wasn't a fast-forward. Here's a JWT to download the causal head, if you want it. - FastForwardPathNotFastForward HashJWT - | -- | There was no history at this path; the client should use the "update path" endpoint instead. - FastForwardPathNoHistory - deriving stock (Show) +data PatchDiff text oldHash hash = PatchDiff + { parent :: hash, + textLookup :: [text], + oldHashLookup :: [oldHash], + newHashLookup :: [hash], + bytes :: ByteString + } + deriving stock (Eq, Ord, Show) -instance ToJSON FastForwardPathResponse where - toJSON = \case - FastForwardPathSuccess -> jsonUnion "success" (Object mempty) - FastForwardPathMissingDependencies deps -> jsonUnion "missing_dependencies" deps - FastForwardPathNoWritePermission repoPath -> jsonUnion "no_write_permission" repoPath - FastForwardPathNotFastForward hashJwt -> jsonUnion "not_fast_forward" hashJwt - FastForwardPathNoHistory -> jsonUnion "no_history" (Object mempty) +instance (ToJSON text, ToJSON oldHash, ToJSON hash) => ToJSON (PatchDiff text oldHash hash) where + toJSON (PatchDiff parent textLookup oldHashLookup newHashLookup bytes) = + object + [ "parent" .= parent, + "text_lookup" .= textLookup, + "optional_hash_lookup" .= oldHashLookup, + "hash_lookup" .= newHashLookup, + "bytes" .= Base64Bytes bytes + ] -instance FromJSON FastForwardPathResponse where - parseJSON = - Aeson.withObject "FastForwardPathResponse" \o -> - o .: "type" >>= Aeson.withText "type" \case - "success" -> pure FastForwardPathSuccess - "missing_dependencies" -> FastForwardPathMissingDependencies <$> o .: "payload" - "no_write_permission" -> FastForwardPathNoWritePermission <$> o .: "payload" - "not_fast_forward" -> FastForwardPathNotFastForward <$> o .: "payload" - "no_history" -> pure FastForwardPathNoHistory - t -> failText $ "Unexpected FastForwardPathResponse type: " <> t +instance (FromJSON text, FromJSON oldHash, FromJSON hash) => FromJSON (PatchDiff text oldHash hash) where + parseJSON = Aeson.withObject "PatchDiff" \obj -> do + parent <- obj .: "parent" + textLookup <- obj .: "text_lookup" + oldHashLookup <- obj .: "optional_hash_lookup" + newHashLookup <- obj .: "hash_lookup" + Base64Bytes bytes <- obj .: "bytes" + pure PatchDiff {..} + +data Namespace text hash = Namespace + { textLookup :: [text], + defnLookup :: [hash], + patchLookup :: [hash], + childLookup :: [(hash, hash)], -- (namespace hash, causal hash) + bytes :: ByteString + } + deriving stock (Eq, Ord, Show) + +instance Bifoldable Namespace where + bifoldMap = bifoldMapDefault + +instance Bifunctor Namespace where + bimap = bimapDefault + +instance Bitraversable Namespace where + bitraverse f g (Namespace tl dl pl cl b) = + Namespace + <$> traverse f tl + <*> traverse g dl + <*> traverse g pl + <*> traverse (bitraverse g g) cl + <*> pure b + +instance (ToJSON text, ToJSON hash) => ToJSON (Namespace text hash) where + toJSON (Namespace textLookup defnLookup patchLookup childLookup bytes) = + object + [ "text_lookup" .= textLookup, + "defn_lookup" .= defnLookup, + "patch_lookup" .= patchLookup, + "child_lookup" .= childLookup, + "bytes" .= Base64Bytes bytes + ] + +instance (FromJSON text, FromJSON hash) => FromJSON (Namespace text hash) where + parseJSON = Aeson.withObject "Namespace" \obj -> do + textLookup <- obj .: "text_lookup" + defnLookup <- obj .: "defn_lookup" + patchLookup <- obj .: "patch_lookup" + childLookup <- obj .: "child_lookup" + Base64Bytes bytes <- obj .: "bytes" + pure Namespace {..} + +data NamespaceDiff text hash = NamespaceDiff + { parent :: hash, + textLookup :: [text], + defnLookup :: [hash], + patchLookup :: [hash], + childLookup :: [(hash, hash)], -- (namespace hash, causal hash) + bytes :: ByteString + } + deriving stock (Eq, Ord, Show) + +instance (ToJSON text, ToJSON hash) => ToJSON (NamespaceDiff text hash) where + toJSON (NamespaceDiff parent textLookup defnLookup patchLookup childLookup bytes) = + object + [ "parent" .= parent, + "text_lookup" .= textLookup, + "defn_lookup" .= defnLookup, + "patch_lookup" .= patchLookup, + "child_lookup" .= childLookup, + "bytes" .= Base64Bytes bytes + ] + +instance (FromJSON text, FromJSON hash) => FromJSON (NamespaceDiff text hash) where + parseJSON = Aeson.withObject "NamespaceDiff" \obj -> do + parent <- obj .: "parent" + textLookup <- obj .: "text_lookup" + defnLookup <- obj .: "defn_lookup" + patchLookup <- obj .: "patch_lookup" + childLookup <- obj .: "child_lookup" + Base64Bytes bytes <- obj .: "bytes" + pure NamespaceDiff {..} + +-- Client _may_ choose not to download the namespace entity in the future, but +-- we still send them the hash/hashjwt. +data Causal hash = Causal + { namespaceHash :: hash, + parents :: Set hash + } + deriving stock (Eq, Ord, Show) + +instance (ToJSON hash) => ToJSON (Causal hash) where + toJSON (Causal namespaceHash parents) = + object + [ "namespace_hash" .= namespaceHash, + "parents" .= parents + ] + +instance (FromJSON hash, Ord hash) => FromJSON (Causal hash) where + parseJSON = Aeson.withObject "Causal" \obj -> do + namespaceHash <- obj .: "namespace_hash" + parents <- obj .: "parents" + pure Causal {..} + +data EntityType + = TermComponentType + | DeclComponentType + | PatchType + | PatchDiffType + | NamespaceType + | NamespaceDiffType + | CausalType + deriving stock (Eq, Ord, Show) + +instance ToJSON EntityType where + toJSON = + String . \case + TermComponentType -> "term_component" + DeclComponentType -> "decl_component" + PatchType -> "patch" + PatchDiffType -> "patch_diff" + NamespaceType -> "namespace" + NamespaceDiffType -> "namespace_diff" + CausalType -> "causal" + +instance FromJSON EntityType where + parseJSON = Aeson.withText "EntityType" \case + "term_component" -> pure TermComponentType + "decl_component" -> pure DeclComponentType + "patch" -> pure PatchType + "patch_diff" -> pure PatchDiffType + "namespace" -> pure NamespaceType + "namespace_diff" -> pure NamespaceDiffType + "causal" -> pure CausalType + t -> failText $ "Unexpected entity type: " <> t ------------------------------------------------------------------------------------------------------------------------ --- Update path +-- Request/response types -data UpdatePathRequest = UpdatePathRequest - { path :: RepoPath, - expectedHash :: Maybe TypedHash, -- Nothing requires empty history at destination - newHash :: TypedHash +------------------------------------------------------------------------------------------------------------------------ +-- Get causal hash by path + +newtype GetCausalHashByPathRequest = GetCausalHashByPathRequest + { repoPath :: RepoPath } deriving stock (Show, Eq, Ord) -instance ToJSON UpdatePathRequest where - toJSON (UpdatePathRequest path expectedHash newHash) = +instance ToJSON GetCausalHashByPathRequest where + toJSON (GetCausalHashByPathRequest repoPath) = object - [ "path" .= path, - "expected_hash" .= expectedHash, - "new_hash" .= newHash + [ "repo_path" .= repoPath ] -instance FromJSON UpdatePathRequest where - parseJSON = Aeson.withObject "UpdatePathRequest" $ \obj -> do - path <- obj .: "path" - expectedHash <- obj .: "expected_hash" - newHash <- obj .: "new_hash" - pure UpdatePathRequest {..} +instance FromJSON GetCausalHashByPathRequest where + parseJSON = Aeson.withObject "GetCausalHashByPathRequest" \obj -> do + repoPath <- obj .: "repo_path" + pure GetCausalHashByPathRequest {..} -data UpdatePathResponse - = UpdatePathSuccess - | UpdatePathHashMismatch HashMismatch - | UpdatePathMissingDependencies (NeedDependencies Hash) - | UpdatePathNoWritePermission RepoPath +data GetCausalHashByPathResponse + = GetCausalHashByPathSuccess (Maybe HashJWT) + | GetCausalHashByPathNoReadPermission RepoPath deriving stock (Show, Eq, Ord) -jsonUnion :: ToJSON a => Text -> a -> Value -jsonUnion typeName val = - Aeson.object - [ "type" .= String typeName, - "payload" .= val - ] - -instance ToJSON UpdatePathResponse where +instance ToJSON GetCausalHashByPathResponse where toJSON = \case - UpdatePathSuccess -> jsonUnion "success" (Object mempty) - UpdatePathHashMismatch hm -> jsonUnion "hash_mismatch" hm - UpdatePathMissingDependencies md -> jsonUnion "missing_dependencies" md - UpdatePathNoWritePermission repoPath -> jsonUnion "no_write_permission" repoPath + GetCausalHashByPathSuccess hashJWT -> jsonUnion "success" hashJWT + GetCausalHashByPathNoReadPermission repoPath -> jsonUnion "no_read_permission" repoPath -instance FromJSON UpdatePathResponse where - parseJSON v = - v & Aeson.withObject "UpdatePathResponse" \obj -> - obj .: "type" >>= Aeson.withText "type" \case - "success" -> pure UpdatePathSuccess - "hash_mismatch" -> UpdatePathHashMismatch <$> obj .: "payload" - "missing_dependencies" -> UpdatePathMissingDependencies <$> obj .: "payload" - "no_write_permission" -> UpdatePathNoWritePermission <$> obj .: "payload" - t -> failText $ "Unexpected UpdatePathResponse type: " <> t +instance FromJSON GetCausalHashByPathResponse where + parseJSON = Aeson.withObject "GetCausalHashByPathResponse" \obj -> do + obj .: "type" >>= Aeson.withText "type" \case + "success" -> GetCausalHashByPathSuccess <$> obj .: "payload" + "no_read_permission" -> GetCausalHashByPathNoReadPermission <$> obj .: "payload" + t -> failText $ "Unexpected GetCausalHashByPathResponse type: " <> t -data NeedDependencies hash = NeedDependencies - { missingDependencies :: NESet hash +------------------------------------------------------------------------------------------------------------------------ +-- Download entities + +data DownloadEntitiesRequest = DownloadEntitiesRequest + { repoName :: RepoName, + hashes :: NESet HashJWT } deriving stock (Show, Eq, Ord) -instance ToJSON hash => ToJSON (NeedDependencies hash) where - toJSON (NeedDependencies missingDependencies) = - object ["missing_dependencies" .= missingDependencies] +instance ToJSON DownloadEntitiesRequest where + toJSON (DownloadEntitiesRequest repoName hashes) = + object + [ "repo_name" .= repoName, + "hashes" .= hashes + ] -instance (FromJSON hash, Ord hash) => FromJSON (NeedDependencies hash) where - parseJSON = Aeson.withObject "NeedDependencies" $ \obj -> do - missingDependencies <- obj .: "missing_dependencies" - pure NeedDependencies {..} +instance FromJSON DownloadEntitiesRequest where + parseJSON = Aeson.withObject "DownloadEntitiesRequest" \obj -> do + repoName <- obj .: "repo_name" + hashes <- obj .: "hashes" + pure DownloadEntitiesRequest {..} -data HashMismatch = HashMismatch - { repoPath :: RepoPath, - expectedHash :: Maybe TypedHash, - actualHash :: Maybe TypedHash +data DownloadEntitiesResponse = DownloadEntitiesResponse + { entities :: NEMap Hash (Entity Text Hash HashJWT) } deriving stock (Show, Eq, Ord) -instance ToJSON HashMismatch where - toJSON (HashMismatch repoPath expectedHash actualHash) = +instance ToJSON DownloadEntitiesResponse where + toJSON (DownloadEntitiesResponse entities) = object - [ "repo_path" .= repoPath, - "expected_hash" .= expectedHash, - "actual_hash" .= actualHash + [ "entities" .= entities ] -instance FromJSON HashMismatch where - parseJSON = Aeson.withObject "HashMismatch" $ \obj -> do - repoPath <- obj .: "repo_path" - expectedHash <- obj .: "expected_hash" - actualHash <- obj .: "actual_hash" - pure HashMismatch {..} +instance FromJSON DownloadEntitiesResponse where + parseJSON = Aeson.withObject "DownloadEntitiesResponse" \obj -> do + DownloadEntitiesResponse <$> obj .: "entities" + +------------------------------------------------------------------------------------------------------------------------ +-- Upload entities data UploadEntitiesRequest = UploadEntitiesRequest { repoName :: RepoName, @@ -392,7 +640,7 @@ instance ToJSON UploadEntitiesRequest where ] instance FromJSON UploadEntitiesRequest where - parseJSON = Aeson.withObject "UploadEntitiesRequest" $ \obj -> do + parseJSON = Aeson.withObject "UploadEntitiesRequest" \obj -> do repoName <- obj .: "repo_name" entities <- obj .: "entities" pure UploadEntitiesRequest {..} @@ -418,371 +666,180 @@ instance FromJSON UploadEntitiesResponse where "no_write_permission" -> UploadEntitiesNoWritePermission <$> obj .: "payload" t -> failText $ "Unexpected UploadEntitiesResponse type: " <> t -data Entity text noSyncHash hash - = TC (TermComponent text hash) - | DC (DeclComponent text hash) - | P (Patch text noSyncHash hash) - | PD (PatchDiff text noSyncHash hash) - | N (Namespace text hash) - | ND (NamespaceDiff text hash) - | C (Causal hash) - deriving stock (Show, Eq, Ord) - -instance (ToJSON text, ToJSON noSyncHash, ToJSON hash) => ToJSON (Entity text noSyncHash hash) where - toJSON = \case - TC tc -> - object - [ "type" .= TermComponentType, - "object" .= tc - ] - DC dc -> - object - [ "type" .= DeclComponentType, - "object" .= dc - ] - P patch -> - object - [ "type" .= PatchType, - "object" .= patch - ] - PD patch -> - object - [ "type" .= PatchDiffType, - "object" .= patch - ] - N ns -> - object - [ "type" .= NamespaceType, - "object" .= ns - ] - ND ns -> - object - [ "type" .= NamespaceDiffType, - "object" .= ns - ] - C causal -> - object - [ "type" .= CausalType, - "object" .= causal - ] - -instance (FromJSON text, FromJSON noSyncHash, FromJSON hash, Ord hash) => FromJSON (Entity text noSyncHash hash) where - parseJSON = Aeson.withObject "Entity" $ \obj -> do - entityType <- obj .: "type" - case entityType of - TermComponentType -> TC <$> obj .: "object" - DeclComponentType -> DC <$> obj .: "object" - PatchType -> P <$> obj .: "object" - PatchDiffType -> PD <$> obj .: "object" - NamespaceType -> N <$> obj .: "object" - NamespaceDiffType -> ND <$> obj .: "object" - CausalType -> C <$> obj .: "object" +------------------------------------------------------------------------------------------------------------------------ +-- Fast-forward path --- | Get the direct dependencies of an entity (which are actually sync'd). +-- | A non-empty list of causal hashes, latest first, that show the lineage from wherever the client wants to +-- fast-forward to back to wherever the (client believes the) server is (not including the server head). -- --- FIXME use generic-lens here? (typed @hash) -entityDependencies :: Ord hash => Entity text noSyncHash hash -> Set hash -entityDependencies = \case - TC (TermComponent terms) -> flip foldMap terms \(LocalIds {hashes}, _term) -> Set.fromList hashes - DC (DeclComponent decls) -> flip foldMap decls \(LocalIds {hashes}, _decl) -> Set.fromList hashes - P Patch {newHashLookup} -> Set.fromList newHashLookup - PD PatchDiff {parent, newHashLookup} -> Set.insert parent (Set.fromList newHashLookup) - N Namespace {defnLookup, patchLookup, childLookup} -> - Set.unions - [ Set.fromList defnLookup, - Set.fromList patchLookup, - foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup - ] - ND NamespaceDiff {parent, defnLookup, patchLookup, childLookup} -> - Set.unions - [ Set.singleton parent, - Set.fromList defnLookup, - Set.fromList patchLookup, - foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup - ] - C Causal {parents} -> parents - -data TermComponent text hash = TermComponent [(LocalIds text hash, ByteString)] - deriving stock (Show, Eq, Ord) - -instance Bifoldable TermComponent where - bifoldMap = bifoldMapDefault - -instance Bifunctor TermComponent where - bimap = bimapDefault - -instance Bitraversable TermComponent where - bitraverse f g (TermComponent xs) = - TermComponent <$> bitraverseComponents f g xs - -instance (ToJSON text, ToJSON hash) => ToJSON (TermComponent text hash) where - toJSON (TermComponent components) = - object - [ "terms" .= (encodeComponentPiece <$> components) - ] - -bitraverseComponents :: - Applicative f => - (a -> f a') -> - (b -> f b') -> - [(LocalIds a b, ByteString)] -> - f [(LocalIds a' b', ByteString)] -bitraverseComponents f g = - traverse . _1 $ bitraverse f g - where - _1 f (l, r) = (,r) <$> f l - -encodeComponentPiece :: (ToJSON text, ToJSON hash) => (LocalIds text hash, ByteString) -> Value -encodeComponentPiece (localIDs, bytes) = - object - [ "local_ids" .= localIDs, - "bytes" .= Base64Bytes bytes - ] - -decodeComponentPiece :: (FromJSON text, FromJSON hash) => Value -> Aeson.Parser (LocalIds text hash, ByteString) -decodeComponentPiece = Aeson.withObject "Component Piece" $ \obj -> do - localIDs <- obj .: "local_ids" - Base64Bytes bytes <- obj .: "local_ids" - pure (localIDs, bytes) - -failText :: MonadFail m => Text -> m a -failText = fail . Text.unpack - -instance (FromJSON text, FromJSON hash) => FromJSON (TermComponent text hash) where - parseJSON = Aeson.withObject "TermComponent" $ \obj -> do - pieces <- obj .: "terms" - terms <- traverse decodeComponentPiece pieces - pure (TermComponent terms) - -data DeclComponent text hash = DeclComponent [(LocalIds text hash, ByteString)] - deriving stock (Show, Eq, Ord) - -instance Bifoldable DeclComponent where - bifoldMap = bifoldMapDefault - -instance Bifunctor DeclComponent where - bimap = bimapDefault - -instance Bitraversable DeclComponent where - bitraverse f g (DeclComponent xs) = - DeclComponent <$> bitraverseComponents f g xs - -instance (ToJSON text, ToJSON hash) => ToJSON (DeclComponent text hash) where - toJSON (DeclComponent components) = - object - [ "decls" .= (encodeComponentPiece <$> components) - ] - -instance (FromJSON text, FromJSON hash) => FromJSON (DeclComponent text hash) where - parseJSON = Aeson.withObject "DeclComponent" $ \obj -> do - pieces <- obj .: "decls" - terms <- traverse decodeComponentPiece pieces - pure (DeclComponent terms) - -data LocalIds text hash = LocalIds - { texts :: [text], - hashes :: [hash] +-- For example, if the client wants to update +-- +-- @ +-- A -> B -> C +-- @ +-- +-- to +-- +-- @ +-- A -> B -> C -> D -> E -> F +-- @ +-- +-- then it would send hashes +-- +-- @ +-- [F, E, D] +-- @ +-- +-- Note that if the client wants to begin a history at a new path on the server, it would use the "update path" endpoint +-- instead. +data FastForwardPathRequest = FastForwardPathRequest + { -- TODO non-empty + hashes :: [Hash], + -- | The repo + path to fast-forward. + path :: RepoPath } - deriving stock (Show, Eq, Ord) - -instance Bifoldable LocalIds where - bifoldMap = bifoldMapDefault - -instance Bifunctor LocalIds where - bimap = bimapDefault - -instance Bitraversable LocalIds where - bitraverse f g (LocalIds texts hashes) = - LocalIds <$> traverse f texts <*> traverse g hashes + deriving stock (Show) -instance (ToJSON text, ToJSON hash) => ToJSON (LocalIds text hash) where - toJSON (LocalIds texts hashes) = +instance ToJSON FastForwardPathRequest where + toJSON FastForwardPathRequest {hashes, path} = object - [ "texts" .= texts, - "hashes" .= hashes + [ "hashes" .= hashes, + "path" .= path ] -instance (FromJSON text, FromJSON hash) => FromJSON (LocalIds text hash) where - parseJSON = Aeson.withObject "LocalIds" $ \obj -> do - texts <- obj .: "texts" - hashes <- obj .: "hashes" - pure LocalIds {..} +instance FromJSON FastForwardPathRequest where + parseJSON = + Aeson.withObject "FastForwardPathRequest" \o -> do + hashes <- o .: "hashes" + path <- o .: "path" + pure FastForwardPathRequest {hashes, path} -data Patch text oldHash newHash = Patch - { textLookup :: [text], - oldHashLookup :: [oldHash], - newHashLookup :: [newHash], - bytes :: ByteString - } - deriving stock (Show, Eq, Ord) +data FastForwardPathResponse + = FastForwardPathSuccess + | FastForwardPathMissingDependencies (NeedDependencies Hash) + | FastForwardPathNoWritePermission RepoPath + | -- | This wasn't a fast-forward. Here's a JWT to download the causal head, if you want it. + FastForwardPathNotFastForward HashJWT + | -- | There was no history at this path; the client should use the "update path" endpoint instead. + FastForwardPathNoHistory + deriving stock (Show) -instance (ToJSON text, ToJSON oldHash, ToJSON newHash) => ToJSON (Patch text oldHash newHash) where - toJSON (Patch textLookup oldHashLookup newHashLookup bytes) = - object - [ "text_lookup" .= textLookup, - "optional_hash_lookup" .= oldHashLookup, - "hash_lookup" .= newHashLookup, - "bytes" .= Base64Bytes bytes - ] +instance ToJSON FastForwardPathResponse where + toJSON = \case + FastForwardPathSuccess -> jsonUnion "success" (Object mempty) + FastForwardPathMissingDependencies deps -> jsonUnion "missing_dependencies" deps + FastForwardPathNoWritePermission repoPath -> jsonUnion "no_write_permission" repoPath + FastForwardPathNotFastForward hashJwt -> jsonUnion "not_fast_forward" hashJwt + FastForwardPathNoHistory -> jsonUnion "no_history" (Object mempty) -instance (FromJSON text, FromJSON oldHash, FromJSON newHash) => FromJSON (Patch text oldHash newHash) where - parseJSON = Aeson.withObject "Patch" $ \obj -> do - textLookup <- obj .: "text_lookup" - oldHashLookup <- obj .: "optional_hash_lookup" - newHashLookup <- obj .: "hash_lookup" - Base64Bytes bytes <- obj .: "bytes" - pure Patch {..} +instance FromJSON FastForwardPathResponse where + parseJSON = + Aeson.withObject "FastForwardPathResponse" \o -> + o .: "type" >>= Aeson.withText "type" \case + "success" -> pure FastForwardPathSuccess + "missing_dependencies" -> FastForwardPathMissingDependencies <$> o .: "payload" + "no_write_permission" -> FastForwardPathNoWritePermission <$> o .: "payload" + "not_fast_forward" -> FastForwardPathNotFastForward <$> o .: "payload" + "no_history" -> pure FastForwardPathNoHistory + t -> failText $ "Unexpected FastForwardPathResponse type: " <> t -data PatchDiff text oldHash hash = PatchDiff - { parent :: hash, - textLookup :: [text], - oldHashLookup :: [oldHash], - newHashLookup :: [hash], - bytes :: ByteString +------------------------------------------------------------------------------------------------------------------------ +-- Update path + +data UpdatePathRequest = UpdatePathRequest + { path :: RepoPath, + expectedHash :: Maybe TypedHash, -- Nothing requires empty history at destination + newHash :: TypedHash } - deriving stock (Eq, Ord, Show) + deriving stock (Show, Eq, Ord) -instance (ToJSON text, ToJSON oldHash, ToJSON hash) => ToJSON (PatchDiff text oldHash hash) where - toJSON (PatchDiff parent textLookup oldHashLookup newHashLookup bytes) = +instance ToJSON UpdatePathRequest where + toJSON (UpdatePathRequest path expectedHash newHash) = object - [ "parent" .= parent, - "text_lookup" .= textLookup, - "optional_hash_lookup" .= oldHashLookup, - "hash_lookup" .= newHashLookup, - "bytes" .= Base64Bytes bytes + [ "path" .= path, + "expected_hash" .= expectedHash, + "new_hash" .= newHash ] -instance (FromJSON text, FromJSON oldHash, FromJSON hash) => FromJSON (PatchDiff text oldHash hash) where - parseJSON = Aeson.withObject "PatchDiff" \obj -> do - parent <- obj .: "parent" - textLookup <- obj .: "text_lookup" - oldHashLookup <- obj .: "optional_hash_lookup" - newHashLookup <- obj .: "hash_lookup" - Base64Bytes bytes <- obj .: "bytes" - pure PatchDiff {..} - -data Namespace text hash = Namespace - { textLookup :: [text], - defnLookup :: [hash], - patchLookup :: [hash], - childLookup :: [(hash, hash)], -- (namespace hash, causal hash) - bytes :: ByteString - } - deriving stock (Eq, Ord, Show) - -instance Bifoldable Namespace where - bifoldMap = bifoldMapDefault +instance FromJSON UpdatePathRequest where + parseJSON = Aeson.withObject "UpdatePathRequest" \obj -> do + path <- obj .: "path" + expectedHash <- obj .: "expected_hash" + newHash <- obj .: "new_hash" + pure UpdatePathRequest {..} -instance Bifunctor Namespace where - bimap = bimapDefault +data UpdatePathResponse + = UpdatePathSuccess + | UpdatePathHashMismatch HashMismatch + | UpdatePathMissingDependencies (NeedDependencies Hash) + | UpdatePathNoWritePermission RepoPath + deriving stock (Show, Eq, Ord) -instance Bitraversable Namespace where - bitraverse f g (Namespace tl dl pl cl b) = - Namespace - <$> traverse f tl - <*> traverse g dl - <*> traverse g pl - <*> traverse (bitraverse g g) cl - <*> pure b +instance ToJSON UpdatePathResponse where + toJSON = \case + UpdatePathSuccess -> jsonUnion "success" (Object mempty) + UpdatePathHashMismatch hm -> jsonUnion "hash_mismatch" hm + UpdatePathMissingDependencies md -> jsonUnion "missing_dependencies" md + UpdatePathNoWritePermission repoPath -> jsonUnion "no_write_permission" repoPath -instance (ToJSON text, ToJSON hash) => ToJSON (Namespace text hash) where - toJSON (Namespace textLookup defnLookup patchLookup childLookup bytes) = - object - [ "text_lookup" .= textLookup, - "defn_lookup" .= defnLookup, - "patch_lookup" .= patchLookup, - "child_lookup" .= childLookup, - "bytes" .= Base64Bytes bytes - ] +instance FromJSON UpdatePathResponse where + parseJSON v = + v & Aeson.withObject "UpdatePathResponse" \obj -> + obj .: "type" >>= Aeson.withText "type" \case + "success" -> pure UpdatePathSuccess + "hash_mismatch" -> UpdatePathHashMismatch <$> obj .: "payload" + "missing_dependencies" -> UpdatePathMissingDependencies <$> obj .: "payload" + "no_write_permission" -> UpdatePathNoWritePermission <$> obj .: "payload" + t -> failText $ "Unexpected UpdatePathResponse type: " <> t -instance (FromJSON text, FromJSON hash) => FromJSON (Namespace text hash) where - parseJSON = Aeson.withObject "Namespace" $ \obj -> do - textLookup <- obj .: "text_lookup" - defnLookup <- obj .: "defn_lookup" - patchLookup <- obj .: "patch_lookup" - childLookup <- obj .: "child_lookup" - Base64Bytes bytes <- obj .: "bytes" - pure Namespace {..} +------------------------------------------------------------------------------------------------------------------------ +-- Error types -data NamespaceDiff text hash = NamespaceDiff - { parent :: hash, - textLookup :: [text], - defnLookup :: [hash], - patchLookup :: [hash], - childLookup :: [(hash, hash)], -- (namespace hash, causal hash) - bytes :: ByteString +data HashMismatch = HashMismatch + { repoPath :: RepoPath, + expectedHash :: Maybe TypedHash, + actualHash :: Maybe TypedHash } - deriving stock (Eq, Ord, Show) + deriving stock (Show, Eq, Ord) -instance (ToJSON text, ToJSON hash) => ToJSON (NamespaceDiff text hash) where - toJSON (NamespaceDiff parent textLookup defnLookup patchLookup childLookup bytes) = +instance ToJSON HashMismatch where + toJSON (HashMismatch repoPath expectedHash actualHash) = object - [ "parent" .= parent, - "text_lookup" .= textLookup, - "defn_lookup" .= defnLookup, - "patch_lookup" .= patchLookup, - "child_lookup" .= childLookup, - "bytes" .= Base64Bytes bytes + [ "repo_path" .= repoPath, + "expected_hash" .= expectedHash, + "actual_hash" .= actualHash ] -instance (FromJSON text, FromJSON hash) => FromJSON (NamespaceDiff text hash) where - parseJSON = Aeson.withObject "NamespaceDiff" \obj -> do - parent <- obj .: "parent" - textLookup <- obj .: "text_lookup" - defnLookup <- obj .: "defn_lookup" - patchLookup <- obj .: "patch_lookup" - childLookup <- obj .: "child_lookup" - Base64Bytes bytes <- obj .: "bytes" - pure NamespaceDiff {..} +instance FromJSON HashMismatch where + parseJSON = Aeson.withObject "HashMismatch" \obj -> do + repoPath <- obj .: "repo_path" + expectedHash <- obj .: "expected_hash" + actualHash <- obj .: "actual_hash" + pure HashMismatch {..} --- Client _may_ choose not to download the namespace entity in the future, but --- we still send them the hash/hashjwt. -data Causal hash = Causal - { namespaceHash :: hash, - parents :: Set hash +data NeedDependencies hash = NeedDependencies + { missingDependencies :: NESet hash } - deriving stock (Eq, Ord, Show) + deriving stock (Show, Eq, Ord) -instance (ToJSON hash) => ToJSON (Causal hash) where - toJSON (Causal namespaceHash parents) = - object - [ "namespace_hash" .= namespaceHash, - "parents" .= parents - ] +instance ToJSON hash => ToJSON (NeedDependencies hash) where + toJSON (NeedDependencies missingDependencies) = + object ["missing_dependencies" .= missingDependencies] -instance (FromJSON hash, Ord hash) => FromJSON (Causal hash) where - parseJSON = Aeson.withObject "Causal" $ \obj -> do - namespaceHash <- obj .: "namespace_hash" - parents <- obj .: "parents" - pure Causal {..} +instance (FromJSON hash, Ord hash) => FromJSON (NeedDependencies hash) where + parseJSON = Aeson.withObject "NeedDependencies" \obj -> do + missingDependencies <- obj .: "missing_dependencies" + pure NeedDependencies {..} -data EntityType - = TermComponentType - | DeclComponentType - | PatchType - | PatchDiffType - | NamespaceType - | NamespaceDiffType - | CausalType - deriving stock (Eq, Ord, Show) +------------------------------------------------------------------------------------------------------------------------ +-- Misc. helpers -instance ToJSON EntityType where - toJSON et = String $ case et of - TermComponentType -> "term_component" - DeclComponentType -> "decl_component" - PatchType -> "patch" - PatchDiffType -> "patch_diff" - NamespaceType -> "namespace" - NamespaceDiffType -> "namespace_diff" - CausalType -> "causal" +failText :: MonadFail m => Text -> m a +failText = fail . Text.unpack -instance FromJSON EntityType where - parseJSON = Aeson.withText "EntityType" \case - "term_component" -> pure TermComponentType - "decl_component" -> pure DeclComponentType - "patch" -> pure PatchType - "patch_diff" -> pure PatchDiffType - "namespace" -> pure NamespaceType - "namespace_diff" -> pure NamespaceDiffType - "causal" -> pure CausalType - t -> failText $ "Unexpected entity type: " <> t +jsonUnion :: ToJSON a => Text -> a -> Value +jsonUnion typeName val = + Aeson.object + [ "type" .= String typeName, + "payload" .= val + ] From 7735cdb6dd8b21e326d7b13dad84c81ec52ad8ab Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 5 May 2022 15:40:59 -0400 Subject: [PATCH 192/529] delete unused TypedHash --- .../src/Unison/Codebase/Editor/HandleInput.hs | 1 - unison-cli/src/Unison/Share/Sync.hs | 14 +------ unison-share-api/src/Unison/Sync/Types.hs | 38 +++++-------------- 3 files changed, 11 insertions(+), 42 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 645e84420a..5b805dac87 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -140,7 +140,6 @@ import qualified Unison.Sync.Types as Share RepoPath (..), hashJWTHash, ) -import qualified Unison.Sync.Types as Share.TypedHash (TypedHash (..)) import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 0208a23451..ac1dca56cb 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -41,7 +41,6 @@ import qualified Data.Set.NonEmpty as NESet import Data.Vector (Vector) import qualified Data.Vector as Vector import Servant.Client (BaseUrl) -import qualified Text.Regex.TDFA.CorePattern as List import U.Codebase.HashTags (CausalHash (..)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import qualified U.Codebase.Sqlite.Causal as Causal @@ -128,17 +127,8 @@ checkAndSetPush httpClient unisonShareUrl conn repoPath expectedHash causalHash unisonShareUrl Share.UpdatePathRequest { path = repoPath, - expectedHash = - expectedHash <&> \hash -> - Share.TypedHash - { hash, - entityType = Share.CausalType - }, - newHash = - Share.TypedHash - { hash = causalHashToHash causalHash, - entityType = Share.CausalType - } + expectedHash, + newHash = causalHashToHash causalHash } -- | An error occurred while fast-forward pushing code to Unison Share. diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 8708256969..1b9b17d3ec 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -8,7 +8,6 @@ module Unison.Sync.Types -- ** Hash types Hash (..), - TypedHash (..), HashJWT (..), hashJWTHash, HashJWTClaims (..), @@ -51,9 +50,9 @@ module Unison.Sync.Types -- ** Update path UpdatePathRequest (..), UpdatePathResponse (..), - - -- * Error types HashMismatch (..), + + -- * Common/shared error types NeedDependencies (..), ) where @@ -117,25 +116,6 @@ instance FromJSON RepoPath where newtype Hash = Hash {toBase32Hex :: Base32Hex} deriving (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey) via (Text) -data TypedHash = TypedHash - { hash :: Hash, - entityType :: EntityType - } - deriving stock (Show, Eq, Ord) - -instance ToJSON TypedHash where - toJSON (TypedHash hash entityType) = - object - [ "hash" .= hash, - "type" .= entityType - ] - -instance FromJSON TypedHash where - parseJSON = Aeson.withObject "TypedHash" \obj -> do - hash <- obj .: "hash" - entityType <- obj .: "type" - pure TypedHash {..} - newtype HashJWT = HashJWT {unHashJWT :: Text} deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) @@ -748,8 +728,8 @@ instance FromJSON FastForwardPathResponse where data UpdatePathRequest = UpdatePathRequest { path :: RepoPath, - expectedHash :: Maybe TypedHash, -- Nothing requires empty history at destination - newHash :: TypedHash + expectedHash :: Maybe Hash, -- Nothing requires empty history at destination + newHash :: Hash } deriving stock (Show, Eq, Ord) @@ -792,13 +772,10 @@ instance FromJSON UpdatePathResponse where "no_write_permission" -> UpdatePathNoWritePermission <$> obj .: "payload" t -> failText $ "Unexpected UpdatePathResponse type: " <> t ------------------------------------------------------------------------------------------------------------------------- --- Error types - data HashMismatch = HashMismatch { repoPath :: RepoPath, - expectedHash :: Maybe TypedHash, - actualHash :: Maybe TypedHash + expectedHash :: Maybe Hash, + actualHash :: Maybe Hash } deriving stock (Show, Eq, Ord) @@ -817,6 +794,9 @@ instance FromJSON HashMismatch where actualHash <- obj .: "actual_hash" pure HashMismatch {..} +------------------------------------------------------------------------------------------------------------------------ +-- Common/shared error types + data NeedDependencies hash = NeedDependencies { missingDependencies :: NESet hash } From 5e09f7788ab5f05a51f93999b2823167d6a718fa Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 6 May 2022 15:10:23 -0600 Subject: [PATCH 193/529] Allow fetching namespace details (and readme) without loading root branch (#3066) * Lazily fetch readme doc without loading whole v1 branch * De-orphan any instances which are in the same package * Add namespace-details transcript * Fix transcript naming * Update unison-share-api/src/Unison/Server/Backend.hs Co-authored-by: Arya Irani <538571+aryairani@users.noreply.github.com> Co-authored-by: Arya Irani <538571+aryairani@users.noreply.github.com> --- unison-share-api/src/Unison/Server/Backend.hs | 43 ++++++++--- .../src/Unison/Server/CodebaseServer.hs | 2 +- unison-share-api/src/Unison/Server/Doc.hs | 63 +++++++++------ .../Server/Endpoints/NamespaceDetails.hs | 31 ++++---- .../Server/Endpoints/NamespaceListing.hs | 17 +--- unison-share-api/src/Unison/Server/Orphans.hs | 65 ++++++++++++++++ unison-share-api/src/Unison/Server/Types.hs | 77 +------------------ unison-share-api/unison-share-api.cabal | 1 + .../transcripts/api-namespace-details.md | 7 +- .../api-namespace-details.output.md | 35 +++++++-- 10 files changed, 190 insertions(+), 151 deletions(-) create mode 100644 unison-share-api/src/Unison/Server/Orphans.hs diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index b3b1f1da34..562577add6 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -18,6 +18,7 @@ import Data.Bifunctor (first) import Data.Containers.ListUtils (nubOrdOn) import qualified Data.List as List import Data.List.Extra (nubOrd) +import qualified Data.List.Extra as List import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text @@ -32,6 +33,7 @@ import qualified Text.FuzzyFind as FZF import qualified U.Codebase.Branch as V2Branch import qualified U.Codebase.Causal as V2Causal import qualified U.Codebase.HashTags as V2.Hash +import qualified U.Codebase.Referent as V2 import qualified Unison.ABT as ABT import qualified Unison.Builtin as B import qualified Unison.Builtin.Decls as Decls @@ -322,25 +324,35 @@ findShallowReadmeInBranchAndRender :: Rt.Runtime Symbol -> Codebase IO Symbol Ann -> NamesWithHistory -> - Branch IO -> + V2Branch.Branch m -> Backend IO (Maybe Doc.Doc) findShallowReadmeInBranchAndRender width runtime codebase printNames namespaceBranch = let ppe hqLen = PPE.fromNamesDecl hqLen printNames + renderReadme :: PPE.PrettyPrintEnvDecl -> V2.Referent -> IO Doc.Doc renderReadme ppe r = do - (_, _, doc) <- renderDoc ppe width runtime codebase (Referent.toReference r) + let docReference = case r of + -- This shouldn't ever happen unless someone puts a non-doc as their readme. + V2.Con ref _conId -> Cv.reference2to1 ref + V2.Ref ref -> Cv.reference2to1 ref + (_, _, doc) <- renderDoc ppe width runtime codebase docReference pure doc - -- allow any of these capitalizations - toCheck = NameSegment <$> ["README", "Readme", "ReadMe", "readme"] - readmes :: Set Referent - readmes = foldMap lookup toCheck + -- choose the first term (among conflicted terms) matching any of these names, in this order. + -- we might later want to return all of them to let the front end decide + toCheck = V2Branch.NameSegment <$> ["README", "Readme", "ReadMe", "readme"] + readme :: Maybe V2.Referent + readme = List.firstJust lookup toCheck where - lookup seg = R.lookupRan seg rel - rel = Star3.d1 (Branch._terms (Branch.head namespaceBranch)) + lookup :: (V2Branch.NameSegment -> Maybe V2.Referent) + lookup seg = do + term <- Map.lookup seg termsMap + (k, _v) <- Map.lookupMin term + pure k + termsMap = V2Branch.terms namespaceBranch in liftIO $ do hqLen <- Codebase.hashLength codebase - traverse (renderReadme (ppe hqLen)) (Set.lookupMin readmes) + traverse (renderReadme (ppe hqLen)) readme isDoc :: Monad m => Codebase m Symbol Ann -> Referent -> m Bool isDoc codebase ref = do @@ -766,6 +778,19 @@ expandShortBranchHash codebase hash = do _ -> throwError . AmbiguousBranchHash hash $ Set.map (SBH.fromHash len) hashSet +-- | Efficiently resolve a root hash and path to a shallow branch's causal. +getShallowCausalAtPathFromRootHash :: Monad m => Codebase m v a -> Maybe Branch.Hash -> Path -> Backend m (V2Branch.CausalBranch m) +getShallowCausalAtPathFromRootHash codebase mayRootHash path = do + shallowRoot <- case mayRootHash of + Nothing -> lift (Codebase.getShallowRootBranch codebase) + Just h -> do + lift $ Codebase.getShallowBranchForHash codebase (Cv.branchHash1to2 h) + causal <- + (lift $ Codebase.shallowBranchAtPath path shallowRoot) >>= \case + Nothing -> pure $ Cv.causalbranch1to2 (Branch.empty) + Just lc -> pure lc + pure causal + formatType' :: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText formatType' ppe w = Pretty.render w . TypePrinter.pretty0 ppe mempty (-1) diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index b58dc31e4d..7bc5443b3a 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -355,7 +355,7 @@ serveUnison :: serveUnison env codebase rt = hoistServer (Proxy @UnisonAPI) (backendHandler env) $ (\root rel name -> setCacheControl <$> NamespaceListing.serve codebase root rel name) - :<|> (\namespaceName mayRoot mayWidth -> setCacheControl <$> NamespaceDetails.serve rt codebase namespaceName mayRoot mayWidth) + :<|> (\namespaceName mayRoot mayWidth -> setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName mayRoot mayWidth) :<|> (\mayRoot mayOwner -> setCacheControl <$> Projects.serve codebase mayRoot mayOwner) :<|> (\mayRoot relativePath rawHqns width suff -> setCacheControl <$> serveDefinitions rt codebase mayRoot relativePath rawHqns width suff) :<|> (\mayRoot relativePath limit typeWidth query -> setCacheControl <$> serveFuzzyFind codebase mayRoot relativePath limit typeWidth query) diff --git a/unison-share-api/src/Unison/Server/Doc.hs b/unison-share-api/src/Unison/Server/Doc.hs index ebca30af63..cb1c7a0afd 100644 --- a/unison-share-api/src/Unison/Server/Doc.hs +++ b/unison-share-api/src/Unison/Server/Doc.hs @@ -12,11 +12,13 @@ module Unison.Server.Doc where import Control.Lens (view, (^.)) import Control.Monad import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) +import Data.Aeson (ToJSON) import Data.Foldable import Data.Functor import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe) +import Data.OpenApi (ToSchema) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text @@ -38,6 +40,7 @@ import qualified Unison.Reference as Reference import Unison.Referent (Referent) import qualified Unison.Referent as Referent import qualified Unison.Runtime.IOSource as DD +import Unison.Server.Orphans () import Unison.Server.Syntax (SyntaxText) import qualified Unison.Server.Syntax as Syntax import qualified Unison.ShortHash as SH @@ -85,13 +88,20 @@ data Doc | UntitledSection [Doc] | Column [Doc] | Group Doc - deriving (Eq, Show, Generic) + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, ToSchema) type UnisonHash = Text -data Ref a = Term a | Type a deriving (Eq, Show, Generic, Functor, Foldable, Traversable) +data Ref a = Term a | Type a + deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable) + deriving anyclass (ToJSON) -data MediaSource = MediaSource {mediaSourceUrl :: Text, mediaSourceMimeType :: Maybe Text} deriving (Eq, Show, Generic) +instance ToSchema a => ToSchema (Ref a) + +data MediaSource = MediaSource {mediaSourceUrl :: Text, mediaSourceMimeType :: Maybe Text} + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, ToSchema) data SpecialForm = Source [Ref (UnisonHash, DisplayObject SyntaxText Src)] @@ -107,10 +117,13 @@ data SpecialForm | EmbedInline SyntaxText | Video [MediaSource] (Map Text Text) | FrontMatter (Map Text [Text]) - deriving (Eq, Show, Generic) + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, ToSchema) -- `Src folded unfolded` -data Src = Src SyntaxText SyntaxText deriving (Eq, Show, Generic) +data Src = Src SyntaxText SyntaxText + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON, ToSchema) renderDoc :: forall v m. @@ -289,29 +302,29 @@ renderDoc pped terms typeOf eval types tm = acc' = case tm of Term.Ref' r | Set.notMember r seen -> - (: acc) . Term . (Reference.toText r,) <$> case r of - Reference.Builtin _ -> - typeOf (Referent.Ref r) <&> \case - Nothing -> DO.BuiltinObject "๐Ÿ†˜ missing type signature" - Just ty -> DO.BuiltinObject (formatPrettyType ppe ty) - ref -> - terms ref >>= \case - Nothing -> pure $ DO.MissingObject (SH.unsafeFromText $ Reference.toText ref) - Just tm -> do - typ <- fromMaybe (Type.builtin () "unknown") <$> typeOf (Referent.Ref ref) - let name = PPE.termName ppe (Referent.Ref ref) - let folded = - formatPretty . P.lines $ - TypePrinter.prettySignaturesST ppe [(Referent.Ref ref, name, typ)] - let full tm@(Term.Ann' _ _) _ = - formatPretty (TermPrinter.prettyBinding ppe name tm) - full tm typ = - formatPretty (TermPrinter.prettyBinding ppe name (Term.ann () tm typ)) - pure (DO.UserObject (Src folded (full tm typ))) + (: acc) . Term . (Reference.toText r,) <$> case r of + Reference.Builtin _ -> + typeOf (Referent.Ref r) <&> \case + Nothing -> DO.BuiltinObject "๐Ÿ†˜ missing type signature" + Just ty -> DO.BuiltinObject (formatPrettyType ppe ty) + ref -> + terms ref >>= \case + Nothing -> pure $ DO.MissingObject (SH.unsafeFromText $ Reference.toText ref) + Just tm -> do + typ <- fromMaybe (Type.builtin () "unknown") <$> typeOf (Referent.Ref ref) + let name = PPE.termName ppe (Referent.Ref ref) + let folded = + formatPretty . P.lines $ + TypePrinter.prettySignaturesST ppe [(Referent.Ref ref, name, typ)] + let full tm@(Term.Ann' _ _) _ = + formatPretty (TermPrinter.prettyBinding ppe name tm) + full tm typ = + formatPretty (TermPrinter.prettyBinding ppe name (Term.ann () tm typ)) + pure (DO.UserObject (Src folded (full tm typ))) Term.RequestOrCtor' (view ConstructorReference.reference_ -> r) | Set.notMember r seen -> (: acc) <$> goType r _ -> pure acc DD.TupleTerm' [DD.EitherLeft' (Term.TypeLink' ref), _anns] | Set.notMember ref seen -> - (Set.insert ref seen,) . (: acc) <$> goType ref + (Set.insert ref seen,) . (: acc) <$> goType ref _ -> pure s1 reverse . snd <$> foldM go mempty es diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs index b2e15d75bc..dc13c32f0e 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs @@ -16,13 +16,13 @@ import qualified Data.Text as Text import Servant (Capture, QueryParam, (:>)) import Servant.Docs (DocCapture (..), ToCapture (..), ToSample (..)) import Servant.OpenApi () +import qualified U.Codebase.Causal as V2Causal import Unison.Codebase (Codebase) -import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Path as Path import Unison.Codebase.Path.Parse (parsePath') import qualified Unison.Codebase.Runtime as Rt import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import Unison.NamesWithHistory (NamesWithHistory (..)) +import qualified Unison.NamesWithHistory as NamesWithHistory import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Server.Backend @@ -33,8 +33,8 @@ import Unison.Server.Types NamespaceFQN, UnisonHash, UnisonName, - branchToUnisonHash, mayDefaultWidth, + v2CausalBranchToUnisonHash, ) import Unison.Symbol (Symbol) import Unison.Util.Pretty (Width) @@ -74,14 +74,14 @@ instance ToJSON NamespaceDetails where deriving instance ToSchema NamespaceDetails -serve :: +namespaceDetails :: Rt.Runtime Symbol -> Codebase IO Symbol Ann -> NamespaceFQN -> Maybe ShortBranchHash -> Maybe Width -> Backend IO NamespaceDetails -serve runtime codebase namespaceName mayRoot mayWidth = +namespaceDetails runtime codebase namespaceName maySBH mayWidth = let errFromEither f = either (throwError . f) pure fqnToPath fqn = do @@ -92,24 +92,19 @@ serve runtime codebase namespaceName mayRoot mayWidth = width = mayDefaultWidth mayWidth in do namespacePath <- fqnToPath namespaceName - + mayRootHash <- traverse (expandShortBranchHash codebase) maySBH + namespaceCausal <- Backend.getShallowCausalAtPathFromRootHash codebase mayRootHash namespacePath + shallowBranch <- lift $ V2Causal.value namespaceCausal namespaceDetails <- do - root <- Backend.resolveRootBranchHash mayRoot codebase - - let namespaceBranch = Branch.getAt' namespacePath root - -- Names used in the README should not be confined to the namespace - -- of the README (since it could be referencing definitions from all - -- over the codebase) - let printNames = Backend.prettyNamesForBranch root (Backend.AllNames namespacePath) - + (_parseNames, printNames) <- Backend.scopedNamesForBranchHash codebase mayRootHash namespacePath readme <- Backend.findShallowReadmeInBranchAndRender width runtime codebase - (NamesWithHistory {currentNames = printNames, oldNames = mempty}) - namespaceBranch - - pure $ NamespaceDetails namespaceName (branchToUnisonHash namespaceBranch) readme + (NamesWithHistory.fromCurrentNames printNames) + shallowBranch + let causalHash = v2CausalBranchToUnisonHash namespaceCausal + pure $ NamespaceDetails namespaceName causalHash readme pure $ namespaceDetails diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs index 42b34d8414..e2e64ce315 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs @@ -28,13 +28,10 @@ import qualified U.Codebase.Branch as V2Branch import qualified U.Codebase.Causal as V2Causal import qualified U.Util.Hash as Hash import Unison.Codebase (Codebase) -import qualified Unison.Codebase as Codebase -import qualified Unison.Codebase.Branch as V1Branch import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Path.Parse as Path import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import qualified Unison.NameSegment as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude @@ -154,7 +151,7 @@ serve :: Maybe NamespaceFQN -> Maybe NamespaceFQN -> Backend.Backend IO NamespaceListing -serve codebase mayRootHash mayRelativeTo mayNamespaceName = +serve codebase maySBH mayRelativeTo mayNamespaceName = let -- Various helpers errFromEither f = either (throwError . f) pure @@ -183,12 +180,6 @@ serve codebase mayRootHash mayRelativeTo mayNamespaceName = -- Lookup paths, root and listing and construct response namespaceListing :: Backend IO NamespaceListing namespaceListing = do - shallowRoot <- case mayRootHash of - Nothing -> liftIO (Codebase.getShallowRootBranch codebase) - Just sbh -> do - h <- Backend.expandShortBranchHash codebase sbh - liftIO $ Codebase.getShallowBranchForHash codebase (Cv.branchHash1to2 h) - -- Relative and Listing Path resolution -- -- The full listing path is a combination of the relativeToPath (prefix) and the namespace path @@ -208,10 +199,8 @@ serve codebase mayRootHash mayRelativeTo mayNamespaceName = let path = Path.fromPath' relativeToPath' <> Path.fromPath' namespacePath' let path' = Path.toPath' path - listingCausal <- - (liftIO $ Codebase.shallowBranchAtPath path shallowRoot) >>= \case - Nothing -> pure $ Cv.causalbranch1to2 (V1Branch.empty) - Just lc -> pure lc + mayRootHash <- traverse (Backend.expandShortBranchHash codebase) maySBH + listingCausal <- Backend.getShallowCausalAtPathFromRootHash codebase mayRootHash path listingBranch <- liftIO $ V2Causal.value listingCausal shallowPPE <- liftIO $ Backend.shallowPPE codebase listingBranch let listingFQN = Path.toText . Path.unabsolute . either id (Path.Absolute . Path.unrelative) $ Path.unPath' path' diff --git a/unison-share-api/src/Unison/Server/Orphans.hs b/unison-share-api/src/Unison/Server/Orphans.hs new file mode 100644 index 0000000000..9f91864452 --- /dev/null +++ b/unison-share-api/src/Unison/Server/Orphans.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Unison.Server.Orphans where + +import Data.Aeson +import Data.OpenApi +import Data.Proxy +import Servant +import Unison.Codebase.Editor.DisplayObject +import Unison.Codebase.ShortBranchHash + ( ShortBranchHash (..), + ) +import qualified Unison.Codebase.ShortBranchHash as SBH +import Unison.ConstructorType (ConstructorType) +import qualified Unison.HashQualified as HQ +import Unison.Name (Name) +import qualified Unison.Name as Name +import Unison.Prelude +import Unison.ShortHash (ShortHash) +import Unison.Util.Pretty (Width (..)) + +instance ToJSON ShortHash where + toEncoding = genericToEncoding defaultOptions + +instance ToJSONKey ShortHash + +deriving instance ToSchema ShortHash + +instance FromHttpApiData ShortBranchHash where + parseUrlPiece = maybe (Left "Invalid ShortBranchHash") Right . SBH.fromText + +instance (ToJSON b, ToJSON a) => ToJSON (DisplayObject b a) where + toEncoding = genericToEncoding defaultOptions + +deriving instance (ToSchema b, ToSchema a) => ToSchema (DisplayObject b a) + +-- [21/10/07] Hello, this is Mitchell. Name refactor in progress. Changing internal representation from a flat text to a +-- list of segments (in reverse order) plus an "is absolute?" bit. +-- +-- To preserve backwards compatibility (for now, anyway -- is this even important long term?), the ToJSON and ToSchema +-- instances below treat Name as before. + +instance ToJSON Name where + toEncoding = toEncoding . Name.toText + toJSON = toJSON . Name.toText + +instance ToSchema Name where + declareNamedSchema _ = declareNamedSchema (Proxy @Text) + +deriving anyclass instance ToParamSchema ShortBranchHash + +deriving via Int instance FromHttpApiData Width + +deriving anyclass instance ToParamSchema Width + +instance ToJSON n => ToJSON (HQ.HashQualified n) where + toEncoding = genericToEncoding defaultOptions + +deriving instance ToSchema n => ToSchema (HQ.HashQualified n) + +instance ToJSON ConstructorType where + toEncoding = genericToEncoding defaultOptions + +deriving instance ToSchema ConstructorType diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 60b9c26b0f..1262313f7a 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -4,7 +4,6 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} -{-# OPTIONS_GHC -Wno-orphans #-} module Unison.Server.Types where @@ -16,7 +15,6 @@ import Data.OpenApi ( ToParamSchema (..), ToSchema (..), ) -import Data.Proxy (Proxy (..)) import qualified Data.Text.Lazy as Text import qualified Data.Text.Lazy.Encoding as Text import Servant.API @@ -35,20 +33,11 @@ import qualified Unison.Codebase.Causal as Causal import Unison.Codebase.Editor.DisplayObject ( DisplayObject, ) -import Unison.Codebase.ShortBranchHash - ( ShortBranchHash (..), - ) -import qualified Unison.Codebase.ShortBranchHash as SBH -import Unison.ConstructorType (ConstructorType) import qualified Unison.Hash as Hash -import qualified Unison.HashQualified as HQ -import Unison.Name (Name) -import qualified Unison.Name as Name import Unison.Prelude import Unison.Server.Doc (Doc) -import qualified Unison.Server.Doc as Doc +import Unison.Server.Orphans () import Unison.Server.Syntax (SyntaxText) -import Unison.ShortHash (ShortHash) import Unison.Util.Pretty (Width (..)) type APIHeaders x = @@ -69,54 +58,10 @@ type UnisonName = Text type UnisonHash = Text --- [21/10/07] Hello, this is Mitchell. Name refactor in progress. Changing internal representation from a flat text to a --- list of segments (in reverse order) plus an "is absolute?" bit. --- --- To preserve backwards compatibility (for now, anyway -- is this even important long term?), the ToJSON and ToSchema --- instances below treat Name as before. - -instance ToJSON Name where - toEncoding = toEncoding . Name.toText - toJSON = toJSON . Name.toText - -instance ToSchema Name where - declareNamedSchema _ = declareNamedSchema (Proxy @Text) - deriving via Bool instance FromHttpApiData Suffixify deriving anyclass instance ToParamSchema Suffixify -instance FromHttpApiData ShortBranchHash where - parseUrlPiece = maybe (Left "Invalid ShortBranchHash") Right . SBH.fromText - -deriving anyclass instance ToParamSchema ShortBranchHash - -deriving via Int instance FromHttpApiData Width - -deriving anyclass instance ToParamSchema Width - -instance (ToJSON b, ToJSON a) => ToJSON (DisplayObject b a) where - toEncoding = genericToEncoding defaultOptions - -deriving instance (ToSchema b, ToSchema a) => ToSchema (DisplayObject b a) - -instance ToJSON ShortHash where - toEncoding = genericToEncoding defaultOptions - -instance ToJSONKey ShortHash - -deriving instance ToSchema ShortHash - -instance ToJSON n => ToJSON (HQ.HashQualified n) where - toEncoding = genericToEncoding defaultOptions - -deriving instance ToSchema n => ToSchema (HQ.HashQualified n) - -instance ToJSON ConstructorType where - toEncoding = genericToEncoding defaultOptions - -deriving instance ToSchema ConstructorType - instance ToJSON TypeDefinition where toEncoding = genericToEncoding defaultOptions @@ -222,26 +167,6 @@ instance ToJSON TypeTag where deriving instance ToSchema TypeTag -instance ToJSON Doc - -instance ToJSON Doc.MediaSource - -instance ToJSON Doc.SpecialForm - -instance ToJSON Doc.Src - -instance ToJSON a => ToJSON (Doc.Ref a) - -instance ToSchema Doc - -instance ToSchema Doc.MediaSource - -instance ToSchema Doc.SpecialForm - -instance ToSchema Doc.Src - -instance ToSchema a => ToSchema (Doc.Ref a) - -- Helpers munge :: Text -> LZ.ByteString diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index a12104d52f..49bc8a9c38 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -27,6 +27,7 @@ library Unison.Server.Endpoints.NamespaceListing Unison.Server.Endpoints.Projects Unison.Server.Errors + Unison.Server.Orphans Unison.Server.QueryResult Unison.Server.SearchResult Unison.Server.SearchResult' diff --git a/unison-src/transcripts/api-namespace-details.md b/unison-src/transcripts/api-namespace-details.md index dde5101e9c..8b0d5bf1ba 100644 --- a/unison-src/transcripts/api-namespace-details.md +++ b/unison-src/transcripts/api-namespace-details.md @@ -1,4 +1,4 @@ -# Namespace details api +# Namespace Details Test ```ucm:hide .> builtins.mergeio @@ -8,7 +8,9 @@ {{ Documentation }} nested.names.x = 42 -nested.names.readme = {{ I'm a readme! }} +nested.names.readme = {{ +Here's a *README*! +}} ``` ```ucm @@ -16,5 +18,6 @@ nested.names.readme = {{ I'm a readme! }} ``` ```api +-- Should find names by suffix GET /api/namespaces/nested.names ``` diff --git a/unison-src/transcripts/api-namespace-details.output.md b/unison-src/transcripts/api-namespace-details.output.md index 2234c30d88..8f16442339 100644 --- a/unison-src/transcripts/api-namespace-details.output.md +++ b/unison-src/transcripts/api-namespace-details.output.md @@ -1,10 +1,12 @@ -# Namespace details api +# Namespace Details Test ```unison {{ Documentation }} nested.names.x = 42 -nested.names.readme = {{ I'm a readme! }} +nested.names.readme = {{ +Here's a *README*! +}} ``` ```ucm @@ -31,14 +33,15 @@ nested.names.readme = {{ I'm a readme! }} ``` ```api +-- Should find names by suffix GET /api/namespaces/nested.names { "fqn": "nested.names", - "hash": "#oms19b4f9s3c8tb5skeb8jii95ij35n3hdg038pu6rv5b0fikqe4gd7lnu6a1i6aq5tdh2opdo4s0sfrupvk6vfkr9lf0n752gbl8o0", + "hash": "#6tnmlu9knsce0u2991u6fvcmf4v44fdf0aiqtmnq7mjj0gi5sephg3lf12iv3odr5rc7vlgq75ciborrd3625c701bdmdomia2gcm3o", "readme": { "contents": [ { - "contents": "I'm", + "contents": "Here's", "tag": "Word" }, { @@ -46,8 +49,28 @@ GET /api/namespaces/nested.names "tag": "Word" }, { - "contents": "readme!", - "tag": "Word" + "contents": { + "contents": [ + { + "contents": { + "contents": [ + { + "contents": "README", + "tag": "Word" + } + ], + "tag": "Paragraph" + }, + "tag": "Bold" + }, + { + "contents": "!", + "tag": "Word" + } + ], + "tag": "Join" + }, + "tag": "Group" } ], "tag": "Paragraph" From 6847d6cfdd56cc887384dd226a4dd7bf8e970df3 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 9 May 2022 08:40:48 -0600 Subject: [PATCH 194/529] More sensible readme selection strategy (#3067) --- unison-share-api/src/Unison/Server/Backend.hs | 25 ++++++++----------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 562577add6..c5ae69645a 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -18,7 +18,6 @@ import Data.Bifunctor (first) import Data.Containers.ListUtils (nubOrdOn) import qualified Data.List as List import Data.List.Extra (nubOrd) -import qualified Data.List.Extra as List import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text @@ -329,26 +328,24 @@ findShallowReadmeInBranchAndRender :: findShallowReadmeInBranchAndRender width runtime codebase printNames namespaceBranch = let ppe hqLen = PPE.fromNamesDecl hqLen printNames - renderReadme :: PPE.PrettyPrintEnvDecl -> V2.Referent -> IO Doc.Doc - renderReadme ppe r = do - let docReference = case r of - -- This shouldn't ever happen unless someone puts a non-doc as their readme. - V2.Con ref _conId -> Cv.reference2to1 ref - V2.Ref ref -> Cv.reference2to1 ref + renderReadme :: PPE.PrettyPrintEnvDecl -> Reference -> IO Doc.Doc + renderReadme ppe docReference = do (_, _, doc) <- renderDoc ppe width runtime codebase docReference pure doc -- choose the first term (among conflicted terms) matching any of these names, in this order. -- we might later want to return all of them to let the front end decide toCheck = V2Branch.NameSegment <$> ["README", "Readme", "ReadMe", "readme"] - readme :: Maybe V2.Referent - readme = List.firstJust lookup toCheck + readme :: Maybe Reference + readme = listToMaybe $ do + name <- toCheck + term <- toList $ Map.lookup name termsMap + k <- Map.keys term + case k of + -- This shouldn't ever happen unless someone puts a non-doc as their readme. + V2.Con {} -> empty + V2.Ref ref -> pure $ Cv.reference2to1 ref where - lookup :: (V2Branch.NameSegment -> Maybe V2.Referent) - lookup seg = do - term <- Map.lookup seg termsMap - (k, _v) <- Map.lookupMin term - pure k termsMap = V2Branch.terms namespaceBranch in liftIO $ do hqLen <- Codebase.hashLength codebase From 9a92dee507a951e03128d188dbfab554e0b92c8e Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 9 May 2022 13:53:46 -0400 Subject: [PATCH 195/529] small refactor --- .../src/Unison/Codebase/Editor/HandleInput.hs | 63 ++++++++++--------- unison-cli/src/Unison/Share/Sync.hs | 2 + 2 files changed, 34 insertions(+), 31 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 5b805dac87..3d0e555be8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1745,7 +1745,7 @@ doPushRemoteBranch :: Path' -> SyncMode.SyncMode -> -- | The remote target. If missing, the given branch contents should be pushed to the remote repo without updating the - -- root namespace. + -- root namespace (a gist). Maybe (Path, PushBehavior) -> Action' m v () doPushRemoteBranch repo localPath syncMode remoteTarget = do @@ -1771,10 +1771,9 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do Nothing -> pure (Left $ RefusedToPush pushBehavior) Just newRemoteRoot -> pure (Right newRemoteRoot) let opts = PushGitBranchOpts {setRoot = True, syncMode} - runExceptT (syncRemoteBranch repo opts withRemoteRoot) >>= \case - Left gitErr -> respond (Output.GitError gitErr) - Right (Left output) -> respond output - Right (Right _branch) -> respond Success + syncRemoteBranch repo opts withRemoteRoot >>= \case + Left output -> respond output + Right _branch -> respond Success where -- Per `pushBehavior`, we are either: -- @@ -1786,36 +1785,38 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch) PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) -handlePushToUnisonShare :: MonadIO m => Text -> Path -> PushBehavior -> Action' m v () -handlePushToUnisonShare remoteRepo remotePath behavior = do +handlePushToUnisonShare :: MonadIO m => Text -> Path -> Path.Absolute -> PushBehavior -> Action' m v () +handlePushToUnisonShare remoteRepo remotePath localPath behavior = do let repoPath = Share.RepoPath (Share.RepoName remoteRepo) (coerce @[NameSegment] @[Text] (Path.toList remotePath)) LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask - localCausalHash <- do - localPath <- use LoopState.currentPath - Sqlite.runTransaction connection do - Ops.expectCausalHashAtPath (coerce @[NameSegment] @[Text] (Path.toList (Path.unabsolute localPath))) - - case behavior of - PushBehavior.RequireEmpty -> - liftIO (Share.checkAndSetPush authHTTPClient unisonShareUrl connection repoPath Nothing localCausalHash) >>= \case - Left err -> - case err of - Share.CheckAndSetPushErrorHashMismatch _mismatch -> error "remote not empty" - Share.CheckAndSetPushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath - Share.CheckAndSetPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps - Right () -> pure () - PushBehavior.RequireNonEmpty -> - liftIO (Share.fastForwardPush authHTTPClient unisonShareUrl connection repoPath localCausalHash) >>= \case - Left err -> - case err of - Share.FastForwardPushErrorNoHistory _repoPath -> error "no history" - Share.FastForwardPushErrorNoReadPermission _repoPath -> error "no read permission" - Share.FastForwardPushErrorNotFastForward -> error "not fast-forward" - Share.FastForwardPushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath - Share.FastForwardPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps - Right () -> pure () + -- doesn't handle the case where a non-existent path is supplied + Sqlite.runTransaction + connection + (Ops.loadCausalHashAtPath (coerce @[NameSegment] @[Text] (Path.toList (Path.unabsolute localPath)))) + >>= \case + Nothing -> respond (error "you are bad") + Just localCausalHash -> + case behavior of + PushBehavior.RequireEmpty -> + liftIO (Share.checkAndSetPush authHTTPClient unisonShareUrl connection repoPath Nothing localCausalHash) >>= \case + Left err -> + case err of + Share.CheckAndSetPushErrorHashMismatch _mismatch -> error "remote not empty" + Share.CheckAndSetPushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath + Share.CheckAndSetPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps + Right () -> pure () + PushBehavior.RequireNonEmpty -> + liftIO (Share.fastForwardPush authHTTPClient unisonShareUrl connection repoPath localCausalHash) >>= \case + Left err -> + case err of + Share.FastForwardPushErrorNoHistory _repoPath -> error "no history" + Share.FastForwardPushErrorNoReadPermission _repoPath -> error "no read permission" + Share.FastForwardPushErrorNotFastForward -> error "not fast-forward" + Share.FastForwardPushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath + Share.FastForwardPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps + Right () -> pure () where errNoWritePermission _repoPath = error "no write permission" errServerMissingDependencies _dependencies = error "server missing dependencies" diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index ac1dca56cb..aa7ad56dfe 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -198,6 +198,8 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = path = repoPath } + -- Return a list from newest to oldest of the ancestors between (excluding) the latest local and the current remote hash. + -- note: seems like we /should/ cut this short, with another command to go longer? :grimace: fancyBfs :: CausalHash -> Share.Hash -> Sqlite.Transaction (Maybe [CausalHash]) fancyBfs = undefined From 83192412ad8dc9c8cf84c07a963735a5d6fa20db Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 9 May 2022 17:32:41 -0400 Subject: [PATCH 196/529] initial work on making ReadRepo a sum type --- .../src/Unison/Codebase/Editor/Git.hs | 6 ++-- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 32 +++++++++++++++---- .../src/Unison/Codebase/GitError.hs | 24 +++++++------- .../src/Unison/Codebase/SqliteCodebase.hs | 22 +++++++++---- .../Codebase/SqliteCodebase/GitError.hs | 8 ++--- .../src/Unison/Codebase/Type.hs | 8 ++--- 6 files changed, 64 insertions(+), 36 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs index a11ccbd142..1fabb1cbdb 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs @@ -28,7 +28,7 @@ import Shellmet (($?), ($^), ($|)) import System.Exit (ExitCode (ExitSuccess)) import System.FilePath (()) import System.IO.Unsafe (unsafePerformIO) -import Unison.Codebase.Editor.RemoteRepo (ReadRepo (..)) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo(..)) import Unison.Codebase.GitError (GitProtocolError) import qualified Unison.Codebase.GitError as GitError import Unison.Prelude @@ -136,7 +136,7 @@ data GitBranchBehavior withRepo :: forall m a. (MonadUnliftIO m) => - ReadRepo -> + ReadGitRepo -> GitBranchBehavior -> (GitRepo -> m a) -> m (Either GitProtocolError a) @@ -209,7 +209,7 @@ withRepo repo@(ReadGitRepo {url = uri, ref = mayGitRef}) branchBehavior action = pure succeeded -- | Do a `git clone` (for a not-previously-cached repo). -cloneIfMissing :: (MonadIO m, MonadError GitProtocolError m) => ReadRepo -> FilePath -> m GitRepo +cloneIfMissing :: (MonadIO m, MonadError GitProtocolError m) => ReadGitRepo -> FilePath -> m GitRepo cloneIfMissing repo@(ReadGitRepo {url = uri}) localPath = do doesDirectoryExist localPath >>= \case True -> diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 67e572e6d6..c9e23adfeb 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -11,21 +11,37 @@ import Unison.Codebase.ShortBranchHash (ShortBranchHash) import qualified Unison.Codebase.ShortBranchHash as SBH import Unison.Prelude -data ReadRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} deriving (Eq, Ord, Show) +data ReadRepo + = ReadRepoGit ReadGitRepo + deriving (Show) -data WriteRepo = WriteGitRepo {url' :: Text, branch :: Maybe Text} deriving (Eq, Ord, Show) +data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} + deriving (Show) + +data WriteRepo = WriteRepoGit WriteGitRepo + deriving (Show) + +data WriteGitRepo = WriteGitRepo {url' :: Text, branch :: Maybe Text} + deriving (Show) writeToRead :: WriteRepo -> ReadRepo -writeToRead (WriteGitRepo {url', branch}) = ReadGitRepo {url = url', ref = branch} +writeToRead = \case + WriteRepoGit repo -> ReadRepoGit (writeToReadGit repo) + +writeToReadGit :: WriteGitRepo -> ReadGitRepo +writeToReadGit = \case + WriteGitRepo {url', branch} -> ReadGitRepo {url = url', ref = branch} writePathToRead :: WriteRemotePath -> ReadRemoteNamespace writePathToRead (w, p) = (writeToRead w, Nothing, p) printReadRepo :: ReadRepo -> Text -printReadRepo ReadGitRepo {url, ref} = url <> Monoid.fromMaybe (Text.cons ':' <$> ref) +printReadRepo = \case + ReadRepoGit ReadGitRepo {url, ref} -> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) printWriteRepo :: WriteRepo -> Text -printWriteRepo WriteGitRepo {url', branch} = url' <> Monoid.fromMaybe (Text.cons ':' <$> branch) +printWriteRepo = \case + WriteRepoGit WriteGitRepo {url', branch} -> url' <> Monoid.fromMaybe (Text.cons ':' <$> branch) printNamespace :: ReadRepo -> Maybe ShortBranchHash -> Path -> Text printNamespace repo sbh path = @@ -45,6 +61,10 @@ printHead repo path = printWriteRepo repo <> if path == Path.empty then mempty else ":." <> Path.toText path -type ReadRemoteNamespace = (ReadRepo, Maybe ShortBranchHash, Path) +type GReadRemoteNamespace a = (a, Maybe ShortBranchHash, Path) + +type ReadRemoteNamespace = GReadRemoteNamespace ReadRepo + +type ReadGitRemoteNamespace = GReadRemoteNamespace ReadGitRepo type WriteRemotePath = (WriteRepo, Path) diff --git a/parser-typechecker/src/Unison/Codebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/GitError.hs index 8cccd2819e..7284493501 100644 --- a/parser-typechecker/src/Unison/Codebase/GitError.hs +++ b/parser-typechecker/src/Unison/Codebase/GitError.hs @@ -2,7 +2,7 @@ module Unison.Codebase.GitError where -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadGitRepo, WriteGitRepo) import Unison.Codebase.Path import Unison.Codebase.ShortBranchHash (ShortBranchHash) import Unison.Prelude @@ -11,15 +11,15 @@ type CodebasePath = FilePath data GitProtocolError = NoGit - | UnrecognizableCacheDir ReadRepo CodebasePath - | UnrecognizableCheckoutDir ReadRepo CodebasePath + | UnrecognizableCacheDir ReadGitRepo CodebasePath + | UnrecognizableCheckoutDir ReadGitRepo CodebasePath | -- srcPath destPath error-description CopyException FilePath FilePath String - | CloneException ReadRepo String - | PushException WriteRepo String - | PushNoOp WriteRepo + | CloneException ReadGitRepo String + | PushException WriteGitRepo String + | PushNoOp WriteGitRepo | -- url commit Diff of what would change on merge with remote - PushDestinationHasNewStuff WriteRepo + PushDestinationHasNewStuff WriteGitRepo | CleanupError SomeException | -- Thrown when a commit, tag, or branch isn't found in a repo. -- repo ref @@ -28,10 +28,10 @@ data GitProtocolError deriving anyclass (Exception) data GitCodebaseError h - = NoRemoteNamespaceWithHash ReadRepo ShortBranchHash - | RemoteNamespaceHashAmbiguous ReadRepo ShortBranchHash (Set h) - | CouldntLoadRootBranch ReadRepo h - | CouldntParseRemoteBranch ReadRepo String + = NoRemoteNamespaceWithHash ReadGitRepo ShortBranchHash + | RemoteNamespaceHashAmbiguous ReadGitRepo ShortBranchHash (Set h) + | CouldntLoadRootBranch ReadGitRepo h + | CouldntParseRemoteBranch ReadGitRepo String | CouldntLoadSyncedBranch ReadRemoteNamespace h - | CouldntFindRemoteBranch ReadRepo Path + | CouldntFindRemoteBranch ReadGitRepo Path deriving (Show) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 7f04dc590c..828f2ac7c0 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -45,7 +45,14 @@ import qualified Unison.Codebase.Branch.Names as Branch import qualified Unison.Codebase.Causal.Type as Causal import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo) import qualified Unison.Codebase.Editor.Git as Git -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo (..), printWriteRepo, writeToRead) +import Unison.Codebase.Editor.RemoteRepo + ( ReadGitRemoteNamespace, + ReadGitRepo, + WriteGitRepo (..), + WriteRepo (..), + printWriteRepo, + writeToReadGit, + ) import qualified Unison.Codebase.GitError as GitError import qualified Unison.Codebase.Init as Codebase import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1 @@ -676,10 +683,11 @@ syncProgress progressStateRef = Sync.Progress (liftIO . need) (liftIO . done) (l where v = const () +-- FIXME(mitchell) seems like this should have "git" in its name viewRemoteBranch' :: forall m r. (MonadUnliftIO m) => - ReadRemoteNamespace -> + ReadGitRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either C.GitError r) @@ -728,7 +736,7 @@ pushGitBranch :: forall m e. (MonadUnliftIO m) => Sqlite.Connection -> - WriteRepo -> + WriteGitRepo -> PushGitBranchOpts -> -- An action which accepts the current root branch on the remote and computes a new branch. (Branch m -> m (Either e (Branch m))) -> @@ -764,8 +772,8 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift for newBranchOrErr $ push pushStaging repo pure newBranchOrErr where - readRepo :: ReadRepo - readRepo = writeToRead repo + readRepo :: ReadGitRepo + readRepo = writeToReadGit repo doSync :: CodebaseStatus -> FilePath -> Sqlite.Connection -> Branch m -> m () doSync codebaseStatus remotePath destConn newBranch = do progressStateRef <- liftIO (newIORef emptySyncProgressState) @@ -802,7 +810,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift Just True -> pure () CreatedCodebase -> pure () run (setRepoRoot newBranchHash) - repoString = Text.unpack $ printWriteRepo repo + repoString = Text.unpack $ printWriteRepo (WriteRepoGit repo) setRepoRoot :: Branch.Hash -> Sqlite.Transaction () setRepoRoot h = do let h2 = Cv.causalHash1to2 h @@ -854,7 +862,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift hasDeleteShm = any isShmDelete statusLines -- Commit our changes - push :: forall n. MonadIO n => Git.GitRepo -> WriteRepo -> Branch m -> n Bool -- withIOError needs IO + push :: forall n. MonadIO n => Git.GitRepo -> WriteGitRepo -> Branch m -> n Bool -- withIOError needs IO push remotePath repo@(WriteGitRepo {url' = url, branch = mayGitBranch}) newRootBranch = time "SqliteCodebase.pushGitRootBranch.push" $ do -- has anything changed? -- note: -uall recursively shows status for all files in untracked directories diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs index 262628db04..6494cc96ff 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs @@ -1,11 +1,11 @@ module Unison.Codebase.SqliteCodebase.GitError where import U.Codebase.Sqlite.DbId (SchemaVersion) -import Unison.Codebase.Editor.RemoteRepo (ReadRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo) import Unison.CodebasePath (CodebasePath) data GitSqliteCodebaseError - = GitCouldntParseRootBranchHash ReadRepo String - | NoDatabaseFile ReadRepo CodebasePath - | UnrecognizedSchemaVersion ReadRepo CodebasePath SchemaVersion + = GitCouldntParseRootBranchHash ReadGitRepo String + | NoDatabaseFile ReadGitRepo CodebasePath + | UnrecognizedSchemaVersion ReadGitRepo CodebasePath SchemaVersion deriving (Show) diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 86e661c366..045e826cdb 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -17,7 +17,7 @@ import qualified U.Codebase.Reference as V2 import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Editor.Git as Git -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo) import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError) import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..)) import Unison.Codebase.Patch (Patch) @@ -111,9 +111,9 @@ data Codebase m v a = Codebase syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (), -- | Copy a branch and all of its dependencies from this codebase into the given codebase. syncToDirectory :: CodebasePath -> SyncMode -> Branch m -> m (), - viewRemoteBranch' :: forall r. ReadRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r), + viewRemoteBranch' :: forall r. ReadGitRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r), -- | Push the given branch to the given repo, and optionally set it as the root branch. - pushGitBranch :: forall e. WriteRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> m (Either GitError (Either e (Branch m))), + pushGitBranch :: forall e. WriteGitRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> m (Either GitError (Either e (Branch m))), -- | @watches k@ returns all of the references @r@ that were previously put by a @putWatch k r t@. @t@ can be -- retrieved by @getWatch k r@. watches :: WK.WatchKind -> m [Reference.Id], @@ -204,7 +204,7 @@ data GitError instance Exception GitError -gitErrorFromOpenCodebaseError :: CodebasePath -> ReadRepo -> OpenCodebaseError -> GitSqliteCodebaseError +gitErrorFromOpenCodebaseError :: CodebasePath -> ReadGitRepo -> OpenCodebaseError -> GitSqliteCodebaseError gitErrorFromOpenCodebaseError path repo = \case OpenCodebaseDoesntExist -> NoDatabaseFile repo path OpenCodebaseUnknownSchemaVersion v -> From ea5aa1dedf83537e2966eae79e6c01503f0d41c4 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 10 May 2022 12:01:34 -0400 Subject: [PATCH 197/529] hook up fast-forward push to dagbfs --- .../U/Codebase/Sqlite/Queries.hs | 14 +++ unison-cli/src/Unison/Share/Sync.hs | 86 ++++++++++++++----- 2 files changed, 77 insertions(+), 23 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index a38ae7e316..a47e7e0b56 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -76,6 +76,7 @@ module U.Codebase.Sqlite.Queries -- ** causal_parent table saveCausalParents, loadCausalParents, + loadCausalParentsByHash, before, lca, @@ -899,6 +900,19 @@ loadCausalParents h = queryListCol sql (Only h) where sql = [here| SELECT parent_id FROM causal_parent WHERE causal_id = ? |] +-- | Like 'loadCausalParents', but the input and outputs are hashes, not hash ids. +loadCausalParentsByHash :: Base32Hex -> Transaction [Base32Hex] +loadCausalParentsByHash hash = + queryListCol + [here| + SELECT h2.base32 + FROM causal_parent cp + JOIN hash h1 ON cp.causal_id = h1.id + JOIN hash h2 ON cp.parent_id = h2.id + WHERE h1.base32 = ? + |] + (Only hash) + expectNamespaceRoot :: Transaction CausalHashId expectNamespaceRoot = queryOneCol_ loadNamespaceRootSql diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index aa7ad56dfe..216fc78fa3 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -201,12 +201,31 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = -- Return a list from newest to oldest of the ancestors between (excluding) the latest local and the current remote hash. -- note: seems like we /should/ cut this short, with another command to go longer? :grimace: fancyBfs :: CausalHash -> Share.Hash -> Sqlite.Transaction (Maybe [CausalHash]) - fancyBfs = undefined - -dagbfs :: forall a m. Monad m => (a -> Bool) -> (a -> m [a]) -> a -> m (Maybe (List.NonEmpty a)) + fancyBfs h0 h1 = + tweak <$> dagbfs (== Share.toBase32Hex h1) Q.loadCausalParentsByHash (Hash.toBase32Hex (unCausalHash h0)) + where + -- Drop 1 and reverse (under a Maybe, and twddling hash types): + -- + -- tweak [] = [] + -- tweak [C,B,A] = [A,B] + -- + -- The drop 1 is because dagbfs returns the goal at the head of the returned list, but we know what the goal is + -- already (the remote head hash). + tweak :: Maybe [Base32Hex] -> Maybe [CausalHash] + tweak = + fmap (map (CausalHash . Hash.fromBase32Hex) . reverse . drop 1) + +data Step a + = DeadEnd + | KeepSearching (List.NonEmpty a) + | FoundGoal a + +-- FIXME: document +dagbfs :: forall a m. Monad m => (a -> Bool) -> (a -> m [a]) -> a -> m (Maybe [a]) dagbfs goal children = - let -- The loop state: all distinct paths from the root to the frontier, in reverse order, with the invariant that we - -- haven't found a goal state yet. (Otherwise, we wouldn't still be in this loop, we'd return!). + let -- The loop state: all distinct paths from the root to the frontier (not including the root, because it's implied, + -- as an input to this function), in reverse order, with the invariant that we haven't found a goal state yet. + -- (Otherwise, we wouldn't still be in this loop, we'd return!). -- -- For example, say we are exploring the tree -- @@ -216,24 +235,25 @@ dagbfs goal children = -- / \ \ -- 4 5 6 -- - -- Graphically, the frontier here is the nodes 4, 5, and 6; we know that, because I haven't drawn any nodes below + -- Graphically, the frontier here is the nodes 4, 5, and 6; we know that, because we haven't drawn any nodes below -- them. (This is a BFS algorithm that discovers children on-the-fly, so maybe node 5 (for example) has children, -- and maybe it doesn't). -- -- The loop state, in this case, would be these three paths: -- - -- [ 4, 2, 1 ] - -- [ 5, 2, 1 ] - -- [ 6, 3, 1 ] + -- [ 4, 2 ] + -- [ 5, 2 ] + -- [ 6, 3 ] + -- + -- (Note, again, that we do not include the root). go :: NESeq (List.NonEmpty a) -> m (Maybe (List.NonEmpty a)) - go (path :<|| paths) = do - -- Get the children of the first path (in the above example, [ 4, 2, 1 ]). - ys0 <- children (List.NonEmpty.head path) - case List.NonEmpty.nonEmpty ys0 of + go (path :<|| paths) = + -- Step forward from the first path in our loop state (in the example above, [4, 2]). + step (List.NonEmpty.head path) >>= \case -- If node 4 had no more children, we can toss that whole path: it didn't end in a goal. Now we either keep -- searching (as we would in the example, since we have two more paths to continue from), or we don't, because -- this was the only remaining path. - Nothing -> + DeadEnd -> case NESeq.nonEmptySeq paths of Nothing -> pure Nothing Just paths' -> go paths' @@ -251,22 +271,42 @@ dagbfs goal children = -- -- 1. One of the children we just discovered (say 7) is a goal node. So we're done, and we'd return the path -- - -- [ 7, 4, 2, 1 ] + -- [ 7, 4, 2 ] -- -- 2. No child we just discovered (7 nor 8) were a goal node. So we loop, putting our new path(s) at the end -- of the list (so we search paths fairly). In this case, we'd re-enter the loop with the following four -- paths: -- - -- [ 5, 2, 1 ] \ these two are are variable 'paths', the tail of the loop state. - -- [ 6, 3, 1 ] / - -- [ 7, 4, 2, 1 ] \ these two are new, just constructed by prepending each of [ 4, 2, 1 ]'s children - -- [ 8, 4, 2, 1 ] / to itself, making two new paths to search + -- [ 5, 2 ] \ these two are are variable 'paths', the tail of the loop state. + -- [ 6, 3 ] / + -- [ 7, 4, 2 ] \ these two are new, just constructed by prepending each of [ 4, 2, 1 ]'s children + -- [ 8, 4, 2 ] / to itself, making two new paths to search + KeepSearching ys -> go (append paths ((\y -> List.NonEmpty.cons y path) <$> NESeq.fromList ys)) + FoundGoal y -> pure (Just (List.NonEmpty.cons y path)) + + -- Step forward from a single node. There are 3 possible outcomes: + -- + -- 1. We discover it has no children. (return DeadEnd) + -- 2. We discover is has children, none of which are a goal. (return KeepSearching) + -- 3. We discover it has children, (at least) one of which is a goal. (return FoundGoal) + step :: a -> m (Step a) + step x = do + ys0 <- children x + pure case List.NonEmpty.nonEmpty ys0 of + Nothing -> DeadEnd Just ys -> case Foldable.find goal ys of - Nothing -> go (append paths ((\y -> List.NonEmpty.cons y path) <$> NESeq.fromList ys)) - Just y -> pure (Just (List.NonEmpty.cons y path)) - in -- lts-18.28 doesn't have List.NonEmpty.singleton - \source -> go (NESeq.singleton (source :| [])) + Nothing -> KeepSearching ys + Just y -> FoundGoal y + in \root -> + if goal root + then pure (Just []) + else + step root >>= \case + DeadEnd -> pure Nothing + -- lts-18.28 doesn't have List.NonEmpty.singleton + KeepSearching xs -> fmap List.NonEmpty.toList <$> go (NESeq.fromList ((:| []) <$> xs)) + FoundGoal x -> pure (Just [x]) where -- Concatenate a seq and a non-empty seq. append :: Seq x -> NESeq x -> NESeq x From 1599106fa3812d032bde759c7b924d5902114b80 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Tue, 10 May 2022 15:04:21 -0400 Subject: [PATCH 198/529] Remove commented code --- parser-typechecker/src/Unison/Runtime/Builtin.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 3df30be433..f537b5bf15 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -1323,12 +1323,6 @@ boxBoxTo0 instr = where (arg1, arg2) = fresh2 --- Nat -> () --- natToUnit :: ForeignOp --- natToUnit = inNat arg nat result (TCon Ty.unitRef 0 []) --- where --- (arg, nat, result) = fresh3 - -- a -> Bool boxToBool :: ForeignOp boxToBool = From d01e05ab6381e6beca0b75ce56f8b19a2231b50c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Tue, 10 May 2022 15:19:51 -0400 Subject: [PATCH 199/529] update transcripts --- unison-src/transcripts/alias-many.output.md | 467 ++++++------ .../transcripts/builtins-merge.output.md | 2 +- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- .../transcripts/name-selection.output.md | 703 +++++++++--------- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 7 files changed, 623 insertions(+), 595 deletions(-) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 1c25b61154..2dad53a332 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -177,303 +177,314 @@ Let's try it! 154. io2.BufferMode.LineBuffering : BufferMode 155. io2.BufferMode.NoBuffering : BufferMode 156. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 157. unique type io2.Failure - 158. io2.Failure.Failure : Type -> Text -> Any -> Failure - 159. unique type io2.FileMode - 160. io2.FileMode.Append : FileMode - 161. io2.FileMode.Read : FileMode - 162. io2.FileMode.ReadWrite : FileMode - 163. io2.FileMode.Write : FileMode - 164. builtin type io2.Handle - 165. builtin type io2.IO - 166. io2.IO.clientSocket.impl : Text + 157. io2.Clock.internals.monotonic : '{IO} Either + Failure TimeSpec + 158. io2.Clock.internals.nsec : TimeSpec -> Nat + 159. io2.Clock.internals.processCPUTime : '{IO} Either + Failure TimeSpec + 160. io2.Clock.internals.realtime : '{IO} Either + Failure TimeSpec + 161. io2.Clock.internals.sec : TimeSpec -> Int + 162. io2.Clock.internals.threadCPUTime : '{IO} Either + Failure TimeSpec + 163. builtin type io2.Clock.internals.TimeSpec + 164. unique type io2.Failure + 165. io2.Failure.Failure : Type -> Text -> Any -> Failure + 166. unique type io2.FileMode + 167. io2.FileMode.Append : FileMode + 168. io2.FileMode.Read : FileMode + 169. io2.FileMode.ReadWrite : FileMode + 170. io2.FileMode.Write : FileMode + 171. builtin type io2.Handle + 172. builtin type io2.IO + 173. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 167. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 168. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 169. io2.IO.createDirectory.impl : Text + 174. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 175. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 176. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 170. io2.IO.createTempDirectory.impl : Text + 177. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 171. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 172. io2.IO.directoryContents.impl : Text + 178. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 179. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 173. io2.IO.fileExists.impl : Text + 180. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 174. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 175. io2.IO.getArgs.impl : '{IO} Either Failure [Text] - 176. io2.IO.getBuffering.impl : Handle + 181. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 182. io2.IO.getArgs.impl : '{IO} Either Failure [Text] + 183. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 177. io2.IO.getBytes.impl : Handle + 184. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 178. io2.IO.getCurrentDirectory.impl : '{IO} Either + 185. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 179. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 180. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 181. io2.IO.getFileTimestamp.impl : Text + 186. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 187. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 188. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 182. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 183. io2.IO.getSomeBytes.impl : Handle + 189. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 190. io2.IO.getSomeBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 184. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 185. io2.IO.handlePosition.impl : Handle + 191. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 192. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 186. io2.IO.isDirectory.impl : Text + 193. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 187. io2.IO.isFileEOF.impl : Handle + 194. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 188. io2.IO.isFileOpen.impl : Handle + 195. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 189. io2.IO.isSeekable.impl : Handle + 196. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 190. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 191. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 192. io2.IO.openFile.impl : Text + 197. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 198. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 199. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 193. io2.IO.putBytes.impl : Handle + 200. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 194. io2.IO.ref : a ->{IO} Ref {IO} a - 195. io2.IO.removeDirectory.impl : Text + 201. io2.IO.ref : a ->{IO} Ref {IO} a + 202. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 196. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 197. io2.IO.renameDirectory.impl : Text + 203. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 204. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 198. io2.IO.renameFile.impl : Text + 205. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 199. io2.IO.seekHandle.impl : Handle + 206. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 200. io2.IO.serverSocket.impl : Optional Text + 207. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 201. io2.IO.setBuffering.impl : Handle + 208. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 202. io2.IO.setCurrentDirectory.impl : Text + 209. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 203. io2.IO.socketAccept.impl : Socket + 210. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 204. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 205. io2.IO.socketReceive.impl : Socket + 211. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 212. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 206. io2.IO.socketSend.impl : Socket + 213. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 207. io2.IO.stdHandle : StdHandle -> Handle - 208. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 209. io2.IO.systemTimeMicroseconds : '{IO} Int - 210. unique type io2.IOError - 211. io2.IOError.AlreadyExists : IOError - 212. io2.IOError.EOF : IOError - 213. io2.IOError.IllegalOperation : IOError - 214. io2.IOError.NoSuchThing : IOError - 215. io2.IOError.PermissionDenied : IOError - 216. io2.IOError.ResourceBusy : IOError - 217. io2.IOError.ResourceExhausted : IOError - 218. io2.IOError.UserError : IOError - 219. unique type io2.IOFailure - 220. builtin type io2.MVar - 221. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 222. io2.MVar.new : a ->{IO} MVar a - 223. io2.MVar.newEmpty : '{IO} MVar a - 224. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 225. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 226. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 227. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 228. io2.MVar.tryPut.impl : MVar a + 214. io2.IO.stdHandle : StdHandle -> Handle + 215. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 216. io2.IO.systemTimeMicroseconds : '{IO} Int + 217. unique type io2.IOError + 218. io2.IOError.AlreadyExists : IOError + 219. io2.IOError.EOF : IOError + 220. io2.IOError.IllegalOperation : IOError + 221. io2.IOError.NoSuchThing : IOError + 222. io2.IOError.PermissionDenied : IOError + 223. io2.IOError.ResourceBusy : IOError + 224. io2.IOError.ResourceExhausted : IOError + 225. io2.IOError.UserError : IOError + 226. unique type io2.IOFailure + 227. builtin type io2.MVar + 228. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 229. io2.MVar.new : a ->{IO} MVar a + 230. io2.MVar.newEmpty : '{IO} MVar a + 231. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 232. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 233. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 234. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 235. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 229. io2.MVar.tryRead.impl : MVar a + 236. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 230. io2.MVar.tryTake : MVar a ->{IO} Optional a - 231. unique type io2.SeekMode - 232. io2.SeekMode.AbsoluteSeek : SeekMode - 233. io2.SeekMode.RelativeSeek : SeekMode - 234. io2.SeekMode.SeekFromEnd : SeekMode - 235. builtin type io2.Socket - 236. unique type io2.StdHandle - 237. io2.StdHandle.StdErr : StdHandle - 238. io2.StdHandle.StdIn : StdHandle - 239. io2.StdHandle.StdOut : StdHandle - 240. builtin type io2.STM - 241. io2.STM.atomically : '{STM} a ->{IO} a - 242. io2.STM.retry : '{STM} a - 243. builtin type io2.ThreadId - 244. builtin type io2.Tls - 245. builtin type io2.Tls.Cipher - 246. builtin type io2.Tls.ClientConfig - 247. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 237. io2.MVar.tryTake : MVar a ->{IO} Optional a + 238. unique type io2.SeekMode + 239. io2.SeekMode.AbsoluteSeek : SeekMode + 240. io2.SeekMode.RelativeSeek : SeekMode + 241. io2.SeekMode.SeekFromEnd : SeekMode + 242. builtin type io2.Socket + 243. unique type io2.StdHandle + 244. io2.StdHandle.StdErr : StdHandle + 245. io2.StdHandle.StdIn : StdHandle + 246. io2.StdHandle.StdOut : StdHandle + 247. builtin type io2.STM + 248. io2.STM.atomically : '{STM} a ->{IO} a + 249. io2.STM.retry : '{STM} a + 250. builtin type io2.ThreadId + 251. builtin type io2.Tls + 252. builtin type io2.Tls.Cipher + 253. builtin type io2.Tls.ClientConfig + 254. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 248. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 255. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 249. io2.Tls.ClientConfig.default : Text + 256. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 250. io2.Tls.ClientConfig.versions.set : [Version] + 257. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 251. io2.Tls.decodeCert.impl : Bytes + 258. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 252. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 253. io2.Tls.encodeCert : SignedCert -> Bytes - 254. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 255. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 256. io2.Tls.newClient.impl : ClientConfig + 259. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 260. io2.Tls.encodeCert : SignedCert -> Bytes + 261. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 262. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 263. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 257. io2.Tls.newServer.impl : ServerConfig + 264. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 258. builtin type io2.Tls.PrivateKey - 259. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 260. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 261. builtin type io2.Tls.ServerConfig - 262. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 265. builtin type io2.Tls.PrivateKey + 266. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 267. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 268. builtin type io2.Tls.ServerConfig + 269. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 263. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 270. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 264. io2.Tls.ServerConfig.default : [SignedCert] + 271. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 265. io2.Tls.ServerConfig.versions.set : [Version] + 272. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 266. builtin type io2.Tls.SignedCert - 267. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 268. builtin type io2.Tls.Version - 269. unique type io2.TlsFailure - 270. builtin type io2.TVar - 271. io2.TVar.new : a ->{STM} TVar a - 272. io2.TVar.newIO : a ->{IO} TVar a - 273. io2.TVar.read : TVar a ->{STM} a - 274. io2.TVar.readIO : TVar a ->{IO} a - 275. io2.TVar.swap : TVar a -> a ->{STM} a - 276. io2.TVar.write : TVar a -> a ->{STM} () - 277. io2.validateSandboxed : [Term] -> a -> Boolean - 278. unique type IsPropagated - 279. IsPropagated.IsPropagated : IsPropagated - 280. unique type IsTest - 281. IsTest.IsTest : IsTest - 282. unique type Link - 283. builtin type Link.Term - 284. Link.Term : Term -> Link - 285. Link.Term.toText : Term -> Text - 286. builtin type Link.Type - 287. Link.Type : Type -> Link - 288. builtin type List - 289. List.++ : [a] -> [a] -> [a] - 290. List.+: : a -> [a] -> [a] - 291. List.:+ : [a] -> a -> [a] - 292. List.at : Nat -> [a] -> Optional a - 293. List.cons : a -> [a] -> [a] - 294. List.drop : Nat -> [a] -> [a] - 295. List.empty : [a] - 296. List.size : [a] -> Nat - 297. List.snoc : [a] -> a -> [a] - 298. List.take : Nat -> [a] -> [a] - 299. metadata.isPropagated : IsPropagated - 300. metadata.isTest : IsTest - 301. builtin type Nat - 302. Nat.* : Nat -> Nat -> Nat - 303. Nat.+ : Nat -> Nat -> Nat - 304. Nat./ : Nat -> Nat -> Nat - 305. Nat.and : Nat -> Nat -> Nat - 306. Nat.complement : Nat -> Nat - 307. Nat.drop : Nat -> Nat -> Nat - 308. Nat.eq : Nat -> Nat -> Boolean - 309. Nat.fromText : Text -> Optional Nat - 310. Nat.gt : Nat -> Nat -> Boolean - 311. Nat.gteq : Nat -> Nat -> Boolean - 312. Nat.increment : Nat -> Nat - 313. Nat.isEven : Nat -> Boolean - 314. Nat.isOdd : Nat -> Boolean - 315. Nat.leadingZeros : Nat -> Nat - 316. Nat.lt : Nat -> Nat -> Boolean - 317. Nat.lteq : Nat -> Nat -> Boolean - 318. Nat.mod : Nat -> Nat -> Nat - 319. Nat.or : Nat -> Nat -> Nat - 320. Nat.popCount : Nat -> Nat - 321. Nat.pow : Nat -> Nat -> Nat - 322. Nat.shiftLeft : Nat -> Nat -> Nat - 323. Nat.shiftRight : Nat -> Nat -> Nat - 324. Nat.sub : Nat -> Nat -> Int - 325. Nat.toFloat : Nat -> Float - 326. Nat.toInt : Nat -> Int - 327. Nat.toText : Nat -> Text - 328. Nat.trailingZeros : Nat -> Nat - 329. Nat.xor : Nat -> Nat -> Nat - 330. structural type Optional a - 331. Optional.None : Optional a - 332. Optional.Some : a -> Optional a - 333. builtin type Ref - 334. Ref.read : Ref g a ->{g} a - 335. Ref.write : Ref g a -> a ->{g} () - 336. builtin type Request - 337. builtin type Scope - 338. Scope.ref : a ->{Scope s} Ref {Scope s} a - 339. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 340. structural type SeqView a b - 341. SeqView.VElem : a -> b -> SeqView a b - 342. SeqView.VEmpty : SeqView a b - 343. Socket.toText : Socket -> Text - 344. unique type Test.Result - 345. Test.Result.Fail : Text -> Result - 346. Test.Result.Ok : Text -> Result - 347. builtin type Text - 348. Text.!= : Text -> Text -> Boolean - 349. Text.++ : Text -> Text -> Text - 350. Text.drop : Nat -> Text -> Text - 351. Text.empty : Text - 352. Text.eq : Text -> Text -> Boolean - 353. Text.fromCharList : [Char] -> Text - 354. Text.fromUtf8.impl : Bytes -> Either Failure Text - 355. Text.gt : Text -> Text -> Boolean - 356. Text.gteq : Text -> Text -> Boolean - 357. Text.lt : Text -> Text -> Boolean - 358. Text.lteq : Text -> Text -> Boolean - 359. Text.repeat : Nat -> Text -> Text - 360. Text.size : Text -> Nat - 361. Text.take : Nat -> Text -> Text - 362. Text.toCharList : Text -> [Char] - 363. Text.toUtf8 : Text -> Bytes - 364. Text.uncons : Text -> Optional (Char, Text) - 365. Text.unsnoc : Text -> Optional (Text, Char) - 366. ThreadId.toText : ThreadId -> Text - 367. todo : a -> b - 368. structural type Tuple a b - 369. Tuple.Cons : a -> b -> Tuple a b - 370. structural type Unit - 371. Unit.Unit : () - 372. Universal.< : a -> a -> Boolean - 373. Universal.<= : a -> a -> Boolean - 374. Universal.== : a -> a -> Boolean - 375. Universal.> : a -> a -> Boolean - 376. Universal.>= : a -> a -> Boolean - 377. Universal.compare : a -> a -> Int - 378. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 379. builtin type Value - 380. Value.dependencies : Value -> [Term] - 381. Value.deserialize : Bytes -> Either Text Value - 382. Value.load : Value ->{IO} Either [Term] a - 383. Value.serialize : Value -> Bytes - 384. Value.value : a -> Value + 273. builtin type io2.Tls.SignedCert + 274. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 275. builtin type io2.Tls.Version + 276. unique type io2.TlsFailure + 277. builtin type io2.TVar + 278. io2.TVar.new : a ->{STM} TVar a + 279. io2.TVar.newIO : a ->{IO} TVar a + 280. io2.TVar.read : TVar a ->{STM} a + 281. io2.TVar.readIO : TVar a ->{IO} a + 282. io2.TVar.swap : TVar a -> a ->{STM} a + 283. io2.TVar.write : TVar a -> a ->{STM} () + 284. io2.validateSandboxed : [Term] -> a -> Boolean + 285. unique type IsPropagated + 286. IsPropagated.IsPropagated : IsPropagated + 287. unique type IsTest + 288. IsTest.IsTest : IsTest + 289. unique type Link + 290. builtin type Link.Term + 291. Link.Term : Term -> Link + 292. Link.Term.toText : Term -> Text + 293. builtin type Link.Type + 294. Link.Type : Type -> Link + 295. builtin type List + 296. List.++ : [a] -> [a] -> [a] + 297. List.+: : a -> [a] -> [a] + 298. List.:+ : [a] -> a -> [a] + 299. List.at : Nat -> [a] -> Optional a + 300. List.cons : a -> [a] -> [a] + 301. List.drop : Nat -> [a] -> [a] + 302. List.empty : [a] + 303. List.size : [a] -> Nat + 304. List.snoc : [a] -> a -> [a] + 305. List.take : Nat -> [a] -> [a] + 306. metadata.isPropagated : IsPropagated + 307. metadata.isTest : IsTest + 308. builtin type Nat + 309. Nat.* : Nat -> Nat -> Nat + 310. Nat.+ : Nat -> Nat -> Nat + 311. Nat./ : Nat -> Nat -> Nat + 312. Nat.and : Nat -> Nat -> Nat + 313. Nat.complement : Nat -> Nat + 314. Nat.drop : Nat -> Nat -> Nat + 315. Nat.eq : Nat -> Nat -> Boolean + 316. Nat.fromText : Text -> Optional Nat + 317. Nat.gt : Nat -> Nat -> Boolean + 318. Nat.gteq : Nat -> Nat -> Boolean + 319. Nat.increment : Nat -> Nat + 320. Nat.isEven : Nat -> Boolean + 321. Nat.isOdd : Nat -> Boolean + 322. Nat.leadingZeros : Nat -> Nat + 323. Nat.lt : Nat -> Nat -> Boolean + 324. Nat.lteq : Nat -> Nat -> Boolean + 325. Nat.mod : Nat -> Nat -> Nat + 326. Nat.or : Nat -> Nat -> Nat + 327. Nat.popCount : Nat -> Nat + 328. Nat.pow : Nat -> Nat -> Nat + 329. Nat.shiftLeft : Nat -> Nat -> Nat + 330. Nat.shiftRight : Nat -> Nat -> Nat + 331. Nat.sub : Nat -> Nat -> Int + 332. Nat.toFloat : Nat -> Float + 333. Nat.toInt : Nat -> Int + 334. Nat.toText : Nat -> Text + 335. Nat.trailingZeros : Nat -> Nat + 336. Nat.xor : Nat -> Nat -> Nat + 337. structural type Optional a + 338. Optional.None : Optional a + 339. Optional.Some : a -> Optional a + 340. builtin type Ref + 341. Ref.read : Ref g a ->{g} a + 342. Ref.write : Ref g a -> a ->{g} () + 343. builtin type Request + 344. builtin type Scope + 345. Scope.ref : a ->{Scope s} Ref {Scope s} a + 346. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r + 347. structural type SeqView a b + 348. SeqView.VElem : a -> b -> SeqView a b + 349. SeqView.VEmpty : SeqView a b + 350. Socket.toText : Socket -> Text + 351. unique type Test.Result + 352. Test.Result.Fail : Text -> Result + 353. Test.Result.Ok : Text -> Result + 354. builtin type Text + 355. Text.!= : Text -> Text -> Boolean + 356. Text.++ : Text -> Text -> Text + 357. Text.drop : Nat -> Text -> Text + 358. Text.empty : Text + 359. Text.eq : Text -> Text -> Boolean + 360. Text.fromCharList : [Char] -> Text + 361. Text.fromUtf8.impl : Bytes -> Either Failure Text + 362. Text.gt : Text -> Text -> Boolean + 363. Text.gteq : Text -> Text -> Boolean + 364. Text.lt : Text -> Text -> Boolean + 365. Text.lteq : Text -> Text -> Boolean + 366. Text.repeat : Nat -> Text -> Text + 367. Text.size : Text -> Nat + 368. Text.take : Nat -> Text -> Text + 369. Text.toCharList : Text -> [Char] + 370. Text.toUtf8 : Text -> Bytes + 371. Text.uncons : Text -> Optional (Char, Text) + 372. Text.unsnoc : Text -> Optional (Text, Char) + 373. ThreadId.toText : ThreadId -> Text + 374. todo : a -> b + 375. structural type Tuple a b + 376. Tuple.Cons : a -> b -> Tuple a b + 377. structural type Unit + 378. Unit.Unit : () + 379. Universal.< : a -> a -> Boolean + 380. Universal.<= : a -> a -> Boolean + 381. Universal.== : a -> a -> Boolean + 382. Universal.> : a -> a -> Boolean + 383. Universal.>= : a -> a -> Boolean + 384. Universal.compare : a -> a -> Int + 385. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 386. builtin type Value + 387. Value.dependencies : Value -> [Term] + 388. Value.deserialize : Bytes -> Either Text Value + 389. Value.load : Value ->{IO} Either [Term] a + 390. Value.serialize : Value -> Bytes + 391. Value.value : a -> Value .builtin> alias.many 94-104 .mylib diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index 90c706a252..719d7a5f5a 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -64,7 +64,7 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 53. Value/ (5 definitions) 54. bug (a -> b) 55. crypto/ (12 definitions) - 56. io2/ (126 definitions) + 56. io2/ (133 definitions) 57. metadata/ (2 definitions) 58. todo (a -> b) 59. unsafe/ (1 definition) diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index e8a7ffbf64..b11235a4eb 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (384 definitions) + 1. builtin/ (391 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (570 definitions) + 1. builtin/ (577 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index fe6045dd7e..27937ad325 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -125,13 +125,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #b9gio3o5vj + โŠ™ 1. #1q6g6u3m73 - Deletes: feature1.y - โŠ™ 2. #qfnfjbucvb + โŠ™ 2. #9e4kqo72l2 + Adds / updates: @@ -142,26 +142,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - โŠ™ 3. #gf42o5nt01 + โŠ™ 3. #n59irrs1fe + Adds / updates: feature1.y - โŠ™ 4. #oualr1ftn5 + โŠ™ 4. #7qstntsn5f > Moves: Original name New name x master.x - โŠ™ 5. #kg9enostoi + โŠ™ 5. #4360t4806a + Adds / updates: x - โ–ก 6. #lg8ma1pi6b (start of history) + โ–ก 6. #n38tt1aodo (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md index 281bbcf2e2..d8cb9c264e 100644 --- a/unison-src/transcripts/name-selection.output.md +++ b/unison-src/transcripts/name-selection.output.md @@ -135,927 +135,944 @@ d = c + 10 47. builtin type builtin.Link.Term 48. builtin type builtin.Text 49. builtin type builtin.io2.ThreadId - 50. builtin type builtin.io2.Tls - 51. unique type builtin.io2.TlsFailure - 52. structural type builtin.Tuple a b - 53. builtin type builtin.Link.Type - 54. structural type builtin.Unit - 55. builtin type builtin.Value - 56. builtin type builtin.io2.Tls.Version - 57. builtin.io2.SeekMode.AbsoluteSeek : SeekMode - 58. builtin.io2.IOError.AlreadyExists : IOError - 59. builtin.io2.FileMode.Append : FileMode - 60. builtin.Doc.Blob : Text + 50. builtin type builtin.io2.Clock.internals.TimeSpec + 51. builtin type builtin.io2.Tls + 52. unique type builtin.io2.TlsFailure + 53. structural type builtin.Tuple a b + 54. builtin type builtin.Link.Type + 55. structural type builtin.Unit + 56. builtin type builtin.Value + 57. builtin type builtin.io2.Tls.Version + 58. builtin.io2.SeekMode.AbsoluteSeek : SeekMode + 59. builtin.io2.IOError.AlreadyExists : IOError + 60. builtin.io2.FileMode.Append : FileMode + 61. builtin.Doc.Blob : Text -> Doc - 61. builtin.io2.BufferMode.BlockBuffering : BufferMode - 62. builtin.Tuple.Cons : a + 62. builtin.io2.BufferMode.BlockBuffering : BufferMode + 63. builtin.Tuple.Cons : a -> b -> Tuple a b - 63. builtin.io2.IOError.EOF : IOError - 64. builtin.Doc.Evaluate : Term + 64. builtin.io2.IOError.EOF : IOError + 65. builtin.Doc.Evaluate : Term -> Doc - 65. builtin.Test.Result.Fail : Text + 66. builtin.Test.Result.Fail : Text -> Result - 66. builtin.io2.Failure.Failure : Type + 67. builtin.io2.Failure.Failure : Type -> Text -> Any -> Failure - 67. builtin.io2.IOError.IllegalOperation : IOError - 68. builtin.IsPropagated.IsPropagated : IsPropagated - 69. builtin.IsTest.IsTest : IsTest - 70. builtin.Doc.Join : [Doc] + 68. builtin.io2.IOError.IllegalOperation : IOError + 69. builtin.IsPropagated.IsPropagated : IsPropagated + 70. builtin.IsTest.IsTest : IsTest + 71. builtin.Doc.Join : [Doc] -> Doc - 71. builtin.Either.Left : a + 72. builtin.Either.Left : a -> Either a b - 72. builtin.io2.BufferMode.LineBuffering : BufferMode - 73. builtin.Doc.Link : Link + 73. builtin.io2.BufferMode.LineBuffering : BufferMode + 74. builtin.Doc.Link : Link -> Doc - 74. builtin.io2.BufferMode.NoBuffering : BufferMode - 75. builtin.io2.IOError.NoSuchThing : IOError - 76. builtin.Optional.None : Optional + 75. builtin.io2.BufferMode.NoBuffering : BufferMode + 76. builtin.io2.IOError.NoSuchThing : IOError + 77. builtin.Optional.None : Optional a - 77. builtin.Test.Result.Ok : Text + 78. builtin.Test.Result.Ok : Text -> Result - 78. builtin.io2.IOError.PermissionDenied : IOError - 79. builtin.io2.FileMode.Read : FileMode - 80. builtin.io2.FileMode.ReadWrite : FileMode - 81. builtin.io2.SeekMode.RelativeSeek : SeekMode - 82. builtin.io2.IOError.ResourceBusy : IOError - 83. builtin.io2.IOError.ResourceExhausted : IOError - 84. builtin.Either.Right : b + 79. builtin.io2.IOError.PermissionDenied : IOError + 80. builtin.io2.FileMode.Read : FileMode + 81. builtin.io2.FileMode.ReadWrite : FileMode + 82. builtin.io2.SeekMode.RelativeSeek : SeekMode + 83. builtin.io2.IOError.ResourceBusy : IOError + 84. builtin.io2.IOError.ResourceExhausted : IOError + 85. builtin.Either.Right : b -> Either a b - 85. builtin.io2.SeekMode.SeekFromEnd : SeekMode - 86. builtin.Doc.Signature : Term + 86. builtin.io2.SeekMode.SeekFromEnd : SeekMode + 87. builtin.Doc.Signature : Term -> Doc - 87. builtin.io2.BufferMode.SizedBlockBuffering : Nat + 88. builtin.io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 88. builtin.Optional.Some : a + 89. builtin.Optional.Some : a -> Optional a - 89. builtin.Doc.Source : Link + 90. builtin.Doc.Source : Link -> Doc - 90. builtin.io2.StdHandle.StdErr : StdHandle - 91. builtin.io2.StdHandle.StdIn : StdHandle - 92. builtin.io2.StdHandle.StdOut : StdHandle - 93. builtin.Link.Term : Term + 91. builtin.io2.StdHandle.StdErr : StdHandle + 92. builtin.io2.StdHandle.StdIn : StdHandle + 93. builtin.io2.StdHandle.StdOut : StdHandle + 94. builtin.Link.Term : Term -> Link - 94. builtin.Link.Type : Type + 95. builtin.Link.Type : Type -> Link - 95. builtin.Unit.Unit : () - 96. builtin.io2.IOError.UserError : IOError - 97. builtin.SeqView.VElem : a + 96. builtin.Unit.Unit : () + 97. builtin.io2.IOError.UserError : IOError + 98. builtin.SeqView.VElem : a -> b -> SeqView a b - 98. builtin.SeqView.VEmpty : SeqView + 99. builtin.SeqView.VEmpty : SeqView a b - 99. builtin.io2.FileMode.Write : FileMode - 100. builtin.Exception.raise : Failure + 100. builtin.io2.FileMode.Write : FileMode + 101. builtin.Exception.raise : Failure ->{Exception} x - 101. builtin.Text.!= : Text + 102. builtin.Text.!= : Text -> Text -> Boolean - 102. builtin.Float.* : Float + 103. builtin.Float.* : Float -> Float -> Float - 103. builtin.Int.* : Int + 104. builtin.Int.* : Int -> Int -> Int - 104. builtin.Nat.* : Nat + 105. builtin.Nat.* : Nat -> Nat -> Nat - 105. builtin.Float.+ : Float + 106. builtin.Float.+ : Float -> Float -> Float - 106. builtin.Int.+ : Int + 107. builtin.Int.+ : Int -> Int -> Int - 107. builtin.Nat.+ : Nat + 108. builtin.Nat.+ : Nat -> Nat -> Nat - 108. builtin.Bytes.++ : Bytes + 109. builtin.Bytes.++ : Bytes -> Bytes -> Bytes - 109. builtin.List.++ : [a] + 110. builtin.List.++ : [a] -> [a] -> [a] - 110. builtin.Text.++ : Text + 111. builtin.Text.++ : Text -> Text -> Text - 111. โ”Œ builtin.List.+: : a + 112. โ”Œ builtin.List.+: : a -> [a] -> [a] - 112. โ”” builtin.List.cons : a + 113. โ”” builtin.List.cons : a -> [a] -> [a] - 113. builtin.Float.- : Float + 114. builtin.Float.- : Float -> Float -> Float - 114. builtin.Int.- : Int + 115. builtin.Int.- : Int -> Int -> Int - 115. builtin.Float./ : Float + 116. builtin.Float./ : Float -> Float -> Float - 116. builtin.Int./ : Int + 117. builtin.Int./ : Int -> Int -> Int - 117. builtin.Nat./ : Nat + 118. builtin.Nat./ : Nat -> Nat -> Nat - 118. โ”Œ builtin.List.:+ : [a] + 119. โ”Œ builtin.List.:+ : [a] -> a -> [a] - 119. โ”” builtin.List.snoc : [a] + 120. โ”” builtin.List.snoc : [a] -> a -> [a] - 120. builtin.Universal.< : a + 121. builtin.Universal.< : a -> a -> Boolean - 121. builtin.Universal.<= : a + 122. builtin.Universal.<= : a -> a -> Boolean - 122. builtin.Universal.== : a + 123. builtin.Universal.== : a -> a -> Boolean - 123. builtin.Universal.> : a + 124. builtin.Universal.> : a -> a -> Boolean - 124. builtin.Universal.>= : a + 125. builtin.Universal.>= : a -> a -> Boolean - 125. builtin.Any.Any : a + 126. builtin.Any.Any : a -> Any - 126. builtin.crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm - 127. builtin.crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm - 128. builtin.crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm - 129. builtin.crypto.HashAlgorithm.Sha2_256 : HashAlgorithm - 130. builtin.crypto.HashAlgorithm.Sha2_512 : HashAlgorithm - 131. builtin.crypto.HashAlgorithm.Sha3_256 : HashAlgorithm - 132. builtin.crypto.HashAlgorithm.Sha3_512 : HashAlgorithm - 133. builtin.Float.abs : Float + 127. builtin.crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm + 128. builtin.crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm + 129. builtin.crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm + 130. builtin.crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 131. builtin.crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 132. builtin.crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 133. builtin.crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 134. builtin.Float.abs : Float -> Float - 134. builtin.Float.acos : Float + 135. builtin.Float.acos : Float -> Float - 135. builtin.Float.acosh : Float + 136. builtin.Float.acosh : Float -> Float - 136. builtin.Int.and : Int + 137. builtin.Int.and : Int -> Int -> Int - 137. builtin.Nat.and : Nat + 138. builtin.Nat.and : Nat -> Nat -> Nat - 138. builtin.Float.asin : Float + 139. builtin.Float.asin : Float -> Float - 139. builtin.Float.asinh : Float + 140. builtin.Float.asinh : Float -> Float - 140. builtin.Bytes.at : Nat + 141. builtin.Bytes.at : Nat -> Bytes -> Optional Nat - 141. builtin.List.at : Nat + 142. builtin.List.at : Nat -> [a] -> Optional a - 142. builtin.Float.atan : Float + 143. builtin.Float.atan : Float -> Float - 143. builtin.Float.atan2 : Float + 144. builtin.Float.atan2 : Float -> Float -> Float - 144. builtin.Float.atanh : Float + 145. builtin.Float.atanh : Float -> Float - 145. builtin.io2.STM.atomically : '{STM} a + 146. builtin.io2.STM.atomically : '{STM} a ->{IO} a - 146. builtin.bug : a -> b - 147. โ”Œ c#gjmq673r1v : Nat - 148. โ”” aaaa.tooManySegments : Nat - 149. builtin.Code.cache_ : [( Term, + 147. builtin.bug : a -> b + 148. โ”Œ c#gjmq673r1v : Nat + 149. โ”” aaaa.tooManySegments : Nat + 150. builtin.Code.cache_ : [( Term, Code)] ->{IO} [Term] - 150. builtin.Float.ceiling : Float + 151. builtin.Float.ceiling : Float -> Int - 151. builtin.unsafe.coerceAbilities : (a + 152. builtin.unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 152. builtin.Universal.compare : a + 153. builtin.Universal.compare : a -> a -> Int - 153. builtin.Int.complement : Int + 154. builtin.Int.complement : Int -> Int - 154. builtin.Nat.complement : Nat + 155. builtin.Nat.complement : Nat -> Nat - 155. builtin.Bytes.gzip.compress : Bytes + 156. builtin.Bytes.gzip.compress : Bytes -> Bytes - 156. builtin.Bytes.zlib.compress : Bytes + 157. builtin.Bytes.zlib.compress : Bytes -> Bytes - 157. builtin.Float.cos : Float + 158. builtin.Float.cos : Float -> Float - 158. builtin.Float.cosh : Float + 159. builtin.Float.cosh : Float -> Float - 159. builtin.Bytes.decodeNat16be : Bytes + 160. builtin.Bytes.decodeNat16be : Bytes -> Optional ( Nat, Bytes) - 160. builtin.Bytes.decodeNat16le : Bytes + 161. builtin.Bytes.decodeNat16le : Bytes -> Optional ( Nat, Bytes) - 161. builtin.Bytes.decodeNat32be : Bytes + 162. builtin.Bytes.decodeNat32be : Bytes -> Optional ( Nat, Bytes) - 162. builtin.Bytes.decodeNat32le : Bytes + 163. builtin.Bytes.decodeNat32le : Bytes -> Optional ( Nat, Bytes) - 163. builtin.Bytes.decodeNat64be : Bytes + 164. builtin.Bytes.decodeNat64be : Bytes -> Optional ( Nat, Bytes) - 164. builtin.Bytes.decodeNat64le : Bytes + 165. builtin.Bytes.decodeNat64le : Bytes -> Optional ( Nat, Bytes) - 165. builtin.io2.Tls.decodePrivateKey : Bytes + 166. builtin.io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 166. builtin.Bytes.gzip.decompress : Bytes + 167. builtin.Bytes.gzip.decompress : Bytes -> Either Text Bytes - 167. builtin.Bytes.zlib.decompress : Bytes + 168. builtin.Bytes.zlib.decompress : Bytes -> Either Text Bytes - 168. builtin.io2.Tls.ClientConfig.default : Text + 169. builtin.io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 169. builtin.io2.Tls.ServerConfig.default : [SignedCert] + 170. builtin.io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 170. builtin.Code.dependencies : Code + 171. builtin.Code.dependencies : Code -> [Term] - 171. builtin.Value.dependencies : Value + 172. builtin.Value.dependencies : Value -> [Term] - 172. builtin.Code.deserialize : Bytes + 173. builtin.Code.deserialize : Bytes -> Either Text Code - 173. builtin.Value.deserialize : Bytes + 174. builtin.Value.deserialize : Bytes -> Either Text Value - 174. builtin.Code.display : Text + 175. builtin.Code.display : Text -> Code -> Text - 175. builtin.Bytes.drop : Nat + 176. builtin.Bytes.drop : Nat -> Bytes -> Bytes - 176. builtin.List.drop : Nat + 177. builtin.List.drop : Nat -> [a] -> [a] - 177. builtin.Nat.drop : Nat + 178. builtin.Nat.drop : Nat -> Nat -> Nat - 178. builtin.Text.drop : Nat + 179. builtin.Text.drop : Nat -> Text -> Text - 179. builtin.Bytes.empty : Bytes - 180. builtin.List.empty : [a] - 181. builtin.Text.empty : Text - 182. builtin.io2.Tls.encodeCert : SignedCert + 180. builtin.Bytes.empty : Bytes + 181. builtin.List.empty : [a] + 182. builtin.Text.empty : Text + 183. builtin.io2.Tls.encodeCert : SignedCert -> Bytes - 183. builtin.Bytes.encodeNat16be : Nat + 184. builtin.Bytes.encodeNat16be : Nat -> Bytes - 184. builtin.Bytes.encodeNat16le : Nat + 185. builtin.Bytes.encodeNat16le : Nat -> Bytes - 185. builtin.Bytes.encodeNat32be : Nat + 186. builtin.Bytes.encodeNat32be : Nat -> Bytes - 186. builtin.Bytes.encodeNat32le : Nat + 187. builtin.Bytes.encodeNat32le : Nat -> Bytes - 187. builtin.Bytes.encodeNat64be : Nat + 188. builtin.Bytes.encodeNat64be : Nat -> Bytes - 188. builtin.Bytes.encodeNat64le : Nat + 189. builtin.Bytes.encodeNat64le : Nat -> Bytes - 189. builtin.io2.Tls.encodePrivateKey : PrivateKey + 190. builtin.io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 190. builtin.Float.eq : Float + 191. builtin.Float.eq : Float -> Float -> Boolean - 191. builtin.Int.eq : Int + 192. builtin.Int.eq : Int -> Int -> Boolean - 192. builtin.Nat.eq : Nat + 193. builtin.Nat.eq : Nat -> Nat -> Boolean - 193. builtin.Text.eq : Text + 194. builtin.Text.eq : Text -> Text -> Boolean - 194. builtin.Float.exp : Float + 195. builtin.Float.exp : Float -> Float - 195. builtin.Bytes.flatten : Bytes + 196. builtin.Bytes.flatten : Bytes -> Bytes - 196. builtin.Float.floor : Float + 197. builtin.Float.floor : Float -> Int - 197. builtin.io2.IO.forkComp : '{IO} a + 198. builtin.io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 198. builtin.Bytes.fromBase16 : Bytes + 199. builtin.Bytes.fromBase16 : Bytes -> Either Text Bytes - 199. builtin.Bytes.fromBase32 : Bytes + 200. builtin.Bytes.fromBase32 : Bytes -> Either Text Bytes - 200. builtin.Bytes.fromBase64 : Bytes + 201. builtin.Bytes.fromBase64 : Bytes -> Either Text Bytes - 201. builtin.Bytes.fromBase64UrlUnpadded : Bytes + 202. builtin.Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes - 202. builtin.Text.fromCharList : [Char] + 203. builtin.Text.fromCharList : [Char] -> Text - 203. builtin.Bytes.fromList : [Nat] + 204. builtin.Bytes.fromList : [Nat] -> Bytes - 204. builtin.Char.fromNat : Nat + 205. builtin.Char.fromNat : Nat -> Char - 205. builtin.Float.fromRepresentation : Nat + 206. builtin.Float.fromRepresentation : Nat -> Float - 206. builtin.Int.fromRepresentation : Nat + 207. builtin.Int.fromRepresentation : Nat -> Int - 207. builtin.Float.fromText : Text + 208. builtin.Float.fromText : Text -> Optional Float - 208. builtin.Int.fromText : Text + 209. builtin.Int.fromText : Text -> Optional Int - 209. builtin.Nat.fromText : Text + 210. builtin.Nat.fromText : Text -> Optional Nat - 210. builtin.Float.gt : Float + 211. builtin.Float.gt : Float -> Float -> Boolean - 211. builtin.Int.gt : Int + 212. builtin.Int.gt : Int -> Int -> Boolean - 212. builtin.Nat.gt : Nat + 213. builtin.Nat.gt : Nat -> Nat -> Boolean - 213. builtin.Text.gt : Text + 214. builtin.Text.gt : Text -> Text -> Boolean - 214. builtin.Float.gteq : Float + 215. builtin.Float.gteq : Float -> Float -> Boolean - 215. builtin.Int.gteq : Int + 216. builtin.Int.gteq : Int -> Int -> Boolean - 216. builtin.Nat.gteq : Nat + 217. builtin.Nat.gteq : Nat -> Nat -> Boolean - 217. builtin.Text.gteq : Text + 218. builtin.Text.gteq : Text -> Text -> Boolean - 218. builtin.crypto.hash : HashAlgorithm + 219. builtin.crypto.hash : HashAlgorithm -> a -> Bytes - 219. builtin.crypto.hashBytes : HashAlgorithm + 220. builtin.crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 220. builtin.crypto.hmac : HashAlgorithm + 221. builtin.crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 221. builtin.crypto.hmacBytes : HashAlgorithm + 222. builtin.crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 222. builtin.io2.IO.clientSocket.impl : Text + 223. builtin.io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 223. builtin.io2.IO.closeFile.impl : Handle + 224. builtin.io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 224. builtin.io2.IO.closeSocket.impl : Socket + 225. builtin.io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 225. builtin.io2.IO.createDirectory.impl : Text + 226. builtin.io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 226. builtin.io2.IO.createTempDirectory.impl : Text + 227. builtin.io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 227. builtin.io2.Tls.decodeCert.impl : Bytes + 228. builtin.io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 228. builtin.io2.IO.delay.impl : Nat + 229. builtin.io2.IO.delay.impl : Nat ->{IO} Either Failure () - 229. builtin.io2.IO.directoryContents.impl : Text + 230. builtin.io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 230. builtin.io2.IO.fileExists.impl : Text + 231. builtin.io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 231. builtin.Text.fromUtf8.impl : Bytes + 232. builtin.Text.fromUtf8.impl : Bytes -> Either Failure Text - 232. builtin.io2.IO.getArgs.impl : '{IO} Either + 233. builtin.io2.IO.getArgs.impl : '{IO} Either Failure [Text] - 233. builtin.io2.IO.getBuffering.impl : Handle + 234. builtin.io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 234. builtin.io2.IO.getBytes.impl : Handle + 235. builtin.io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 235. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either + 236. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 236. builtin.io2.IO.getEnv.impl : Text + 237. builtin.io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 237. builtin.io2.IO.getFileSize.impl : Text + 238. builtin.io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 238. builtin.io2.IO.getFileTimestamp.impl : Text + 239. builtin.io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 239. builtin.io2.IO.getLine.impl : Handle + 240. builtin.io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 240. builtin.io2.IO.getSomeBytes.impl : Handle + 241. builtin.io2.IO.getSomeBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 241. builtin.io2.IO.getTempDirectory.impl : '{IO} Either + 242. builtin.io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 242. builtin.io2.IO.handlePosition.impl : Handle + 243. builtin.io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 243. builtin.io2.Tls.handshake.impl : Tls + 244. builtin.io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 244. builtin.io2.IO.isDirectory.impl : Text + 245. builtin.io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 245. builtin.io2.IO.isFileEOF.impl : Handle + 246. builtin.io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 246. builtin.io2.IO.isFileOpen.impl : Handle + 247. builtin.io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 247. builtin.io2.IO.isSeekable.impl : Handle + 248. builtin.io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 248. builtin.io2.IO.kill.impl : ThreadId + 249. builtin.io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 249. builtin.io2.IO.listen.impl : Socket + 250. builtin.io2.IO.listen.impl : Socket ->{IO} Either Failure () - 250. builtin.io2.Tls.newClient.impl : ClientConfig + 251. builtin.io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 251. builtin.io2.Tls.newServer.impl : ServerConfig + 252. builtin.io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 252. builtin.io2.IO.openFile.impl : Text + 253. builtin.io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 253. builtin.io2.MVar.put.impl : MVar a + 254. builtin.io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 254. builtin.io2.IO.putBytes.impl : Handle + 255. builtin.io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 255. builtin.io2.MVar.read.impl : MVar a + 256. builtin.io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 256. builtin.io2.Tls.receive.impl : Tls + 257. builtin.io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 257. builtin.io2.IO.removeDirectory.impl : Text + 258. builtin.io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 258. builtin.io2.IO.removeFile.impl : Text + 259. builtin.io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 259. builtin.io2.IO.renameDirectory.impl : Text + 260. builtin.io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 260. builtin.io2.IO.renameFile.impl : Text + 261. builtin.io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 261. builtin.io2.IO.seekHandle.impl : Handle + 262. builtin.io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 262. builtin.io2.Tls.send.impl : Tls + 263. builtin.io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 263. builtin.io2.IO.serverSocket.impl : Optional + 264. builtin.io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 264. builtin.io2.IO.setBuffering.impl : Handle + 265. builtin.io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 265. builtin.io2.IO.setCurrentDirectory.impl : Text + 266. builtin.io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 266. builtin.io2.IO.socketAccept.impl : Socket + 267. builtin.io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 267. builtin.io2.IO.socketPort.impl : Socket + 268. builtin.io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 268. builtin.io2.IO.socketReceive.impl : Socket + 269. builtin.io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 269. builtin.io2.IO.socketSend.impl : Socket + 270. builtin.io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 270. builtin.io2.MVar.swap.impl : MVar a + 271. builtin.io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 271. builtin.io2.IO.systemTime.impl : '{IO} Either + 272. builtin.io2.IO.systemTime.impl : '{IO} Either Failure Nat - 272. builtin.io2.MVar.take.impl : MVar a + 273. builtin.io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 273. builtin.io2.Tls.terminate.impl : Tls + 274. builtin.io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 274. builtin.io2.MVar.tryPut.impl : MVar a + 275. builtin.io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 275. builtin.io2.MVar.tryRead.impl : MVar a + 276. builtin.io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 276. builtin.Int.increment : Int + 277. builtin.Int.increment : Int -> Int - 277. builtin.Nat.increment : Nat + 278. builtin.Nat.increment : Nat -> Nat - 278. builtin.io2.MVar.isEmpty : MVar a + 279. builtin.io2.MVar.isEmpty : MVar a ->{IO} Boolean - 279. builtin.Int.isEven : Int + 280. builtin.Int.isEven : Int -> Boolean - 280. builtin.Nat.isEven : Nat + 281. builtin.Nat.isEven : Nat -> Boolean - 281. builtin.Code.isMissing : Term + 282. builtin.Code.isMissing : Term ->{IO} Boolean - 282. builtin.Int.isOdd : Int + 283. builtin.Int.isOdd : Int -> Boolean - 283. builtin.Nat.isOdd : Nat + 284. builtin.Nat.isOdd : Nat -> Boolean - 284. builtin.metadata.isPropagated : IsPropagated - 285. builtin.metadata.isTest : IsTest - 286. builtin.Int.leadingZeros : Int + 285. builtin.metadata.isPropagated : IsPropagated + 286. builtin.metadata.isTest : IsTest + 287. builtin.Int.leadingZeros : Int -> Nat - 287. builtin.Nat.leadingZeros : Nat + 288. builtin.Nat.leadingZeros : Nat -> Nat - 288. builtin.Value.load : Value + 289. builtin.Value.load : Value ->{IO} Either [Term] a - 289. builtin.Float.log : Float + 290. builtin.Float.log : Float -> Float - 290. builtin.Float.logBase : Float + 291. builtin.Float.logBase : Float -> Float -> Float - 291. builtin.Code.lookup : Term + 292. builtin.Code.lookup : Term ->{IO} Optional Code - 292. builtin.Float.lt : Float + 293. builtin.Float.lt : Float -> Float -> Boolean - 293. builtin.Int.lt : Int + 294. builtin.Int.lt : Int -> Int -> Boolean - 294. builtin.Nat.lt : Nat + 295. builtin.Nat.lt : Nat -> Nat -> Boolean - 295. builtin.Text.lt : Text + 296. builtin.Text.lt : Text -> Text -> Boolean - 296. builtin.Float.lteq : Float + 297. builtin.Float.lteq : Float -> Float -> Boolean - 297. builtin.Int.lteq : Int + 298. builtin.Int.lteq : Int -> Int -> Boolean - 298. builtin.Nat.lteq : Nat + 299. builtin.Nat.lteq : Nat -> Nat -> Boolean - 299. builtin.Text.lteq : Text + 300. builtin.Text.lteq : Text -> Text -> Boolean - 300. builtin.Float.max : Float + 301. builtin.Float.max : Float -> Float -> Float - 301. builtin.Float.min : Float + 302. builtin.Float.min : Float -> Float -> Float - 302. builtin.Int.mod : Int + 303. builtin.Int.mod : Int -> Int -> Int - 303. builtin.Nat.mod : Nat + 304. builtin.Nat.mod : Nat -> Nat -> Nat - 304. builtin.Int.negate : Int + 305. builtin.io2.Clock.internals.monotonic : '{IO} Either + Failure + TimeSpec + 306. builtin.Int.negate : Int -> Int - 305. builtin.io2.MVar.new : a + 307. builtin.io2.MVar.new : a ->{IO} MVar a - 306. builtin.io2.TVar.new : a + 308. builtin.io2.TVar.new : a ->{STM} TVar a - 307. builtin.io2.MVar.newEmpty : '{IO} MVar + 309. builtin.io2.MVar.newEmpty : '{IO} MVar a - 308. builtin.io2.TVar.newIO : a + 310. builtin.io2.TVar.newIO : a ->{IO} TVar a - 309. builtin.Boolean.not : Boolean + 311. builtin.Boolean.not : Boolean -> Boolean - 310. builtin.Int.or : Int + 312. builtin.io2.Clock.internals.nsec : TimeSpec + -> Nat + 313. builtin.Int.or : Int -> Int -> Int - 311. builtin.Nat.or : Nat + 314. builtin.Nat.or : Nat -> Nat -> Nat - 312. builtin.Int.popCount : Int + 315. builtin.Int.popCount : Int -> Nat - 313. builtin.Nat.popCount : Nat + 316. builtin.Nat.popCount : Nat -> Nat - 314. builtin.Float.pow : Float + 317. builtin.Float.pow : Float -> Float -> Float - 315. builtin.Int.pow : Int + 318. builtin.Int.pow : Int -> Nat -> Int - 316. builtin.Nat.pow : Nat + 319. builtin.Nat.pow : Nat -> Nat -> Nat - 317. builtin.Ref.read : Ref g a + 320. builtin.io2.Clock.internals.processCPUTime : '{IO} Either + Failure + TimeSpec + 321. builtin.Ref.read : Ref g a ->{g} a - 318. builtin.io2.TVar.read : TVar a + 322. builtin.io2.TVar.read : TVar a ->{STM} a - 319. builtin.io2.TVar.readIO : TVar a + 323. builtin.io2.TVar.readIO : TVar a ->{IO} a - 320. builtin.io2.IO.ref : a + 324. builtin.io2.Clock.internals.realtime : '{IO} Either + Failure + TimeSpec + 325. builtin.io2.IO.ref : a ->{IO} Ref {IO} a - 321. builtin.Scope.ref : a + 326. builtin.Scope.ref : a ->{Scope s} Ref {Scope s} a - 322. builtin.Text.repeat : Nat + 327. builtin.Text.repeat : Nat -> Text -> Text - 323. builtin.io2.STM.retry : '{STM} a - 324. builtin.Float.round : Float + 328. builtin.io2.STM.retry : '{STM} a + 329. builtin.Float.round : Float -> Int - 325. builtin.Scope.run : (โˆ€ s. + 330. builtin.Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 326. builtin.Code.serialize : Code + 331. builtin.io2.Clock.internals.sec : TimeSpec + -> Int + 332. builtin.Code.serialize : Code -> Bytes - 327. builtin.Value.serialize : Value + 333. builtin.Value.serialize : Value -> Bytes - 328. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] + 334. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 329. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] + 335. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 330. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] + 336. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 331. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] + 337. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 332. builtin.io2.Tls.ClientConfig.versions.set : [Version] + 338. builtin.io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 333. builtin.io2.Tls.ServerConfig.versions.set : [Version] + 339. builtin.io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 334. builtin.Int.shiftLeft : Int + 340. builtin.Int.shiftLeft : Int -> Nat -> Int - 335. builtin.Nat.shiftLeft : Nat + 341. builtin.Nat.shiftLeft : Nat -> Nat -> Nat - 336. builtin.Int.shiftRight : Int + 342. builtin.Int.shiftRight : Int -> Nat -> Int - 337. builtin.Nat.shiftRight : Nat + 343. builtin.Nat.shiftRight : Nat -> Nat -> Nat - 338. builtin.Int.signum : Int + 344. builtin.Int.signum : Int -> Int - 339. builtin.Float.sin : Float + 345. builtin.Float.sin : Float -> Float - 340. builtin.Float.sinh : Float + 346. builtin.Float.sinh : Float -> Float - 341. builtin.Bytes.size : Bytes + 347. builtin.Bytes.size : Bytes -> Nat - 342. builtin.List.size : [a] + 348. builtin.List.size : [a] -> Nat - 343. builtin.Text.size : Text + 349. builtin.Text.size : Text -> Nat - 344. builtin.Float.sqrt : Float + 350. builtin.Float.sqrt : Float -> Float - 345. builtin.io2.IO.stdHandle : StdHandle + 351. builtin.io2.IO.stdHandle : StdHandle -> Handle - 346. builtin.Nat.sub : Nat + 352. builtin.Nat.sub : Nat -> Nat -> Int - 347. builtin.io2.TVar.swap : TVar a + 353. builtin.io2.TVar.swap : TVar a -> a ->{STM} a - 348. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int - 349. builtin.Bytes.take : Nat + 354. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int + 355. builtin.Bytes.take : Nat -> Bytes -> Bytes - 350. builtin.List.take : Nat + 356. builtin.List.take : Nat -> [a] -> [a] - 351. builtin.Text.take : Nat + 357. builtin.Text.take : Nat -> Text -> Text - 352. builtin.Float.tan : Float + 358. builtin.Float.tan : Float -> Float - 353. builtin.Float.tanh : Float + 359. builtin.Float.tanh : Float -> Float - 354. builtin.Bytes.toBase16 : Bytes + 360. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either + Failure + TimeSpec + 361. builtin.Bytes.toBase16 : Bytes -> Bytes - 355. builtin.Bytes.toBase32 : Bytes + 362. builtin.Bytes.toBase32 : Bytes -> Bytes - 356. builtin.Bytes.toBase64 : Bytes + 363. builtin.Bytes.toBase64 : Bytes -> Bytes - 357. builtin.Bytes.toBase64UrlUnpadded : Bytes + 364. builtin.Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 358. builtin.Text.toCharList : Text + 365. builtin.Text.toCharList : Text -> [Char] - 359. builtin.Int.toFloat : Int + 366. builtin.Int.toFloat : Int -> Float - 360. builtin.Nat.toFloat : Nat + 367. builtin.Nat.toFloat : Nat -> Float - 361. builtin.Nat.toInt : Nat + 368. builtin.Nat.toInt : Nat -> Int - 362. builtin.Bytes.toList : Bytes + 369. builtin.Bytes.toList : Bytes -> [Nat] - 363. builtin.Char.toNat : Char + 370. builtin.Char.toNat : Char -> Nat - 364. builtin.Float.toRepresentation : Float + 371. builtin.Float.toRepresentation : Float -> Nat - 365. builtin.Int.toRepresentation : Int + 372. builtin.Int.toRepresentation : Int -> Nat - 366. builtin.Char.toText : Char + 373. builtin.Char.toText : Char -> Text - 367. builtin.Float.toText : Float + 374. builtin.Float.toText : Float -> Text - 368. builtin.Handle.toText : Handle + 375. builtin.Handle.toText : Handle -> Text - 369. builtin.Int.toText : Int + 376. builtin.Int.toText : Int -> Text - 370. builtin.Nat.toText : Nat + 377. builtin.Nat.toText : Nat -> Text - 371. builtin.Socket.toText : Socket + 378. builtin.Socket.toText : Socket -> Text - 372. builtin.Link.Term.toText : Term + 379. builtin.Link.Term.toText : Term -> Text - 373. builtin.ThreadId.toText : ThreadId + 380. builtin.ThreadId.toText : ThreadId -> Text - 374. builtin.Text.toUtf8 : Text + 381. builtin.Text.toUtf8 : Text -> Bytes - 375. builtin.todo : a -> b - 376. builtin.Debug.trace : Text + 382. builtin.todo : a -> b + 383. builtin.Debug.trace : Text -> a -> () - 377. builtin.Int.trailingZeros : Int + 384. builtin.Int.trailingZeros : Int -> Nat - 378. builtin.Nat.trailingZeros : Nat + 385. builtin.Nat.trailingZeros : Nat -> Nat - 379. builtin.Float.truncate : Float + 386. builtin.Float.truncate : Float -> Int - 380. builtin.Int.truncate0 : Int + 387. builtin.Int.truncate0 : Int -> Nat - 381. builtin.io2.MVar.tryTake : MVar a + 388. builtin.io2.MVar.tryTake : MVar a ->{IO} Optional a - 382. builtin.Text.uncons : Text + 389. builtin.Text.uncons : Text -> Optional ( Char, Text) - 383. builtin.Any.unsafeExtract : Any + 390. builtin.Any.unsafeExtract : Any -> a - 384. builtin.Text.unsnoc : Text + 391. builtin.Text.unsnoc : Text -> Optional ( Text, Char) - 385. builtin.Code.validate : [( Term, + 392. builtin.Code.validate : [( Term, Code)] ->{IO} Optional Failure - 386. builtin.io2.validateSandboxed : [Term] + 393. builtin.io2.validateSandboxed : [Term] -> a -> Boolean - 387. builtin.Value.value : a + 394. builtin.Value.value : a -> Value - 388. builtin.Debug.watch : Text + 395. builtin.Debug.watch : Text -> a -> a - 389. builtin.Ref.write : Ref g a + 396. builtin.Ref.write : Ref g a -> a ->{g} () - 390. builtin.io2.TVar.write : TVar a + 397. builtin.io2.TVar.write : TVar a -> a ->{STM} () - 391. builtin.Int.xor : Int + 398. builtin.Int.xor : Int -> Int -> Int - 392. builtin.Nat.xor : Nat + 399. builtin.Nat.xor : Nat -> Nat -> Nat diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index 79b70f905f..2c10714665 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #252vcd822j .old` to make an old namespace + `fork #j7ar890fgd .old` to make an old namespace accessible again, - `reset-root #252vcd822j` to reset the root namespace and + `reset-root #j7ar890fgd` to reset the root namespace and its history to that of the specified namespace. - 1. #1svuebjsh1 : add - 2. #252vcd822j : add - 3. #pnv2a0gkq2 : builtins.merge + 1. #396ap2v898 : add + 2. #j7ar890fgd : add + 3. #7eacs027uv : builtins.merge 4. #sg60bvjo91 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index 46c8db1404..aeaa5fb227 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - โ–ก 1. #aktpkdqc1d (start of history) + โ–ก 1. #4vt616ak19 (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #su54dhbbgp + โŠ™ 1. #6k85v9fd02 > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #nhe50pjji2 + โŠ™ 2. #0rpodsf1gq > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #aktpkdqc1d (start of history) + โ–ก 3. #4vt616ak19 (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #su54dhbbgp + โŠ™ 1. #6k85v9fd02 > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #nhe50pjji2 + โŠ™ 2. #0rpodsf1gq > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #aktpkdqc1d (start of history) + โ–ก 3. #4vt616ak19 (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - โ–ก 1. #aktpkdqc1d (start of history) + โ–ก 1. #4vt616ak19 (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #bl7pg3asuu + โŠ™ 1. #h1ecefevst - Deletes: Nat.* Nat.+ - โ–ก 2. #aktpkdqc1d (start of history) + โ–ก 2. #4vt616ak19 (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From 00355fd8bd905c8688676cdb93f9fbe4020d2a5b Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 10 May 2022 17:04:28 -0400 Subject: [PATCH 200/529] now compiles --- parser-typechecker/src/Unison/Codebase.hs | 8 +- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 8 +- .../src/Unison/Codebase/GitError.hs | 4 +- .../src/Unison/Codebase/Editor/Command.hs | 16 +-- .../Unison/Codebase/Editor/HandleCommand.hs | 6 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 100 ++++++++++-------- .../src/Unison/Codebase/Editor/Input.hs | 2 +- .../src/Unison/Codebase/Editor/UriParser.hs | 6 +- .../src/Unison/CommandLine/OutputMessages.hs | 36 +++---- unison-cli/src/Unison/Share/Sync.hs | 7 +- 10 files changed, 100 insertions(+), 93 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index b4c44955a8..e519dc9bbc 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -117,7 +117,7 @@ import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation)) import qualified Unison.Codebase.CodeLookup as CL import Unison.Codebase.Editor.Git (withStatus) import qualified Unison.Codebase.Editor.Git as Git -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace) import qualified Unison.Codebase.GitError as GitError import Unison.Codebase.Path import qualified Unison.Codebase.Path as Path @@ -378,14 +378,14 @@ data Preprocessing m = Unmodified | Preprocessed (Branch m -> m (Branch m)) --- | Sync elements as needed from a remote codebase into the local one. +-- | Sync elements as needed from a remote git codebase into the local one. -- If `sbh` is supplied, we try to load the specified branch hash; -- otherwise we try to load the root branch. importRemoteBranch :: forall m v a. MonadUnliftIO m => Codebase m v a -> - ReadRemoteNamespace -> + ReadGitRemoteNamespace -> SyncMode -> Preprocessing m -> m (Either GitError (Branch m)) @@ -411,7 +411,7 @@ importRemoteBranch codebase ns mode preprocess = runExceptT $ do viewRemoteBranch :: MonadIO m => Codebase m v a -> - ReadRemoteNamespace -> + ReadGitRemoteNamespace -> Git.GitBranchBehavior -> (Branch m -> m r) -> m (Either GitError r) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index c9e23adfeb..524e821dde 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -13,16 +13,16 @@ import Unison.Prelude data ReadRepo = ReadRepoGit ReadGitRepo - deriving (Show) + deriving (Eq, Show) data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} - deriving (Show) + deriving (Eq, Show) data WriteRepo = WriteRepoGit WriteGitRepo - deriving (Show) + deriving (Eq, Show) data WriteGitRepo = WriteGitRepo {url' :: Text, branch :: Maybe Text} - deriving (Show) + deriving (Eq, Show) writeToRead :: WriteRepo -> ReadRepo writeToRead = \case diff --git a/parser-typechecker/src/Unison/Codebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/GitError.hs index 7284493501..b0131e1375 100644 --- a/parser-typechecker/src/Unison/Codebase/GitError.hs +++ b/parser-typechecker/src/Unison/Codebase/GitError.hs @@ -2,7 +2,7 @@ module Unison.Codebase.GitError where -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadGitRepo, WriteGitRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo) import Unison.Codebase.Path import Unison.Codebase.ShortBranchHash (ShortBranchHash) import Unison.Prelude @@ -32,6 +32,6 @@ data GitCodebaseError h | RemoteNamespaceHashAmbiguous ReadGitRepo ShortBranchHash (Set h) | CouldntLoadRootBranch ReadGitRepo h | CouldntParseRemoteBranch ReadGitRepo String - | CouldntLoadSyncedBranch ReadRemoteNamespace h + | CouldntLoadSyncedBranch ReadGitRemoteNamespace h | CouldntFindRemoteBranch ReadGitRepo Path deriving (Show) diff --git a/unison-cli/src/Unison/Codebase/Editor/Command.hs b/unison-cli/src/Unison/Codebase/Editor/Command.hs index 168e377b6e..499b8b82f3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Command.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Command.hs @@ -197,16 +197,16 @@ data LoadLocalBranch :: Branch.Hash -> Command m i v (Branch m) -- Merge two branches, using the codebase for the LCA calculation where possible. Merge :: Branch.MergeMode -> Branch m -> Branch m -> Command m i v (Branch m) - ViewRemoteBranch :: - ReadRemoteNamespace -> + ViewRemoteGitBranch :: + ReadGitRemoteNamespace -> Git.GitBranchBehavior -> (Branch m -> (Free (Command m i v) r)) -> Command m i v (Either GitError r) -- we want to import as little as possible, so we pass the SBH/path as part -- of the `RemoteNamespace`. The Branch that's returned should be fully -- imported and not retain any resources from the remote codebase - ImportRemoteBranch :: - ReadRemoteNamespace -> + ImportRemoteGitBranch :: + ReadGitRemoteNamespace -> SyncMode -> -- | A preprocessing step to perform on the branch before it's imported. -- This is sometimes useful for minimizing the number of definitions to sync. @@ -217,7 +217,7 @@ data -- Any definitions in the head of the supplied branch that aren't in the target -- codebase are copied there. SyncLocalRootBranch :: Branch m -> Command m i v () - SyncRemoteBranch :: WriteRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> Command m i v (Either GitError (Either e (Branch m))) + SyncRemoteGitBranch :: WriteGitRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> Command m i v (Either GitError (Either e (Branch m))) AppendToReflog :: Text -> Branch m -> Branch m -> Command m i v () -- load the reflog in file (chronological) order LoadReflog :: Command m i v [Reflog.Entry Branch.Hash] @@ -316,10 +316,10 @@ commandName = \case LoadLocalRootBranch -> "LoadLocalRootBranch" LoadLocalBranch {} -> "LoadLocalBranch" Merge {} -> "Merge" - ViewRemoteBranch {} -> "ViewRemoteBranch" - ImportRemoteBranch {} -> "ImportRemoteBranch" + ViewRemoteGitBranch {} -> "ViewRemoteGitBranch" + ImportRemoteGitBranch {} -> "ImportRemoteGitBranch" SyncLocalRootBranch {} -> "SyncLocalRootBranch" - SyncRemoteBranch {} -> "SyncRemoteBranch" + SyncRemoteGitBranch {} -> "SyncRemoteGitBranch" AppendToReflog {} -> "AppendToReflog" LoadReflog -> "LoadReflog" LoadTerm {} -> "LoadTerm" diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs index 0419d1c279..03ea15a880 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs @@ -151,14 +151,14 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour SyncLocalRootBranch branch -> lift $ do setBranchRef branch Codebase.putRootBranch codebase branch - ViewRemoteBranch ns gitBranchBehavior action -> do + ViewRemoteGitBranch ns gitBranchBehavior action -> do -- TODO: We probably won'd need to unlift anything once we remove the Command -- abstraction. toIO <- UnliftIO.askRunInIO lift $ Codebase.viewRemoteBranch codebase ns gitBranchBehavior (toIO . Free.fold go . action) - ImportRemoteBranch ns syncMode preprocess -> + ImportRemoteGitBranch ns syncMode preprocess -> lift $ Codebase.importRemoteBranch codebase ns syncMode preprocess - SyncRemoteBranch repo opts action -> + SyncRemoteGitBranch repo opts action -> lift $ Codebase.pushGitBranch codebase repo opts action LoadTerm r -> lift $ Codebase.getTerm codebase r LoadTypeOfTerm r -> lift $ Codebase.getTypeOfTerm codebase r diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 3d0e555be8..e1c96d3674 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -28,7 +28,6 @@ import qualified Data.Set.NonEmpty as NESet import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) import qualified Text.Megaparsec as P -import U.Codebase.HashTags (CausalHash) import qualified U.Codebase.Sqlite.Operations as Ops import U.Util.Timing (unsafeTime) import qualified Unison.ABT as ABT @@ -59,7 +58,7 @@ import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN import qualified Unison.Codebase.Editor.Propagate as Propagate -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemotePath, WriteRepo, printNamespace, writePathToRead) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRepo (ReadRepoGit), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit), printNamespace, writePathToRead) import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -134,11 +133,8 @@ import qualified Unison.ShortHash as SH import qualified Unison.Sqlite as Sqlite import Unison.Symbol (Symbol) import qualified Unison.Sync.Types as Share - ( Hash, - HashMismatch (..), - RepoName (..), + ( RepoName (..), RepoPath (..), - hashJWTHash, ) import Unison.Term (Term) import qualified Unison.Term as Term @@ -499,8 +495,8 @@ loop = do Action m i v1 Bool updateAtM = Unison.Codebase.Editor.HandleInput.updateAtM inputDescription unlessGitError = unlessError' Output.GitError - importRemoteBranch ns mode preprocess = - ExceptT . eval $ ImportRemoteBranch ns mode preprocess + importRemoteGitBranch ns mode preprocess = + ExceptT . eval $ ImportRemoteGitBranch ns mode preprocess loadSearchResults = eval . LoadSearchResults saveAndApplyPatch patchPath'' patchName patch' = do stepAtM @@ -657,9 +653,11 @@ loop = do ppe outputDiff CreatePullRequestI baseRepo headRepo -> do + let viewRemoteBranch repo callback = case repo of + (ReadRepoGit r, sbh, path) -> viewRemoteGitBranch (r, sbh, path) Git.RequireExistingBranch callback result <- - join @(Either GitError) <$> viewRemoteBranch baseRepo Git.RequireExistingBranch \baseBranch -> do - viewRemoteBranch headRepo Git.RequireExistingBranch \headBranch -> do + join @(Either GitError) <$> viewRemoteBranch baseRepo \baseBranch -> do + viewRemoteBranch headRepo \headBranch -> do merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) pure $ ShowDiffAfterCreatePR baseRepo headRepo ppe diff @@ -672,8 +670,12 @@ loop = do destb <- getAt desta if Branch.isEmpty0 (Branch.head destb) then unlessGitError do - baseb <- importRemoteBranch baseRepo SyncMode.ShortCircuit Unmodified - headb <- importRemoteBranch headRepo SyncMode.ShortCircuit Unmodified + baseb <- case baseRepo of + (ReadRepoGit r, sbh, path) -> + importRemoteGitBranch (r, sbh, path) SyncMode.ShortCircuit Unmodified + headb <- case headRepo of + (ReadRepoGit r, sbh, path) -> + importRemoteGitBranch (r, sbh, path) SyncMode.ShortCircuit Unmodified lift $ do mergedb <- eval $ Merge Branch.RegularMerge baseb headb squashedb <- eval $ Merge Branch.SquashMerge headb baseb @@ -1507,9 +1509,11 @@ loop = do let preprocess = case pullMode of Input.PullWithHistory -> Unmodified Input.PullWithoutHistory -> Preprocessed $ pure . Branch.discardHistory - ns <- maybe (writePathToRead <$> resolveConfiguredGitUrl Pull path) pure mayRepo + ns <- maybe (writePathToRead <$> resolveConfiguredUrl Pull path) pure mayRepo lift $ unlessGitError do - remoteBranch <- importRemoteBranch ns syncMode preprocess + remoteBranch <- case ns of + (ReadRepoGit r, sbh, path) -> + importRemoteGitBranch (r, sbh, path) syncMode preprocess let unchangedMsg = PullAlreadyUpToDate ns path let destAbs = resolveToAbsolute path let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path @@ -1714,8 +1718,8 @@ handlePullFromUnisonShare remoteRepo remotePath = do liftIO (Share.pull authHTTPClient unisonShareUrl connection repoPath) >>= \case Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined - Right Nothing -> undefined - Right (Just causalHash) -> do + Left (Share.PullErrorNoHistoryAtPath repoPath) -> undefined + Right causalHash -> do undefined -- | Handle a @push@ command. @@ -1732,7 +1736,7 @@ handlePushRemoteBranch :: Action' m v () handlePushRemoteBranch mayRepo path pushBehavior syncMode = do unlessError do - (repo, remotePath) <- maybe (resolveConfiguredGitUrl Push path) pure mayRepo + (repo, remotePath) <- maybe (resolveConfiguredUrl Push path) pure mayRepo lift (doPushRemoteBranch repo path syncMode (Just (remotePath, pushBehavior))) -- Internal helper that implements pushing to a remote repo, which generalizes @gist@ and @push@. @@ -1754,26 +1758,28 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do getAt (Path.resolve currentPath' localPath) unlessError do - withExceptT Output.GitError $ do - case remoteTarget of - Nothing -> do - let opts = PushGitBranchOpts {setRoot = False, syncMode} - syncRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch)) - sbhLength <- (eval BranchHashLength) - respond (GistCreated sbhLength repo (Branch.headHash sourceBranch)) - Just (remotePath, pushBehavior) -> do - let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) - withRemoteRoot remoteRoot = do - let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this - -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. - f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing - Branch.modifyAtM remotePath f remoteRoot & \case - Nothing -> pure (Left $ RefusedToPush pushBehavior) - Just newRemoteRoot -> pure (Right newRemoteRoot) - let opts = PushGitBranchOpts {setRoot = True, syncMode} - syncRemoteBranch repo opts withRemoteRoot >>= \case - Left output -> respond output - Right _branch -> respond Success + case repo of + WriteRepoGit repo -> + withExceptT Output.GitError $ do + case remoteTarget of + Nothing -> do + let opts = PushGitBranchOpts {setRoot = False, syncMode} + syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch)) + sbhLength <- (eval BranchHashLength) + respond (GistCreated sbhLength (WriteRepoGit repo) (Branch.headHash sourceBranch)) + Just (remotePath, pushBehavior) -> do + let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) + withRemoteRoot remoteRoot = do + let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this + -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. + f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing + Branch.modifyAtM remotePath f remoteRoot & \case + Nothing -> pure (Left $ RefusedToPush pushBehavior) + Just newRemoteRoot -> pure (Right newRemoteRoot) + let opts = PushGitBranchOpts {setRoot = True, syncMode} + syncGitRemoteBranch repo opts withRemoteRoot >>= \case + Left output -> respond output + Right _branch -> respond Success where -- Per `pushBehavior`, we are either: -- @@ -2147,11 +2153,11 @@ manageLinks silent srcs mdValues op = do -- Takes a maybe (namespace address triple); returns it as-is if `Just`; -- otherwise, tries to load a value from .unisonConfig, and complains -- if needed. -resolveConfiguredGitUrl :: +resolveConfiguredUrl :: PushPull -> Path' -> ExceptT (Output v) (Action m i v) WriteRemotePath -resolveConfiguredGitUrl pushPull destPath' = ExceptT do +resolveConfiguredUrl pushPull destPath' = ExceptT do currentPath' <- use LoopState.currentPath let destPath = Path.resolve currentPath' destPath' let configKey = gitUrlKey destPath @@ -2177,26 +2183,26 @@ configKey k p = NameSegment.toText (Path.toSeq $ Path.unabsolute p) -viewRemoteBranch :: +viewRemoteGitBranch :: (MonadCommand n m i v, MonadUnliftIO m) => - ReadRemoteNamespace -> + ReadGitRemoteNamespace -> Git.GitBranchBehavior -> (Branch m -> Free (Command m i v) r) -> n (Either GitError r) -viewRemoteBranch ns gitBranchBehavior action = do - eval $ ViewRemoteBranch ns gitBranchBehavior action +viewRemoteGitBranch ns gitBranchBehavior action = do + eval $ ViewRemoteGitBranch ns gitBranchBehavior action -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) -- compute a new branch, which will then be synced and pushed. -syncRemoteBranch :: +syncGitRemoteBranch :: MonadCommand n m i v => - WriteRepo -> + WriteGitRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> ExceptT GitError n (Either e (Branch m)) -syncRemoteBranch repo opts action = - ExceptT . eval $ SyncRemoteBranch repo opts action +syncGitRemoteBranch repo opts action = + ExceptT . eval $ SyncRemoteGitBranch repo opts action -- todo: compare to `getHQTerms` / `getHQTypes`. Is one universally better? resolveHQToLabeledDependencies :: Functor m => HQ.HashQualified Name -> Action' m v (Set LabeledDependency) diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 96bb1effc7..b9e19d273d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -189,7 +189,7 @@ data Input | VersionI deriving (Eq, Show) --- | @"gist repo"@ pushes the contents of the current namespace to @repo@. +-- | @"push.gist repo"@ pushes the contents of the current namespace to @repo@. data GistInput = GistInput { repo :: WriteRepo } diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 0dde3d6671..888d961d4c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -9,7 +9,7 @@ import Data.Void import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as C import qualified Text.Megaparsec.Char.Lexer as L -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo (..), WriteRemotePath, WriteRepo (..)) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..), ReadRemoteNamespace, ReadRepo (..), WriteGitRepo (..), WriteRemotePath, WriteRepo (..)) import Unison.Codebase.Path (Path (..)) import qualified Unison.Codebase.Path as Path import Unison.Codebase.ShortBranchHash (ShortBranchHash (..)) @@ -42,7 +42,7 @@ repoPath :: P ReadRemoteNamespace repoPath = P.label "generic git repo" $ do protocol <- parseProtocol treeish <- P.optional treeishSuffix - let repo = ReadGitRepo {url = printProtocol protocol, ref = treeish} + let repo = (ReadRepoGit ReadGitRepo {url = printProtocol protocol, ref = treeish}) nshashPath <- P.optional (C.char ':' *> namespaceHashPath) case nshashPath of Nothing -> pure (repo, Nothing, Path.empty) @@ -52,7 +52,7 @@ writeRepo :: P WriteRepo writeRepo = P.label "repo root for writing" $ do uri <- parseProtocol treeish <- P.optional treeishSuffix - pure WriteGitRepo {url' = printProtocol uri, branch = treeish} + pure (WriteRepoGit WriteGitRepo {url' = printProtocol uri, branch = treeish}) writeRepoPath :: P WriteRemotePath writeRepoPath = P.label "generic git repo" $ do diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index c5675f190d..4fa9c5368f 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -44,7 +44,7 @@ import Unison.Codebase.Editor.Output import qualified Unison.Codebase.Editor.Output as E import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBD -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo (ReadRepoGit), WriteRepo (WriteRepoGit)) import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo import qualified Unison.Codebase.Editor.SlurpResult as SlurpResult import qualified Unison.Codebase.Editor.TodoOutput as TO @@ -1045,14 +1045,14 @@ notifyUser dir o = case o of NoDatabaseFile repo localPath -> P.wrap $ "I didn't find a codebase in the repository at" - <> prettyReadRepo repo + <> prettyReadRepo (ReadRepoGit repo) <> "in the cache directory at" <> P.backticked' (P.string localPath) "." UnrecognizedSchemaVersion repo localPath (SchemaVersion v) -> P.wrap $ "I don't know how to interpret schema version " <> P.shown v <> "in the repository at" - <> prettyReadRepo repo + <> prettyReadRepo (ReadRepoGit repo) <> "in the cache directory at" <> P.backticked' (P.string localPath) "." GitCouldntParseRootBranchHash repo s -> @@ -1060,7 +1060,7 @@ notifyUser dir o = case o of "I couldn't parse the string" <> P.red (P.string s) <> "into a namespace hash, when opening the repository at" - <> P.group (prettyReadRepo repo <> ".") + <> P.group (prettyReadRepo (ReadRepoGit repo) <> ".") GitProtocolError e -> case e of NoGit -> P.wrap $ @@ -1071,7 +1071,7 @@ notifyUser dir o = case o of <> P.group (P.shown e) CloneException repo msg -> P.wrap $ - "I couldn't clone the repository at" <> prettyReadRepo repo <> ";" + "I couldn't clone the repository at" <> prettyReadRepo (ReadRepoGit repo) <> ";" <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg CopyException srcRepoPath destPath msg -> @@ -1081,10 +1081,10 @@ notifyUser dir o = case o of <> (P.indentNAfterNewline 2 . P.group . P.string) msg PushNoOp repo -> P.wrap $ - "The repository at" <> prettyWriteRepo repo <> "is already up-to-date." + "The repository at" <> prettyWriteRepo (WriteRepoGit repo) <> "is already up-to-date." PushException repo msg -> P.wrap $ - "I couldn't push to the repository at" <> prettyWriteRepo repo <> ";" + "I couldn't push to the repository at" <> prettyWriteRepo (WriteRepoGit repo) <> ";" <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg RemoteRefNotFound repo ref -> @@ -1093,7 +1093,7 @@ notifyUser dir o = case o of UnrecognizableCacheDir uri localPath -> P.wrap $ "A cache directory for" - <> P.backticked (P.text $ RemoteRepo.printReadRepo uri) + <> P.backticked (P.text $ RemoteRepo.printReadRepo (ReadRepoGit uri)) <> "already exists at" <> P.backticked' (P.string localPath) "," <> "but it doesn't seem to" @@ -1101,7 +1101,7 @@ notifyUser dir o = case o of UnrecognizableCheckoutDir uri localPath -> P.wrap $ "I tried to clone" - <> P.backticked (P.text $ RemoteRepo.printReadRepo uri) + <> P.backticked (P.text $ RemoteRepo.printReadRepo (ReadRepoGit uri)) <> "into a cache directory at" <> P.backticked' (P.string localPath) "," <> "but I can't recognize the" @@ -1109,7 +1109,7 @@ notifyUser dir o = case o of PushDestinationHasNewStuff repo -> P.callout "โธ" . P.lines $ [ P.wrap $ - "The repository at" <> prettyWriteRepo repo + "The repository at" <> prettyWriteRepo (WriteRepoGit repo) <> "has some changes I don't know about.", "", P.wrap $ "Try" <> pull <> "to merge these changes locally, then" <> push <> "again." @@ -1123,28 +1123,28 @@ notifyUser dir o = case o of "I couldn't decode the root branch " <> P.string s <> "from the repository at" - <> prettyReadRepo repo + <> prettyReadRepo (ReadRepoGit repo) CouldntLoadRootBranch repo hash -> P.wrap $ "I couldn't load the designated root hash" <> P.group ("(" <> P.text (Hash.base32Hex $ Causal.unRawHash hash) <> ")") <> "from the repository at" - <> prettyReadRepo repo + <> prettyReadRepo (ReadRepoGit repo) CouldntLoadSyncedBranch ns h -> P.wrap $ "I just finished importing the branch" <> P.red (P.shown h) <> "from" - <> P.red (prettyRemoteNamespace ns) + <> P.red (prettyRemoteNamespace (over _1 ReadRepoGit ns)) <> "but now I can't find it." CouldntFindRemoteBranch repo path -> P.wrap $ "I couldn't find the remote branch at" <> P.shown path <> "in the repository at" - <> prettyReadRepo repo + <> prettyReadRepo (ReadRepoGit repo) NoRemoteNamespaceWithHash repo sbh -> P.wrap $ - "The repository at" <> prettyReadRepo repo + "The repository at" <> prettyReadRepo (ReadRepoGit repo) <> "doesn't contain a namespace with the hash prefix" <> (P.blue . P.text . SBH.toText) sbh RemoteNamespaceHashAmbiguous repo sbh hashes -> @@ -1152,7 +1152,7 @@ notifyUser dir o = case o of [ P.wrap $ "The namespace hash" <> prettySBH sbh <> "at" - <> prettyReadRepo repo + <> prettyReadRepo (ReadRepoGit repo) <> "is ambiguous." <> "Did you mean one of these hashes?", "", @@ -2821,10 +2821,10 @@ prettyTypeName ppe r = prettyHashQualified (PPE.typeName ppe r) prettyReadRepo :: ReadRepo -> Pretty -prettyReadRepo (RemoteRepo.ReadGitRepo {url}) = P.blue (P.text url) +prettyReadRepo (RemoteRepo.ReadRepoGit RemoteRepo.ReadGitRepo {url}) = P.blue (P.text url) prettyWriteRepo :: WriteRepo -> Pretty -prettyWriteRepo (RemoteRepo.WriteGitRepo {url'}) = P.blue (P.text url') +prettyWriteRepo (RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url'}) = P.blue (P.text url') isTestOk :: Term v Ann -> Bool isTestOk tm = case tm of diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index aa7ad56dfe..b82a988431 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -279,6 +279,7 @@ dagbfs goal children = data PullError = -- | An error occurred while resolving a repo+path to a causal hash. PullErrorGetCausalHashByPath GetCausalHashByPathError + | PullErrorNoHistoryAtPath Share.RepoPath.RepoPath pull :: -- | The HTTP client to use for Unison Share requests. @@ -289,19 +290,19 @@ pull :: Sqlite.Connection -> -- | The repo+path to pull from. Share.RepoPath -> - IO (Either PullError (Maybe CausalHash)) + IO (Either PullError CausalHash) pull httpClient unisonShareUrl conn repoPath = do getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case Left err -> pure (Left (PullErrorGetCausalHashByPath err)) -- There's nothing at the remote path, so there's no causal to pull. - Right Nothing -> pure (Right Nothing) + Right Nothing -> pure (Left (PullErrorNoHistoryAtPath repoPath)) Right (Just hashJwt) -> do let hash = Share.hashJWTHash hashJwt Sqlite.runTransaction conn (entityLocation hash) >>= \case EntityInMainStorage -> pure () EntityInTempStorage missingDependencies -> doDownload missingDependencies EntityNotStored -> doDownload (NESet.singleton hashJwt) - pure (Right (Just (CausalHash (Hash.fromBase32Hex (Share.toBase32Hex hash))))) + pure (Right (CausalHash (Hash.fromBase32Hex (Share.toBase32Hex hash)))) where doDownload :: NESet Share.HashJWT -> IO () doDownload = From fc39e2e24ef6517577c88a3d485d790348e4131e Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 10 May 2022 17:55:12 -0400 Subject: [PATCH 201/529] started adding ShareRepo constructors --- parser-typechecker/package.yaml | 1 + .../src/Unison/Codebase/Editor/RemoteRepo.hs | 19 +++++++++++++++---- .../src/Unison/Codebase/SqliteCodebase.hs | 2 +- .../unison-parser-typechecker.cabal | 2 ++ .../src/Unison/Codebase/Editor/HandleInput.hs | 18 +++++++++++++----- .../src/Unison/Codebase/Editor/UriParser.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 8 ++++++-- 7 files changed, 39 insertions(+), 13 deletions(-) diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 2b4b6e81e9..4a2e8eb010 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -173,6 +173,7 @@ default-extensions: - DerivingStrategies - DerivingVia - DoAndIfThenElse + - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 524e821dde..0e69bf0a4a 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -13,24 +13,31 @@ import Unison.Prelude data ReadRepo = ReadRepoGit ReadGitRepo + | ReadRepoShare ShareRepo deriving (Eq, Show) data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} deriving (Eq, Show) -data WriteRepo = WriteRepoGit WriteGitRepo +newtype ShareRepo = ShareRepo {url :: Text} deriving (Eq, Show) -data WriteGitRepo = WriteGitRepo {url' :: Text, branch :: Maybe Text} +data WriteRepo + = WriteRepoGit WriteGitRepo + | WriteRepoShare ShareRepo + deriving (Eq, Show) + +data WriteGitRepo = WriteGitRepo {url :: Text, branch :: Maybe Text} deriving (Eq, Show) writeToRead :: WriteRepo -> ReadRepo writeToRead = \case WriteRepoGit repo -> ReadRepoGit (writeToReadGit repo) + WriteRepoShare repo -> ReadRepoShare repo writeToReadGit :: WriteGitRepo -> ReadGitRepo writeToReadGit = \case - WriteGitRepo {url', branch} -> ReadGitRepo {url = url', ref = branch} + WriteGitRepo {url, branch} -> ReadGitRepo {url = url, ref = branch} writePathToRead :: WriteRemotePath -> ReadRemoteNamespace writePathToRead (w, p) = (writeToRead w, Nothing, p) @@ -38,11 +45,14 @@ writePathToRead (w, p) = (writeToRead w, Nothing, p) printReadRepo :: ReadRepo -> Text printReadRepo = \case ReadRepoGit ReadGitRepo {url, ref} -> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) + ReadRepoShare ShareRepo {url} -> url printWriteRepo :: WriteRepo -> Text printWriteRepo = \case - WriteRepoGit WriteGitRepo {url', branch} -> url' <> Monoid.fromMaybe (Text.cons ':' <$> branch) + WriteRepoGit WriteGitRepo {url, branch} -> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) + WriteRepoShare ShareRepo {url} -> url +-- | print remote namespace printNamespace :: ReadRepo -> Maybe ShortBranchHash -> Path -> Text printNamespace repo sbh path = printReadRepo repo <> case sbh of @@ -56,6 +66,7 @@ printNamespace repo sbh path = then mempty else "." <> Path.toText path +-- | print remote path printHead :: WriteRepo -> Path -> Text printHead repo path = printWriteRepo repo diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 828f2ac7c0..fca896b4eb 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -863,7 +863,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift -- Commit our changes push :: forall n. MonadIO n => Git.GitRepo -> WriteGitRepo -> Branch m -> n Bool -- withIOError needs IO - push remotePath repo@(WriteGitRepo {url' = url, branch = mayGitBranch}) newRootBranch = time "SqliteCodebase.pushGitRootBranch.push" $ do + push remotePath repo@(WriteGitRepo {url, branch = mayGitBranch}) newRootBranch = time "SqliteCodebase.pushGitRootBranch.push" $ do -- has anything changed? -- note: -uall recursively shows status for all files in untracked directories -- we want this so that we see diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index e42169e525..b659960bad 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -178,6 +178,7 @@ library DerivingStrategies DerivingVia DoAndIfThenElse + DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving @@ -349,6 +350,7 @@ test-suite parser-typechecker-tests DerivingStrategies DerivingVia DoAndIfThenElse + DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index e1c96d3674..a07bcdef34 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -58,7 +58,7 @@ import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN import qualified Unison.Codebase.Editor.Propagate as Propagate -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRepo (ReadRepoGit), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit), printNamespace, writePathToRead) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRepo (ReadRepoGit), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit, WriteRepoShare), printNamespace, writePathToRead) import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -1757,10 +1757,10 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do currentPath' <- use LoopState.currentPath getAt (Path.resolve currentPath' localPath) - unlessError do - case repo of - WriteRepoGit repo -> - withExceptT Output.GitError $ do + case repo of + WriteRepoGit repo -> + unlessError do + withExceptT Output.GitError do case remoteTarget of Nothing -> do let opts = PushGitBranchOpts {setRoot = False, syncMode} @@ -1780,6 +1780,14 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do syncGitRemoteBranch repo opts withRemoteRoot >>= \case Left output -> respond output Right _branch -> respond Success + WriteRepoShare repo -> do + case remoteTarget of + Nothing -> + -- do a gist + error "don't do a gist" + Just (remotePath, pushBehavior) -> + -- let (userSegment :| pathSegments) = undefined + handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior where -- Per `pushBehavior`, we are either: -- diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 888d961d4c..52e7b2e4ae 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -52,7 +52,7 @@ writeRepo :: P WriteRepo writeRepo = P.label "repo root for writing" $ do uri <- parseProtocol treeish <- P.optional treeishSuffix - pure (WriteRepoGit WriteGitRepo {url' = printProtocol uri, branch = treeish}) + pure (WriteRepoGit WriteGitRepo {url = printProtocol uri, branch = treeish}) writeRepoPath :: P WriteRemotePath writeRepoPath = P.label "generic git repo" $ do diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 4fa9c5368f..d2f6a34704 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2821,10 +2821,14 @@ prettyTypeName ppe r = prettyHashQualified (PPE.typeName ppe r) prettyReadRepo :: ReadRepo -> Pretty -prettyReadRepo (RemoteRepo.ReadRepoGit RemoteRepo.ReadGitRepo {url}) = P.blue (P.text url) +prettyReadRepo = \case + RemoteRepo.ReadRepoGit RemoteRepo.ReadGitRepo {url} -> P.blue (P.text url) + RemoteRepo.ReadRepoShare RemoteRepo.ShareRepo {url} -> P.blue (P.text url) prettyWriteRepo :: WriteRepo -> Pretty -prettyWriteRepo (RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url'}) = P.blue (P.text url') +prettyWriteRepo = \case + RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url} -> P.blue (P.text url) + RemoteRepo.WriteRepoShare RemoteRepo.ShareRepo {url} -> P.blue (P.text url) isTestOk :: Term v Ann -> Bool isTestOk tm = case tm of From a297cf9c5965fe72b14d45274cb189ce71c8b8d2 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?R=C3=BAnar?= Date: Tue, 10 May 2022 21:18:07 -0400 Subject: [PATCH 202/529] Windows compatibility issue --- parser-typechecker/src/Unison/Runtime/Builtin.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index f537b5bf15..14749ef283 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -1815,7 +1815,7 @@ declareForeigns = do mkForeign $ \() -> fmap (1e6 *) getPOSIXTime declareForeign Tracked "Clock.internals.monotonic.v1" unitToEFBox $ - mkForeignIOF $ \() -> getTime MonotonicRaw <|> getTime Monotonic + mkForeignIOF $ \() -> getTime Monotonic declareForeign Tracked "Clock.internals.realtime.v1" unitToEFBox $ mkForeignIOF $ \() -> getTime Realtime From 24e4f4bc6a1cce290ff00c6b94ace728351319da Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 10 May 2022 21:38:35 -0400 Subject: [PATCH 203/529] inline Unison.Sync.HTTP into Unison.Share.Sync --- unison-cli/src/Unison/Share/Sync.hs | 65 +++++++++++++++++++++++------ unison-cli/src/Unison/Sync/HTTP.hs | 64 ---------------------------- unison-cli/unison-cli.cabal | 1 - 3 files changed, 53 insertions(+), 77 deletions(-) delete mode 100644 unison-cli/src/Unison/Sync/HTTP.hs diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 216fc78fa3..5ea1bc2476 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -25,8 +25,11 @@ module Unison.Share.Sync ) where +import Control.Exception (throwIO) import qualified Control.Lens as Lens import Control.Monad.Extra ((||^)) +import Control.Monad.Trans.Reader (ReaderT, runReaderT) +import qualified Control.Monad.Trans.Reader as Reader import qualified Data.Foldable as Foldable (find) import Data.List.NonEmpty (pattern (:|)) import qualified Data.List.NonEmpty as List (NonEmpty) @@ -40,7 +43,9 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import Data.Vector (Vector) import qualified Data.Vector as Vector +import qualified Servant.API as Servant ((:<|>) (..)) import Servant.Client (BaseUrl) +import qualified Servant.Client as Servant (ClientEnv, ClientM, client, hoistClient, mkClientEnv, runClientM) import U.Codebase.HashTags (CausalHash (..)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import qualified U.Codebase.Sqlite.Causal as Causal @@ -55,15 +60,10 @@ import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Hash as Hash import Unison.Auth.HTTPClient (AuthorizedHttpClient) +import qualified Unison.Auth.HTTPClient as Auth import Unison.Prelude import qualified Unison.Sqlite as Sqlite -import qualified Unison.Sync.HTTP as Share - ( downloadEntitiesHandler, - fastForwardPathHandler, - getPathHandler, - updatePathHandler, - uploadEntitiesHandler, - ) +import qualified Unison.Sync.API as Share (api) import qualified Unison.Sync.Types as Share import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) import Unison.Util.Monoid (foldMapM) @@ -122,7 +122,7 @@ checkAndSetPush httpClient unisonShareUrl conn repoPath expectedHash causalHash where updatePath :: IO Share.UpdatePathResponse updatePath = - Share.updatePathHandler + httpUpdatePath httpClient unisonShareUrl Share.UpdatePathRequest @@ -190,7 +190,7 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = doFastForwardPath :: [CausalHash] -> IO Share.FastForwardPathResponse doFastForwardPath causalSpine = - Share.fastForwardPathHandler + httpFastForwardPath httpClient unisonShareUrl Share.FastForwardPathRequest @@ -364,7 +364,7 @@ getCausalHashByPath :: Share.RepoPath -> IO (Either GetCausalHashByPathError (Maybe Share.HashJWT)) getCausalHashByPath httpClient unisonShareUrl repoPath = - Share.getPathHandler httpClient unisonShareUrl (Share.GetCausalHashByPathRequest repoPath) <&> \case + httpGetCausalHashByPath httpClient unisonShareUrl (Share.GetCausalHashByPathRequest repoPath) <&> \case Share.GetCausalHashByPathSuccess maybeHashJwt -> Right maybeHashJwt Share.GetCausalHashByPathNoReadPermission _ -> Left (GetCausalHashByPathErrorNoReadPermission repoPath) @@ -397,7 +397,7 @@ downloadEntities httpClient unisonShareUrl conn repoName = doDownload :: NESet Share.HashJWT -> IO (NEMap Share.Hash (Share.Entity Text Share.Hash Share.HashJWT)) doDownload hashes = do Share.DownloadEntitiesResponse entities <- - Share.downloadEntitiesHandler + httpDownloadEntities httpClient unisonShareUrl Share.DownloadEntitiesRequest {repoName, hashes} @@ -428,7 +428,7 @@ uploadEntities httpClient unisonShareUrl conn repoName = let uploadEntities :: IO Share.UploadEntitiesResponse uploadEntities = - Share.uploadEntitiesHandler + httpUploadEntities httpClient unisonShareUrl Share.UploadEntitiesRequest @@ -721,3 +721,44 @@ tempEntityToEntity = \case { texts = Vector.toList textLookup, hashes = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) defnLookup) } + +------------------------------------------------------------------------------------------------------------------------ +-- HTTP calls + +httpGetCausalHashByPath :: Auth.AuthorizedHttpClient -> BaseUrl -> Share.GetCausalHashByPathRequest -> IO Share.GetCausalHashByPathResponse +httpFastForwardPath :: Auth.AuthorizedHttpClient -> BaseUrl -> Share.FastForwardPathRequest -> IO Share.FastForwardPathResponse +httpUpdatePath :: Auth.AuthorizedHttpClient -> BaseUrl -> Share.UpdatePathRequest -> IO Share.UpdatePathResponse +httpDownloadEntities :: Auth.AuthorizedHttpClient -> BaseUrl -> Share.DownloadEntitiesRequest -> IO Share.DownloadEntitiesResponse +httpUploadEntities :: Auth.AuthorizedHttpClient -> BaseUrl -> Share.UploadEntitiesRequest -> IO Share.UploadEntitiesResponse +( httpGetCausalHashByPath, + httpFastForwardPath, + httpUpdatePath, + httpDownloadEntities, + httpUploadEntities + ) = + let ( httpGetCausalHashByPath + Servant.:<|> httpFastForwardPath + Servant.:<|> httpUpdatePath + Servant.:<|> httpDownloadEntities + Servant.:<|> httpUploadEntities + ) = Servant.hoistClient Share.api hoist (Servant.client Share.api) + in ( go httpGetCausalHashByPath, + go httpFastForwardPath, + go httpUpdatePath, + go httpDownloadEntities, + go httpUploadEntities + ) + where + hoist :: Servant.ClientM a -> ReaderT Servant.ClientEnv IO a + hoist m = do + clientEnv <- Reader.ask + liftIO (throwEitherM (Servant.runClientM m clientEnv)) + + go :: + (req -> ReaderT Servant.ClientEnv IO resp) -> + Auth.AuthorizedHttpClient -> + BaseUrl -> + req -> + IO resp + go f (Auth.AuthorizedHttpClient httpClient) unisonShareUrl req = + runReaderT (f req) (Servant.mkClientEnv httpClient unisonShareUrl) diff --git a/unison-cli/src/Unison/Sync/HTTP.hs b/unison-cli/src/Unison/Sync/HTTP.hs deleted file mode 100644 index 3903b8c7a1..0000000000 --- a/unison-cli/src/Unison/Sync/HTTP.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Sync.HTTP - ( getPathHandler, - fastForwardPathHandler, - updatePathHandler, - downloadEntitiesHandler, - uploadEntitiesHandler, - ) -where - -import Control.Monad.Reader -import Servant.API -import Servant.Client -import qualified Unison.Auth.HTTPClient as Auth -import Unison.Prelude -import qualified Unison.Sync.API as Sync -import Unison.Sync.Types - -data SyncError - = ClientErr ClientError - deriving stock (Show) - deriving anyclass (Exception) - -getPathHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse -fastForwardPathHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> FastForwardPathRequest -> IO FastForwardPathResponse -updatePathHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> UpdatePathRequest -> IO UpdatePathResponse -downloadEntitiesHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> DownloadEntitiesRequest -> IO DownloadEntitiesResponse -uploadEntitiesHandler :: Auth.AuthorizedHttpClient -> BaseUrl -> UploadEntitiesRequest -> IO UploadEntitiesResponse -( getPathHandler, - fastForwardPathHandler, - updatePathHandler, - downloadEntitiesHandler, - uploadEntitiesHandler - ) = - let ( getPathHandler - :<|> fastForwardPathHandler - :<|> updatePathHandler - :<|> downloadEntitiesHandler - :<|> uploadEntitiesHandler - ) = hoistClient Sync.api hoist (client Sync.api) - in ( uncurryReaderT getPathHandler, - uncurryReaderT fastForwardPathHandler, - uncurryReaderT updatePathHandler, - uncurryReaderT downloadEntitiesHandler, - uncurryReaderT uploadEntitiesHandler - ) - where - hoist :: forall a. ClientM a -> ReaderT (Auth.AuthorizedHttpClient, BaseUrl) IO a - hoist m = do - (Auth.AuthorizedHttpClient manager, baseUrl) <- ask - let clientEnv = mkClientEnv manager baseUrl - resp <- liftIO . throwEitherMWith ClientErr $ (runClientM m clientEnv) - pure resp - - uncurryReaderT :: forall req resp. (req -> ReaderT (Auth.AuthorizedHttpClient, BaseUrl) IO resp) -> Auth.AuthorizedHttpClient -> BaseUrl -> req -> IO resp - uncurryReaderT f httpClient baseURL req = - runReaderT (f req) (httpClient, baseURL) diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index dc6fac3a25..59f5f26844 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -60,7 +60,6 @@ library Unison.CommandLine.OutputMessages Unison.CommandLine.Welcome Unison.Share.Sync - Unison.Sync.HTTP Unison.Util.HTTP other-modules: Paths_unison_cli From 5d5e425b326e4db42bf0c008d3b38a0823f2f358 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Wed, 11 May 2022 10:29:46 -0400 Subject: [PATCH 204/529] refactored RepoPath into a non-empty Path --- .../src/Unison/Codebase/Editor/HandleInput.hs | 16 ++--- unison-cli/src/Unison/Share/Sync.hs | 54 +++++++-------- unison-share-api/src/Unison/Sync/Types.hs | 65 ++++++++++--------- 3 files changed, 70 insertions(+), 65 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index a07bcdef34..96d7cc1974 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -132,10 +132,7 @@ import qualified Unison.Share.Sync as Share import qualified Unison.ShortHash as SH import qualified Unison.Sqlite as Sqlite import Unison.Symbol (Symbol) -import qualified Unison.Sync.Types as Share - ( RepoName (..), - RepoPath (..), - ) +import qualified Unison.Sync.Types as Share (Path (..)) import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) @@ -654,7 +651,8 @@ loop = do outputDiff CreatePullRequestI baseRepo headRepo -> do let viewRemoteBranch repo callback = case repo of - (ReadRepoGit r, sbh, path) -> viewRemoteGitBranch (r, sbh, path) Git.RequireExistingBranch callback + (ReadRepoGit r, sbh, path) -> + viewRemoteGitBranch (r, sbh, path) Git.RequireExistingBranch callback result <- join @(Either GitError) <$> viewRemoteBranch baseRepo \baseBranch -> do viewRemoteBranch headRepo \headBranch -> do @@ -1712,11 +1710,11 @@ handleGist (GistInput repo) = handlePullFromUnisonShare :: MonadIO m => Text -> Path -> Action' m v () handlePullFromUnisonShare remoteRepo remotePath = do - let repoPath = Share.RepoPath (Share.RepoName remoteRepo) (coerce @[NameSegment] @[Text] (Path.toList remotePath)) + let path = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask - liftIO (Share.pull authHTTPClient unisonShareUrl connection repoPath) >>= \case + liftIO (Share.pull authHTTPClient unisonShareUrl connection path) >>= \case Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined Left (Share.PullErrorNoHistoryAtPath repoPath) -> undefined Right causalHash -> do @@ -1787,7 +1785,7 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do error "don't do a gist" Just (remotePath, pushBehavior) -> -- let (userSegment :| pathSegments) = undefined - handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior + error "handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior" where -- Per `pushBehavior`, we are either: -- @@ -1801,7 +1799,7 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do handlePushToUnisonShare :: MonadIO m => Text -> Path -> Path.Absolute -> PushBehavior -> Action' m v () handlePushToUnisonShare remoteRepo remotePath localPath behavior = do - let repoPath = Share.RepoPath (Share.RepoName remoteRepo) (coerce @[NameSegment] @[Text] (Path.toList remotePath)) + let repoPath = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index b82a988431..f407bb45cf 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -65,7 +65,7 @@ import qualified Unison.Sync.HTTP as Share uploadEntitiesHandler, ) import qualified Unison.Sync.Types as Share -import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) +import qualified Unison.Sync.Types as Share.Path (Path (..)) import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set @@ -75,7 +75,7 @@ import qualified Unison.Util.Set as Set -- | An error occurred while pushing code to Unison Share. data CheckAndSetPushError = CheckAndSetPushErrorHashMismatch Share.HashMismatch - | CheckAndSetPushErrorNoWritePermission Share.RepoPath + | CheckAndSetPushErrorNoWritePermission Share.Path | CheckAndSetPushErrorServerMissingDependencies (NESet Share.Hash) -- | Push a causal to Unison Share. @@ -88,14 +88,14 @@ checkAndSetPush :: -- | SQLite connection, for reading entities to push. Sqlite.Connection -> -- | The repo+path to push to. - Share.RepoPath -> + Share.Path -> -- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error. -- This prevents accidentally pushing over data that we didn't know was there. Maybe Share.Hash -> -- | The hash of our local causal to push. CausalHash -> IO (Either CheckAndSetPushError ()) -checkAndSetPush httpClient unisonShareUrl conn repoPath expectedHash causalHash = do +checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash = do -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs -- this causal (UpdatePathMissingDependencies). updatePath >>= \case @@ -103,8 +103,8 @@ checkAndSetPush httpClient unisonShareUrl conn repoPath expectedHash causalHash Share.UpdatePathHashMismatch mismatch -> pure (Left (CheckAndSetPushErrorHashMismatch mismatch)) Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do -- Upload the causal and all of its dependencies. - uploadEntities httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) dependencies >>= \case - False -> pure (Left (CheckAndSetPushErrorNoWritePermission repoPath)) + uploadEntities httpClient unisonShareUrl conn (Share.pathRepoName path) dependencies >>= \case + False -> pure (Left (CheckAndSetPushErrorNoWritePermission path)) True -> -- After uploading the causal and all of its dependencies, try setting the remote path again. updatePath <&> \case @@ -117,8 +117,8 @@ checkAndSetPush httpClient unisonShareUrl conn repoPath expectedHash causalHash -- upload some dependency? Who knows. Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> Left (CheckAndSetPushErrorServerMissingDependencies dependencies) - Share.UpdatePathNoWritePermission _ -> Left (CheckAndSetPushErrorNoWritePermission repoPath) - Share.UpdatePathNoWritePermission _ -> pure (Left (CheckAndSetPushErrorNoWritePermission repoPath)) + Share.UpdatePathNoWritePermission _ -> Left (CheckAndSetPushErrorNoWritePermission path) + Share.UpdatePathNoWritePermission _ -> pure (Left (CheckAndSetPushErrorNoWritePermission path)) where updatePath :: IO Share.UpdatePathResponse updatePath = @@ -126,17 +126,17 @@ checkAndSetPush httpClient unisonShareUrl conn repoPath expectedHash causalHash httpClient unisonShareUrl Share.UpdatePathRequest - { path = repoPath, + { path, expectedHash, newHash = causalHashToHash causalHash } -- | An error occurred while fast-forward pushing code to Unison Share. data FastForwardPushError - = FastForwardPushErrorNoHistory Share.RepoPath - | FastForwardPushErrorNoReadPermission Share.RepoPath + = FastForwardPushErrorNoHistory Share.Path + | FastForwardPushErrorNoReadPermission Share.Path | FastForwardPushErrorNotFastForward - | FastForwardPushErrorNoWritePermission Share.RepoPath + | FastForwardPushErrorNoWritePermission Share.Path | FastForwardPushErrorServerMissingDependencies (NESet Share.Hash) -- | Push a causal to Unison Share. @@ -149,14 +149,14 @@ fastForwardPush :: -- | SQLite connection, for reading entities to push. Sqlite.Connection -> -- | The repo+path to push to. - Share.RepoPath -> + Share.Path -> -- | The hash of our local causal to push. CausalHash -> IO (Either FastForwardPushError ()) -fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = - getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case - Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission repoPath)) - Right Nothing -> pure (Left (FastForwardPushErrorNoHistory repoPath)) +fastForwardPush httpClient unisonShareUrl conn path localHeadHash = + getCausalHashByPath httpClient unisonShareUrl path >>= \case + Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path)) + Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path)) Right (Just (Share.hashJWTHash -> remoteHeadHash)) -> Sqlite.runTransaction conn (fancyBfs localHeadHash remoteHeadHash) >>= \case -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a @@ -164,7 +164,7 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = Nothing -> pure (Left FastForwardPushErrorNotFastForward) Just localTailHashes -> doUpload (localHeadHash :| localTailHashes) >>= \case - False -> pure (Left (FastForwardPushErrorNoWritePermission repoPath)) + False -> pure (Left (FastForwardPushErrorNoWritePermission path)) True -> doFastForwardPath (localHeadHash : localTailHashes) <&> \case Share.FastForwardPathSuccess -> Right () @@ -172,8 +172,8 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = Left (FastForwardPushErrorServerMissingDependencies dependencies) -- Weird: someone must have force-pushed no history here, or something. We observed a history at this -- path but moments ago! - Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory repoPath) - Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission repoPath) + Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory path) + Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission path) Share.FastForwardPathNotFastForward _ -> Left FastForwardPushErrorNotFastForward where doUpload :: List.NonEmpty CausalHash -> IO Bool @@ -185,7 +185,7 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = httpClient unisonShareUrl conn - (Share.RepoPath.repoName repoPath) + (Share.pathRepoName path) (NESet.singleton (causalHashToHash headHash)) doFastForwardPath :: [CausalHash] -> IO Share.FastForwardPathResponse @@ -195,7 +195,7 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = unisonShareUrl Share.FastForwardPathRequest { hashes = map causalHashToHash causalSpine, - path = repoPath + path = path } -- Return a list from newest to oldest of the ancestors between (excluding) the latest local and the current remote hash. @@ -279,7 +279,7 @@ dagbfs goal children = data PullError = -- | An error occurred while resolving a repo+path to a causal hash. PullErrorGetCausalHashByPath GetCausalHashByPathError - | PullErrorNoHistoryAtPath Share.RepoPath.RepoPath + | PullErrorNoHistoryAtPath Share.Path pull :: -- | The HTTP client to use for Unison Share requests. @@ -289,7 +289,7 @@ pull :: -- | SQLite connection, for writing entities we pull. Sqlite.Connection -> -- | The repo+path to pull from. - Share.RepoPath -> + Share.Path -> IO (Either PullError CausalHash) pull httpClient unisonShareUrl conn repoPath = do getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case @@ -306,7 +306,7 @@ pull httpClient unisonShareUrl conn repoPath = do where doDownload :: NESet Share.HashJWT -> IO () doDownload = - downloadEntities httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) + downloadEntities httpClient unisonShareUrl conn (Share.pathRepoName repoPath) ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path @@ -314,7 +314,7 @@ pull httpClient unisonShareUrl conn repoPath = do -- | An error occurred when getting causal hash by path. data GetCausalHashByPathError = -- | The user does not have permission to read this path. - GetCausalHashByPathErrorNoReadPermission Share.RepoPath + GetCausalHashByPathErrorNoReadPermission Share.Path -- | Get the causal hash of a path hosted on Unison Share. getCausalHashByPath :: @@ -322,7 +322,7 @@ getCausalHashByPath :: AuthorizedHttpClient -> -- | The Unison Share URL. BaseUrl -> - Share.RepoPath -> + Share.Path -> IO (Either GetCausalHashByPathError (Maybe Share.HashJWT)) getCausalHashByPath httpClient unisonShareUrl repoPath = Share.getPathHandler httpClient unisonShareUrl (Share.GetCausalHashByPathRequest repoPath) <&> \case diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 1b9b17d3ec..0a1ba93b00 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -4,7 +4,8 @@ module Unison.Sync.Types ( -- * Misc. types Base64Bytes (..), RepoName (..), - RepoPath (..), + Path (..), + pathRepoName, -- ** Hash types Hash (..), @@ -65,6 +66,7 @@ import Data.Bifunctor import Data.Bitraversable import Data.ByteArray.Encoding (Base (Base64), convertFromBase, convertToBase) import qualified Data.HashMap.Strict as HashMap +import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Map.NonEmpty (NEMap) import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -91,24 +93,29 @@ instance FromJSON Base64Bytes where newtype RepoName = RepoName Text deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) -data RepoPath = RepoPath - { repoName :: RepoName, - pathSegments :: [Text] +data Path = Path + { -- This is a nonempty list, where we require the first segment to be the repo name / user name / whatever, + -- which we need on the server side as an implementation detail of how we're representing different users' codebases. + + -- This could be relaxed in some other share implementation that allows access to the "root" of the shared codebase. + -- Our share implementation doesn't have a root, just a collection of sub-roots, one per user or (eventually) organization. + pathSegments :: NonEmpty Text } deriving stock (Show, Eq, Ord) -instance ToJSON RepoPath where - toJSON (RepoPath name segments) = +pathRepoName :: Path -> RepoName +pathRepoName (Path (p :| _)) = RepoName p + +instance ToJSON Path where + toJSON (Path segments) = object - [ "repo_name" .= name, - "path" .= segments + [ "path" .= segments ] -instance FromJSON RepoPath where - parseJSON = Aeson.withObject "RepoPath" \obj -> do - repoName <- obj .: "repo_name" +instance FromJSON Path where + parseJSON = Aeson.withObject "Path" \obj -> do pathSegments <- obj .: "path" - pure RepoPath {..} + pure Path {..} ------------------------------------------------------------------------------------------------------------------------ -- Hash types @@ -534,30 +541,30 @@ instance FromJSON EntityType where -- Get causal hash by path newtype GetCausalHashByPathRequest = GetCausalHashByPathRequest - { repoPath :: RepoPath + { path :: Path } deriving stock (Show, Eq, Ord) instance ToJSON GetCausalHashByPathRequest where - toJSON (GetCausalHashByPathRequest repoPath) = + toJSON (GetCausalHashByPathRequest path) = object - [ "repo_path" .= repoPath + [ "path" .= path ] instance FromJSON GetCausalHashByPathRequest where parseJSON = Aeson.withObject "GetCausalHashByPathRequest" \obj -> do - repoPath <- obj .: "repo_path" + path <- obj .: "path" pure GetCausalHashByPathRequest {..} data GetCausalHashByPathResponse = GetCausalHashByPathSuccess (Maybe HashJWT) - | GetCausalHashByPathNoReadPermission RepoPath + | GetCausalHashByPathNoReadPermission Path deriving stock (Show, Eq, Ord) instance ToJSON GetCausalHashByPathResponse where toJSON = \case GetCausalHashByPathSuccess hashJWT -> jsonUnion "success" hashJWT - GetCausalHashByPathNoReadPermission repoPath -> jsonUnion "no_read_permission" repoPath + GetCausalHashByPathNoReadPermission path -> jsonUnion "no_read_permission" path instance FromJSON GetCausalHashByPathResponse where parseJSON = Aeson.withObject "GetCausalHashByPathResponse" \obj -> do @@ -675,8 +682,8 @@ instance FromJSON UploadEntitiesResponse where data FastForwardPathRequest = FastForwardPathRequest { -- TODO non-empty hashes :: [Hash], - -- | The repo + path to fast-forward. - path :: RepoPath + -- | The path to fast-forward. + path :: Path } deriving stock (Show) @@ -697,7 +704,7 @@ instance FromJSON FastForwardPathRequest where data FastForwardPathResponse = FastForwardPathSuccess | FastForwardPathMissingDependencies (NeedDependencies Hash) - | FastForwardPathNoWritePermission RepoPath + | FastForwardPathNoWritePermission Path | -- | This wasn't a fast-forward. Here's a JWT to download the causal head, if you want it. FastForwardPathNotFastForward HashJWT | -- | There was no history at this path; the client should use the "update path" endpoint instead. @@ -708,7 +715,7 @@ instance ToJSON FastForwardPathResponse where toJSON = \case FastForwardPathSuccess -> jsonUnion "success" (Object mempty) FastForwardPathMissingDependencies deps -> jsonUnion "missing_dependencies" deps - FastForwardPathNoWritePermission repoPath -> jsonUnion "no_write_permission" repoPath + FastForwardPathNoWritePermission path -> jsonUnion "no_write_permission" path FastForwardPathNotFastForward hashJwt -> jsonUnion "not_fast_forward" hashJwt FastForwardPathNoHistory -> jsonUnion "no_history" (Object mempty) @@ -727,7 +734,7 @@ instance FromJSON FastForwardPathResponse where -- Update path data UpdatePathRequest = UpdatePathRequest - { path :: RepoPath, + { path :: Path, expectedHash :: Maybe Hash, -- Nothing requires empty history at destination newHash :: Hash } @@ -752,7 +759,7 @@ data UpdatePathResponse = UpdatePathSuccess | UpdatePathHashMismatch HashMismatch | UpdatePathMissingDependencies (NeedDependencies Hash) - | UpdatePathNoWritePermission RepoPath + | UpdatePathNoWritePermission Path deriving stock (Show, Eq, Ord) instance ToJSON UpdatePathResponse where @@ -760,7 +767,7 @@ instance ToJSON UpdatePathResponse where UpdatePathSuccess -> jsonUnion "success" (Object mempty) UpdatePathHashMismatch hm -> jsonUnion "hash_mismatch" hm UpdatePathMissingDependencies md -> jsonUnion "missing_dependencies" md - UpdatePathNoWritePermission repoPath -> jsonUnion "no_write_permission" repoPath + UpdatePathNoWritePermission path -> jsonUnion "no_write_permission" path instance FromJSON UpdatePathResponse where parseJSON v = @@ -773,23 +780,23 @@ instance FromJSON UpdatePathResponse where t -> failText $ "Unexpected UpdatePathResponse type: " <> t data HashMismatch = HashMismatch - { repoPath :: RepoPath, + { path :: Path, expectedHash :: Maybe Hash, actualHash :: Maybe Hash } deriving stock (Show, Eq, Ord) instance ToJSON HashMismatch where - toJSON (HashMismatch repoPath expectedHash actualHash) = + toJSON (HashMismatch path expectedHash actualHash) = object - [ "repo_path" .= repoPath, + [ "path" .= path, "expected_hash" .= expectedHash, "actual_hash" .= actualHash ] instance FromJSON HashMismatch where parseJSON = Aeson.withObject "HashMismatch" \obj -> do - repoPath <- obj .: "repo_path" + path <- obj .: "path" expectedHash <- obj .: "expected_hash" actualHash <- obj .: "actual_hash" pure HashMismatch {..} From 06e9089c12f23248280dfce7fbf1f92d74c3fc13 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Wed, 11 May 2022 13:08:12 -0400 Subject: [PATCH 205/529] fix ShareRepo related missing case warnings --- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 9 +++-- .../src/Unison/Codebase/Editor/HandleInput.hs | 38 ++++++++++++------- .../Codebase/Editor/HandleInput/LoopState.hs | 5 +-- .../Unison/Codebase/Editor/VersionParser.hs | 17 +++++---- .../src/Unison/Codebase/TranscriptParser.hs | 3 +- unison-cli/src/Unison/CommandLine/Main.hs | 3 +- .../src/Unison/CommandLine/OutputMessages.hs | 4 +- unison-cli/src/Unison/Share/Sync.hs | 1 - 8 files changed, 44 insertions(+), 36 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 0e69bf0a4a..117f5e4b89 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -19,7 +19,7 @@ data ReadRepo data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} deriving (Eq, Show) -newtype ShareRepo = ShareRepo {url :: Text} +data ShareRepo = ShareRepo deriving (Eq, Show) data WriteRepo @@ -45,12 +45,15 @@ writePathToRead (w, p) = (writeToRead w, Nothing, p) printReadRepo :: ReadRepo -> Text printReadRepo = \case ReadRepoGit ReadGitRepo {url, ref} -> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) - ReadRepoShare ShareRepo {url} -> url + ReadRepoShare s -> printShareRepo s + +printShareRepo :: ShareRepo -> Text +printShareRepo = const "PLACEHOLDER" printWriteRepo :: WriteRepo -> Text printWriteRepo = \case WriteRepoGit WriteGitRepo {url, branch} -> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) - WriteRepoShare ShareRepo {url} -> url + WriteRepoShare s -> printShareRepo s -- | print remote namespace printNamespace :: ReadRepo -> Maybe ShortBranchHash -> Path -> Text diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 96d7cc1974..b30fd79f54 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -27,6 +27,7 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) +import qualified Servant.Client as Servant import qualified Text.Megaparsec as P import qualified U.Codebase.Sqlite.Operations as Ops import U.Util.Timing (unsafeTime) @@ -58,7 +59,7 @@ import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN import qualified Unison.Codebase.Editor.Propagate as Propagate -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRepo (ReadRepoGit), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit, WriteRepoShare), printNamespace, writePathToRead) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRepo (ReadRepoGit), ShareRepo (ShareRepo), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit, WriteRepoShare), printNamespace, writePathToRead) import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -1709,16 +1710,17 @@ handleGist (GistInput repo) = doPushRemoteBranch repo Path.relativeEmpty' SyncMode.ShortCircuit Nothing handlePullFromUnisonShare :: MonadIO m => Text -> Path -> Action' m v () -handlePullFromUnisonShare remoteRepo remotePath = do - let path = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) +handlePullFromUnisonShare remoteRepo remotePath = undefined - LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask +-- let path = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) - liftIO (Share.pull authHTTPClient unisonShareUrl connection path) >>= \case - Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined - Left (Share.PullErrorNoHistoryAtPath repoPath) -> undefined - Right causalHash -> do - undefined +-- LoopState.Env {authHTTPClient, codebase = Codebase {connection}} <- ask + +-- liftIO (Share.pull authHTTPClient unisonShareUrl connection path) >>= \case +-- Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined +-- Left (Share.PullErrorNoHistoryAtPath repoPath) -> undefined +-- Right causalHash -> do +-- undefined -- | Handle a @push@ command. handlePushRemoteBranch :: @@ -1797,11 +1799,14 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch) PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) -handlePushToUnisonShare :: MonadIO m => Text -> Path -> Path.Absolute -> PushBehavior -> Action' m v () -handlePushToUnisonShare remoteRepo remotePath localPath behavior = do +shareRepoToBaseURL :: ShareRepo -> Servant.BaseUrl +shareRepoToBaseURL ShareRepo = Servant.BaseUrl Servant.Https "share.unison.cloud" 443 "" + +handlePushToUnisonShare :: MonadIO m => ShareRepo -> Text -> Path -> Path.Absolute -> PushBehavior -> Action' m v () +handlePushToUnisonShare shareRepo remoteRepo remotePath localPath behavior = do let repoPath = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) - LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask + LoopState.Env {authHTTPClient, codebase = Codebase {connection}} <- ask -- doesn't handle the case where a non-existent path is supplied Sqlite.runTransaction @@ -1812,7 +1817,7 @@ handlePushToUnisonShare remoteRepo remotePath localPath behavior = do Just localCausalHash -> case behavior of PushBehavior.RequireEmpty -> - liftIO (Share.checkAndSetPush authHTTPClient unisonShareUrl connection repoPath Nothing localCausalHash) >>= \case + liftIO (Share.checkAndSetPush authHTTPClient (shareRepoToBaseURL shareRepo) connection repoPath Nothing localCausalHash) >>= \case Left err -> case err of Share.CheckAndSetPushErrorHashMismatch _mismatch -> error "remote not empty" @@ -1820,7 +1825,7 @@ handlePushToUnisonShare remoteRepo remotePath localPath behavior = do Share.CheckAndSetPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps Right () -> pure () PushBehavior.RequireNonEmpty -> - liftIO (Share.fastForwardPush authHTTPClient unisonShareUrl connection repoPath localCausalHash) >>= \case + liftIO (Share.fastForwardPush authHTTPClient (shareRepoToBaseURL shareRepo) connection repoPath localCausalHash) >>= \case Left err -> case err of Share.FastForwardPushErrorNoHistory _repoPath -> error "no history" @@ -2198,6 +2203,11 @@ viewRemoteGitBranch :: viewRemoteGitBranch ns gitBranchBehavior action = do eval $ ViewRemoteGitBranch ns gitBranchBehavior action +-- todo: support the full ReadShareRemoteNamespace eventually, in place of (ShareRepo, Text, Path) +importRemoteShareBranch :: + ShareRepo -> Text -> Path -> (Branch m -> Action' m v ()) -> Action' m v () +importRemoteShareBranch url repoName path action = undefined + -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) -- compute a new branch, which will then be synced and pushed. diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs index b023c7add1..372b8bbb42 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs @@ -11,7 +11,6 @@ import Control.Monad.State import Data.Configurator () import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel -import Servant.Client (BaseUrl) import Unison.Auth.CredentialManager (CredentialManager) import Unison.Auth.HTTPClient (AuthorizedHttpClient) import Unison.Codebase (Codebase) @@ -33,9 +32,7 @@ type F m i v = Free (Command m i v) data Env m v = Env { authHTTPClient :: AuthorizedHttpClient, codebase :: Codebase m v Ann, - credentialManager :: CredentialManager, - -- | The URL to Unison Share - unisonShareUrl :: BaseUrl + credentialManager :: CredentialManager } newtype Action m i v a = Action {unAction :: MaybeT (ReaderT (Env m v) (StateT (LoopState m v) (F m i v))) a} diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index 4dc9ca87c6..ccafb831ae 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -25,14 +25,15 @@ defaultBaseLib = fmap makeNS $ latest <|> release Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) makeNS :: Text -> ReadRemoteNamespace makeNS t = - ( ReadGitRepo - { url = "https://github.com/unisonweb/base", - -- Use the 'v3' branch of base for now. - -- We can revert back to the main branch once enough people have upgraded ucm and - -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm - -- release). - ref = Just "v3" - }, + ( ReadRepoGit + ReadGitRepo + { url = "https://github.com/unisonweb/base", + -- Use the 'v3' branch of base for now. + -- We can revert back to the main branch once enough people have upgraded ucm and + -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm + -- release). + ref = Just "v3" + }, Nothing, Path.fromText t ) diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 2c2690f90b..2ab95649c6 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -425,8 +425,7 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do LoopState.Env { LoopState.authHTTPClient = error "Error: No access to authorized requests from transcripts.", LoopState.codebase = codebase, - LoopState.credentialManager = error "Error: No access to credentials from transcripts.", - LoopState.unisonShareUrl = error "Error: No access to Unison Share from transcripts." + LoopState.credentialManager = error "Error: No access to credentials from transcripts." } let free = LoopState.runAction env state $ HandleInput.loop rng i = pure $ Random.drgNewSeed (Random.seedFromInteger (fromIntegral i)) diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 480b297783..70d51fcb0a 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -197,8 +197,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba LoopState.Env { LoopState.authHTTPClient = authorizedHTTPClient, LoopState.codebase = codebase, - LoopState.credentialManager = credMan, - LoopState.unisonShareUrl = error "TODO: wire in Unison Share URL" + LoopState.credentialManager = credMan } let free = LoopState.runAction env state HandleInput.loop let handleCommand = diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index d2f6a34704..5f1fe73bd3 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2823,12 +2823,12 @@ prettyTypeName ppe r = prettyReadRepo :: ReadRepo -> Pretty prettyReadRepo = \case RemoteRepo.ReadRepoGit RemoteRepo.ReadGitRepo {url} -> P.blue (P.text url) - RemoteRepo.ReadRepoShare RemoteRepo.ShareRepo {url} -> P.blue (P.text url) + RemoteRepo.ReadRepoShare s -> P.blue (P.text (RemoteRepo.printShareRepo s)) prettyWriteRepo :: WriteRepo -> Pretty prettyWriteRepo = \case RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url} -> P.blue (P.text url) - RemoteRepo.WriteRepoShare RemoteRepo.ShareRepo {url} -> P.blue (P.text url) + RemoteRepo.WriteRepoShare s -> P.blue (P.text (RemoteRepo.printShareRepo s)) isTestOk :: Term v Ann -> Bool isTestOk tm = case tm of diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index f407bb45cf..af664f2945 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -65,7 +65,6 @@ import qualified Unison.Sync.HTTP as Share uploadEntitiesHandler, ) import qualified Unison.Sync.Types as Share -import qualified Unison.Sync.Types as Share.Path (Path (..)) import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set From 51d5e73b923efe56be24949bf4ee0bbb7b2c2a21 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 11 May 2022 15:29:53 -0400 Subject: [PATCH 206/529] pull handleCreatePullRequest out to the top level --- .../src/Unison/Codebase/Editor/HandleInput.hs | 55 ++++++++++--------- 1 file changed, 30 insertions(+), 25 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index b30fd79f54..a41bfeccc6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -59,7 +59,7 @@ import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN import qualified Unison.Codebase.Editor.Propagate as Propagate -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRepo (ReadRepoGit), ShareRepo (ShareRepo), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit, WriteRepoShare), printNamespace, writePathToRead) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRemoteNamespace, ReadRepo (ReadRepoGit), ShareRepo (ShareRepo), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit, WriteRepoShare), printNamespace, writePathToRead) import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -650,19 +650,7 @@ loop = do (resolveToAbsolute <$> after) ppe outputDiff - CreatePullRequestI baseRepo headRepo -> do - let viewRemoteBranch repo callback = case repo of - (ReadRepoGit r, sbh, path) -> - viewRemoteGitBranch (r, sbh, path) Git.RequireExistingBranch callback - result <- - join @(Either GitError) <$> viewRemoteBranch baseRepo \baseBranch -> do - viewRemoteBranch headRepo \headBranch -> do - merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch - (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) - pure $ ShowDiffAfterCreatePR baseRepo headRepo ppe diff - case result of - Left gitErr -> respond (Output.GitError gitErr) - Right diff -> respondNumbered diff + CreatePullRequestI baseRepo headRepo -> handleCreatePullRequest baseRepo headRepo LoadPullRequestI baseRepo headRepo dest0 -> do let desta = resolveToAbsolute dest0 let dest = Path.unabsolute desta @@ -714,8 +702,8 @@ loop = do case getAtSplit' dest of Just existingDest | not (Branch.isEmpty0 (Branch.head existingDest)) -> do - -- Branch exists and isn't empty, print an error - throwError (BranchAlreadyExists (Path.unsplit' dest)) + -- Branch exists and isn't empty, print an error + throwError (BranchAlreadyExists (Path.unsplit' dest)) _ -> pure () -- allow rewriting history to ensure we move the branch's history too. lift $ @@ -1408,11 +1396,11 @@ loop = do case filtered of [(Referent.Ref ref, ty)] | Typechecker.isSubtype ty mainType -> - eval (MakeStandalone ppe ref output) >>= \case - Just err -> respond $ EvaluationFailure err - Nothing -> pure () + eval (MakeStandalone ppe ref output) >>= \case + Just err -> respond $ EvaluationFailure err + Nothing -> pure () | otherwise -> - respond $ BadMainFunction smain ty ppe [mainType] + respond $ BadMainFunction smain ty ppe [mainType] _ -> respond $ NoMainFunction smain ppe [mainType] IOTestI main -> do -- todo - allow this to run tests from scratch file, using addRunMain @@ -1668,6 +1656,23 @@ loop = do Right input -> LoopState.lastInput .= Just input _ -> pure () +handleCreatePullRequest :: MonadUnliftIO m => ReadRemoteNamespace -> ReadRemoteNamespace -> Action' m v () +handleCreatePullRequest baseRepo headRepo = do + root' <- use LoopState.root + currentPath' <- use LoopState.currentPath + let viewRemoteBranch repo callback = case repo of + (ReadRepoGit r, sbh, path) -> + viewRemoteGitBranch (r, sbh, path) Git.RequireExistingBranch callback + result <- + join @(Either GitError) <$> viewRemoteBranch baseRepo \baseBranch -> do + viewRemoteBranch headRepo \headBranch -> do + merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch + (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) + pure $ ShowDiffAfterCreatePR baseRepo headRepo ppe diff + case result of + Left gitErr -> respond (Output.GitError gitErr) + Right diff -> respondNumbered diff + handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v () handleDependents hq = do hqLength <- eval CodebaseHashLength @@ -2497,10 +2502,10 @@ searchBranchScored names0 score queries = pair qn HQ.HashQualified qn h | h `SH.isPrefixOf` Referent.toShortHash ref -> - pair qn + pair qn HQ.HashOnly h | h `SH.isPrefixOf` Referent.toShortHash ref -> - Set.singleton (Nothing, result) + Set.singleton (Nothing, result) _ -> mempty where result = SR.termSearchResult names0 name ref @@ -2517,10 +2522,10 @@ searchBranchScored names0 score queries = pair qn HQ.HashQualified qn h | h `SH.isPrefixOf` Reference.toShortHash ref -> - pair qn + pair qn HQ.HashOnly h | h `SH.isPrefixOf` Reference.toShortHash ref -> - Set.singleton (Nothing, result) + Set.singleton (Nothing, result) _ -> mempty where result = SR.typeSearchResult names0 name ref @@ -2913,7 +2918,7 @@ docsI srcLoc prettyPrintNames src = do | Set.size s == 1 -> displayI prettyPrintNames ConsoleLocation dotDoc | Set.size s == 0 -> respond $ ListOfLinks mempty [] | otherwise -> -- todo: return a list of links here too - respond $ ListOfLinks mempty [] + respond $ ListOfLinks mempty [] filterBySlurpResult :: Ord v => From d719276508137b0bdd31c6afd58397d93396708b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 11 May 2022 17:30:21 -0400 Subject: [PATCH 207/529] broken partial propagation of more structured read/write repo types --- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 74 ++++++++++++----- .../src/Unison/Codebase/SqliteCodebase.hs | 4 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 82 +++++++++++++------ .../src/Unison/Codebase/Editor/Output.hs | 4 +- .../src/Unison/Codebase/Editor/UriParser.hs | 26 ++++-- .../Unison/Codebase/Editor/VersionParser.hs | 26 +++--- .../src/Unison/CommandLine/InputPatterns.hs | 12 +-- .../src/Unison/CommandLine/OutputMessages.hs | 15 ++-- unison-cli/src/Unison/CommandLine/Welcome.hs | 20 +++-- 9 files changed, 171 insertions(+), 92 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 117f5e4b89..96f1abcece 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -19,6 +19,7 @@ data ReadRepo data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} deriving (Eq, Show) +-- FIXME rename to ShareServer data ShareRepo = ShareRepo deriving (Eq, Show) @@ -40,7 +41,11 @@ writeToReadGit = \case WriteGitRepo {url, branch} -> ReadGitRepo {url = url, ref = branch} writePathToRead :: WriteRemotePath -> ReadRemoteNamespace -writePathToRead (w, p) = (writeToRead w, Nothing, p) +writePathToRead = \case + WriteRemotePathGit WriteGitRemotePath {repo, path} -> + ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo = writeToReadGit repo, sbh = Nothing, path} + WriteRemotePathShare WriteShareRemotePath {server, repo, path} -> + ReadRemoteNamespaceShare ReadShareRemoteNamespace {server, repo, path} printReadRepo :: ReadRepo -> Text printReadRepo = \case @@ -56,18 +61,19 @@ printWriteRepo = \case WriteRepoShare s -> printShareRepo s -- | print remote namespace -printNamespace :: ReadRepo -> Maybe ShortBranchHash -> Path -> Text -printNamespace repo sbh path = - printReadRepo repo <> case sbh of - Nothing -> - if path == Path.empty - then mempty - else ":." <> Path.toText path - Just sbh -> - ":#" <> SBH.toText sbh - <> if path == Path.empty +printNamespace :: ReadRemoteNamespace -> Text +printNamespace = \case + ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sbh, path} -> + printReadRepo (ReadRepoGit repo) <> case sbh of + Nothing -> + if path == Path.empty then mempty - else "." <> Path.toText path + else ":." <> Path.toText path + Just sbh -> + ":#" <> SBH.toText sbh + <> if path == Path.empty + then mempty + else "." <> Path.toText path -- | print remote path printHead :: WriteRepo -> Path -> Text @@ -75,10 +81,40 @@ printHead repo path = printWriteRepo repo <> if path == Path.empty then mempty else ":." <> Path.toText path -type GReadRemoteNamespace a = (a, Maybe ShortBranchHash, Path) - -type ReadRemoteNamespace = GReadRemoteNamespace ReadRepo - -type ReadGitRemoteNamespace = GReadRemoteNamespace ReadGitRepo - -type WriteRemotePath = (WriteRepo, Path) +data ReadRemoteNamespace + = ReadRemoteNamespaceGit ReadGitRemoteNamespace + | ReadRemoteNamespaceShare ReadShareRemoteNamespace + deriving stock (Eq, Show) + +data ReadGitRemoteNamespace = ReadGitRemoteNamespace + { repo :: ReadGitRepo, + sbh :: Maybe ShortBranchHash, + path :: Path + } + deriving stock (Eq, Show) + +data ReadShareRemoteNamespace = ReadShareRemoteNamespace + { server :: ShareRepo, + repo :: Text, + -- sbh :: Maybe ShortBranchHash, -- maybe later + path :: Path + } + deriving stock (Eq, Show) + +data WriteRemotePath + = WriteRemotePathGit WriteGitRemotePath + | WriteRemotePathShare WriteShareRemotePath + deriving stock (Eq, Show) + +data WriteGitRemotePath = WriteGitRemotePath + { repo :: WriteGitRepo, + path :: Path + } + deriving stock (Eq, Show) + +data WriteShareRemotePath = WriteShareRemotePath + { server :: ShareRepo, + repo :: Text, + path :: Path + } + deriving stock (Eq, Show) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index fca896b4eb..f789099d84 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -46,7 +46,7 @@ import qualified Unison.Codebase.Causal.Type as Causal import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo) import qualified Unison.Codebase.Editor.Git as Git import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRemoteNamespace, + ( ReadGitRemoteNamespace (..), ReadGitRepo, WriteGitRepo (..), WriteRepo (..), @@ -691,7 +691,7 @@ viewRemoteBranch' :: Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either C.GitError r) -viewRemoteBranch' (repo, sbh, path) gitBranchBehavior action = UnliftIO.try $ do +viewRemoteBranch' ReadGitRemoteNamespace {repo, sbh, path} gitBranchBehavior action = UnliftIO.try $ do -- set up the cache dir time "Git fetch" $ throwEitherMWith C.GitProtocolError . withRepo repo gitBranchBehavior $ \remoteRepo -> do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index a41bfeccc6..b9548594fb 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -59,7 +59,20 @@ import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN import qualified Unison.Codebase.Editor.Propagate as Propagate -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRemoteNamespace, ReadRepo (ReadRepoGit), ShareRepo (ShareRepo), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit, WriteRepoShare), printNamespace, writePathToRead) +import Unison.Codebase.Editor.RemoteRepo + ( ReadGitRemoteNamespace, + ReadRemoteNamespace (..), + ReadRepo (ReadRepoGit), + ShareRepo (ShareRepo), + WriteGitRepo, + WriteRemotePath, + WriteRepo (WriteRepoGit, WriteRepoShare), + printNamespace, + writePathToRead, + pattern ReadGitRemoteNamespace, + pattern ReadShareRemoteNamespace, + ) +import qualified Unison.Codebase.Editor.RemoteRepo as ReadGitRemoteNamespace (ReadGitRemoteNamespace (..)) import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -416,7 +429,7 @@ loop = do -- todo: show the actual config-loaded namespace <> maybe "(remote namespace from .unisonConfig)" - (uncurry3 printNamespace) + printNamespace orepo <> " " <> p' dest @@ -428,9 +441,9 @@ loop = do CreatePullRequestI {} -> wat LoadPullRequestI base head dest -> "pr.load " - <> uncurry3 printNamespace base + <> printNamespace base <> " " - <> uncurry3 printNamespace head + <> printNamespace head <> " " <> p' dest PushRemoteBranchI {} -> wat @@ -658,11 +671,9 @@ loop = do if Branch.isEmpty0 (Branch.head destb) then unlessGitError do baseb <- case baseRepo of - (ReadRepoGit r, sbh, path) -> - importRemoteGitBranch (r, sbh, path) SyncMode.ShortCircuit Unmodified + ReadRemoteNamespaceGit repo -> importRemoteGitBranch repo SyncMode.ShortCircuit Unmodified headb <- case headRepo of - (ReadRepoGit r, sbh, path) -> - importRemoteGitBranch (r, sbh, path) SyncMode.ShortCircuit Unmodified + ReadRemoteNamespaceGit repo -> importRemoteGitBranch repo SyncMode.ShortCircuit Unmodified lift $ do mergedb <- eval $ Merge Branch.RegularMerge baseb headb squashedb <- eval $ Merge Branch.SquashMerge headb baseb @@ -1499,8 +1510,7 @@ loop = do ns <- maybe (writePathToRead <$> resolveConfiguredUrl Pull path) pure mayRepo lift $ unlessGitError do remoteBranch <- case ns of - (ReadRepoGit r, sbh, path) -> - importRemoteGitBranch (r, sbh, path) syncMode preprocess + ReadRemoteNamespaceGit repo -> importRemoteGitBranch repo syncMode preprocess let unchangedMsg = PullAlreadyUpToDate ns path let destAbs = resolveToAbsolute path let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path @@ -1657,21 +1667,32 @@ loop = do _ -> pure () handleCreatePullRequest :: MonadUnliftIO m => ReadRemoteNamespace -> ReadRemoteNamespace -> Action' m v () -handleCreatePullRequest baseRepo headRepo = do +handleCreatePullRequest baseRepo0 headRepo0 = do root' <- use LoopState.root currentPath' <- use LoopState.currentPath - let viewRemoteBranch repo callback = case repo of - (ReadRepoGit r, sbh, path) -> - viewRemoteGitBranch (r, sbh, path) Git.RequireExistingBranch callback - result <- - join @(Either GitError) <$> viewRemoteBranch baseRepo \baseBranch -> do - viewRemoteBranch headRepo \headBranch -> do - merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch - (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) - pure $ ShowDiffAfterCreatePR baseRepo headRepo ppe diff - case result of - Left gitErr -> respond (Output.GitError gitErr) - Right diff -> respondNumbered diff + case (baseRepo0, headRepo0) of + (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceGit headRepo) -> do + result <- + viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do + viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch -> do + merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch + (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) + pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff + case join result of + Left gitErr -> respond (Output.GitError gitErr) + Right diff -> respondNumbered diff + -- (ReadGitRemoteNamespace baseRepo, ReadShareRemoteNamespace headRepo@(headRepo', _, _)) -> do + -- importRemoteShareBranch headRepo' undefined undefined >>= \case + -- Left () -> respond (error "bad pull") + -- Right headBranch -> do + -- result <- + -- viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do + -- merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch + -- (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) + -- pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff + -- case result of + -- Left gitErr -> respond (Output.GitError gitErr) + -- Right diff -> respondNumbered diff handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v () handleDependents hq = do @@ -1771,7 +1792,16 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do let opts = PushGitBranchOpts {setRoot = False, syncMode} syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch)) sbhLength <- (eval BranchHashLength) - respond (GistCreated sbhLength (WriteRepoGit repo) (Branch.headHash sourceBranch)) + respond + ( GistCreated + ( ReadRemoteNamespaceGit + ReadGitRemoteNamespace + { repo, + ReadGitRemoteNamespace.sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)), + ReadGitRemoteNamespace.path = Path.empty + } + ) + ) Just (remotePath, pushBehavior) -> do let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) withRemoteRoot remoteRoot = do @@ -2210,8 +2240,8 @@ viewRemoteGitBranch ns gitBranchBehavior action = do -- todo: support the full ReadShareRemoteNamespace eventually, in place of (ShareRepo, Text, Path) importRemoteShareBranch :: - ShareRepo -> Text -> Path -> (Branch m -> Action' m v ()) -> Action' m v () -importRemoteShareBranch url repoName path action = undefined + ShareRepo -> Text -> Path -> Action' m v (Either () (Branch m)) +importRemoteShareBranch url repoName path = undefined -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index ca0251f1e8..500f467ca5 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -248,8 +248,8 @@ data Output v | NoOp | -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace. RefusedToPush PushBehavior - | -- | @GistCreated repo hash@ means causal @hash@ was just published to @repo@. - GistCreated Int WriteRepo Branch.Hash + | -- | @GistCreated repo@ means a causal was just published to @repo@. + GistCreated ReadRemoteNamespace | -- | Directs the user to URI to begin an authorization flow. InitiateAuthFlow URI | UnknownCodeServer Text diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 52e7b2e4ae..87b676a18d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -9,7 +9,7 @@ import Data.Void import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as C import qualified Text.Megaparsec.Char.Lexer as L -import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..), ReadRemoteNamespace, ReadRepo (..), WriteGitRepo (..), WriteRemotePath, WriteRepo (..)) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadGitRepo (..), ReadRemoteNamespace (..), WriteGitRemotePath (..), WriteGitRepo (..), WriteRemotePath (..), WriteRepo (..)) import Unison.Codebase.Path (Path (..)) import qualified Unison.Codebase.Path as Path import Unison.Codebase.ShortBranchHash (ShortBranchHash (..)) @@ -42,11 +42,13 @@ repoPath :: P ReadRemoteNamespace repoPath = P.label "generic git repo" $ do protocol <- parseProtocol treeish <- P.optional treeishSuffix - let repo = (ReadRepoGit ReadGitRepo {url = printProtocol protocol, ref = treeish}) + let repo = ReadGitRepo {url = printProtocol protocol, ref = treeish} nshashPath <- P.optional (C.char ':' *> namespaceHashPath) - case nshashPath of - Nothing -> pure (repo, Nothing, Path.empty) - Just (sbh, p) -> pure (repo, sbh, p) + pure do + ReadRemoteNamespaceGit do + case nshashPath of + Nothing -> ReadGitRemoteNamespace {repo, sbh = Nothing, path = Path.empty} + Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path} writeRepo :: P WriteRepo writeRepo = P.label "repo root for writing" $ do @@ -55,10 +57,18 @@ writeRepo = P.label "repo root for writing" $ do pure (WriteRepoGit WriteGitRepo {url = printProtocol uri, branch = treeish}) writeRepoPath :: P WriteRemotePath -writeRepoPath = P.label "generic git repo" $ do +writeRepoPath = P.label "generic write repo" $ do repo <- writeRepo - path <- P.optional (C.char ':' *> absolutePath) - pure (repo, fromMaybe Path.empty path) + case repo of + WriteRepoGit repo -> do + path <- P.optional (C.char ':' *> absolutePath) + pure (WriteRemotePathGit WriteGitRemotePath {repo, path = fromMaybe Path.empty path}) + {- + WriteRepoShare server -> do + repo <- undefined + path <- undefined + pure (WriteRemotePathShare WriteShareRemotePath {server, repo, path}) + -} -- does this not exist somewhere in megaparsec? yes in 7.0 symbol :: Text -> P Text diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index ccafb831ae..1e161c4cb4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -25,15 +25,17 @@ defaultBaseLib = fmap makeNS $ latest <|> release Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) makeNS :: Text -> ReadRemoteNamespace makeNS t = - ( ReadRepoGit - ReadGitRepo - { url = "https://github.com/unisonweb/base", - -- Use the 'v3' branch of base for now. - -- We can revert back to the main branch once enough people have upgraded ucm and - -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm - -- release). - ref = Just "v3" - }, - Nothing, - Path.fromText t - ) + ReadRemoteNamespaceGit + ReadGitRemoteNamespace + { repo = + ReadGitRepo + { url = "https://github.com/unisonweb/base", + -- Use the 'v3' branch of base for now. + -- We can revert back to the main branch once enough people have upgraded ucm and + -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm + -- release). + ref = Just "v3" + }, + sbh = Nothing, + path = Path.fromText t + } diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 3cd2b042cb..6c12200729 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1086,12 +1086,12 @@ push = [] -> Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireNonEmpty SyncMode.ShortCircuit url : rest -> do - (repo, path) <- parsePushPath "url" url + pushPath <- parsePushPath "url" url p <- case rest of [] -> Right Path.relativeEmpty' [path] -> first fromString $ Path.parsePath' path _ -> Left (I.help push) - Right $ Input.PushRemoteBranchI (Just (repo, path)) p PushBehavior.RequireNonEmpty SyncMode.ShortCircuit + Right $ Input.PushRemoteBranchI (Just pushPath) p PushBehavior.RequireNonEmpty SyncMode.ShortCircuit ) pushCreate :: InputPattern @@ -1127,12 +1127,12 @@ pushCreate = [] -> Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireEmpty SyncMode.ShortCircuit url : rest -> do - (repo, path) <- parsePushPath "url" url + pushPath <- parsePushPath "url" url p <- case rest of [] -> Right Path.relativeEmpty' [path] -> first fromString $ Path.parsePath' path _ -> Left (I.help push) - Right $ Input.PushRemoteBranchI (Just (repo, path)) p PushBehavior.RequireEmpty SyncMode.ShortCircuit + Right $ Input.PushRemoteBranchI (Just pushPath) p PushBehavior.RequireEmpty SyncMode.ShortCircuit ) pushExhaustive :: InputPattern @@ -1155,12 +1155,12 @@ pushExhaustive = [] -> Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireNonEmpty SyncMode.Complete url : rest -> do - (repo, path) <- parsePushPath "url" url + pushPath <- parsePushPath "url" url p <- case rest of [] -> Right Path.relativeEmpty' [path] -> first fromString $ Path.parsePath' path _ -> Left (I.help push) - Right $ Input.PushRemoteBranchI (Just (repo, path)) p PushBehavior.RequireNonEmpty SyncMode.Complete + Right $ Input.PushRemoteBranchI (Just pushPath) p PushBehavior.RequireNonEmpty SyncMode.Complete ) createPullRequest :: InputPattern diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 5f1fe73bd3..11a1d70e53 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -23,7 +23,7 @@ import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Text as Text import Data.Tuple (swap) -import Data.Tuple.Extra (dupe, uncurry3) +import Data.Tuple.Extra (dupe) import Network.URI (URI) import System.Directory ( canonicalizePath, @@ -506,11 +506,9 @@ showListEdits patch ppe = prettyURI :: URI -> Pretty prettyURI = P.bold . P.blue . P.shown -prettyRemoteNamespace :: - ReadRemoteNamespace -> - Pretty +prettyRemoteNamespace :: ReadRemoteNamespace -> Pretty prettyRemoteNamespace = - P.group . P.blue . P.text . uncurry3 RemoteRepo.printNamespace + P.group . P.blue . P.text . RemoteRepo.printNamespace notifyUser :: forall v. Var v => FilePath -> Output v -> IO Pretty notifyUser dir o = case o of @@ -1134,7 +1132,7 @@ notifyUser dir o = case o of P.wrap $ "I just finished importing the branch" <> P.red (P.shown h) <> "from" - <> P.red (prettyRemoteNamespace (over _1 ReadRepoGit ns)) + <> P.red (prettyRemoteNamespace (RemoteRepo.ReadRemoteNamespaceGit ns)) <> "but now I can't find it." CouldntFindRemoteBranch repo path -> P.wrap $ @@ -1525,16 +1523,13 @@ notifyUser dir o = case o of "", "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" ] - GistCreated hqLength repo hash -> + GistCreated remoteNamespace -> pure $ P.lines [ "Gist created. Pull via:", "", P.indentN 2 (IP.patternName IP.pull <> " " <> prettyRemoteNamespace remoteNamespace) ] - where - remoteNamespace = - (RemoteRepo.writeToRead repo, Just (SBH.fromHash hqLength hash), Path.empty) InitiateAuthFlow authURI -> do pure $ P.wrap $ diff --git a/unison-cli/src/Unison/CommandLine/Welcome.hs b/unison-cli/src/Unison/CommandLine/Welcome.hs index 4f3447071f..59b9b10b9e 100644 --- a/unison-cli/src/Unison/CommandLine/Welcome.hs +++ b/unison-cli/src/Unison/CommandLine/Welcome.hs @@ -7,7 +7,7 @@ import System.Random (randomRIO) import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Unison.Codebase.Editor.Input -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadRemoteNamespace (..)) import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SyncMode as SyncMode @@ -25,7 +25,7 @@ data Welcome = Welcome } data DownloadBase - = DownloadBase ReadRemoteNamespace + = DownloadBase ReadGitRemoteNamespace | DontDownloadBase -- Previously Created is different from Previously Onboarded because a user can @@ -38,7 +38,7 @@ data CodebaseInitStatus data Onboarding = Init CodebaseInitStatus -- Can transition to [DownloadingBase, Author, Finished, PreviouslyOnboarded] - | DownloadingBase ReadRemoteNamespace -- Can transition to [Author, Finished] + | DownloadingBase ReadGitRemoteNamespace -- Can transition to [Author, Finished] | Author -- Can transition to [Finished] -- End States | Finished @@ -48,12 +48,18 @@ welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> Text -> Welcome welcome initStatus downloadBase filePath unisonVersion = Welcome (Init initStatus) downloadBase filePath unisonVersion -pullBase :: ReadRemoteNamespace -> Either Event Input +pullBase :: ReadGitRemoteNamespace -> Either Event Input pullBase ns = let seg = NameSegment "base" rootPath = Path.Path {Path.toSeq = singleton seg} abs = Path.Absolute {Path.unabsolute = rootPath} - pullRemote = PullRemoteBranchI (Just ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete PullWithHistory Verbosity.Silent + pullRemote = + PullRemoteBranchI + (Just (ReadRemoteNamespaceGit ns)) + (Path.Path' {Path.unPath' = Left abs}) + SyncMode.Complete + PullWithHistory + Verbosity.Silent in Right pullRemote run :: Codebase IO v a -> Welcome -> IO [Either Event Input] @@ -71,7 +77,7 @@ run codebase Welcome {onboarding = onboarding, downloadBase = downloadBase, watc go PreviouslyOnboarded (headerMsg : acc) where headerMsg = toInput (header version) - DownloadingBase ns@(_, _, path) -> + DownloadingBase ns@ReadGitRemoteNamespace {path} -> go Author ([pullBaseInput, downloadMsg] ++ acc) where downloadMsg = Right $ CreateMessage (downloading path) @@ -98,7 +104,7 @@ determineFirstStep downloadBase codebase = do case downloadBase of DownloadBase ns | isEmptyCodebase -> - pure $ DownloadingBase ns + pure $ DownloadingBase ns _ -> pure PreviouslyOnboarded From d2940e1fa932b456d1d0fdb990840a52bb95e54b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 11 May 2022 20:23:05 -0400 Subject: [PATCH 208/529] more busted work --- .../src/Unison/Codebase/Editor/HandleInput.hs | 144 ++++++++++-------- .../src/Unison/Codebase/Editor/UriParser.hs | 32 ++-- 2 files changed, 95 insertions(+), 81 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index b9548594fb..f93121da44 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -64,11 +64,14 @@ import Unison.Codebase.Editor.RemoteRepo ReadRemoteNamespace (..), ReadRepo (ReadRepoGit), ShareRepo (ShareRepo), + WriteGitRemotePath (..), WriteGitRepo, - WriteRemotePath, + WriteRemotePath (..), WriteRepo (WriteRepoGit, WriteRepoShare), + WriteShareRemotePath (..), printNamespace, writePathToRead, + writeToReadGit, pattern ReadGitRemoteNamespace, pattern ReadShareRemoteNamespace, ) @@ -1681,18 +1684,19 @@ handleCreatePullRequest baseRepo0 headRepo0 = do case join result of Left gitErr -> respond (Output.GitError gitErr) Right diff -> respondNumbered diff - -- (ReadGitRemoteNamespace baseRepo, ReadShareRemoteNamespace headRepo@(headRepo', _, _)) -> do - -- importRemoteShareBranch headRepo' undefined undefined >>= \case - -- Left () -> respond (error "bad pull") - -- Right headBranch -> do - -- result <- - -- viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do - -- merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch - -- (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) - -- pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff - -- case result of - -- Left gitErr -> respond (Output.GitError gitErr) - -- Right diff -> respondNumbered diff + +-- (ReadGitRemoteNamespace baseRepo, ReadShareRemoteNamespace headRepo@(headRepo', _, _)) -> do +-- importRemoteShareBranch headRepo' undefined undefined >>= \case +-- Left () -> respond (error "bad pull") +-- Right headBranch -> do +-- result <- +-- viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do +-- merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch +-- (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) +-- pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff +-- case result of +-- Left gitErr -> respond (Output.GitError gitErr) +-- Right diff -> respondNumbered diff handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v () handleDependents hq = do @@ -1748,81 +1752,89 @@ handlePullFromUnisonShare remoteRepo remotePath = undefined -- Right causalHash -> do -- undefined +-- | Either perform a "normal" push (updating a remote path), which takes a 'PushBehavior' (to control whether creating +-- a new namespace is allowed), or perform a "gisty" push, which doesn't update any paths (and also is currently only +-- uploaded for remote git repos, not remote Share repos). +data PushFlavor f + = NormalPush (f WriteRemotePath) PushBehavior + | GistyPush (f WriteGitRepo) + -- | Handle a @push@ command. handlePushRemoteBranch :: forall m v. MonadUnliftIO m => -- | The repo to push to. If missing, it is looked up in `.unisonConfig`. - Maybe WriteRemotePath -> + PushFlavor Maybe -> -- | The local path to push. If relative, it's resolved relative to the current path (`cd`). Path' -> - -- | The push behavior (whether the remote branch is required to be empty or non-empty). - PushBehavior -> SyncMode.SyncMode -> Action' m v () -handlePushRemoteBranch mayRepo path pushBehavior syncMode = do - unlessError do - (repo, remotePath) <- maybe (resolveConfiguredUrl Push path) pure mayRepo - lift (doPushRemoteBranch repo path syncMode (Just (remotePath, pushBehavior))) +handlePushRemoteBranch pushFlavor0 path syncMode = do + resolvePushFlavor path pushFlavor0 >>= \case + Left output -> respond output + Right pushFlavor -> doPushRemoteBranch pushFlavor path syncMode + +resolvePushFlavor :: Path' -> PushFlavor Maybe -> Action' m v (Either (Output v) (PushFlavor Identity)) +resolvePushFlavor localPath = \case + NormalPush Nothing pushBehavior -> + runExceptT do + remotePath <- resolveConfiguredUrl Push localPath + pure (NormalPush (Identity (WriteRemotePathGit remotePath)) pushBehavior) + NormalPush (Just repo) pushBehavior -> pure (Right (NormalPush (Identity repo) pushBehavior)) + GistyPush Nothing -> + runExceptT do + WriteGitRemotePath {repo} <- resolveConfiguredUrl Push localPath + pure (GistyPush (Identity repo)) + GistyPush (Just repo) -> pure (Right (GistyPush (Identity repo))) -- Internal helper that implements pushing to a remote repo, which generalizes @gist@ and @push@. doPushRemoteBranch :: forall m v. MonadUnliftIO m => -- | The repo to push to. - WriteRepo -> + PushFlavor Identity -> -- | The local path to push. If relative, it's resolved relative to the current path (`cd`). Path' -> SyncMode.SyncMode -> - -- | The remote target. If missing, the given branch contents should be pushed to the remote repo without updating the - -- root namespace (a gist). - Maybe (Path, PushBehavior) -> Action' m v () -doPushRemoteBranch repo localPath syncMode remoteTarget = do +doPushRemoteBranch pushFlavor localPath syncMode = do sourceBranch <- do currentPath' <- use LoopState.currentPath getAt (Path.resolve currentPath' localPath) - case repo of - WriteRepoGit repo -> + case pushFlavor of + NormalPush (Identity (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath})) pushBehavior -> unlessError do - withExceptT Output.GitError do - case remoteTarget of - Nothing -> do - let opts = PushGitBranchOpts {setRoot = False, syncMode} - syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch)) - sbhLength <- (eval BranchHashLength) - respond - ( GistCreated - ( ReadRemoteNamespaceGit - ReadGitRemoteNamespace - { repo, - ReadGitRemoteNamespace.sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)), - ReadGitRemoteNamespace.path = Path.empty - } - ) - ) - Just (remotePath, pushBehavior) -> do - let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) - withRemoteRoot remoteRoot = do - let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this - -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. - f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing - Branch.modifyAtM remotePath f remoteRoot & \case - Nothing -> pure (Left $ RefusedToPush pushBehavior) - Just newRemoteRoot -> pure (Right newRemoteRoot) - let opts = PushGitBranchOpts {setRoot = True, syncMode} - syncGitRemoteBranch repo opts withRemoteRoot >>= \case - Left output -> respond output - Right _branch -> respond Success - WriteRepoShare repo -> do - case remoteTarget of - Nothing -> - -- do a gist - error "don't do a gist" - Just (remotePath, pushBehavior) -> - -- let (userSegment :| pathSegments) = undefined - error "handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior" + let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) + withRemoteRoot remoteRoot = do + let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this + -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. + f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing + Branch.modifyAtM remotePath f remoteRoot & \case + Nothing -> pure (Left $ RefusedToPush pushBehavior) + Just newRemoteRoot -> pure (Right newRemoteRoot) + let opts = PushGitBranchOpts {setRoot = True, syncMode} + withExceptT Output.GitError (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case + Left output -> respond output + Right _branch -> respond Success + NormalPush (Identity (WriteRemotePathShare WriteShareRemotePath {server, repo, path = remotePath})) pushBehavior -> + -- let (userSegment :| pathSegments) = undefined + error "handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior" + GistyPush (Identity repo) -> do + unlessError do + let opts = PushGitBranchOpts {setRoot = False, syncMode} + withExceptT Output.GitError (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))) + sbhLength <- eval BranchHashLength + respond + ( GistCreated + ( ReadRemoteNamespaceGit + ReadGitRemoteNamespace + { repo = writeToReadGit repo, + ReadGitRemoteNamespace.sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)), + ReadGitRemoteNamespace.path = Path.empty + } + ) + ) where -- Per `pushBehavior`, we are either: -- @@ -2202,14 +2214,14 @@ manageLinks silent srcs mdValues op = do resolveConfiguredUrl :: PushPull -> Path' -> - ExceptT (Output v) (Action m i v) WriteRemotePath + ExceptT (Output v) (Action m i v) WriteGitRemotePath resolveConfiguredUrl pushPull destPath' = ExceptT do currentPath' <- use LoopState.currentPath let destPath = Path.resolve currentPath' destPath' let configKey = gitUrlKey destPath (eval . ConfigLookup) configKey >>= \case Just url -> - case P.parse UriParser.writeRepoPath (Text.unpack configKey) url of + case P.parse UriParser.writeGitRepoPath (Text.unpack configKey) url of Left e -> pure . Left $ ConfiguredGitUrlParseError pushPull destPath' url (show e) diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 87b676a18d..7fbda71e55 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Unison.Codebase.Editor.UriParser (repoPath, writeRepo, writeRepoPath) where +module Unison.Codebase.Editor.UriParser (repoPath, writeRepo, writeRepoPath, writeGitRepoPath) where import Data.Char (isAlphaNum, isDigit, isSpace) import Data.Sequence as Seq @@ -51,24 +51,26 @@ repoPath = P.label "generic git repo" $ do Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path} writeRepo :: P WriteRepo -writeRepo = P.label "repo root for writing" $ do +writeRepo = + -- FIXME parse share paths too + WriteRepoGit <$> writeGitRepo + +writeGitRepo :: P WriteGitRepo +writeGitRepo = P.label "repo root for writing" $ do uri <- parseProtocol treeish <- P.optional treeishSuffix - pure (WriteRepoGit WriteGitRepo {url = printProtocol uri, branch = treeish}) + pure WriteGitRepo {url = printProtocol uri, branch = treeish} writeRepoPath :: P WriteRemotePath -writeRepoPath = P.label "generic write repo" $ do - repo <- writeRepo - case repo of - WriteRepoGit repo -> do - path <- P.optional (C.char ':' *> absolutePath) - pure (WriteRemotePathGit WriteGitRemotePath {repo, path = fromMaybe Path.empty path}) - {- - WriteRepoShare server -> do - repo <- undefined - path <- undefined - pure (WriteRemotePathShare WriteShareRemotePath {server, repo, path}) - -} +writeRepoPath = + -- FIXME parse share paths too + WriteRemotePathGit <$> writeGitRepoPath + +writeGitRepoPath :: P WriteGitRemotePath +writeGitRepoPath = P.label "generic write repo" $ do + repo <- writeGitRepo + path <- P.optional (C.char ':' *> absolutePath) + pure WriteGitRemotePath {repo, path = fromMaybe Path.empty path} -- does this not exist somewhere in megaparsec? yes in 7.0 symbol :: Text -> P Text From 1304f3e3e8e3ff88771c4cc5abc23fdf4a80a6ab Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 12 May 2022 09:51:26 -0400 Subject: [PATCH 209/529] fix a few compiler errors and make a better push type --- .../src/Unison/Codebase/Editor/HandleInput.hs | 59 +++++++++---------- .../src/Unison/Codebase/Editor/Input.hs | 2 +- .../src/Unison/Codebase/Editor/UriParser.hs | 20 ++++++- .../Unison/Codebase/Editor/VersionParser.hs | 31 +++++----- .../src/Unison/CommandLine/InputPatterns.hs | 10 ++-- unison-cli/unison/Main.hs | 4 +- 6 files changed, 67 insertions(+), 59 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f93121da44..cb2c7d8055 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1737,7 +1737,7 @@ handleDependents hq = do -- | Handle a @gist@ command. handleGist :: MonadUnliftIO m => GistInput -> Action' m v () handleGist (GistInput repo) = - doPushRemoteBranch repo Path.relativeEmpty' SyncMode.ShortCircuit Nothing + doPushRemoteBranch (GistyPush repo) Path.relativeEmpty' SyncMode.ShortCircuit handlePullFromUnisonShare :: MonadIO m => Text -> Path -> Action' m v () handlePullFromUnisonShare remoteRepo remotePath = undefined @@ -1752,47 +1752,42 @@ handlePullFromUnisonShare remoteRepo remotePath = undefined -- Right causalHash -> do -- undefined --- | Either perform a "normal" push (updating a remote path), which takes a 'PushBehavior' (to control whether creating --- a new namespace is allowed), or perform a "gisty" push, which doesn't update any paths (and also is currently only --- uploaded for remote git repos, not remote Share repos). -data PushFlavor f - = NormalPush (f WriteRemotePath) PushBehavior - | GistyPush (f WriteGitRepo) - -- | Handle a @push@ command. handlePushRemoteBranch :: forall m v. MonadUnliftIO m => -- | The repo to push to. If missing, it is looked up in `.unisonConfig`. - PushFlavor Maybe -> + Maybe WriteRemotePath -> -- | The local path to push. If relative, it's resolved relative to the current path (`cd`). Path' -> + -- | The push behavior (whether the remote branch is required to be empty or non-empty). + PushBehavior -> SyncMode.SyncMode -> Action' m v () -handlePushRemoteBranch pushFlavor0 path syncMode = do - resolvePushFlavor path pushFlavor0 >>= \case - Left output -> respond output - Right pushFlavor -> doPushRemoteBranch pushFlavor path syncMode - -resolvePushFlavor :: Path' -> PushFlavor Maybe -> Action' m v (Either (Output v) (PushFlavor Identity)) -resolvePushFlavor localPath = \case - NormalPush Nothing pushBehavior -> - runExceptT do - remotePath <- resolveConfiguredUrl Push localPath - pure (NormalPush (Identity (WriteRemotePathGit remotePath)) pushBehavior) - NormalPush (Just repo) pushBehavior -> pure (Right (NormalPush (Identity repo) pushBehavior)) - GistyPush Nothing -> - runExceptT do - WriteGitRemotePath {repo} <- resolveConfiguredUrl Push localPath - pure (GistyPush (Identity repo)) - GistyPush (Just repo) -> pure (Right (GistyPush (Identity repo))) +handlePushRemoteBranch mayRepo path pushBehavior syncMode = + case mayRepo of + Nothing -> + runExceptT (resolveConfiguredUrl Push path) >>= \case + Left output -> respond output + Right repo -> push repo + Just repo -> push repo + where + push repo = + doPushRemoteBranch (NormalPush repo pushBehavior) path syncMode + +-- | Either perform a "normal" push (updating a remote path), which takes a 'PushBehavior' (to control whether creating +-- a new namespace is allowed), or perform a "gisty" push, which doesn't update any paths (and also is currently only +-- uploaded for remote git repos, not remote Share repos). +data PushFlavor + = NormalPush WriteRemotePath PushBehavior + | GistyPush WriteGitRepo -- Internal helper that implements pushing to a remote repo, which generalizes @gist@ and @push@. doPushRemoteBranch :: forall m v. MonadUnliftIO m => -- | The repo to push to. - PushFlavor Identity -> + PushFlavor -> -- | The local path to push. If relative, it's resolved relative to the current path (`cd`). Path' -> SyncMode.SyncMode -> @@ -1803,7 +1798,7 @@ doPushRemoteBranch pushFlavor localPath syncMode = do getAt (Path.resolve currentPath' localPath) case pushFlavor of - NormalPush (Identity (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath})) pushBehavior -> + NormalPush (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath}) pushBehavior -> unlessError do let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) withRemoteRoot remoteRoot = do @@ -1817,10 +1812,10 @@ doPushRemoteBranch pushFlavor localPath syncMode = do withExceptT Output.GitError (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case Left output -> respond output Right _branch -> respond Success - NormalPush (Identity (WriteRemotePathShare WriteShareRemotePath {server, repo, path = remotePath})) pushBehavior -> + NormalPush (WriteRemotePathShare WriteShareRemotePath {server, repo, path = remotePath}) pushBehavior -> -- let (userSegment :| pathSegments) = undefined error "handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior" - GistyPush (Identity repo) -> do + GistyPush repo -> do unlessError do let opts = PushGitBranchOpts {setRoot = False, syncMode} withExceptT Output.GitError (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))) @@ -2214,14 +2209,14 @@ manageLinks silent srcs mdValues op = do resolveConfiguredUrl :: PushPull -> Path' -> - ExceptT (Output v) (Action m i v) WriteGitRemotePath + ExceptT (Output v) (Action m i v) WriteRemotePath resolveConfiguredUrl pushPull destPath' = ExceptT do currentPath' <- use LoopState.currentPath let destPath = Path.resolve currentPath' destPath' let configKey = gitUrlKey destPath (eval . ConfigLookup) configKey >>= \case Just url -> - case P.parse UriParser.writeGitRepoPath (Text.unpack configKey) url of + case P.parse UriParser.writeRepoPath (Text.unpack configKey) url of Left e -> pure . Left $ ConfiguredGitUrlParseError pushPull destPath' url (show e) diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index b9e19d273d..4071bb4585 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -191,7 +191,7 @@ data Input -- | @"push.gist repo"@ pushes the contents of the current namespace to @repo@. data GistInput = GistInput - { repo :: WriteRepo + { repo :: WriteGitRepo } deriving stock (Eq, Show) diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 7fbda71e55..55d1b2c3c6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -1,6 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -module Unison.Codebase.Editor.UriParser (repoPath, writeRepo, writeRepoPath, writeGitRepoPath) where +module Unison.Codebase.Editor.UriParser + ( repoPath, + writeGitRepo, + writeRepo, + writeRepoPath, + ) +where import Data.Char (isAlphaNum, isDigit, isSpace) import Data.Sequence as Seq @@ -9,7 +15,15 @@ import Data.Void import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as C import qualified Text.Megaparsec.Char.Lexer as L -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadGitRepo (..), ReadRemoteNamespace (..), WriteGitRemotePath (..), WriteGitRepo (..), WriteRemotePath (..), WriteRepo (..)) +import Unison.Codebase.Editor.RemoteRepo + ( ReadGitRemoteNamespace (..), + ReadGitRepo (..), + ReadRemoteNamespace (..), + WriteGitRemotePath (..), + WriteGitRepo (..), + WriteRemotePath (..), + WriteRepo (..), + ) import Unison.Codebase.Path (Path (..)) import qualified Unison.Codebase.Path as Path import Unison.Codebase.ShortBranchHash (ShortBranchHash (..)) @@ -50,9 +64,9 @@ repoPath = P.label "generic git repo" $ do Nothing -> ReadGitRemoteNamespace {repo, sbh = Nothing, path = Path.empty} Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path} +-- FIXME parse share paths too writeRepo :: P WriteRepo writeRepo = - -- FIXME parse share paths too WriteRepoGit <$> writeGitRepo writeGitRepo :: P WriteGitRepo diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index 1e161c4cb4..24a1f42b5c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -15,7 +15,7 @@ import qualified Unison.Codebase.Path as Path -- "release/M1j" -> "releases._M1j" -- "release/M1j.2" -> "releases._M1j_2" -- "latest-*" -> "trunk" -defaultBaseLib :: Parsec Void Text ReadRemoteNamespace +defaultBaseLib :: Parsec Void Text ReadGitRemoteNamespace defaultBaseLib = fmap makeNS $ latest <|> release where latest, release, version :: Parsec Void Text Text @@ -23,19 +23,18 @@ defaultBaseLib = fmap makeNS $ latest <|> release release = fmap ("releases._" <>) $ "release/" *> version <* eof version = do Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) - makeNS :: Text -> ReadRemoteNamespace + makeNS :: Text -> ReadGitRemoteNamespace makeNS t = - ReadRemoteNamespaceGit - ReadGitRemoteNamespace - { repo = - ReadGitRepo - { url = "https://github.com/unisonweb/base", - -- Use the 'v3' branch of base for now. - -- We can revert back to the main branch once enough people have upgraded ucm and - -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm - -- release). - ref = Just "v3" - }, - sbh = Nothing, - path = Path.fromText t - } + ReadGitRemoteNamespace + { repo = + ReadGitRepo + { url = "https://github.com/unisonweb/base", + -- Use the 'v3' branch of base for now. + -- We can revert back to the main branch once enough people have upgraded ucm and + -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm + -- release). + ref = Just "v3" + }, + sbh = Nothing, + path = Path.fromText t + } diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 6c12200729..4ecc2fdc12 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -21,7 +21,7 @@ import qualified Unison.Codebase.Branch.Merge as Branch import qualified Unison.Codebase.Branch.Names as Branch import Unison.Codebase.Editor.Input (Input) import qualified Unison.Codebase.Editor.Input as Input -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemotePath, WriteRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemotePath) import qualified Unison.Codebase.Editor.SlurpResult as SR import qualified Unison.Codebase.Editor.UriParser as UriParser import qualified Unison.Codebase.Path as Path @@ -1263,11 +1263,11 @@ prettyPrintParseError input = \case message = [expected] <> catMaybes [found] in P.oxfordCommasWith "." message -parseWriteRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteRepo -parseWriteRepo label input = do +parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitRepo +parseWriteGitRepo label input = do first (fromString . show) -- turn any parsing errors into a Pretty. - (P.parse UriParser.writeRepo label (Text.pack input)) + (P.parse UriParser.writeGitRepo label (Text.pack input)) parsePushPath :: String -> String -> Either (P.Pretty P.ColorText) WriteRemotePath parsePushPath label input = do @@ -2002,7 +2002,7 @@ gist = ) ( \case [repoString] -> do - repo <- parseWriteRepo "repo" repoString + repo <- parseWriteGitRepo "repo" repoString pure (Input.GistI (Input.GistInput repo)) _ -> Left (showPatternHelp gist) ) diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index 2dfabfb76c..6df256e56a 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -50,7 +50,7 @@ import Text.Pretty.Simple (pHPrint) import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Editor.Input as Input -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace) import qualified Unison.Codebase.Editor.VersionParser as VP import Unison.Codebase.Execute (execute) import Unison.Codebase.Init (CodebaseInitOptions (..), InitError (..), InitResult (..), SpecifiedCodebase (..)) @@ -418,7 +418,7 @@ isFlag f arg = arg == f || arg == "-" ++ f || arg == "--" ++ f getConfigFilePath :: Maybe FilePath -> IO FilePath getConfigFilePath mcodepath = (FP. ".unisonConfig") <$> Codebase.getCodebaseDir mcodepath -defaultBaseLib :: Maybe ReadRemoteNamespace +defaultBaseLib :: Maybe ReadGitRemoteNamespace defaultBaseLib = rightMay $ runParser VP.defaultBaseLib "version" gitRef From 79618e75781f5c8cb7133254f141723c7284712c Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 12 May 2022 10:08:44 -0400 Subject: [PATCH 210/529] pull git/share case --- .../src/Unison/Codebase/Editor/HandleInput.hs | 43 +++++++++---------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index cb2c7d8055..a05cfdb634 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -60,9 +60,10 @@ import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN import qualified Unison.Codebase.Editor.Propagate as Propagate import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRemoteNamespace, + ( ReadGitRemoteNamespace (..), ReadRemoteNamespace (..), ReadRepo (ReadRepoGit), + ReadShareRemoteNamespace (..), ShareRepo (ShareRepo), WriteGitRemotePath (..), WriteGitRepo, @@ -72,8 +73,6 @@ import Unison.Codebase.Editor.RemoteRepo printNamespace, writePathToRead, writeToReadGit, - pattern ReadGitRemoteNamespace, - pattern ReadShareRemoteNamespace, ) import qualified Unison.Codebase.Editor.RemoteRepo as ReadGitRemoteNamespace (ReadGitRemoteNamespace (..)) import qualified Unison.Codebase.Editor.Slurp as Slurp @@ -1673,30 +1672,31 @@ handleCreatePullRequest :: MonadUnliftIO m => ReadRemoteNamespace -> ReadRemoteN handleCreatePullRequest baseRepo0 headRepo0 = do root' <- use LoopState.root currentPath' <- use LoopState.currentPath + + let block baseBranch headBranch = do + merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch + (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) + pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff + case (baseRepo0, headRepo0) of (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceGit headRepo) -> do result <- viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch -> do - merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch - (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) - pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff + block baseBranch headBranch case join result of Left gitErr -> respond (Output.GitError gitErr) Right diff -> respondNumbered diff - --- (ReadGitRemoteNamespace baseRepo, ReadShareRemoteNamespace headRepo@(headRepo', _, _)) -> do --- importRemoteShareBranch headRepo' undefined undefined >>= \case --- Left () -> respond (error "bad pull") --- Right headBranch -> do --- result <- --- viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do --- merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch --- (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) --- pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff --- case result of --- Left gitErr -> respond (Output.GitError gitErr) --- Right diff -> respondNumbered diff + (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceShare headRepo) -> do + importRemoteShareBranch headRepo >>= \case + Left () -> respond (error "bad pull") + Right headBranch -> do + result <- + viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do + block baseBranch headBranch + case result of + Left gitErr -> respond (Output.GitError gitErr) + Right diff -> respondNumbered diff handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v () handleDependents hq = do @@ -2246,9 +2246,8 @@ viewRemoteGitBranch ns gitBranchBehavior action = do eval $ ViewRemoteGitBranch ns gitBranchBehavior action -- todo: support the full ReadShareRemoteNamespace eventually, in place of (ShareRepo, Text, Path) -importRemoteShareBranch :: - ShareRepo -> Text -> Path -> Action' m v (Either () (Branch m)) -importRemoteShareBranch url repoName path = undefined +importRemoteShareBranch :: ReadShareRemoteNamespace -> Action' m v (Either () (Branch m)) +importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = undefined -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) From 05b5469e48b6511e8973b7284ea7a10a5b4c788f Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 12 May 2022 11:24:43 -0400 Subject: [PATCH 211/529] importRemoteShareBranch and handleCreatePullRequest --- .../src/Unison/Codebase/Editor/HandleInput.hs | 86 ++++++++++++------- 1 file changed, 56 insertions(+), 30 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index a05cfdb634..0615666fa5 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -29,6 +29,7 @@ import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) import qualified Servant.Client as Servant import qualified Text.Megaparsec as P +import U.Codebase.Causal (Causal (causalHash)) import qualified U.Codebase.Sqlite.Operations as Ops import U.Util.Timing (unsafeTime) import qualified Unison.ABT as ABT @@ -37,6 +38,7 @@ import qualified Unison.Builtin as Builtin import qualified Unison.Builtin.Decls as DD import qualified Unison.Builtin.Terms as Builtin import Unison.Codebase (Preprocessing (..), PushGitBranchOpts (..)) +import qualified Unison.Codebase as Codebase import Unison.Codebase.Branch (Branch (..), Branch0 (..)) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Branch.Merge as Branch @@ -62,19 +64,16 @@ import qualified Unison.Codebase.Editor.Propagate as Propagate import Unison.Codebase.Editor.RemoteRepo ( ReadGitRemoteNamespace (..), ReadRemoteNamespace (..), - ReadRepo (ReadRepoGit), ReadShareRemoteNamespace (..), ShareRepo (ShareRepo), WriteGitRemotePath (..), WriteGitRepo, WriteRemotePath (..), - WriteRepo (WriteRepoGit, WriteRepoShare), WriteShareRemotePath (..), printNamespace, writePathToRead, writeToReadGit, ) -import qualified Unison.Codebase.Editor.RemoteRepo as ReadGitRemoteNamespace (ReadGitRemoteNamespace (..)) import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -95,6 +94,7 @@ import qualified Unison.Codebase.PushBehavior as PushBehavior import qualified Unison.Codebase.Reflog as Reflog import Unison.Codebase.ShortBranchHash (ShortBranchHash) import qualified Unison.Codebase.ShortBranchHash as SBH +import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import qualified Unison.Codebase.SyncMode as SyncMode import Unison.Codebase.TermEdit (TermEdit (..)) import qualified Unison.Codebase.TermEdit as TermEdit @@ -1668,12 +1668,22 @@ loop = do Right input -> LoopState.lastInput .= Just input _ -> pure () -handleCreatePullRequest :: MonadUnliftIO m => ReadRemoteNamespace -> ReadRemoteNamespace -> Action' m v () +handleCreatePullRequest :: forall m v. MonadUnliftIO m => ReadRemoteNamespace -> ReadRemoteNamespace -> Action' m v () handleCreatePullRequest baseRepo0 headRepo0 = do root' <- use LoopState.root currentPath' <- use LoopState.currentPath - let block baseBranch headBranch = do + -- One of these needs a callback and the other doesn't. you might think you can get around that problem with + -- a helper function to unify the two cases, but we tried that and they were in such different monads that it + -- was hard to do. + -- viewRemoteBranch' :: forall r. ReadGitRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r), + -- because there's no MonadUnliftIO instance on Action. + -- We need `Command` to go away (the FreeT layer goes away), + -- We have the StateT layer goes away (can put it into an IORef in the environment), + -- We have the MaybeT layer that signals end of input (can just been an IORef bool that we check before looping), + -- and once all those things become IO, we can add a MonadUnliftIO instance on Action, and unify these cases. + let mergeAndDiff :: MonadCommand n m i v => Branch m -> Branch m -> n (NumberedOutput v) + mergeAndDiff baseBranch headBranch = do merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff @@ -1681,22 +1691,41 @@ handleCreatePullRequest baseRepo0 headRepo0 = do case (baseRepo0, headRepo0) of (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceGit headRepo) -> do result <- - viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do - viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch -> do - block baseBranch headBranch + viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> + viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch -> + mergeAndDiff baseBranch headBranch case join result of Left gitErr -> respond (Output.GitError gitErr) Right diff -> respondNumbered diff - (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceShare headRepo) -> do + (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceShare headRepo) -> importRemoteShareBranch headRepo >>= \case - Left () -> respond (error "bad pull") + Left () -> respond (error "bad pull because" headRepo) Right headBranch -> do result <- - viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do - block baseBranch headBranch + viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> + mergeAndDiff baseBranch headBranch case result of Left gitErr -> respond (Output.GitError gitErr) Right diff -> respondNumbered diff + (ReadRemoteNamespaceShare baseRepo, ReadRemoteNamespaceGit headRepo) -> + importRemoteShareBranch baseRepo >>= \case + Left () -> respond (error "bad pull because" baseRepo) + Right baseBranch -> do + result <- + viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch -> + mergeAndDiff baseBranch headBranch + case result of + Left gitErr -> respond (Output.GitError gitErr) + Right diff -> respondNumbered diff + (ReadRemoteNamespaceShare baseRepo, ReadRemoteNamespaceShare headRepo) -> + importRemoteShareBranch headRepo >>= \case + Left () -> respond (error "bad pull because" headRepo) + Right headBranch -> + importRemoteShareBranch baseRepo >>= \case + Left () -> respond (error "bad pull because" baseRepo) + Right baseBranch -> do + diff <- mergeAndDiff baseBranch headBranch + respondNumbered diff handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v () handleDependents hq = do @@ -1739,19 +1768,6 @@ handleGist :: MonadUnliftIO m => GistInput -> Action' m v () handleGist (GistInput repo) = doPushRemoteBranch (GistyPush repo) Path.relativeEmpty' SyncMode.ShortCircuit -handlePullFromUnisonShare :: MonadIO m => Text -> Path -> Action' m v () -handlePullFromUnisonShare remoteRepo remotePath = undefined - --- let path = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) - --- LoopState.Env {authHTTPClient, codebase = Codebase {connection}} <- ask - --- liftIO (Share.pull authHTTPClient unisonShareUrl connection path) >>= \case --- Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined --- Left (Share.PullErrorNoHistoryAtPath repoPath) -> undefined --- Right causalHash -> do --- undefined - -- | Handle a @push@ command. handlePushRemoteBranch :: forall m v. @@ -1825,8 +1841,8 @@ doPushRemoteBranch pushFlavor localPath syncMode = do ( ReadRemoteNamespaceGit ReadGitRemoteNamespace { repo = writeToReadGit repo, - ReadGitRemoteNamespace.sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)), - ReadGitRemoteNamespace.path = Path.empty + sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)), + path = Path.empty } ) ) @@ -2245,9 +2261,19 @@ viewRemoteGitBranch :: viewRemoteGitBranch ns gitBranchBehavior action = do eval $ ViewRemoteGitBranch ns gitBranchBehavior action --- todo: support the full ReadShareRemoteNamespace eventually, in place of (ShareRepo, Text, Path) -importRemoteShareBranch :: ReadShareRemoteNamespace -> Action' m v (Either () (Branch m)) -importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = undefined +importRemoteShareBranch :: MonadIO m => ReadShareRemoteNamespace -> Action' m v (Either () (Branch m)) +importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do + let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) + LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask + liftIO (Share.pull authHTTPClient (shareRepoToBaseURL server) connection shareFlavoredPath) >>= \case + Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> + error "Share.GetCausalHashByPathErrorNoReadPermission" + Left (Share.PullErrorNoHistoryAtPath repoPath) -> + error "Share.PullErrorNoHistoryAtPath" + Right causalHash -> do + (eval . Eval) (Codebase.getBranchForHash codebase (Cv.branchHash2to1 causalHash)) >>= \case + Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" + Just branch -> pure (Right branch) -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) From a3856ba81d19d517949da7e5ef457d2017e630ac Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 12 May 2022 15:12:58 -0400 Subject: [PATCH 212/529] fill in call to push to unison share --- .../src/Unison/Codebase/SqliteCodebase.hs | 2 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 93 +++++++++++-------- 2 files changed, 54 insertions(+), 41 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index f789099d84..f49b40bb5c 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -478,7 +478,7 @@ sqliteCodebase debugName root localOrRemote action = do syncFromDirectory = syncFromDirectory, syncToDirectory = syncToDirectory, viewRemoteBranch' = viewRemoteBranch', - pushGitBranch = (\r opts action -> pushGitBranch conn r opts action), + pushGitBranch = pushGitBranch conn, watches = watches, getWatch = getWatch, putWatch = putWatch, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 0615666fa5..f206753b52 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1808,36 +1808,36 @@ doPushRemoteBranch :: Path' -> SyncMode.SyncMode -> Action' m v () -doPushRemoteBranch pushFlavor localPath syncMode = do - sourceBranch <- do - currentPath' <- use LoopState.currentPath - getAt (Path.resolve currentPath' localPath) +doPushRemoteBranch pushFlavor localPath0 syncMode = do + currentPath' <- use LoopState.currentPath + let localPath = Path.resolve currentPath' localPath0 case pushFlavor of - NormalPush (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath}) pushBehavior -> - unlessError do - let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) - withRemoteRoot remoteRoot = do - let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this - -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. - f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing - Branch.modifyAtM remotePath f remoteRoot & \case - Nothing -> pure (Left $ RefusedToPush pushBehavior) - Just newRemoteRoot -> pure (Right newRemoteRoot) - let opts = PushGitBranchOpts {setRoot = True, syncMode} - withExceptT Output.GitError (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case - Left output -> respond output - Right _branch -> respond Success - NormalPush (WriteRemotePathShare WriteShareRemotePath {server, repo, path = remotePath}) pushBehavior -> - -- let (userSegment :| pathSegments) = undefined - error "handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior" + NormalPush (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath}) pushBehavior -> do + sourceBranch <- getAt localPath + let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) + withRemoteRoot remoteRoot = do + let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this + -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. + f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing + Branch.modifyAtM remotePath f remoteRoot & \case + Nothing -> pure (Left $ RefusedToPush pushBehavior) + Just newRemoteRoot -> pure (Right newRemoteRoot) + let opts = PushGitBranchOpts {setRoot = True, syncMode} + runExceptT (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case + Left gitErr -> respond (Output.GitError gitErr) + Right _branch -> respond Success + NormalPush (WriteRemotePathShare sharePath) pushBehavior -> + handlePushToUnisonShare sharePath localPath pushBehavior GistyPush repo -> do - unlessError do - let opts = PushGitBranchOpts {setRoot = False, syncMode} - withExceptT Output.GitError (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))) - sbhLength <- eval BranchHashLength - respond - ( GistCreated + sourceBranch <- getAt localPath + let opts = PushGitBranchOpts {setRoot = False, syncMode} + runExceptT (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))) >>= \case + Left gitErr -> respond (Output.GitError gitErr) + Right _result -> do + sbhLength <- eval BranchHashLength + respond $ + GistCreated ( ReadRemoteNamespaceGit ReadGitRemoteNamespace { repo = writeToReadGit repo, @@ -1845,7 +1845,6 @@ doPushRemoteBranch pushFlavor localPath syncMode = do path = Path.empty } ) - ) where -- Per `pushBehavior`, we are either: -- @@ -1860,42 +1859,56 @@ doPushRemoteBranch pushFlavor localPath syncMode = do shareRepoToBaseURL :: ShareRepo -> Servant.BaseUrl shareRepoToBaseURL ShareRepo = Servant.BaseUrl Servant.Https "share.unison.cloud" 443 "" -handlePushToUnisonShare :: MonadIO m => ShareRepo -> Text -> Path -> Path.Absolute -> PushBehavior -> Action' m v () -handlePushToUnisonShare shareRepo remoteRepo remotePath localPath behavior = do - let repoPath = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) +handlePushToUnisonShare :: MonadIO m => WriteShareRemotePath -> Path.Absolute -> PushBehavior -> Action' m v () +handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} localPath behavior = do + let sharePath = Share.Path (repo Nel.:| pathToSegments remotePath) LoopState.Env {authHTTPClient, codebase = Codebase {connection}} <- ask -- doesn't handle the case where a non-existent path is supplied - Sqlite.runTransaction - connection - (Ops.loadCausalHashAtPath (coerce @[NameSegment] @[Text] (Path.toList (Path.unabsolute localPath)))) + Sqlite.runTransaction connection (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath))) >>= \case Nothing -> respond (error "you are bad") Just localCausalHash -> case behavior of - PushBehavior.RequireEmpty -> - liftIO (Share.checkAndSetPush authHTTPClient (shareRepoToBaseURL shareRepo) connection repoPath Nothing localCausalHash) >>= \case + PushBehavior.RequireEmpty -> do + let push :: IO (Either Share.CheckAndSetPushError ()) + push = + Share.checkAndSetPush + authHTTPClient + (shareRepoToBaseURL server) + connection + sharePath + Nothing + localCausalHash + liftIO push >>= \case Left err -> case err of Share.CheckAndSetPushErrorHashMismatch _mismatch -> error "remote not empty" - Share.CheckAndSetPushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath + Share.CheckAndSetPushErrorNoWritePermission _repoPath -> errNoWritePermission sharePath Share.CheckAndSetPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps Right () -> pure () - PushBehavior.RequireNonEmpty -> - liftIO (Share.fastForwardPush authHTTPClient (shareRepoToBaseURL shareRepo) connection repoPath localCausalHash) >>= \case + PushBehavior.RequireNonEmpty -> do + let push :: IO (Either Share.FastForwardPushError ()) + push = + Share.fastForwardPush authHTTPClient (shareRepoToBaseURL server) connection sharePath localCausalHash + liftIO push >>= \case Left err -> case err of Share.FastForwardPushErrorNoHistory _repoPath -> error "no history" Share.FastForwardPushErrorNoReadPermission _repoPath -> error "no read permission" Share.FastForwardPushErrorNotFastForward -> error "not fast-forward" - Share.FastForwardPushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath + Share.FastForwardPushErrorNoWritePermission _repoPath -> errNoWritePermission sharePath Share.FastForwardPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps Right () -> pure () where errNoWritePermission _repoPath = error "no write permission" errServerMissingDependencies _dependencies = error "server missing dependencies" + pathToSegments :: Path -> [Text] + pathToSegments = + coerce Path.toList + -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: forall m v. From f5103652903dffc07da1e1693e536d06531a9fca Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 12 May 2022 18:03:00 -0400 Subject: [PATCH 213/529] filled in a lot of things? --- lib/unison-prelude/src/Unison/Prelude.hs | 5 ++ unison-cli/src/Unison/Auth/HTTPClient.hs | 4 +- .../src/Unison/Codebase/Editor/Command.hs | 4 +- .../Unison/Codebase/Editor/HandleCommand.hs | 3 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 69 ++++++++----------- .../src/Unison/Codebase/Editor/Output.hs | 10 +++ .../src/Unison/Codebase/Editor/UCMVersion.hs | 5 ++ .../src/Unison/Codebase/TranscriptParser.hs | 3 +- unison-cli/src/Unison/CommandLine/Main.hs | 3 +- .../src/Unison/CommandLine/OutputMessages.hs | 8 ++- unison-cli/src/Unison/Util/HTTP.hs | 2 +- unison-cli/unison-cli.cabal | 3 +- 12 files changed, 65 insertions(+), 54 deletions(-) create mode 100644 unison-cli/src/Unison/Codebase/Editor/UCMVersion.hs diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index 97d3a03890..b3de550cd3 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -7,6 +7,7 @@ module Unison.Prelude uncurry4, reportBug, tShow, + wundefined, -- * @Maybe@ control flow onNothing, @@ -165,3 +166,7 @@ reportBug bugId msg = "on the issue to let the team know you encountered it, and you can add", "any additional details you know of to the issue." ] + +{-# WARNING wundefined "You left this wundefined." #-} +wundefined :: a +wundefined = undefined diff --git a/unison-cli/src/Unison/Auth/HTTPClient.hs b/unison-cli/src/Unison/Auth/HTTPClient.hs index 26765332dc..85ffb4d009 100644 --- a/unison-cli/src/Unison/Auth/HTTPClient.hs +++ b/unison-cli/src/Unison/Auth/HTTPClient.hs @@ -1,4 +1,4 @@ -module Unison.Auth.HTTPClient (newAuthorizedHTTPClient, AuthorizedHttpClient(..)) where +module Unison.Auth.HTTPClient (newAuthorizedHTTPClient, AuthorizedHttpClient (..)) where import qualified Data.Text.Encoding as Text import Network.HTTP.Client (Request) @@ -7,7 +7,7 @@ import qualified Network.HTTP.Client.TLS as HTTP import Unison.Auth.CredentialManager (CredentialManager) import Unison.Auth.Tokens (TokenProvider, newTokenProvider) import Unison.Auth.Types -import Unison.Codebase.Editor.Command (UCMVersion) +import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Prelude import qualified Unison.Util.HTTP as HTTP diff --git a/unison-cli/src/Unison/Codebase/Editor/Command.hs b/unison-cli/src/Unison/Codebase/Editor/Command.hs index 499b8b82f3..4647909d42 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Command.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Command.hs @@ -13,7 +13,6 @@ module Unison.Codebase.Editor.Command EvalResult, commandName, lookupEvalResult, - UCMVersion, ) where @@ -30,6 +29,7 @@ import Unison.Codebase.Editor.AuthorInfo (AuthorInfo) import qualified Unison.Codebase.Editor.Git as Git import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.RemoteRepo +import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Reflog as Reflog @@ -94,8 +94,6 @@ type TypecheckingResult v = (Seq (Note v Ann)) (Either Names (UF.TypecheckedUnisonFile v Ann)) -type UCMVersion = Text - data Command m -- Command monad diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs index 03ea15a880..c71f05e82d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs @@ -22,8 +22,9 @@ import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Branch.Merge as Branch import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo -import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UCMVersion, UseCache) +import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UseCache) import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output (PrintMessage)) +import Unison.Codebase.Editor.UCMVersion (UCMVersion) import qualified Unison.Codebase.Path as Path import Unison.Codebase.Runtime (Runtime) import qualified Unison.Codebase.Runtime as Runtime diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f206753b52..0ba6bba292 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -29,7 +29,6 @@ import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) import qualified Servant.Client as Servant import qualified Text.Megaparsec as P -import U.Codebase.Causal (Causal (causalHash)) import qualified U.Codebase.Sqlite.Operations as Ops import U.Util.Timing (unsafeTime) import qualified Unison.ABT as ABT @@ -507,7 +506,6 @@ loop = do (Branch m -> Action m i v1 (Branch m)) -> Action m i v1 Bool updateAtM = Unison.Codebase.Editor.HandleInput.updateAtM inputDescription - unlessGitError = unlessError' Output.GitError importRemoteGitBranch ns mode preprocess = ExceptT . eval $ ImportRemoteGitBranch ns mode preprocess loadSearchResults = eval . LoadSearchResults @@ -670,12 +668,15 @@ loop = do let desta = resolveToAbsolute dest0 let dest = Path.unabsolute desta destb <- getAt desta + let tryImportBranch = \case + ReadRemoteNamespaceGit repo -> + withExceptT Output.GitError (importRemoteGitBranch repo SyncMode.ShortCircuit Unmodified) + ReadRemoteNamespaceShare repo -> + ExceptT (importRemoteShareBranch repo) if Branch.isEmpty0 (Branch.head destb) - then unlessGitError do - baseb <- case baseRepo of - ReadRemoteNamespaceGit repo -> importRemoteGitBranch repo SyncMode.ShortCircuit Unmodified - headb <- case headRepo of - ReadRemoteNamespaceGit repo -> importRemoteGitBranch repo SyncMode.ShortCircuit Unmodified + then unlessError do + baseb <- tryImportBranch baseRepo + headb <- tryImportBranch headRepo lift $ do mergedb <- eval $ Merge Branch.RegularMerge baseb headb squashedb <- eval $ Merge Branch.SquashMerge headb baseb @@ -1510,9 +1511,10 @@ loop = do Input.PullWithHistory -> Unmodified Input.PullWithoutHistory -> Preprocessed $ pure . Branch.discardHistory ns <- maybe (writePathToRead <$> resolveConfiguredUrl Pull path) pure mayRepo - lift $ unlessGitError do + lift $ unlessError do remoteBranch <- case ns of - ReadRemoteNamespaceGit repo -> importRemoteGitBranch repo syncMode preprocess + ReadRemoteNamespaceGit repo -> withExceptT Output.GitError (importRemoteGitBranch repo syncMode preprocess) + ReadRemoteNamespaceShare repo -> ExceptT (importRemoteShareBranch repo) let unchangedMsg = PullAlreadyUpToDate ns path let destAbs = resolveToAbsolute path let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path @@ -1699,7 +1701,7 @@ handleCreatePullRequest baseRepo0 headRepo0 = do Right diff -> respondNumbered diff (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceShare headRepo) -> importRemoteShareBranch headRepo >>= \case - Left () -> respond (error "bad pull because" headRepo) + Left err -> respond err Right headBranch -> do result <- viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> @@ -1709,7 +1711,7 @@ handleCreatePullRequest baseRepo0 headRepo0 = do Right diff -> respondNumbered diff (ReadRemoteNamespaceShare baseRepo, ReadRemoteNamespaceGit headRepo) -> importRemoteShareBranch baseRepo >>= \case - Left () -> respond (error "bad pull because" baseRepo) + Left err -> respond err Right baseBranch -> do result <- viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch -> @@ -1719,10 +1721,10 @@ handleCreatePullRequest baseRepo0 headRepo0 = do Right diff -> respondNumbered diff (ReadRemoteNamespaceShare baseRepo, ReadRemoteNamespaceShare headRepo) -> importRemoteShareBranch headRepo >>= \case - Left () -> respond (error "bad pull because" headRepo) + Left err -> respond err Right headBranch -> importRemoteShareBranch baseRepo >>= \case - Left () -> respond (error "bad pull because" baseRepo) + Left err -> respond err Right baseBranch -> do diff <- mergeAndDiff baseBranch headBranch respondNumbered diff @@ -1882,29 +1884,16 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l Nothing localCausalHash liftIO push >>= \case - Left err -> - case err of - Share.CheckAndSetPushErrorHashMismatch _mismatch -> error "remote not empty" - Share.CheckAndSetPushErrorNoWritePermission _repoPath -> errNoWritePermission sharePath - Share.CheckAndSetPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps + Left err -> respond (Output.ShareError (ShareErrorCheckAndSetPush err)) Right () -> pure () PushBehavior.RequireNonEmpty -> do let push :: IO (Either Share.FastForwardPushError ()) push = Share.fastForwardPush authHTTPClient (shareRepoToBaseURL server) connection sharePath localCausalHash liftIO push >>= \case - Left err -> - case err of - Share.FastForwardPushErrorNoHistory _repoPath -> error "no history" - Share.FastForwardPushErrorNoReadPermission _repoPath -> error "no read permission" - Share.FastForwardPushErrorNotFastForward -> error "not fast-forward" - Share.FastForwardPushErrorNoWritePermission _repoPath -> errNoWritePermission sharePath - Share.FastForwardPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps + Left err -> respond (Output.ShareError (ShareErrorFastForwardPush err)) Right () -> pure () where - errNoWritePermission _repoPath = error "no write permission" - errServerMissingDependencies _dependencies = error "server missing dependencies" - pathToSegments :: Path -> [Text] pathToSegments = coerce Path.toList @@ -2274,19 +2263,17 @@ viewRemoteGitBranch :: viewRemoteGitBranch ns gitBranchBehavior action = do eval $ ViewRemoteGitBranch ns gitBranchBehavior action -importRemoteShareBranch :: MonadIO m => ReadShareRemoteNamespace -> Action' m v (Either () (Branch m)) -importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do - let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) - LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask - liftIO (Share.pull authHTTPClient (shareRepoToBaseURL server) connection shareFlavoredPath) >>= \case - Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> - error "Share.GetCausalHashByPathErrorNoReadPermission" - Left (Share.PullErrorNoHistoryAtPath repoPath) -> - error "Share.PullErrorNoHistoryAtPath" - Right causalHash -> do - (eval . Eval) (Codebase.getBranchForHash codebase (Cv.branchHash2to1 causalHash)) >>= \case - Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" - Just branch -> pure (Right branch) +importRemoteShareBranch :: MonadIO m => ReadShareRemoteNamespace -> Action' m v (Either (Output v) (Branch m)) +importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = + mapLeft Output.ShareError <$> do + let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) + LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask + liftIO (Share.pull authHTTPClient (shareRepoToBaseURL server) connection shareFlavoredPath) >>= \case + Left e -> pure (Left (Output.ShareErrorPull e)) + Right causalHash -> do + (eval . Eval) (Codebase.getBranchForHash codebase (Cv.branchHash2to1 causalHash)) >>= \case + Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" + Just branch -> pure (Right branch) -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 500f467ca5..a06daa80d6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -10,6 +10,7 @@ module Unison.Codebase.Editor.Output UndoFailureReason (..), PushPull (..), ReflogEntry (..), + ShareError (..), pushPull, isFailure, isNumberedFailure, @@ -56,6 +57,7 @@ import qualified Unison.Reference as Reference import Unison.Referent (Referent) import Unison.Server.Backend (ShallowListEntry (..)) import Unison.Server.SearchResult' (SearchResult') +import qualified Unison.Share.Sync as Sync import Unison.ShortHash (ShortHash) import Unison.Term (Term) import Unison.Type (Type) @@ -206,6 +208,7 @@ data Output v -- and a nicer render. BustedBuiltins (Set Reference) (Set Reference) | GitError GitError + | ShareError ShareError | ConfiguredMetadataParseError Path' String (P.Pretty P.ColorText) | NoConfiguredGitUrl PushPull Path' | ConfiguredGitUrlParseError PushPull Path' Text String @@ -256,6 +259,12 @@ data Output v | CredentialFailureMsg CredentialFailure | PrintVersion Text +data ShareError + = ShareErrorCheckAndSetPush Sync.CheckAndSetPushError + | ShareErrorFastForwardPush Sync.FastForwardPushError + | ShareErrorPull Sync.PullError + | ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError + data ReflogEntry = ReflogEntry {hash :: ShortBranchHash, reason :: Text} deriving (Show) @@ -381,6 +390,7 @@ isFailure o = case o of UnknownCodeServer {} -> True CredentialFailureMsg {} -> True PrintVersion {} -> False + ShareError {} -> True isNumberedFailure :: NumberedOutput v -> Bool isNumberedFailure = \case diff --git a/unison-cli/src/Unison/Codebase/Editor/UCMVersion.hs b/unison-cli/src/Unison/Codebase/Editor/UCMVersion.hs new file mode 100644 index 0000000000..4e003e63e3 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/UCMVersion.hs @@ -0,0 +1,5 @@ +module Unison.Codebase.Editor.UCMVersion where + +import Data.Text (Text) + +type UCMVersion = Text diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 2ab95649c6..54edbba95a 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -40,12 +40,13 @@ import qualified Text.Megaparsec as P import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.Editor.Command (LoadSourceResult (..), UCMVersion) +import Unison.Codebase.Editor.Command (LoadSourceResult (..)) import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState import Unison.Codebase.Editor.Input (Event (UnisonFileChanged), Input (..)) import qualified Unison.Codebase.Editor.Output as Output +import Unison.Codebase.Editor.UCMVersion (UCMVersion) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.Runtime as Runtime diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 70d51fcb0a..be44430ac3 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -28,12 +28,13 @@ import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.Editor.Command (LoadSourceResult (..), UCMVersion) +import Unison.Codebase.Editor.Command (LoadSourceResult (..)) import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState import Unison.Codebase.Editor.Input (Event, Input (..)) import Unison.Codebase.Editor.Output (Output) +import Unison.Codebase.Editor.UCMVersion (UCMVersion) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Runtime as Runtime import Unison.CommandLine diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 11a1d70e53..20f9610097 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -622,8 +622,8 @@ notifyUser dir o = case o of CachedTests 0 _ -> pure . P.callout "๐Ÿ˜ถ" $ "No tests to run." CachedTests n n' | n == n' -> - pure $ - P.lines [cache, "", displayTestResults True ppe oks fails] + pure $ + P.lines [cache, "", displayTestResults True ppe oks fails] CachedTests _n m -> pure $ if m == 0 @@ -632,6 +632,7 @@ notifyUser dir o = case o of P.indentN 2 $ P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "โœ… "] where + NewlyComputed -> do clearCurrentLine pure $ @@ -1575,6 +1576,7 @@ notifyUser dir o = case o of "Host names should NOT include a schema or path." ] PrintVersion ucmVersion -> pure (P.text ucmVersion) + ShareError {} -> wundefined where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" @@ -2162,7 +2164,7 @@ showDiffNamespace :: (Pretty, NumberedArgs) showDiffNamespace _ _ _ _ diffOutput | OBD.isEmpty diffOutput = - ("The namespaces are identical.", mempty) + ("The namespaces are identical.", mempty) showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = (P.sepNonEmpty "\n\n" p, toList args) where diff --git a/unison-cli/src/Unison/Util/HTTP.hs b/unison-cli/src/Unison/Util/HTTP.hs index 940d681f43..8f0e6f577b 100644 --- a/unison-cli/src/Unison/Util/HTTP.hs +++ b/unison-cli/src/Unison/Util/HTTP.hs @@ -2,7 +2,7 @@ module Unison.Util.HTTP (addRequestMiddleware, setUserAgent, ucmUserAgent) where import qualified Data.Text.Encoding as Text import qualified Network.HTTP.Client as HTTP -import Unison.Codebase.Editor.Command (UCMVersion) +import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Prelude addRequestMiddleware :: (HTTP.Request -> IO HTTP.Request) -> HTTP.ManagerSettings -> HTTP.ManagerSettings diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index dc6fac3a25..7183af7725 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack @@ -47,6 +47,7 @@ library Unison.Codebase.Editor.SlurpComponent Unison.Codebase.Editor.SlurpResult Unison.Codebase.Editor.TodoOutput + Unison.Codebase.Editor.UCMVersion Unison.Codebase.Editor.UriParser Unison.Codebase.Editor.VersionParser Unison.Codebase.TranscriptParser From bfadd5d06e20556af0d3c02b94fb2e532be5ded3 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 12 May 2022 18:45:54 -0400 Subject: [PATCH 214/529] started fleshing out OutputMessages --- .../src/Unison/CommandLine/OutputMessages.hs | 21 ++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 20f9610097..5c2e69521e 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -117,8 +117,10 @@ import qualified Unison.Referent' as Referent import qualified Unison.Result as Result import Unison.Server.Backend (ShallowListEntry (..), TermEntry (..), TypeEntry (..)) import qualified Unison.Server.SearchResult' as SR' +import qualified Unison.Share.Sync as Sync import qualified Unison.ShortHash as SH import qualified Unison.ShortHash as ShortHash +import qualified Unison.Sync.Types as Sync import Unison.Term (Term) import qualified Unison.Term as Term import qualified Unison.TermPrinter as TermPrinter @@ -1576,7 +1578,24 @@ notifyUser dir o = case o of "Host names should NOT include a schema or path." ] PrintVersion ucmVersion -> pure (P.text ucmVersion) - ShareError {} -> wundefined + ShareError x -> case x of + ShareErrorCheckAndSetPush e -> case e of + (Sync.CheckAndSetPushErrorHashMismatch Sync.HashMismatch {path, expectedHash, actualHash}) -> wundefined + (Sync.CheckAndSetPushErrorNoWritePermission sharePath) -> wundefined + (Sync.CheckAndSetPushErrorServerMissingDependencies hashes) -> wundefined + ShareErrorFastForwardPush e -> case e of + (Sync.FastForwardPushErrorNoHistory sharePath) -> wundefined + (Sync.FastForwardPushErrorNoReadPermission sharePath) -> wundefined + Sync.FastForwardPushErrorNotFastForward -> wundefined + (Sync.FastForwardPushErrorNoWritePermission sharePath) -> wundefined + (Sync.FastForwardPushErrorServerMissingDependencies hashes) -> wundefined + ShareErrorPull e -> case e of + (Sync.PullErrorGetCausalHashByPath (Sync.GetCausalHashByPathErrorNoReadPermission sharePath)) -> wundefined + (Sync.PullErrorNoHistoryAtPath sharePath) -> wundefined + ShareErrorGetCausalHashByPath gchbpe -> case gchbpe of + (Sync.GetCausalHashByPathErrorNoReadPermission sharePath) -> wundefined + where + y = () where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" From c7291c672cec6b52492749c86f5ac10852528786 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 13 May 2022 11:01:09 -0400 Subject: [PATCH 215/529] working on OutputMessages --- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 5 + .../src/Unison/Codebase/Editor/Output.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 91 +++++++++++++------ 3 files changed, 69 insertions(+), 29 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 96f1abcece..819dda188f 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -75,6 +75,11 @@ printNamespace = \case then mempty else "." <> Path.toText path +printWriteRemotePath :: WriteRemotePath -> Text +printWriteRemotePath = \case + WriteRemotePathGit WriteGitRemotePath {repo, path} -> wundefined + WriteRemotePathShare WriteShareRemotePath {server, repo, path} -> wundefined + -- | print remote path printHead :: WriteRepo -> Path -> Text printHead repo path = diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index a06daa80d6..786604f6b6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -250,7 +250,7 @@ data Output v | NamespaceEmpty (NonEmpty AbsBranchId) | NoOp | -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace. - RefusedToPush PushBehavior + RefusedToPush PushBehavior WriteRemotePath | -- | @GistCreated repo@ means a causal was just published to @repo@. GistCreated ReadRemoteNamespace | -- | Directs the user to URI to begin an authorization flow. diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 5c2e69521e..dfbb619563 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} @@ -31,6 +32,8 @@ import System.Directory getHomeDirectory, ) import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) +import U.Util.Base32Hex (Base32Hex) +import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as Hash import qualified U.Util.Monoid as Monoid import qualified Unison.ABT as ABT @@ -44,7 +47,7 @@ import Unison.Codebase.Editor.Output import qualified Unison.Codebase.Editor.Output as E import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBD -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo (ReadRepoGit), WriteRepo (WriteRepoGit)) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo (ReadRepoGit), WriteRemotePath, WriteRepo (WriteRepoGit)) import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo import qualified Unison.Codebase.Editor.SlurpResult as SlurpResult import qualified Unison.Codebase.Editor.TodoOutput as TO @@ -117,10 +120,11 @@ import qualified Unison.Referent' as Referent import qualified Unison.Result as Result import Unison.Server.Backend (ShallowListEntry (..), TermEntry (..), TypeEntry (..)) import qualified Unison.Server.SearchResult' as SR' -import qualified Unison.Share.Sync as Sync +import qualified Unison.Share.Sync as Share import qualified Unison.ShortHash as SH import qualified Unison.ShortHash as ShortHash -import qualified Unison.Sync.Types as Sync +import qualified Unison.Sync.Types as Share +import qualified Unison.Sync.Types as Share.Hash (toBase32Hex) import Unison.Term (Term) import qualified Unison.Term as Term import qualified Unison.TermPrinter as TermPrinter @@ -508,10 +512,14 @@ showListEdits patch ppe = prettyURI :: URI -> Pretty prettyURI = P.bold . P.blue . P.shown -prettyRemoteNamespace :: ReadRemoteNamespace -> Pretty -prettyRemoteNamespace = +prettyReadRemoteNamespace :: ReadRemoteNamespace -> Pretty +prettyReadRemoteNamespace = P.group . P.blue . P.text . RemoteRepo.printNamespace +-- prettyWriteRemotePath :: WriteRemotePath -> Pretty +-- prettyWriteRemotePath = +-- P.group . P.blue . P.text . RemoteRepo.printWriteRemotePath + notifyUser :: forall v. Var v => FilePath -> Output v -> IO Pretty notifyUser dir o = case o of Success -> pure $ P.bold "Done." @@ -1514,18 +1522,15 @@ notifyUser dir o = case o of <> ( terms <&> \(n, r) -> prettyHashQualified' (HQ'.take hqLength . HQ'.fromNamedReference n $ Reference.DerivedId r) ) - RefusedToPush pushBehavior -> - (pure . P.warnCallout . P.lines) case pushBehavior of + RefusedToPush pushBehavior path -> + (pure . P.warnCallout) case pushBehavior of PushBehavior.RequireEmpty -> - [ "The remote namespace is not empty.", - "", - "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" - ] - PushBehavior.RequireNonEmpty -> - [ "The remote namespace is empty.", - "", - "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" - ] + P.lines + [ "The remote namespace is not empty.", + "", + "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" + ] + PushBehavior.RequireNonEmpty -> expectedNonEmptyPushDest path GistCreated remoteNamespace -> pure $ P.lines @@ -1578,26 +1583,44 @@ notifyUser dir o = case o of "Host names should NOT include a schema or path." ] PrintVersion ucmVersion -> pure (P.text ucmVersion) - ShareError x -> case x of + ShareError x -> (pure . P.warnCallout) case x of ShareErrorCheckAndSetPush e -> case e of - (Sync.CheckAndSetPushErrorHashMismatch Sync.HashMismatch {path, expectedHash, actualHash}) -> wundefined - (Sync.CheckAndSetPushErrorNoWritePermission sharePath) -> wundefined - (Sync.CheckAndSetPushErrorServerMissingDependencies hashes) -> wundefined + (Share.CheckAndSetPushErrorHashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash}) -> + P.wrap $ P.text "It looks like someone modified" <> prettySharePath sharePath <> P.text "an instant before you. Pull and try again? ๐Ÿคž" + (Share.CheckAndSetPushErrorNoWritePermission sharePath) -> + P.wrap $ P.text "The server said you don't have permission to write" <> prettySharePath sharePath + (Share.CheckAndSetPushErrorServerMissingDependencies hashes) -> + -- maybe todo: stuff in all the args to CheckAndSetPush + P.lines + [ P.wrap + ( P.text "The server was expecting to have received some stuff from UCM during that last command, but claims to have not received it." + <> P.text "(This is probably a bug in UCM.)" + ), + P.text "", + P.text "The hashes it expected are:\n" + <> P.indentN 2 (P.lines (map prettyShareHash (toList hashes))) + ] ShareErrorFastForwardPush e -> case e of - (Sync.FastForwardPushErrorNoHistory sharePath) -> wundefined - (Sync.FastForwardPushErrorNoReadPermission sharePath) -> wundefined - Sync.FastForwardPushErrorNotFastForward -> wundefined - (Sync.FastForwardPushErrorNoWritePermission sharePath) -> wundefined - (Sync.FastForwardPushErrorServerMissingDependencies hashes) -> wundefined + (Share.FastForwardPushErrorNoHistory _sharePath) -> expectedNonEmptyPushDest + (Share.FastForwardPushErrorNoReadPermission sharePath) -> wundefined + Share.FastForwardPushErrorNotFastForward -> wundefined + (Share.FastForwardPushErrorNoWritePermission sharePath) -> wundefined + (Share.FastForwardPushErrorServerMissingDependencies hashes) -> wundefined ShareErrorPull e -> case e of - (Sync.PullErrorGetCausalHashByPath (Sync.GetCausalHashByPathErrorNoReadPermission sharePath)) -> wundefined - (Sync.PullErrorNoHistoryAtPath sharePath) -> wundefined + (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission sharePath)) -> wundefined + (Share.PullErrorNoHistoryAtPath sharePath) -> wundefined ShareErrorGetCausalHashByPath gchbpe -> case gchbpe of - (Sync.GetCausalHashByPathErrorNoReadPermission sharePath) -> wundefined + (Share.GetCausalHashByPathErrorNoReadPermission sharePath) -> wundefined where y = () where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" + expectedNonEmptyPushDest writeRemotePath = + P.lines + [ "The remote namespace" <> prettyRemoteNamespace <> "is empty.", + "", + "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" + ] -- do -- when (not . Set.null $ E.changedSuccessfully r) . putPrettyLn . P.okCallout $ @@ -1653,6 +1676,18 @@ prettySBH hash = P.group $ "#" <> P.text (SBH.toText hash) prettyCausalHash :: IsString s => Causal.RawHash x -> P.Pretty s prettyCausalHash hash = P.group $ "#" <> P.text (Hash.toBase32HexText . Causal.unRawHash $ hash) +prettyBase32Hex :: IsString s => Base32Hex -> P.Pretty s +prettyBase32Hex = P.text . Base32Hex.toText + +prettyBase32Hex# :: IsString s => Base32Hex -> P.Pretty s +prettyBase32Hex# b = P.group $ "#" <> prettyBase32Hex b + +prettyHash :: IsString s => Hash.Hash -> P.Pretty s +prettyHash = prettyBase32Hex# . Hash.toBase32Hex + +prettyShareHash :: IsString s => Share.Hash -> P.Pretty s +prettyShareHash = prettyBase32Hex# . Share.Hash.toBase32Hex + formatMissingStuff :: (Show tm, Show typ) => [(HQ.HashQualified Name, tm)] -> From 9569907e88e43f05b17fa78ddd70b378ddeadb65 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 13 May 2022 11:36:34 -0400 Subject: [PATCH 216/529] prettyRemoteNamespace -> prettyReadRemoteNamespace --- .../src/Unison/CommandLine/OutputMessages.hs | 29 +++++++++---------- 1 file changed, 13 insertions(+), 16 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index dfbb619563..e2dc391b5c 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1,9 +1,6 @@ {-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Unison.CommandLine.OutputMessages where @@ -273,9 +270,9 @@ notifyNumbered o = case o of then ( P.wrap $ "Looks like there's no difference between " - <> prettyRemoteNamespace baseRepo + <> prettyReadRemoteNamespace baseRepo <> "and" - <> prettyRemoteNamespace headRepo + <> prettyReadRemoteNamespace headRepo <> ".", mempty ) @@ -290,8 +287,8 @@ notifyNumbered o = case o of P.indentN 2 $ IP.makeExampleNoBackticks IP.loadPullRequest - [ (prettyRemoteNamespace baseRepo), - (prettyRemoteNamespace headRepo) + [ (prettyReadRemoteNamespace baseRepo), + (prettyReadRemoteNamespace headRepo) ], "", p @@ -590,8 +587,8 @@ notifyUser dir o = case o of LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath -> pure $ P.lines - [ P.wrap $ "I checked out" <> prettyRemoteNamespace baseNS <> "to" <> P.group (prettyPath' basePath <> "."), - P.wrap $ "I checked out" <> prettyRemoteNamespace headNS <> "to" <> P.group (prettyPath' headPath <> "."), + [ P.wrap $ "I checked out" <> prettyReadRemoteNamespace baseNS <> "to" <> P.group (prettyPath' basePath <> "."), + P.wrap $ "I checked out" <> prettyReadRemoteNamespace headNS <> "to" <> P.group (prettyPath' headPath <> "."), "", P.wrap $ "The merged result is in" <> P.group (prettyPath' mergedPath <> "."), P.wrap $ "The (squashed) merged result is in" <> P.group (prettyPath' squashedPath <> "."), @@ -617,11 +614,11 @@ notifyUser dir o = case o of "Use" <> IP.makeExample IP.push - [prettyRemoteNamespace baseNS, prettyPath' mergedPath] + [prettyReadRemoteNamespace baseNS, prettyPath' mergedPath] <> "or" <> IP.makeExample IP.push - [prettyRemoteNamespace baseNS, prettyPath' squashedPath] + [prettyReadRemoteNamespace baseNS, prettyPath' squashedPath] <> "to push the changes." ] DisplayDefinitions outputLoc ppe types terms -> @@ -1143,7 +1140,7 @@ notifyUser dir o = case o of P.wrap $ "I just finished importing the branch" <> P.red (P.shown h) <> "from" - <> P.red (prettyRemoteNamespace (RemoteRepo.ReadRemoteNamespaceGit ns)) + <> P.red (prettyReadRemoteNamespace (RemoteRepo.ReadRemoteNamespaceGit ns)) <> "but now I can't find it." CouldntFindRemoteBranch repo path -> P.wrap $ @@ -1387,12 +1384,12 @@ notifyUser dir o = case o of pure . P.callout "๐Ÿ˜ถ" $ P.wrap $ prettyPath' dest <> "was already up-to-date with" - <> P.group (prettyRemoteNamespace ns <> ".") + <> P.group (prettyReadRemoteNamespace ns <> ".") PullSuccessful ns dest -> pure . P.okCallout $ P.wrap $ "Successfully updated" <> prettyPath' dest <> "from" - <> P.group (prettyRemoteNamespace ns <> ".") + <> P.group (prettyReadRemoteNamespace ns <> ".") MergeOverEmpty dest -> pure . P.okCallout $ P.wrap $ @@ -1536,7 +1533,7 @@ notifyUser dir o = case o of P.lines [ "Gist created. Pull via:", "", - P.indentN 2 (IP.patternName IP.pull <> " " <> prettyRemoteNamespace remoteNamespace) + P.indentN 2 (IP.patternName IP.pull <> " " <> prettyReadRemoteNamespace remoteNamespace) ] InitiateAuthFlow authURI -> do pure $ @@ -1617,7 +1614,7 @@ notifyUser dir o = case o of _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" expectedNonEmptyPushDest writeRemotePath = P.lines - [ "The remote namespace" <> prettyRemoteNamespace <> "is empty.", + [ "The remote namespace" <> prettyReadRemoteNamespace <> "is empty.", "", "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" ] From bf2c6d6329ed940ef4bcc2b9f6dae121c0609ff0 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 13 May 2022 12:25:09 -0400 Subject: [PATCH 217/529] more pretty-printing work --- parser-typechecker/package.yaml | 1 + .../src/Unison/Codebase/Editor/RemoteRepo.hs | 5 +++ .../unison-parser-typechecker.cabal | 1 + .../src/Unison/Codebase/Editor/HandleInput.hs | 15 ++++----- .../src/Unison/CommandLine/OutputMessages.hs | 31 ++++++++++++++----- unison-share-api/src/Unison/Sync/Types.hs | 6 +++- 6 files changed, 42 insertions(+), 17 deletions(-) diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 4a2e8eb010..b447556d6a 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -77,6 +77,7 @@ library: - safe - safe-exceptions - semialign + - servant-client - mwc-random - NanoID - lucid diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 819dda188f..d272369458 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -4,6 +4,7 @@ module Unison.Codebase.Editor.RemoteRepo where import qualified Data.Text as Text +import qualified Servant.Client as Servant import qualified U.Util.Monoid as Monoid import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Path as Path @@ -23,6 +24,9 @@ data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} data ShareRepo = ShareRepo deriving (Eq, Show) +shareRepoToBaseUrl :: ShareRepo -> Servant.BaseUrl +shareRepoToBaseUrl ShareRepo = Servant.BaseUrl Servant.Https "share.unison.cloud" 443 "" + data WriteRepo = WriteRepoGit WriteGitRepo | WriteRepoShare ShareRepo @@ -75,6 +79,7 @@ printNamespace = \case then mempty else "." <> Path.toText path +-- | Render a 'WriteRemotePath' as text. printWriteRemotePath :: WriteRemotePath -> Text printWriteRemotePath = \case WriteRemotePathGit WriteGitRemotePath {repo, path} -> wundefined diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index b659960bad..15cb81e4b7 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -260,6 +260,7 @@ library , safe-exceptions , semialign , servant + , servant-client , servant-docs , servant-openapi3 , servant-server diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 0ba6bba292..27808b85eb 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -27,7 +27,6 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) -import qualified Servant.Client as Servant import qualified Text.Megaparsec as P import qualified U.Codebase.Sqlite.Operations as Ops import U.Util.Timing (unsafeTime) @@ -70,6 +69,7 @@ import Unison.Codebase.Editor.RemoteRepo WriteRemotePath (..), WriteShareRemotePath (..), printNamespace, + shareRepoToBaseUrl, writePathToRead, writeToReadGit, ) @@ -1815,7 +1815,7 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do let localPath = Path.resolve currentPath' localPath0 case pushFlavor of - NormalPush (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath}) pushBehavior -> do + NormalPush (writeRemotePath@(WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath})) pushBehavior -> do sourceBranch <- getAt localPath let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) withRemoteRoot remoteRoot = do @@ -1823,7 +1823,7 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing Branch.modifyAtM remotePath f remoteRoot & \case - Nothing -> pure (Left $ RefusedToPush pushBehavior) + Nothing -> pure (Left $ RefusedToPush pushBehavior writeRemotePath) Just newRemoteRoot -> pure (Right newRemoteRoot) let opts = PushGitBranchOpts {setRoot = True, syncMode} runExceptT (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case @@ -1858,9 +1858,6 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch) PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) -shareRepoToBaseURL :: ShareRepo -> Servant.BaseUrl -shareRepoToBaseURL ShareRepo = Servant.BaseUrl Servant.Https "share.unison.cloud" 443 "" - handlePushToUnisonShare :: MonadIO m => WriteShareRemotePath -> Path.Absolute -> PushBehavior -> Action' m v () handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} localPath behavior = do let sharePath = Share.Path (repo Nel.:| pathToSegments remotePath) @@ -1878,7 +1875,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l push = Share.checkAndSetPush authHTTPClient - (shareRepoToBaseURL server) + (shareRepoToBaseUrl server) connection sharePath Nothing @@ -1889,7 +1886,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l PushBehavior.RequireNonEmpty -> do let push :: IO (Either Share.FastForwardPushError ()) push = - Share.fastForwardPush authHTTPClient (shareRepoToBaseURL server) connection sharePath localCausalHash + Share.fastForwardPush authHTTPClient (shareRepoToBaseUrl server) connection sharePath localCausalHash liftIO push >>= \case Left err -> respond (Output.ShareError (ShareErrorFastForwardPush err)) Right () -> pure () @@ -2268,7 +2265,7 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = mapLeft Output.ShareError <$> do let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask - liftIO (Share.pull authHTTPClient (shareRepoToBaseURL server) connection shareFlavoredPath) >>= \case + liftIO (Share.pull authHTTPClient (shareRepoToBaseUrl server) connection shareFlavoredPath) >>= \case Left e -> pure (Left (Output.ShareErrorPull e)) Right causalHash -> do (eval . Eval) (Codebase.getBranchForHash codebase (Cv.branchHash2to1 causalHash)) >>= \case diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index e2dc391b5c..808d7c050a 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -44,7 +44,13 @@ import Unison.Codebase.Editor.Output import qualified Unison.Codebase.Editor.Output as E import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBD -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo (ReadRepoGit), WriteRemotePath, WriteRepo (WriteRepoGit)) +import Unison.Codebase.Editor.RemoteRepo + ( ReadRemoteNamespace, + ReadRepo (..), + WriteRemotePath (..), + WriteRepo (..), + WriteShareRemotePath (..), + ) import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo import qualified Unison.Codebase.Editor.SlurpResult as SlurpResult import qualified Unison.Codebase.Editor.TodoOutput as TO @@ -91,6 +97,7 @@ import Unison.NamePrinter styleHashQualified, styleHashQualified', ) +import Unison.NameSegment (NameSegment (..)) import Unison.Names (Names (..)) import qualified Unison.Names as Names import qualified Unison.NamesWithHistory as Names @@ -513,9 +520,9 @@ prettyReadRemoteNamespace :: ReadRemoteNamespace -> Pretty prettyReadRemoteNamespace = P.group . P.blue . P.text . RemoteRepo.printNamespace --- prettyWriteRemotePath :: WriteRemotePath -> Pretty --- prettyWriteRemotePath = --- P.group . P.blue . P.text . RemoteRepo.printWriteRemotePath +prettyWriteRemotePath :: WriteRemotePath -> Pretty +prettyWriteRemotePath = + P.group . P.blue . P.text . RemoteRepo.printWriteRemotePath notifyUser :: forall v. Var v => FilePath -> Output v -> IO Pretty notifyUser dir o = case o of @@ -1598,7 +1605,17 @@ notifyUser dir o = case o of <> P.indentN 2 (P.lines (map prettyShareHash (toList hashes))) ] ShareErrorFastForwardPush e -> case e of - (Share.FastForwardPushErrorNoHistory _sharePath) -> expectedNonEmptyPushDest + (Share.FastForwardPushErrorNoHistory sharePath) -> + expectedNonEmptyPushDest + -- Recover the original WriteRemotePath from the information in the error, which is thrown from generic share + -- client code that doesn't know about WriteRemotePath + ( WriteRemotePathShare + WriteShareRemotePath + { server = RemoteRepo.ShareRepo, + repo = Share.unRepoName (Share.pathRepoName sharePath), + path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath)) + } + ) (Share.FastForwardPushErrorNoReadPermission sharePath) -> wundefined Share.FastForwardPushErrorNotFastForward -> wundefined (Share.FastForwardPushErrorNoWritePermission sharePath) -> wundefined @@ -1609,12 +1626,12 @@ notifyUser dir o = case o of ShareErrorGetCausalHashByPath gchbpe -> case gchbpe of (Share.GetCausalHashByPathErrorNoReadPermission sharePath) -> wundefined where - y = () + prettySharePath = undefined where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" expectedNonEmptyPushDest writeRemotePath = P.lines - [ "The remote namespace" <> prettyReadRemoteNamespace <> "is empty.", + [ "The remote namespace" <> prettyWriteRemotePath writeRemotePath <> "is empty.", "", "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" ] diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 0a1ba93b00..c5929d9059 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -6,6 +6,7 @@ module Unison.Sync.Types RepoName (..), Path (..), pathRepoName, + pathCodebasePath, -- ** Hash types Hash (..), @@ -90,7 +91,7 @@ instance FromJSON Base64Bytes where parseJSON = Aeson.withText "Base64" \txt -> do either fail (pure . Base64Bytes) $ convertFromBase Base64 (Text.encodeUtf8 txt) -newtype RepoName = RepoName Text +newtype RepoName = RepoName {unRepoName :: Text} deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) data Path = Path @@ -106,6 +107,9 @@ data Path = Path pathRepoName :: Path -> RepoName pathRepoName (Path (p :| _)) = RepoName p +pathCodebasePath :: Path -> [Text] +pathCodebasePath (Path (_ :| ps)) = ps + instance ToJSON Path where toJSON (Path segments) = object From 5ace0e1ee18de09d0cf885da3994387b63ffffe7 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 13 May 2022 15:08:59 -0400 Subject: [PATCH 218/529] couple more output messages --- .../src/Unison/CommandLine/OutputMessages.hs | 20 +++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 808d7c050a..d099ed5996 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1591,8 +1591,7 @@ notifyUser dir o = case o of ShareErrorCheckAndSetPush e -> case e of (Share.CheckAndSetPushErrorHashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash}) -> P.wrap $ P.text "It looks like someone modified" <> prettySharePath sharePath <> P.text "an instant before you. Pull and try again? ๐Ÿคž" - (Share.CheckAndSetPushErrorNoWritePermission sharePath) -> - P.wrap $ P.text "The server said you don't have permission to write" <> prettySharePath sharePath + (Share.CheckAndSetPushErrorNoWritePermission sharePath) -> noWritePermission sharePath (Share.CheckAndSetPushErrorServerMissingDependencies hashes) -> -- maybe todo: stuff in all the args to CheckAndSetPush P.lines @@ -1616,17 +1615,22 @@ notifyUser dir o = case o of path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath)) } ) - (Share.FastForwardPushErrorNoReadPermission sharePath) -> wundefined + (Share.FastForwardPushErrorNoReadPermission sharePath) -> noReadPermission sharePath Share.FastForwardPushErrorNotFastForward -> wundefined - (Share.FastForwardPushErrorNoWritePermission sharePath) -> wundefined + (Share.FastForwardPushErrorNoWritePermission sharePath) -> noWritePermission sharePath (Share.FastForwardPushErrorServerMissingDependencies hashes) -> wundefined ShareErrorPull e -> case e of - (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission sharePath)) -> wundefined + (Share.PullErrorGetCausalHashByPath err) -> handleGetCausalHashByPathError err (Share.PullErrorNoHistoryAtPath sharePath) -> wundefined - ShareErrorGetCausalHashByPath gchbpe -> case gchbpe of - (Share.GetCausalHashByPathErrorNoReadPermission sharePath) -> wundefined + ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err where - prettySharePath = undefined + prettySharePath sharePath = undefined + handleGetCausalHashByPathError = \case + Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermission sharePath + noReadPermission sharePath = + P.wrap $ P.text "The server said you don't have permission to read" <> prettySharePath sharePath + noWritePermission sharePath = + P.wrap $ P.text "The server said you don't have permission to write" <> prettySharePath sharePath where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" expectedNonEmptyPushDest writeRemotePath = From 6cf9cd1f421b6c59fb388563a27f767d4bd706bc Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sun, 15 May 2022 17:10:18 -0400 Subject: [PATCH 219/529] implementing the new git and share remote syntaxes, and maybe other stuff --- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 51 ++--- .../src/Unison/Codebase/SqliteCodebase.hs | 4 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 3 +- .../src/Unison/Codebase/Editor/UriParser.hs | 193 +++++++++++++----- .../src/Unison/CommandLine/InputPatterns.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 71 ++++--- unison-cli/src/Unison/Share/Sync.hs | 6 +- 7 files changed, 215 insertions(+), 115 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index d272369458..4eeed6055b 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -51,45 +51,38 @@ writePathToRead = \case WriteRemotePathShare WriteShareRemotePath {server, repo, path} -> ReadRemoteNamespaceShare ReadShareRemoteNamespace {server, repo, path} -printReadRepo :: ReadRepo -> Text -printReadRepo = \case - ReadRepoGit ReadGitRepo {url, ref} -> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) - ReadRepoShare s -> printShareRepo s +printReadGitRepo :: ReadGitRepo -> Text +printReadGitRepo ReadGitRepo {url, ref} = + "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) <> ")" -printShareRepo :: ShareRepo -> Text -printShareRepo = const "PLACEHOLDER" - -printWriteRepo :: WriteRepo -> Text -printWriteRepo = \case - WriteRepoGit WriteGitRepo {url, branch} -> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) - WriteRepoShare s -> printShareRepo s +printWriteGitRepo :: WriteGitRepo -> Text +printWriteGitRepo WriteGitRepo {url, branch} = "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) <> ")" -- | print remote namespace printNamespace :: ReadRemoteNamespace -> Text printNamespace = \case ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sbh, path} -> - printReadRepo (ReadRepoGit repo) <> case sbh of - Nothing -> - if path == Path.empty - then mempty - else ":." <> Path.toText path - Just sbh -> - ":#" <> SBH.toText sbh - <> if path == Path.empty - then mempty - else "." <> Path.toText path + printReadGitRepo repo <> maybePrintSBH sbh <> maybePrintPath path + where + maybePrintSBH = \case + Nothing -> mempty + Just sbh -> "#" <> SBH.toText sbh + ReadRemoteNamespaceShare ReadShareRemoteNamespace {server = ShareRepo, repo, path} -> + repo <> maybePrintPath path -- | Render a 'WriteRemotePath' as text. printWriteRemotePath :: WriteRemotePath -> Text printWriteRemotePath = \case - WriteRemotePathGit WriteGitRemotePath {repo, path} -> wundefined - WriteRemotePathShare WriteShareRemotePath {server, repo, path} -> wundefined - --- | print remote path -printHead :: WriteRepo -> Path -> Text -printHead repo path = - printWriteRepo repo - <> if path == Path.empty then mempty else ":." <> Path.toText path + WriteRemotePathGit WriteGitRemotePath {repo, path} -> + printWriteGitRepo repo <> maybePrintPath path + WriteRemotePathShare WriteShareRemotePath {server = ShareRepo, repo, path} -> + repo <> maybePrintPath path + +maybePrintPath :: Path -> Text +maybePrintPath path = + if path == Path.empty + then mempty + else "." <> Path.toText path data ReadRemoteNamespace = ReadRemoteNamespaceGit ReadGitRemoteNamespace diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index f49b40bb5c..4613f75942 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -50,7 +50,7 @@ import Unison.Codebase.Editor.RemoteRepo ReadGitRepo, WriteGitRepo (..), WriteRepo (..), - printWriteRepo, + printWriteGitRepo, writeToReadGit, ) import qualified Unison.Codebase.GitError as GitError @@ -810,7 +810,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift Just True -> pure () CreatedCodebase -> pure () run (setRepoRoot newBranchHash) - repoString = Text.unpack $ printWriteRepo (WriteRepoGit repo) + repoString = Text.unpack $ printWriteGitRepo repo setRepoRoot :: Branch.Hash -> Sqlite.Transaction () setRepoRoot h = do let h2 = Cv.causalHash1to2 h diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 27808b85eb..b3760a95e9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -63,7 +63,6 @@ import Unison.Codebase.Editor.RemoteRepo ( ReadGitRemoteNamespace (..), ReadRemoteNamespace (..), ReadShareRemoteNamespace (..), - ShareRepo (ShareRepo), WriteGitRemotePath (..), WriteGitRepo, WriteRemotePath (..), @@ -2231,7 +2230,7 @@ resolveConfiguredUrl pushPull destPath' = ExceptT do let configKey = gitUrlKey destPath (eval . ConfigLookup) configKey >>= \case Just url -> - case P.parse UriParser.writeRepoPath (Text.unpack configKey) url of + case P.parse UriParser.writeRemotePath (Text.unpack configKey) url of Left e -> pure . Left $ ConfiguredGitUrlParseError pushPull destPath' url (show e) diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 55d1b2c3c6..f24e18ed1e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -3,8 +3,7 @@ module Unison.Codebase.Editor.UriParser ( repoPath, writeGitRepo, - writeRepo, - writeRepoPath, + writeRemotePath, ) where @@ -14,15 +13,17 @@ import Data.Text as Text import Data.Void import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as C -import qualified Text.Megaparsec.Char.Lexer as L +import qualified Text.Megaparsec.Char as P import Unison.Codebase.Editor.RemoteRepo ( ReadGitRemoteNamespace (..), ReadGitRepo (..), ReadRemoteNamespace (..), + ReadShareRemoteNamespace (..), + ShareRepo (..), WriteGitRemotePath (..), WriteGitRepo (..), WriteRemotePath (..), - WriteRepo (..), + WriteShareRemotePath (..), ) import Unison.Codebase.Path (Path (..)) import qualified Unison.Codebase.Path as Path @@ -30,6 +31,7 @@ import Unison.Codebase.ShortBranchHash (ShortBranchHash (..)) import qualified Unison.Hash as Hash import qualified Unison.Lexer import Unison.NameSegment (NameSegment (..)) +import qualified Unison.NameSegment as NameSegment import Unison.Prelude type P = P.Parsec Void Text.Text @@ -53,43 +55,108 @@ type P = P.Parsec Void Text.Text -- $ git clone [user@]server:project.git[:treeish][:[#hash][.path]] repoPath :: P ReadRemoteNamespace -repoPath = P.label "generic git repo" $ do - protocol <- parseProtocol - treeish <- P.optional treeishSuffix +repoPath = + P.label "generic repo" $ + fmap ReadRemoteNamespaceGit readGitRemoteNamespace + <|> fmap ReadRemoteNamespaceShare readShareRemoteNamespace + +-- >>> P.parseMaybe writeRemotePath "unisonweb.base._releases.M4" +-- >>> P.parseMaybe writeRemotePath "git(git@github.com:unisonweb/base:v3)._releases.M3" +-- Just (WriteRemotePathShare (WriteShareRemotePath {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})) +-- Just (WriteRemotePathGit (WriteGitRemotePath {repo = WriteGitRepo {url = "git@github.com:unisonweb/base", branch = Just "v3"}, path = _releases.M3})) +writeRemotePath :: P WriteRemotePath +writeRemotePath = + (fmap WriteRemotePathGit writeGitRemotePath) + <|> fmap WriteRemotePathShare writeShareRemotePath + +-- >>> P.parseMaybe writeShareRemotePath "unisonweb.base._releases.M4" +-- Just (WriteShareRemotePath {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}) +writeShareRemotePath :: P WriteShareRemotePath +writeShareRemotePath = + P.label "write share remote path" $ + WriteShareRemotePath + <$> pure ShareRepo + <*> (NameSegment.toText <$> nameSegment) + <*> (Path.fromList <$> P.many (C.char '.' *> nameSegment)) + +-- >>> P.parseMaybe readShareRemoteNamespace ".unisonweb.base._releases.M4" +-- >>> P.parseMaybe readShareRemoteNamespace "unisonweb.base._releases.M4" +-- Nothing +-- Just (ReadShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}) +readShareRemoteNamespace :: P ReadShareRemoteNamespace +readShareRemoteNamespace = do + P.label "read share remote namespace" $ + ReadShareRemoteNamespace + <$> pure ShareRepo + -- <*> sbh <- P.optional shortBranchHash + <*> (NameSegment.toText <$> nameSegment) + <*> (Path.fromList <$> P.many (C.char '.' *> nameSegment)) + +-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf.foo.bar" +-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf" +-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf." +-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)" +-- >>> P.parseMaybe readGitRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3" +-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = foo.bar}) +-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = }) +-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = }) +-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Nothing, path = }) +-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "git@github.com:unisonweb/base", ref = Just "v3"}, sbh = Nothing, path = _releases.M3}) +readGitRemoteNamespace :: P ReadGitRemoteNamespace +readGitRemoteNamespace = P.label "generic git repo" $ do + P.string "git(" + protocol <- parseGitProtocol + treeish <- P.optional gitTreeishSuffix let repo = ReadGitRepo {url = printProtocol protocol, ref = treeish} - nshashPath <- P.optional (C.char ':' *> namespaceHashPath) - pure do - ReadRemoteNamespaceGit do - case nshashPath of - Nothing -> ReadGitRemoteNamespace {repo, sbh = Nothing, path = Path.empty} - Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path} - --- FIXME parse share paths too -writeRepo :: P WriteRepo -writeRepo = - WriteRepoGit <$> writeGitRepo + P.string ")" + nshashPath <- P.optional namespaceHashPath + pure case nshashPath of + Nothing -> ReadGitRemoteNamespace {repo, sbh = Nothing, path = Path.empty} + Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path} +-- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git)" +-- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git:branch)" +-- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Nothing}) +-- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"}) +-- +-- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git)" +-- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git:branch)" +-- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing}) +-- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"}) +-- +-- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git)" +-- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git:base)" +-- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing}) +-- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"}) +-- +-- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git)" +-- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git:branch)" +-- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git)" +-- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git:branch)" +-- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing}) +-- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"}) +-- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Nothing}) +-- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"}) +-- +-- >>> P.parseMaybe writeGitRepo "git(server:project)" +-- >>> P.parseMaybe writeGitRepo "git(user@server:project.git:branch)" +-- Just (WriteGitRepo {url = "server:project", branch = Nothing}) +-- Just (WriteGitRepo {url = "user@server:project.git", branch = Just "branch"}) writeGitRepo :: P WriteGitRepo writeGitRepo = P.label "repo root for writing" $ do - uri <- parseProtocol - treeish <- P.optional treeishSuffix + P.string "git(" + uri <- parseGitProtocol + treeish <- P.optional gitTreeishSuffix + P.string ")" pure WriteGitRepo {url = printProtocol uri, branch = treeish} -writeRepoPath :: P WriteRemotePath -writeRepoPath = - -- FIXME parse share paths too - WriteRemotePathGit <$> writeGitRepoPath - -writeGitRepoPath :: P WriteGitRemotePath -writeGitRepoPath = P.label "generic write repo" $ do +-- git(myrepo@git.com).foo.bar +writeGitRemotePath :: P WriteGitRemotePath +writeGitRemotePath = P.label "generic write repo" $ do repo <- writeGitRepo - path <- P.optional (C.char ':' *> absolutePath) + path <- P.optional absolutePath pure WriteGitRemotePath {repo, path = fromMaybe Path.empty path} --- does this not exist somewhere in megaparsec? yes in 7.0 -symbol :: Text -> P Text -symbol = L.symbol (pure ()) - data GitProtocol = HttpsProtocol (Maybe User) HostInfo UrlPath | SshProtocol (Maybe User) HostInfo UrlPath @@ -136,29 +203,29 @@ type Host = Text -- no port -- doesn't yet handle basic authentication like https://user:pass@server.com -- (does anyone even want that?) -- or handle ipv6 addresses (https://en.wikipedia.org/wiki/IPv6#Addressing) -parseProtocol :: P GitProtocol -parseProtocol = - P.label "parseProtocol" $ +parseGitProtocol :: P GitProtocol +parseGitProtocol = + P.label "parseGitProtocol" $ fileRepo <|> httpsRepo <|> sshRepo <|> scpRepo <|> localRepo where localRepo, fileRepo, httpsRepo, sshRepo, scpRepo :: P GitProtocol parsePath = P.takeWhile1P (Just "repo path character") - (\c -> not (isSpace c || c == ':')) + (\c -> not (isSpace c || c == ':' || c == ')')) localRepo = LocalProtocol <$> parsePath fileRepo = P.label "fileRepo" $ do - void $ symbol "file://" + void $ P.string "file://" FileProtocol <$> parsePath httpsRepo = P.label "httpsRepo" $ do - void $ symbol "https://" + void $ P.string "https://" HttpsProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath sshRepo = P.label "sshRepo" $ do - void $ symbol "ssh://" + void $ P.string "ssh://" SshProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath scpRepo = P.label "scpRepo" . P.try $ - ScpProtocol <$> P.optional userInfo <*> parseHost <* symbol ":" <*> parsePath + ScpProtocol <$> P.optional userInfo <*> parseHost <* P.string ":" <*> parsePath userInfo :: P User userInfo = P.label "userInfo" . P.try $ do username <- P.takeWhile1P (Just "username character") (/= '@') @@ -169,7 +236,7 @@ parseProtocol = P.label "parseHostInfo" $ HostInfo <$> parseHost <*> ( P.optional $ do - void $ symbol ":" + void $ P.string ":" P.takeWhile1P (Just "digits") isDigit ) @@ -190,29 +257,47 @@ parseProtocol = pure $ Text.pack $ o1 <> "." <> o2 <> "." <> o3 <> "." <> o4 decOctet = P.count' 1 3 C.digitChar --- #nshashabc.path.foo.bar or .path.foo.bar +-- >>> P.parseMaybe namespaceHashPath "#nshashabc.path.foo.bar" +-- Just (Just #nshashabc,path.foo.bar) +-- +-- >>> P.parseMaybe namespaceHashPath ".path.foo.bar" +-- Just (Nothing,path.foo.bar) +-- +-- >>> P.parseMaybe namespaceHashPath "#nshashabc" +-- Just (Just #nshashabc,) +-- +-- >>> P.parseMaybe namespaceHashPath "#nshashabc." +-- Just (Just #nshashabc,) +-- +-- >>> P.parseMaybe namespaceHashPath "." +-- Just (Nothing,) namespaceHashPath :: P (Maybe ShortBranchHash, Path) namespaceHashPath = do sbh <- P.optional shortBranchHash p <- P.optional absolutePath pure (sbh, fromMaybe Path.empty p) +-- >>> P.parseMaybe absolutePath "." +-- Just +-- +-- >>> P.parseMaybe absolutePath ".path.foo.bar" +-- Just path.foo.bar absolutePath :: P Path absolutePath = do void $ C.char '.' - Path . Seq.fromList . fmap (NameSegment . Text.pack) - <$> P.sepBy1 - ( (:) <$> C.satisfy Unison.Lexer.wordyIdStartChar - <*> P.many (C.satisfy Unison.Lexer.wordyIdChar) - ) - (C.char '.') - -treeishSuffix :: P Text -treeishSuffix = P.label "git treeish" . P.try $ do + Path . Seq.fromList <$> P.sepBy nameSegment (C.char '.') + +nameSegment :: P NameSegment +nameSegment = + NameSegment . Text.pack + <$> ( (:) <$> C.satisfy Unison.Lexer.wordyIdStartChar + <*> P.many (C.satisfy Unison.Lexer.wordyIdChar) + ) + +gitTreeishSuffix :: P Text +gitTreeishSuffix = P.label "git treeish" . P.try $ do void $ C.char ':' - notdothash <- C.noneOf @[] ".#:" - rest <- P.takeWhileP (Just "not colon") (/= ':') - pure $ Text.cons notdothash rest + P.takeWhile1P (Just "not close paren") (/= ')') shortBranchHash :: P ShortBranchHash shortBranchHash = P.label "short branch hash" $ do diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 4ecc2fdc12..e73fcc93cf 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1273,7 +1273,7 @@ parsePushPath :: String -> String -> Either (P.Pretty P.ColorText) WriteRemotePa parsePushPath label input = do first (fromString . show) -- turn any parsing errors into a Pretty. - (P.parse UriParser.writeRepoPath label (Text.pack input)) + (P.parse UriParser.writeRemotePath label (Text.pack input)) squashMerge :: InputPattern squashMerge = diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index d099ed5996..72c1c8aa40 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1589,10 +1589,45 @@ notifyUser dir o = case o of PrintVersion ucmVersion -> pure (P.text ucmVersion) ShareError x -> (pure . P.warnCallout) case x of ShareErrorCheckAndSetPush e -> case e of - (Share.CheckAndSetPushErrorHashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash}) -> + (Share.CheckAndSetPushErrorHashMismatch Share.HashMismatch {path = sharePath, expectedHash = _expectedHash, actualHash = _actualHash}) -> P.wrap $ P.text "It looks like someone modified" <> prettySharePath sharePath <> P.text "an instant before you. Pull and try again? ๐Ÿคž" (Share.CheckAndSetPushErrorNoWritePermission sharePath) -> noWritePermission sharePath - (Share.CheckAndSetPushErrorServerMissingDependencies hashes) -> + (Share.CheckAndSetPushErrorServerMissingDependencies hashes) -> missingDependencies hashes + ShareErrorFastForwardPush e -> case e of + (Share.FastForwardPushErrorNoHistory sharePath) -> + expectedNonEmptyPushDest (sharePathToWriteRemotePathShare sharePath) + (Share.FastForwardPushErrorNoReadPermission sharePath) -> noReadPermission sharePath + Share.FastForwardPushErrorNotFastForward sharePath -> + P.lines $ + [ P.wrap $ + "There are some changes at" <> prettySharePath sharePath <> "that aren't in the history you pushed.", + "", + P.wrap $ + "If you're sure you got the right paths, try" + <> pull + <> "to merge these changes locally, then" + <> push + <> "again." + ] + where + push = P.group . P.backticked . IP.patternName $ IP.push + pull = P.group . P.backticked . IP.patternName $ IP.pull + (Share.FastForwardPushErrorNoWritePermission sharePath) -> noWritePermission sharePath + (Share.FastForwardPushErrorServerMissingDependencies hashes) -> missingDependencies hashes + ShareErrorPull e -> case e of + (Share.PullErrorGetCausalHashByPath err) -> handleGetCausalHashByPathError err + (Share.PullErrorNoHistoryAtPath sharePath) -> + P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath + ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err + where + prettySharePath = + prettyRelative + . Path.Relative + . Path.fromList + . coerce @[Text] @[NameSegment] + . toList + . Share.pathSegments + missingDependencies hashes = -- maybe todo: stuff in all the args to CheckAndSetPush P.lines [ P.wrap @@ -1603,28 +1638,6 @@ notifyUser dir o = case o of P.text "The hashes it expected are:\n" <> P.indentN 2 (P.lines (map prettyShareHash (toList hashes))) ] - ShareErrorFastForwardPush e -> case e of - (Share.FastForwardPushErrorNoHistory sharePath) -> - expectedNonEmptyPushDest - -- Recover the original WriteRemotePath from the information in the error, which is thrown from generic share - -- client code that doesn't know about WriteRemotePath - ( WriteRemotePathShare - WriteShareRemotePath - { server = RemoteRepo.ShareRepo, - repo = Share.unRepoName (Share.pathRepoName sharePath), - path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath)) - } - ) - (Share.FastForwardPushErrorNoReadPermission sharePath) -> noReadPermission sharePath - Share.FastForwardPushErrorNotFastForward -> wundefined - (Share.FastForwardPushErrorNoWritePermission sharePath) -> noWritePermission sharePath - (Share.FastForwardPushErrorServerMissingDependencies hashes) -> wundefined - ShareErrorPull e -> case e of - (Share.PullErrorGetCausalHashByPath err) -> handleGetCausalHashByPathError err - (Share.PullErrorNoHistoryAtPath sharePath) -> wundefined - ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err - where - prettySharePath sharePath = undefined handleGetCausalHashByPathError = \case Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermission sharePath noReadPermission sharePath = @@ -1639,6 +1652,16 @@ notifyUser dir o = case o of "", "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" ] + sharePathToWriteRemotePathShare sharePath = + -- Recover the original WriteRemotePath from the information in the error, which is thrown from generic share + -- client code that doesn't know about WriteRemotePath + ( WriteRemotePathShare + WriteShareRemotePath + { server = RemoteRepo.ShareRepo, + repo = Share.unRepoName (Share.pathRepoName sharePath), + path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath)) + } + ) -- do -- when (not . Set.null $ E.changedSuccessfully r) . putPrettyLn . P.okCallout $ diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index af664f2945..31bf34895e 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -134,7 +134,7 @@ checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash = do data FastForwardPushError = FastForwardPushErrorNoHistory Share.Path | FastForwardPushErrorNoReadPermission Share.Path - | FastForwardPushErrorNotFastForward + | FastForwardPushErrorNotFastForward Share.Path | FastForwardPushErrorNoWritePermission Share.Path | FastForwardPushErrorServerMissingDependencies (NESet Share.Hash) @@ -160,7 +160,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = Sqlite.runTransaction conn (fancyBfs localHeadHash remoteHeadHash) >>= \case -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a -- fast-forward push, so we don't bother trying - just report the error now. - Nothing -> pure (Left FastForwardPushErrorNotFastForward) + Nothing -> pure (Left (FastForwardPushErrorNotFastForward path)) Just localTailHashes -> doUpload (localHeadHash :| localTailHashes) >>= \case False -> pure (Left (FastForwardPushErrorNoWritePermission path)) @@ -173,7 +173,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = -- path but moments ago! Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory path) Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission path) - Share.FastForwardPathNotFastForward _ -> Left FastForwardPushErrorNotFastForward + Share.FastForwardPathNotFastForward _ -> Left (FastForwardPushErrorNotFastForward path) where doUpload :: List.NonEmpty CausalHash -> IO Bool -- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes", but we From 4d6e8f9377414e5c1cebcb39eb4b09a1bee020e5 Mon Sep 17 00:00:00 2001 From: Karthik Ravikanti Date: Tue, 17 May 2022 10:43:49 +0800 Subject: [PATCH 220/529] Support version option Close #2981 Co-authored-by: Alberto Flores --- unison-cli/unison/ArgParse.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/unison-cli/unison/ArgParse.hs b/unison-cli/unison/ArgParse.hs index ece7471a48..29ccfc2df0 100644 --- a/unison-cli/unison/ArgParse.hs +++ b/unison-cli/unison/ArgParse.hs @@ -7,7 +7,7 @@ -- See the excellent documentation at https://hackage.haskell.org/package/optparse-applicative module ArgParse where -import Control.Applicative (Alternative (many, (<|>)), Applicative (liftA2), optional, (<**>)) +import Control.Applicative (Alternative (many, (<|>)), Applicative (liftA2), optional) import Data.Foldable (Foldable (fold)) import Data.Functor ((<&>)) import qualified Data.List as List @@ -34,6 +34,7 @@ import Options.Applicative helper, hsubparser, info, + infoOption, long, metavar, option, @@ -112,7 +113,7 @@ data GlobalOptions = GlobalOptions rootParserInfo :: String -> String -> CodebaseServerOpts -> ParserInfo (GlobalOptions, Command) rootParserInfo progName version envOpts = info - ((,) <$> globalOptionsParser <*> commandParser envOpts <**> helper) + (helper <*> versionOptionParser progName version <*> ((,) <$> globalOptionsParser <*> commandParser envOpts)) ( fullDesc <> headerDoc (Just $ unisonHelp progName version) ) @@ -265,6 +266,10 @@ codebaseCreateParser = do <> help "The path to a new or existing codebase (one will be created if there isn't one)" pure (fmap CreateCodebaseWhenMissing path) +versionOptionParser :: String -> String -> Parser (a -> a) +versionOptionParser progName version = + infoOption (progName <> " version: " <> version) (short 'v' <> long "version" <> help "Show version") + launchHeadlessCommand :: CodebaseServerOpts -> Mod CommandFields Command launchHeadlessCommand envOpts = command "headless" (info (launchParser envOpts Headless) (progDesc headlessHelp)) From 37add698d12c1f152e2b05894ddabb364d2417c7 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 17 May 2022 18:45:06 -0400 Subject: [PATCH 221/529] plumb new repo types --- docs/release-steps.md | 8 +- hie.yaml | 43 +- parser-typechecker/package.yaml | 242 +++--- .../src/Unison/Codebase/SqliteCodebase.hs | 1 - .../unison-parser-typechecker.cabal | 87 +- .../src/Unison/CommandLine/InputPatterns.hs | 12 +- .../src/Unison/CommandLine/OutputMessages.hs | 52 +- unison-cli/src/Unison/Share/Sync.hs | 3 +- unison-cli/tests/Unison/Test/GitSync.hs | 783 ++++++++---------- unison-cli/tests/Unison/Test/UriParser.hs | 4 +- 10 files changed, 618 insertions(+), 617 deletions(-) diff --git a/docs/release-steps.md b/docs/release-steps.md index 34b5b0ef29..026b592209 100644 --- a/docs/release-steps.md +++ b/docs/release-steps.md @@ -40,7 +40,7 @@ Cut a release of base. @runarorama does this usually. ``` -.> pull git@github.com:unisonweb/base basedev.release +.> pull git(git@github.com:unisonweb/base) basedev.release .> cd .basedev.release .basedev.release> delete.namespace releases._latest .basedev.release> squash trunk releases._ @@ -50,7 +50,7 @@ Edit `releases._.README` to include `Release: `. ``` .basedev.release> fork releases._ releases._latest -.basedev.release> push git@github.com:unisonweb/base +.basedev.release> push git(git@github.com:unisonweb/base) ``` __6__ @@ -64,7 +64,7 @@ Build a new version of Unison Share by following these instructions: https://git __8__ -Update homebrew. +Update homebrew. ``` git clone git@github.com/unisonweb/homebrew-unison.git @@ -96,7 +96,7 @@ Release announcement template (be sure to update the release urls) - We've just released a new version of Unison, $RELEASE_NAME, release notes here (link to the issue). Install/upgrade instructions in the thread. -Mac upgrade is just `brew upgrade unison-language`. +Mac upgrade is just `brew upgrade unison-language`. A fresh install via: diff --git a/hie.yaml b/hie.yaml index 06fd56067b..182444fff6 100644 --- a/hie.yaml +++ b/hie.yaml @@ -1,6 +1,6 @@ cradle: stack: - - path: "codebase2/codebase" + - path: "codebase2/codebase/" component: "unison-codebase:lib" - path: "codebase2/codebase-sqlite" @@ -12,12 +12,12 @@ cradle: - path: "codebase2/core" component: "unison-core:lib" - - path: "codebase2/util/bench" - component: "unison-util:bench:bench" - - path: "codebase2/util/src" component: "unison-util:lib" + - path: "codebase2/util/bench" + component: "unison-util:bench:bench" + - path: "codebase2/util-serialization" component: "unison-util-serialization:lib" @@ -27,12 +27,18 @@ cradle: - path: "lib/unison-prelude/src" component: "unison-prelude:lib" + - path: "lib/unison-pretty-printer/src" + component: "unison-pretty-printer:lib" + + - path: "lib/unison-pretty-printer/prettyprintdemo" + component: "unison-pretty-printer:exe:prettyprintdemo" + + - path: "lib/unison-pretty-printer/tests" + component: "unison-pretty-printer:test:pretty-printer-tests" + - path: "lib/unison-sqlite/src" component: "unison-sqlite:lib" - - path: "unison-share-api/src" - component: "unison-share-api:lib" - - path: "lib/unison-util-base32hex/src" component: "unison-util-base32hex:lib" @@ -40,7 +46,7 @@ cradle: component: "unison-util-relation:lib" - path: "lib/unison-util-relation/test" - component: "unison-util-relation:test:tests" + component: "unison-util-relation:test:util-relation-tests" - path: "lib/unison-util-relation/benchmarks/relation" component: "unison-util-relation:bench:relation" @@ -48,20 +54,14 @@ cradle: - path: "parser-typechecker/src" component: "unison-parser-typechecker:lib" - - path: "parser-typechecker/prettyprintdemo" - component: "unison-parser-typechecker:exe:prettyprintdemo" - - path: "parser-typechecker/tests" - component: "unison-parser-typechecker:exe:tests" + component: "unison-parser-typechecker:test:parser-typechecker-tests" - path: "unison-cli/src" component: "unison-cli:lib" - path: "unison-cli/integration-tests" - component: "unison-cli:exe:integration-tests" - - - path: "unison-cli/tests" - component: "unison-cli:test:tests" + component: "unison-cli:exe:cli-integration-tests" - path: "unison-cli/transcripts" component: "unison-cli:exe:transcripts" @@ -69,14 +69,17 @@ cradle: - path: "unison-cli/unison" component: "unison-cli:exe:unison" + - path: "unison-cli/tests" + component: "unison-cli:test:cli-tests" + - path: "unison-core/src" component: "unison-core1:lib" + - path: "unison-share-api/src" + component: "unison-share-api:lib" + - path: "yaks/easytest/src" component: "easytest:lib" - - path: "yaks/easytest/tests/Suite.hs" - component: "easytest:exe:runtests" - - path: "yaks/easytest/tests" - component: "easytest:test:tests" + component: "easytest:exe:runtests" diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index b447556d6a..e6ecc05517 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -13,117 +13,115 @@ when: - condition: flag(optimized) ghc-options: -funbox-strict-fields -O2 +dependencies: + - aeson + - ansi-terminal + - async + - base + - base16 >= 0.2.1.0 + - base64-bytestring + - basement + - binary + - bytes + - bytestring + - bytestring-to-vector + - cereal + - configurator + - containers >= 0.6.3 + - cryptonite + - data-default + - data-memocombinators + - deepseq + - directory + - either + - errors + - exceptions + - extra + - filepath + - fingertree + - fsnotify + - fuzzyfind + - generic-lens + - generic-monoid + - hashable + - hashtables + - haskeline + - here + - http-client + - http-media + - http-types + - lens + - ListLike + - lucid + - megaparsec >= 5.0.0 && < 7.0.0 + - memory + - mmorph + - monad-validate + - mtl + - mutable-containers + - mwc-random + - NanoID + - natural-transformation + - network + - network-simple + - nonempty-containers + - open-browser + - openapi3 + - optparse-applicative >= 0.16.1.0 + - pem + - prelude-extras + - primitive + - process + - random >= 1.2.0 + - raw-strings-qq + - regex-base + - regex-tdfa + - safe + - safe-exceptions + - semialign + - servant + - servant-client + - servant-docs + - servant-openapi3 + - servant-server + - shellmet + - stm + - strings + - tagged + - temporary + - terminal-size + - text + - text-short + - these + - time + - tls + - transformers + - unicode-show + - unison-codebase + - unison-codebase-sqlite + - unison-codebase-sync + - unison-core + - unison-core1 + - unison-prelude + - unison-pretty-printer + - unison-sqlite + - unison-util + - unison-util-base32hex + - unison-util-relation + - unliftio + - uri-encode + - utf8-string + - vector + - wai + - warp + - x509 + - x509-store + - x509-system + - yaml + - zlib + library: source-dirs: src - dependencies: - - aeson - - ansi-terminal - - async - - base - - base16 >= 0.2.1.0 - - base64-bytestring - - basement - - binary - - bytes - - bytestring - - bytestring-to-vector - - cereal - - containers >= 0.6.3 - - configurator - - cryptonite - - data-default - - deepseq - - directory - - either - - fuzzyfind - - data-memocombinators - - errors - - exceptions - - extra - - filepath - - fingertree - - fsnotify - - generic-monoid - - generic-lens - - hashable - - hashtables - - haskeline - - here - - http-types - - http-media - - http-client - - lens - - ListLike - - megaparsec >= 5.0.0 && < 7.0.0 - - memory - - mmorph - - monad-validate - - mtl - - mutable-containers - - natural-transformation - - network - - network-simple - - nonempty-containers - - optparse-applicative >= 0.16.1.0 - - openapi3 - - pem - - prelude-extras - - process - - primitive - - random >= 1.2.0 - - raw-strings-qq - - regex-base - - regex-tdfa - - safe - - safe-exceptions - - semialign - - servant-client - - mwc-random - - NanoID - - lucid - - yaml - - semialign - - servant - - servant-docs - - servant-openapi3 - - servant-server - - shellmet - - stm - - strings - - tagged - - temporary - - terminal-size - - text - - text-short - - these - - time - - tls - - transformers - - unliftio - - utf8-string - - unicode-show - - vector - - wai - - warp - - unicode-show - - x509 - - x509-store - - x509-system - - zlib - - unison-codebase - - unison-codebase-sqlite - - unison-codebase-sync - - unison-core - - unison-core1 - - unison-prelude - - unison-pretty-printer - - unison-sqlite - - unison-util - - unison-util-base32hex - - unison-util-relation - - open-browser - - uri-encode - - generic-lens tests: parser-typechecker-tests: @@ -131,37 +129,11 @@ tests: main: Suite.hs ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 dependencies: - - async - - base - - bytestring - code-page - - containers - - directory - easytest - - errors - - exceptions - - extra - - filepath - filemanip - - haskeline - - here - - lens - - megaparsec - - mtl - - raw-strings-qq - - stm - - shellmet - split - - temporary - - text - - transformers - - unliftio - - unison-core1 - unison-parser-typechecker - - unison-prelude - - unison-util - - unison-util-relation - - unison-pretty-printer default-extensions: - ApplicativeDo diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 4613f75942..6c974315a8 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -49,7 +49,6 @@ import Unison.Codebase.Editor.RemoteRepo ( ReadGitRemoteNamespace (..), ReadGitRepo, WriteGitRepo (..), - WriteRepo (..), printWriteGitRepo, writeToReadGit, ) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 15cb81e4b7..a9bbf6c5af 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack @@ -367,37 +367,116 @@ test-suite parser-typechecker-tests ViewPatterns ghc-options: -Wall -O0 -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 build-depends: - async + ListLike + , NanoID + , aeson + , ansi-terminal + , async , base + , base16 >=0.2.1.0 + , base64-bytestring + , basement + , binary + , bytes , bytestring + , bytestring-to-vector + , cereal , code-page - , containers + , configurator + , containers >=0.6.3 + , cryptonite + , data-default + , data-memocombinators + , deepseq , directory , easytest + , either , errors , exceptions , extra , filemanip , filepath + , fingertree + , fsnotify + , fuzzyfind + , generic-lens + , generic-monoid + , hashable + , hashtables , haskeline , here + , http-client + , http-media + , http-types , lens - , megaparsec + , lucid + , megaparsec >=5.0.0 && <7.0.0 + , memory + , mmorph + , monad-validate , mtl + , mutable-containers + , mwc-random + , natural-transformation + , network + , network-simple + , nonempty-containers + , open-browser + , openapi3 + , optparse-applicative >=0.16.1.0 + , pem + , prelude-extras + , primitive + , process + , random >=1.2.0 , raw-strings-qq + , regex-base + , regex-tdfa + , safe + , safe-exceptions + , semialign + , servant + , servant-client + , servant-docs + , servant-openapi3 + , servant-server , shellmet , split , stm + , strings + , tagged , temporary + , terminal-size , text + , text-short + , these + , time + , tls , transformers + , unicode-show + , unison-codebase + , unison-codebase-sqlite + , unison-codebase-sync + , unison-core , unison-core1 , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-sqlite , unison-util + , unison-util-base32hex , unison-util-relation , unliftio + , uri-encode + , utf8-string + , vector + , wai + , warp + , x509 + , x509-store + , x509-system + , yaml + , zlib if flag(optimized) ghc-options: -funbox-strict-fields -O2 default-language: Haskell2010 diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index e73fcc93cf..7dd13d9854 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -2319,12 +2319,12 @@ gitUrlArg = suggestions = let complete s = pure [Completion s s False] in \input _ _ _ -> case input of - "gh" -> complete "https://github.com/" - "gl" -> complete "https://gitlab.com/" - "bb" -> complete "https://bitbucket.com/" - "ghs" -> complete "git@github.com:" - "gls" -> complete "git@gitlab.com:" - "bbs" -> complete "git@bitbucket.com:" + "gh" -> complete "git(https://github.com/" + "gl" -> complete "git(https://gitlab.com/" + "bb" -> complete "git(https://bitbucket.com/" + "ghs" -> complete "git(git@github.com:" + "gls" -> complete "git(git@gitlab.com:" + "bbs" -> complete "git(git@bitbucket.com:" _ -> pure [], globTargets = mempty } diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 72c1c8aa40..41d97ae987 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -45,10 +45,10 @@ import qualified Unison.Codebase.Editor.Output as E import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBD import Unison.Codebase.Editor.RemoteRepo - ( ReadRemoteNamespace, - ReadRepo (..), + ( ReadGitRepo, + ReadRemoteNamespace, + WriteGitRepo, WriteRemotePath (..), - WriteRepo (..), WriteShareRemotePath (..), ) import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo @@ -1058,14 +1058,14 @@ notifyUser dir o = case o of NoDatabaseFile repo localPath -> P.wrap $ "I didn't find a codebase in the repository at" - <> prettyReadRepo (ReadRepoGit repo) + <> prettyReadGitRepo repo <> "in the cache directory at" <> P.backticked' (P.string localPath) "." UnrecognizedSchemaVersion repo localPath (SchemaVersion v) -> P.wrap $ "I don't know how to interpret schema version " <> P.shown v <> "in the repository at" - <> prettyReadRepo (ReadRepoGit repo) + <> prettyReadGitRepo repo <> "in the cache directory at" <> P.backticked' (P.string localPath) "." GitCouldntParseRootBranchHash repo s -> @@ -1073,7 +1073,7 @@ notifyUser dir o = case o of "I couldn't parse the string" <> P.red (P.string s) <> "into a namespace hash, when opening the repository at" - <> P.group (prettyReadRepo (ReadRepoGit repo) <> ".") + <> P.group (prettyReadGitRepo repo <> ".") GitProtocolError e -> case e of NoGit -> P.wrap $ @@ -1084,7 +1084,7 @@ notifyUser dir o = case o of <> P.group (P.shown e) CloneException repo msg -> P.wrap $ - "I couldn't clone the repository at" <> prettyReadRepo (ReadRepoGit repo) <> ";" + "I couldn't clone the repository at" <> prettyReadGitRepo repo <> ";" <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg CopyException srcRepoPath destPath msg -> @@ -1094,10 +1094,10 @@ notifyUser dir o = case o of <> (P.indentNAfterNewline 2 . P.group . P.string) msg PushNoOp repo -> P.wrap $ - "The repository at" <> prettyWriteRepo (WriteRepoGit repo) <> "is already up-to-date." + "The repository at" <> prettyWriteGitRepo repo <> "is already up-to-date." PushException repo msg -> P.wrap $ - "I couldn't push to the repository at" <> prettyWriteRepo (WriteRepoGit repo) <> ";" + "I couldn't push to the repository at" <> prettyWriteGitRepo repo <> ";" <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg RemoteRefNotFound repo ref -> @@ -1106,7 +1106,7 @@ notifyUser dir o = case o of UnrecognizableCacheDir uri localPath -> P.wrap $ "A cache directory for" - <> P.backticked (P.text $ RemoteRepo.printReadRepo (ReadRepoGit uri)) + <> P.backticked (P.text $ RemoteRepo.printReadGitRepo uri) <> "already exists at" <> P.backticked' (P.string localPath) "," <> "but it doesn't seem to" @@ -1114,7 +1114,7 @@ notifyUser dir o = case o of UnrecognizableCheckoutDir uri localPath -> P.wrap $ "I tried to clone" - <> P.backticked (P.text $ RemoteRepo.printReadRepo (ReadRepoGit uri)) + <> P.backticked (P.text $ RemoteRepo.printReadGitRepo uri) <> "into a cache directory at" <> P.backticked' (P.string localPath) "," <> "but I can't recognize the" @@ -1122,7 +1122,7 @@ notifyUser dir o = case o of PushDestinationHasNewStuff repo -> P.callout "โธ" . P.lines $ [ P.wrap $ - "The repository at" <> prettyWriteRepo (WriteRepoGit repo) + "The repository at" <> prettyWriteGitRepo repo <> "has some changes I don't know about.", "", P.wrap $ "Try" <> pull <> "to merge these changes locally, then" <> push <> "again." @@ -1136,13 +1136,13 @@ notifyUser dir o = case o of "I couldn't decode the root branch " <> P.string s <> "from the repository at" - <> prettyReadRepo (ReadRepoGit repo) + <> prettyReadGitRepo repo CouldntLoadRootBranch repo hash -> P.wrap $ "I couldn't load the designated root hash" <> P.group ("(" <> P.text (Hash.base32Hex $ Causal.unRawHash hash) <> ")") <> "from the repository at" - <> prettyReadRepo (ReadRepoGit repo) + <> prettyReadGitRepo repo CouldntLoadSyncedBranch ns h -> P.wrap $ "I just finished importing the branch" <> P.red (P.shown h) @@ -1154,10 +1154,10 @@ notifyUser dir o = case o of "I couldn't find the remote branch at" <> P.shown path <> "in the repository at" - <> prettyReadRepo (ReadRepoGit repo) + <> prettyReadGitRepo repo NoRemoteNamespaceWithHash repo sbh -> P.wrap $ - "The repository at" <> prettyReadRepo (ReadRepoGit repo) + "The repository at" <> prettyReadGitRepo repo <> "doesn't contain a namespace with the hash prefix" <> (P.blue . P.text . SBH.toText) sbh RemoteNamespaceHashAmbiguous repo sbh hashes -> @@ -1165,7 +1165,7 @@ notifyUser dir o = case o of [ P.wrap $ "The namespace hash" <> prettySBH sbh <> "at" - <> prettyReadRepo (ReadRepoGit repo) + <> prettyReadGitRepo repo <> "is ambiguous." <> "Did you mean one of these hashes?", "", @@ -2912,15 +2912,17 @@ prettyTypeName ppe r = P.syntaxToColor $ prettyHashQualified (PPE.typeName ppe r) -prettyReadRepo :: ReadRepo -> Pretty -prettyReadRepo = \case - RemoteRepo.ReadRepoGit RemoteRepo.ReadGitRepo {url} -> P.blue (P.text url) - RemoteRepo.ReadRepoShare s -> P.blue (P.text (RemoteRepo.printShareRepo s)) +prettyReadGitRepo :: ReadGitRepo -> Pretty +prettyReadGitRepo = \case + RemoteRepo.ReadGitRepo {url} -> P.blue (P.text url) -prettyWriteRepo :: WriteRepo -> Pretty -prettyWriteRepo = \case - RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url} -> P.blue (P.text url) - RemoteRepo.WriteRepoShare s -> P.blue (P.text (RemoteRepo.printShareRepo s)) +prettyWriteGitRepo :: WriteGitRepo -> Pretty +prettyWriteGitRepo RemoteRepo.WriteGitRepo {url} = P.blue (P.text url) + +-- prettyWriteRepo :: WriteRepo -> Pretty +-- prettyWriteRepo = \case +-- RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url} -> P.blue (P.text url) +-- RemoteRepo.WriteRepoShare s -> P.blue (P.text (RemoteRepo.printShareRepo s)) isTestOk :: Term v Ann -> Bool isTestOk tm = case tm of diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 707ea33a39..e296fccc11 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -25,7 +25,6 @@ module Unison.Share.Sync ) where -import Control.Exception (throwIO) import qualified Control.Lens as Lens import Control.Monad.Extra ((||^)) import Control.Monad.Trans.Reader (ReaderT, runReaderT) @@ -37,7 +36,7 @@ import qualified Data.List.NonEmpty as List.NonEmpty import Data.Map.NonEmpty (NEMap) import qualified Data.Map.NonEmpty as NEMap import Data.Sequence.NonEmpty (NESeq ((:<||))) -import qualified Data.Sequence.NonEmpty as NESeq (fromList, nonEmptySeq, singleton, (><|)) +import qualified Data.Sequence.NonEmpty as NESeq (fromList, nonEmptySeq, (><|)) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet diff --git a/unison-cli/tests/Unison/Test/GitSync.hs b/unison-cli/tests/Unison/Test/GitSync.hs index b4dd5c35c7..0036c4b9c1 100644 --- a/unison-cli/tests/Unison/Test/GitSync.hs +++ b/unison-cli/tests/Unison/Test/GitSync.hs @@ -49,59 +49,59 @@ test = fmt ( \repo -> [i| - ```unison:hide - x = 1 - ``` - ```ucm:hide - .> add - .> push.create ${repo} - ``` - |] + ```unison:hide + x = 1 + ``` + ```ucm:hide + .> add + .> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| - ```unison:hide - child.y = 2 - ``` + ```unison:hide + child.y = 2 + ``` - Should be able to pull a branch from the repo over top of our deleted local branch. - ```ucm - .> add - .> delete.namespace child - .> pull ${repo} child - ``` - |] + Should be able to pull a branch from the repo over top of our deleted local branch. + ```ucm + .> add + .> delete.namespace child + .> pull git(${repo}) child + ``` + |] ), pushPullTest "pull.without-history" fmt ( \repo -> [i| - ```unison:hide - child.x = 1 - ``` + ```unison:hide + child.x = 1 + ``` - ```ucm:hide - .> add - ``` + ```ucm:hide + .> add + ``` - ```unison:hide - child.y = 2 - ``` + ```unison:hide + child.y = 2 + ``` - ```ucm:hide - .> add - ``` + ```ucm:hide + .> add + ``` - ```unison:hide - child.x = 3 - ``` + ```unison:hide + child.x = 3 + ``` - ```ucm:hide - .> update - .> push.create ${repo} - ``` - |] + ```ucm:hide + .> update + .> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| @@ -119,228 +119,228 @@ test = fmt ( \repo -> [i| - ```unison:hide - child.x = 1 - y = 2 - ``` - ```ucm:hide - .> add - .> delete.namespace child - .> push.create ${repo} - ``` - |] + ```unison:hide + child.x = 1 + y = 2 + ``` + ```ucm:hide + .> add + .> delete.namespace child + .> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| - ```unison:hide - child.z = 3 - ``` + ```unison:hide + child.z = 3 + ``` - Should be able to push a branch over top of a deleted remote branch. - ```ucm - .> add - .> push.create ${repo}:.child child - ``` - |] + Should be able to push a branch over top of a deleted remote branch. + ```ucm + .> add + .> push.create git(${repo}).child child + ``` + |] ), pushPullTest "typeAlias" fmt ( \repo -> [i| - ```ucm - .> alias.type ##Nat builtin.Nat - .> history - .> history builtin - .> push.create ${repo} - ``` - |] + ```ucm + .> alias.type ##Nat builtin.Nat + .> history + .> history builtin + .> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| - ```ucm - .> pull ${repo} - ``` - ```unison - x : Nat - x = 3 - ``` - |] + ```ucm + .> pull git(${repo}) + ``` + ```unison + x : Nat + x = 3 + ``` + |] ), pushPullTest "topLevelTerm" fmt ( \repo -> [i| - ```unison:hide - y = 3 - ``` - ```ucm - .> add - .> history - .> push.create ${repo} - ``` - |] + ```unison:hide + y = 3 + ``` + ```ucm + .> add + .> history + .> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| - ```ucm - .> pull ${repo} - .> find - ``` - ```unison - > y - ``` - |] + ```ucm + .> pull git(${repo}) + .> find + ``` + ```unison + > y + ``` + |] ), pushPullTest "metadataForTerm" fmt ( \repo -> [i| - ```unison:hide - doc = "y is the number 3" - y = 3 - ``` - ```ucm - .> debug.file - .> add - .> link doc y - .> links y - .> history - .> push.create ${repo} - ``` - |] + ```unison:hide + doc = "y is the number 3" + y = 3 + ``` + ```ucm + .> debug.file + .> add + .> link doc y + .> links y + .> history + .> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| - ```ucm - .> pull ${repo} - .> links y - ``` - |] + ```ucm + .> pull git(${repo}) + .> links y + ``` + |] ), pushPullTest "metadataForType" fmt ( \repo -> [i| - ```unison:hide - doc = "Nat means natural number" - ``` - ```ucm - .> add - .> alias.type ##Nat Nat - .> link doc Nat - .> push.create ${repo} - ``` - |] + ```unison:hide + doc = "Nat means natural number" + ``` + ```ucm + .> add + .> alias.type ##Nat Nat + .> link doc Nat + .> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| - ```ucm - .> pull ${repo} - .> links Nat - ``` - |] + ```ucm + .> pull git(${repo}) + .> links Nat + ``` + |] ), pushPullTest "subNamespace" fmt ( \repo -> [i| - ```ucm - .> alias.type ##Nat builtin.Nat - ``` - ```unison - unique type a.b.C = C Nat - a.b.d = 4 - ``` - ```ucm - .> add - .> push.create ${repo} - ``` - |] + ```ucm + .> alias.type ##Nat builtin.Nat + ``` + ```unison + unique type a.b.C = C Nat + a.b.d = 4 + ``` + ```ucm + .> add + .> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| - ```ucm - .> pull.silent ${repo} - .> find - ``` - ```unison - > a.b.C.C a.b.d - ``` - |] + ```ucm + .> pull.silent git(${repo}) + .> find + ``` + ```unison + > a.b.C.C a.b.d + ``` + |] ), pushPullTest "accessPatch" fmt ( \repo -> [i| - ```ucm - .> alias.type ##Nat builtin.Nat - ``` - ```unison:hide - unique type A = A Nat - foo = A.A 3 - ``` - ```ucm - .> debug.file - .> add - ``` - ```unison:hide - unique type A = A Nat Nat - foo = A.A 3 3 - ``` - ```ucm - .> debug.file - .> update - ``` - ```ucm - .> view.patch patch - .> push.create ${repo} - ``` - |] + ```ucm + .> alias.type ##Nat builtin.Nat + ``` + ```unison:hide + unique type A = A Nat + foo = A.A 3 + ``` + ```ucm + .> debug.file + .> add + ``` + ```unison:hide + unique type A = A Nat Nat + foo = A.A 3 3 + ``` + ```ucm + .> debug.file + .> update + ``` + ```ucm + .> view.patch patch + .> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| - ```ucm - .> pull.silent ${repo} - .> view.patch patch - ``` - |] + ```ucm + .> pull.silent git(${repo}) + .> view.patch patch + ``` + |] ), pushPullTest "history" fmt ( \repo -> [i| - ```unison - foo = 3 - ``` - ```ucm - .> add - ``` - ```unison - foo = 4 - ``` - ```ucm - .> update - .> history - .> push.create ${repo} - ``` - |] + ```unison + foo = 3 + ``` + ```ucm + .> add + ``` + ```unison + foo = 4 + ``` + ```ucm + .> update + .> history + .> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| - ```ucm - .> pull ${repo} - .> history - .> reset-root #l43v9nr16v - .> history - ``` - |] -- Not sure why this hash is here. + ```ucm + .> pull ${repo} + .> history + .> reset-root #l43v9nr16v + .> history + ``` + |] -- Not sure why this hash is here. -- Is it to test `reset-root`? -- Or to notice a change in hashing? -- Or to test that two distinct points of history were pulled? @@ -354,26 +354,26 @@ test = -- simplest-author ( \repo -> [i| - ```unison - c = 3 - ``` - ```ucm - .> debug.file - .myLib> add - .myLib> push.create ${repo} - ``` - |] + ```unison + c = 3 + ``` + ```ucm + .> debug.file + .myLib> add + .myLib> push.create git(${repo}) + ``` + |] ) -- simplest-user ( \repo -> [i| - ```ucm - .yourLib> pull ${repo} - ``` - ```unison - > c - ``` - |] + ```ucm + .yourLib> pull git(${repo}) + ``` + ```unison + > c + ``` + |] ), pushPullTest "one-type" @@ -381,79 +381,79 @@ test = -- simplest-author ( \repo -> [i| - ```unison - structural type Foo = Foo - ``` - ```ucm - .myLib> debug.file - .myLib> add - .myLib> push.create ${repo} - ``` - |] + ```unison + structural type Foo = Foo + ``` + ```ucm + .myLib> debug.file + .myLib> add + .myLib> push.create git(${repo}) + ``` + |] ) -- simplest-user ( \repo -> [i| - ```ucm - .yourLib> pull ${repo} - ``` - ```unison - > Foo.Foo - ``` - |] + ```ucm + .yourLib> pull git(${repo}) + ``` + ```unison + > Foo.Foo + ``` + |] ), pushPullTest "patching" fmt ( \repo -> [i| - ```ucm - .myLib> alias.term ##Nat.+ + - ``` - ```unison - improveNat x = x + 3 - ``` - ```ucm - .myLib> add - .myLib> ls - .myLib> move.namespace .myLib .workaround1552.myLib.v1 - .workaround1552.myLib> ls - .workaround1552.myLib> fork v1 v2 - .workaround1552.myLib.v2> - ``` - ```unison - improveNat x = x + 100 - ``` - ```ucm - .workaround1552.myLib.v2> update - .workaround1552.myLib> push.create ${repo} - ``` - |] + ```ucm + .myLib> alias.term ##Nat.+ + + ``` + ```unison + improveNat x = x + 3 + ``` + ```ucm + .myLib> add + .myLib> ls + .myLib> move.namespace .myLib .workaround1552.myLib.v1 + .workaround1552.myLib> ls + .workaround1552.myLib> fork v1 v2 + .workaround1552.myLib.v2> + ``` + ```unison + improveNat x = x + 100 + ``` + ```ucm + .workaround1552.myLib.v2> update + .workaround1552.myLib> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| - ```ucm - .myApp> pull ${repo}:.v1 external.yourLib - .myApp> alias.term ##Nat.* * - ```` - ```unison - greatApp = improveNat 5 * improveNat 6 - > greatApp - ``` - ```ucm - .myApp> add - .myApp> pull ${repo}:.v2 external.yourLib - ``` - ```unison - > greatApp - ``` - ```ucm - .myApp> patch external.yourLib.patch - ``` - ```unison - > greatApp - ``` - |] + ```ucm + .myApp> pull git(${repo}).v1 external.yourLib + .myApp> alias.term ##Nat.* * + ```` + ```unison + greatApp = improveNat 5 * improveNat 6 + > greatApp + ``` + ```ucm + .myApp> add + .myApp> pull git(${repo}).v2 external.yourLib + ``` + ```unison + > greatApp + ``` + ```ucm + .myApp> patch external.yourLib.patch + ``` + ```unison + > greatApp + ``` + |] ), -- TODO: remove the alias.type .defns.A A line once patch syncing is fixed pushPullTest @@ -461,56 +461,56 @@ test = fmt ( \repo -> [i| - ```ucm - .> builtins.merge - ``` - ```unison - structural type A = A Nat - structural type B = B Int - x = 3 - y = 4 - ``` - ```ucm - .defns> add - .patches> replace .defns.A .defns.B - .patches> alias.type .defns.A A - .patches> replace .defns.x .defns.y - .patches> push.create ${repo} - ``` - |] + ```ucm + .> builtins.merge + ``` + ```unison + structural type A = A Nat + structural type B = B Int + x = 3 + y = 4 + ``` + ```ucm + .defns> add + .patches> replace .defns.A .defns.B + .patches> alias.type .defns.A A + .patches> replace .defns.x .defns.y + .patches> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| - ```ucm - .> builtins.merge - .> pull ${repo} patches - .> view.patch patches.patch - ``` - |] + ```ucm + .> builtins.merge + .> pull git(${repo}) patches + .> view.patch patches.patch + ``` + |] ), watchPushPullTest "test-watches" fmt ( \repo -> [i| - ```ucm - .> builtins.merge - ``` - ```unison - test> pass = [Ok "Passed"] - ``` - ```ucm - .> add - .> push.create ${repo} - ``` - |] + ```ucm + .> builtins.merge + ``` + ```unison + test> pass = [Ok "Passed"] + ``` + ```ucm + .> add + .> push.create git(${repo}) + ``` + |] ) ( \repo -> [i| - ```ucm - .> pull ${repo} - ``` - |] + ```ucm + .> pull git(${repo}) + ``` + |] ) ( \cb -> do void . fmap (fromJust . sequence) $ @@ -530,21 +530,21 @@ test = -} ( \repo -> [i| - ```ucm - .> alias.type ##Nat builtin.Nat2 - .> alias.type ##Int builtin.Int2 - .> push.create ${repo}:.foo.bar - ``` - |] + ```ucm + .> alias.type ##Nat builtin.Nat2 + .> alias.type ##Int builtin.Int2 + .> push.create git(${repo}).foo.bar + ``` + |] ) ( \repo -> [i| - ```ucm - .> pull ${repo} pulled - .> view pulled.foo.bar.builtin.Nat2 - .> view pulled.foo.bar.builtin.Int2 - ``` - |] + ```ucm + .> pull git(${repo}) pulled + .> view pulled.foo.bar.builtin.Nat2 + .> view pulled.foo.bar.builtin.Int2 + ``` + |] ), pushPullTest "fix2068_b_" @@ -557,78 +557,25 @@ test = -} ( \repo -> [i| - ```ucm - .> alias.type ##Nat builtin.Nat2 - .> alias.type ##Int builtin.Int2 - .> push.create ${repo} - .> push.create ${repo}:.foo.bar - ``` - |] + ```ucm + .> alias.type ##Nat builtin.Nat2 + .> alias.type ##Int builtin.Int2 + .> push.create git(${repo}) + .> push.create git(${repo}).foo.bar + ``` + |] ) ( \repo -> [i| - ```ucm - .> pull ${repo} pulled - .> view pulled.foo.bar.builtin.Nat2 - .> view pulled.foo.bar.builtin.Int2 - ``` - |] + ```ucm + .> pull git(${repo}) pulled + .> view pulled.foo.bar.builtin.Nat2 + .> view pulled.foo.bar.builtin.Int2 + ``` + |] ) - -- m [Reference.Id] - - -- traverse :: (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) - -- watches :: UF.WatchKind -> m [Reference.Id] - -- getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term v a)) - - -- pushPullTest "regular" fmt - -- (\repo -> [i| - -- ```ucm:hide - -- .builtin> alias.type ##Nat Nat - -- .builtin> alias.term ##Nat.+ Nat.+ - -- ``` - -- ```unison - -- unique type outside.A = A Nat - -- unique type outside.B = B Nat Nat - -- outside.c = 3 - -- outside.d = 4 - - -- unique type inside.X = X outside.A - -- inside.y = c + c - -- ``` - -- ```ucm - -- .myLib> debug.file - -- .myLib> add - -- .myLib> push ${repo} - -- ``` - -- |]) - - -- (\repo -> [i| - -- ```ucm:hide - -- .builtin> alias.type ##Nat Nat - -- .builtin> alias.term ##Nat.+ Nat.+ - -- ``` - -- ```ucm - -- .yourLib> pull ${repo}:.inside - -- ``` - -- ```unison - -- > y + #msp7bv40rv + 1 - -- ``` - -- |]) ] --- type inside.X#skinr6rvg7 --- type outside.A#l2fmn9sdbk --- type outside.B#nsgsq4ot5u --- inside.y#omqnfettvj --- outside.c#msp7bv40rv --- outside.d#52addbrohu --- .myLib> #6l0nd3i15e --- .myLib.inside> #5regvciils --- .myLib.inside.X> #kvcjrmgki6 --- .myLib.outside> #uq1mkkhlf1 --- .myLib.outside.A> #0e3g041m56 --- .myLib.outside.B> #j57m94daqi - pushPullTest :: String -> CodebaseFormat -> (FilePath -> Transcript) -> (FilePath -> Transcript) -> Test () pushPullTest name fmt authorScript userScript = scope name do io do @@ -681,13 +628,13 @@ gistTest fmt = ``` ```ucm .> add - .> gist ${repo} + .> gist git(${repo}) ``` |] userScript repo = [i| ```ucm - .> pull ${repo}:#td09c6jlks + .> pull git(${repo})#td09c6jlks .> find ``` ```unison @@ -709,13 +656,13 @@ pushPullBranchesTests fmt = scope "branches" $ do ``` ```ucm .> add - .> push.create ${repo}:mybranch:.path + .> push.create git(${repo}:mybranch).path ``` |] userScript repo = [i| ```ucm - .> pull ${repo}:mybranch .dest + .> pull git(${repo}:mybranch) .dest .> view .dest.path.y ``` |] @@ -725,7 +672,7 @@ pushPullBranchesTests fmt = scope "branches" $ do userScript repo = [i| ```ucm:error - .> pull ${repo}:mybranch .dest + .> pull git(${repo}:mybranch) .dest ``` |] in pushPullTest "empty" fmt authorScript userScript @@ -738,8 +685,8 @@ pushPullBranchesTests fmt = scope "branches" $ do ``` ```ucm .> add - .> push.create ${repo}:mybranch:.ns1 .ns1 - .> push.create ${repo}:mybranch:.ns2 .ns2 + .> push.create git(${repo}:mybranch).ns1 .ns1 + .> push.create git(${repo}:mybranch).ns2 .ns2 ``` ```unison ns1.x = 11 @@ -747,14 +694,14 @@ pushPullBranchesTests fmt = scope "branches" $ do ``` ```ucm .> update - .> push ${repo}:mybranch:.ns1 .ns1 + .> push git(${repo}:mybranch).ns1 .ns1 ``` |] userScript repo = [i| ```ucm - .> pull ${repo}:mybranch:.ns1 .ns1 - .> pull ${repo}:mybranch:.ns2 .ns2 + .> pull git(${repo}:mybranch).ns1 .ns1 + .> pull git(${repo}:mybranch).ns2 .ns2 .> view .ns1.x .> view .ns1.new .> view .ns2.y @@ -771,13 +718,13 @@ fastForwardPush = scope "fastforward-push" do Ucm.runTranscript author [i| - ```ucm - .lib> alias.type ##Nat Nat - .lib> push.create ${repo} - .lib> alias.type ##Int Int - .lib> push ${repo} - ``` - |] + ```ucm + .lib> alias.type ##Nat Nat + .lib> push.create git(${repo}) + .lib> alias.type ##Int Int + .lib> push git(${repo}) + ``` + |] ok nonFastForwardPush :: Test () @@ -789,13 +736,13 @@ nonFastForwardPush = scope "non-fastforward-push" do Ucm.runTranscript author [i| - ```ucm:error - .lib> alias.type ##Nat Nat - .lib> push ${repo} - .lib2> alias.type ##Int Int - .lib2> push ${repo} - ``` - |] + ```ucm:error + .lib> alias.type ##Nat Nat + .lib> push git(${repo}) + .lib2> alias.type ##Int Int + .lib2> push git(${repo}) + ``` + |] ok destroyedRemote :: Test () @@ -807,20 +754,20 @@ destroyedRemote = scope "destroyed-remote" do Ucm.runTranscript codebase [i| - ```ucm - .lib> alias.type ##Nat Nat - .lib> push.create ${repo} - ``` - |] + ```ucm + .lib> alias.type ##Nat Nat + .lib> push.create git(${repo}) + ``` + |] reinitRepo repo void $ Ucm.runTranscript codebase [i| - ```ucm - .lib> push.create ${repo} - ``` - |] + ```ucm + .lib> push.create git(${repo}) + ``` + |] ok where reinitRepo repoStr@(Text.pack -> repo) = do diff --git a/unison-cli/tests/Unison/Test/UriParser.hs b/unison-cli/tests/Unison/Test/UriParser.hs index 6de1d82976..5d5c78c0c9 100644 --- a/unison-cli/tests/Unison/Test/UriParser.hs +++ b/unison-cli/tests/Unison/Test/UriParser.hs @@ -7,7 +7,7 @@ import Data.Text (Text) import qualified Data.Text as Text import EasyTest import qualified Text.Megaparsec as P -import Unison.Codebase.Editor.RemoteRepo (ReadRepo (..)) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..)) import qualified Unison.Codebase.Editor.UriParser as UriParser import Unison.Codebase.Path (Path (..)) import qualified Unison.Codebase.Path as Path @@ -87,7 +87,7 @@ testAugmented = ] ] -parseAugmented :: (Text, (ReadRepo, Maybe ShortBranchHash, Path)) -> Test () +parseAugmented :: (Text, (ReadGitRepo, Maybe ShortBranchHash, Path)) -> Test () parseAugmented (s, r) = scope (Text.unpack s) $ case P.parse UriParser.repoPath "test case" s of Left x -> crash $ show x From 0a0e089e1d61fe0e3bd80d0604787e2c54e8d572 Mon Sep 17 00:00:00 2001 From: Karthik Ravikanti Date: Wed, 18 May 2022 16:14:04 +0800 Subject: [PATCH 222/529] Add examples to `patch`'s help Close #3030 --- .../src/Unison/CommandLine/InputPatterns.hs | 21 +++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 3cd2b042cb..5e9f196861 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -293,11 +293,24 @@ patch = [] I.Visible [(Required, patchArg), (Optional, namespaceArg)] - ( P.wrap $ + ( P.lines + [ P.wrap $ makeExample' patch - <> "rewrites any definitions that depend on " - <> "definitions with type-preserving edits to use the updated versions of" - <> "these dependencies." + <> "rewrites any definitions that depend on " + <> "definitions with type-preserving edits to use the updated versions of" + <> "these dependencies.", + "", + P.wrapColumn2 + [ ( makeExample patch ["", "[path]"], + "applies the given patch" + <> "to the given namespace" + ), + ( makeExample patch [""], + "applies the given patch" + <> "to the current namespace" + ) + ] + ] ) ( \case patchStr : ws -> first fromString $ do From 6a195b46928f22e857590cdb64eca68fae1524ec Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 19 May 2022 09:49:19 -0400 Subject: [PATCH 223/529] some new operations for enlil --- .../codebase-sqlite/U/Codebase/Sqlite/Operations.hs | 1 + .../codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 6 +++++- .../Migrations/MigrateSchema1To2/DbHelpers.hs | 11 +++++++++++ 3 files changed, 17 insertions(+), 1 deletion(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 619b8e9299..c037bc14b6 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -71,6 +71,7 @@ module U.Codebase.Sqlite.Operations expectDbPatch, saveBranchObject, saveDbPatch, + expectDbBranchByCausalHashId, -- * somewhat unexpectedly unused definitions c2sReferenceId, diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index a47e7e0b56..311b459103 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -19,6 +19,7 @@ module U.Codebase.Sqlite.Queries loadHashId, expectHash, expectHash32, + expectBranchHash, loadHashIdByHash, expectHashIdByHash, saveCausalHash, @@ -318,6 +319,9 @@ expectHash32 :: HashId -> Transaction Base32Hex expectHash32 h = queryOneCol sql (Only h) where sql = [here|ย SELECT base32 FROM hash WHERE id = ? |] +expectBranchHash :: BranchHashId -> Transaction BranchHash +expectBranchHash = coerce expectHash + saveText :: Text -> Transaction TextId saveText t = execute sql (Only t) >> expectTextId t where sql = [here| INSERT INTO text (text) VALUES (?) ON CONFLICT DO NOTHING|] @@ -859,7 +863,7 @@ expectCausalValueHashId (CausalHashId id) = queryOneCol loadCausalValueHashIdSql (Only id) expectCausalHash :: CausalHashId -> Transaction CausalHash -expectCausalHash (CausalHashId id) = CausalHash <$> expectHash id +expectCausalHash = coerce expectHash loadCausalValueHashId :: HashId -> Transaction (Maybe BranchHashId) loadCausalValueHashId id = diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs index 8331d812bf..79bbf2af64 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs @@ -11,6 +11,7 @@ import U.Codebase.Sqlite.Branch.Full (DbMetadataSet) import qualified U.Codebase.Sqlite.Branch.Full as S import qualified U.Codebase.Sqlite.Branch.Full as S.Branch.Full import qualified U.Codebase.Sqlite.Branch.Full as S.MetadataSet +import qualified U.Codebase.Sqlite.Causal as S import qualified U.Codebase.Sqlite.DbId as Db import qualified U.Codebase.Sqlite.Patch.Full as S import qualified U.Codebase.Sqlite.Patch.TermEdit as S (TermEdit) @@ -24,6 +25,7 @@ import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import Unison.Hash (Hash) import Unison.Hashing.V2.Branch (NameSegment (..)) import qualified Unison.Hashing.V2.Branch as Hashing.Branch +import qualified Unison.Hashing.V2.Causal as Hashing.Causal import qualified Unison.Hashing.V2.Patch as Hashing (Patch (..)) import qualified Unison.Hashing.V2.Patch as Hashing.Patch import qualified Unison.Hashing.V2.Reference as Hashing (Reference) @@ -39,6 +41,15 @@ import Unison.Sqlite (Transaction) import qualified Unison.Util.Map as Map import qualified Unison.Util.Set as Set +syncCausalHash :: S.SyncCausalFormat -> Transaction Hash +syncCausalHash S.SyncCausalFormat {valueHash = valueHashId, parents = parentChIds} = do + fmap Hashing.Causal.hashCausal $ + Hashing.Causal.Causal + <$> coerce @(Transaction BranchHash) @(Transaction Hash) (Q.expectBranchHash valueHashId) + valueHash <- _ valueHashId + parents <- traverse _ parentChIds + pure $ Hashing.Causal.hashCausal valueHash parents + dbBranchHash :: S.DbBranch -> Transaction Hash dbBranchHash (S.Branch.Full.Branch tms tps patches children) = fmap Hashing.Branch.hashBranch $ From 00e1d613178ff0eb623d1e023318d4a85727afb0 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 19 May 2022 10:27:39 -0400 Subject: [PATCH 224/529] get syncCausalHash building --- .../Migrations/MigrateSchema1To2/DbHelpers.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs index 79bbf2af64..4824838b00 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs @@ -1,9 +1,13 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers ( dbBranchHash, dbPatchHash, + syncCausalHash, ) where +import qualified Data.Set as Set +import qualified Data.Vector as Vector +import U.Codebase.HashTags (BranchHash (..), CausalHash (..)) import qualified U.Codebase.Reference as S hiding (Reference) import qualified U.Codebase.Reference as S.Reference import qualified U.Codebase.Referent as S.Referent @@ -46,9 +50,7 @@ syncCausalHash S.SyncCausalFormat {valueHash = valueHashId, parents = parentChId fmap Hashing.Causal.hashCausal $ Hashing.Causal.Causal <$> coerce @(Transaction BranchHash) @(Transaction Hash) (Q.expectBranchHash valueHashId) - valueHash <- _ valueHashId - parents <- traverse _ parentChIds - pure $ Hashing.Causal.hashCausal valueHash parents + <*> fmap (Set.fromList . coerce @[CausalHash] @[Hash] . Vector.toList) (traverse Q.expectCausalHash parentChIds) dbBranchHash :: S.DbBranch -> Transaction Hash dbBranchHash (S.Branch.Full.Branch tms tps patches children) = From 88abca10ceca7b6e34fe5ad24da6a010f639cb94 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 19 May 2022 10:29:07 -0400 Subject: [PATCH 225/529] hpack tweak --- parser-typechecker/unison-parser-typechecker.cabal | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 43e5ef3ed2..6f9c0f41e7 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.6. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack @@ -382,6 +382,7 @@ test-suite parser-typechecker-tests , bytestring , bytestring-to-vector , cereal + , clock , code-page , configurator , containers >=0.6.3 From 88ff76e5f137538ba7a980e48f6fdb0b53b4d86a Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 19 May 2022 16:05:03 -0400 Subject: [PATCH 226/529] saveDbBranch --- .../U/Codebase/Sqlite/Operations.hs | 51 ++++++++++++------- .../Migrations/MigrateSchema1To2.hs | 6 +-- 2 files changed, 35 insertions(+), 22 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index c037bc14b6..80204e38fe 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -68,8 +68,9 @@ module U.Codebase.Sqlite.Operations -- * low-level stuff expectDbBranch, + saveDbBranch, + saveDbBranchUnderHashId, expectDbPatch, - saveBranchObject, saveDbPatch, expectDbBranchByCausalHashId, @@ -213,12 +214,12 @@ loadCausalHashAtPath = [] -> lift (Q.expectCausalHash hashId) t : ts -> do tid <- MaybeT (Q.loadTextId t) - S.Branch{children} <- MaybeT (loadDbBranchByCausalHashId hashId) + S.Branch {children} <- MaybeT (loadDbBranchByCausalHashId hashId) (_, hashId') <- MaybeT (pure (Map.lookup tid children)) go hashId' ts - in \path -> do - hashId <- Q.expectNamespaceRoot - runMaybeT (go hashId path) + in \path -> do + hashId <- Q.expectNamespaceRoot + runMaybeT (go hashId path) -- | Expect the causal hash at the given path from the root. -- @@ -230,12 +231,12 @@ expectCausalHashAtPath = [] -> Q.expectCausalHash hashId t : ts -> do tid <- Q.expectTextId t - S.Branch{children} <- expectDbBranchByCausalHashId hashId + S.Branch {children} <- expectDbBranchByCausalHashId hashId let (_, hashId') = children Map.! tid go hashId' ts - in \path -> do - hashId <- Q.expectNamespaceRoot - go hashId path + in \path -> do + hashId <- Q.expectNamespaceRoot + go hashId path -- * Reference transformations @@ -945,8 +946,7 @@ saveBranch (C.Causal hc he parents me) = do pure (chId, bhId) boId <- flip Monad.fromMaybeM (Q.loadBranchObjectIdByCausalHashId chId) do branch <- c2sBranch =<< me - let (li, lBranch) = LocalizeObject.localizeBranch branch - saveBranchObject bhId li lBranch + saveDbBranchUnderHashId bhId branch pure (boId, chId) where c2sBranch :: C.Branch.Branch Transaction -> Transaction S.DbBranch @@ -973,13 +973,6 @@ saveBranch (C.Causal hc he parents me) = do patch <- mp savePatch h patch -saveBranchObject :: Db.BranchHashId -> BranchLocalIds -> S.Branch.Full.LocalBranch -> Transaction Db.BranchObjectId -saveBranchObject id@(Db.unBranchHashId -> hashId) li lBranch = do - when debug $ traceM $ "saveBranchObject\n\tid = " ++ show id ++ "\n\tli = " ++ show li ++ "\n\tlBranch = " ++ show lBranch - let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full li lBranch - oId <- Q.saveObject hashId OT.Namespace bytes - pure $ Db.BranchObjectId oId - expectRootCausal :: Transaction (C.Branch.CausalBranch Transaction) expectRootCausal = Q.expectNamespaceRoot >>= expectCausalBranchByCausalHashId @@ -1128,6 +1121,28 @@ expectDbBranch id = let (Set.fromList -> adds, Set.fromList -> removes) = S.BranchDiff.addsRemoves md' in Just . S.MetadataSet.Inline $ (Set.union adds $ Set.difference md removes) +-- | Save a 'S.DbBranch', given its hash (which the caller is expected to produce from the branch). +-- +-- Note: long-standing question: should this package depend on the hashing package? (If so, we would only need to take +-- the DbBranch, and hash internally). +saveDbBranch :: BranchHash -> S.DbBranch -> Transaction Db.BranchObjectId +saveDbBranch hash branch = do + hashId <- Q.saveBranchHash hash + saveDbBranchUnderHashId hashId branch + +-- | Variant of 'saveDbBranch' that might be preferred by callers that already have a hash id, not a hash. +saveDbBranchUnderHashId :: Db.BranchHashId -> S.DbBranch -> Transaction Db.BranchObjectId +saveDbBranchUnderHashId id@(Db.unBranchHashId -> hashId) branch = do + let (localBranchIds, localBranch) = LocalizeObject.localizeBranch branch + when debug $ + traceM $ + "saveBranchObject\n\tid = " ++ show id ++ "\n\tli = " ++ show localBranchIds + ++ "\n\tlBranch = " + ++ show localBranch + let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full localBranchIds localBranch + oId <- Q.saveObject hashId OT.Namespace bytes + pure $ Db.BranchObjectId oId + expectBranch :: Db.BranchObjectId -> Transaction (C.Branch.Branch Transaction) expectBranch id = expectDbBranch id >>= s2cBranch diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index db402ba512..7f882c3e22 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -333,10 +333,9 @@ migrateBranch oldObjectId = fmap (either id id) . runExceptT $ do & S.patches_ %~ remapPatchObjectId & S.childrenHashes_ %~ (remapBranchObjectId *** remapCausalHashId) - let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch newBranch newHash <- lift . lift $ Hashing.dbBranchHash newBranch newHashId <- lift . lift $ Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash)) - newObjectId <- lift . lift $ Ops.saveBranchObject newHashId localBranchIds localBranch + newObjectId <- lift . lift $ Ops.saveDbBranchUnderHashId newHashId newBranch field @"objLookup" %= Map.insert oldObjectId (unBranchObjectId newObjectId, unBranchHashId newHashId, newHash, oldHash) pure Sync.Done @@ -849,8 +848,7 @@ foldSetter t s = execWriter (s & t %%~ \a -> tell [a] *> pure a) saveV2EmptyBranch :: Sqlite.Transaction (BranchHashId, Hash) saveV2EmptyBranch = do let branch = S.emptyBranch - let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch branch newHash <- Hashing.dbBranchHash branch newHashId <- Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash)) - _ <- Ops.saveBranchObject newHashId localBranchIds localBranch + _ <- Ops.saveDbBranchUnderHashId newHashId branch pure (newHashId, newHash) From 77a8f021c5c49f0c0f98f45e4f38d8eaf553ef40 Mon Sep 17 00:00:00 2001 From: Alberto Flores Date: Mon, 23 May 2022 20:38:17 -0500 Subject: [PATCH 227/529] Remove old references to namespace blocks Co-authored-by: Karthik Ravikanti --- parser-typechecker/src/Unison/FileParser.hs | 5 ----- parser-typechecker/src/Unison/PrintError.hs | 2 -- unison-src/transcripts/error-messages.output.md | 1 - unison-src/transcripts/errors/unison-hide-all.output.md | 1 - unison-src/transcripts/errors/unison-hide.output.md | 1 - 5 files changed, 10 deletions(-) diff --git a/parser-typechecker/src/Unison/FileParser.hs b/parser-typechecker/src/Unison/FileParser.hs index 81f50e19a8..9514175bb3 100644 --- a/parser-typechecker/src/Unison/FileParser.hs +++ b/parser-typechecker/src/Unison/FileParser.hs @@ -184,11 +184,6 @@ checkForDuplicateTermsAndConstructors uf = do -- Or it is a binding like: -- foo : Nat -> Nat -- foo x = x + 42 --- Or it is a namespace like: --- namespace Woot where --- x = 42 --- y = 17 --- which parses as [(Woot.x, 42), (Woot.y, 17)] data Stanza v term = WatchBinding UF.WatchKind Ann ((Ann, v), term) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 0578b01fe0..c4e9fbd340 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -1413,8 +1413,6 @@ prettyParseError s = \case <> style Code "ability Foo where ...", "\n - A `type` declaration, like " <> style Code "structural type Optional a = None | Some a", - "\n - A `namespace` declaration, like " - <> style Code "namespace Seq where ...", "\n" ] where diff --git a/unison-src/transcripts/error-messages.output.md b/unison-src/transcripts/error-messages.output.md index b6069096a8..d1a57f856e 100644 --- a/unison-src/transcripts/error-messages.output.md +++ b/unison-src/transcripts/error-messages.output.md @@ -244,7 +244,6 @@ a ! b = 1 - A watch expression, like > a + 1 - An `ability` declaration, like ability Foo where ... - A `type` declaration, like structural type Optional a = None | Some a - - A `namespace` declaration, like namespace Seq where ... ``` diff --git a/unison-src/transcripts/errors/unison-hide-all.output.md b/unison-src/transcripts/errors/unison-hide-all.output.md index 51e6024bce..d71d0849ae 100644 --- a/unison-src/transcripts/errors/unison-hide-all.output.md +++ b/unison-src/transcripts/errors/unison-hide-all.output.md @@ -28,6 +28,5 @@ The transcript failed due to an error in the stanza above. The error is: - A watch expression, like > g + 1 - An `ability` declaration, like ability Foo where ... - A `type` declaration, like structural type Optional a = None | Some a - - A `namespace` declaration, like namespace Seq where ... diff --git a/unison-src/transcripts/errors/unison-hide.output.md b/unison-src/transcripts/errors/unison-hide.output.md index d9f51a526f..c2dbfed584 100644 --- a/unison-src/transcripts/errors/unison-hide.output.md +++ b/unison-src/transcripts/errors/unison-hide.output.md @@ -28,6 +28,5 @@ The transcript failed due to an error in the stanza above. The error is: - A watch expression, like > g + 1 - An `ability` declaration, like ability Foo where ... - A `type` declaration, like structural type Optional a = None | Some a - - A `namespace` declaration, like namespace Seq where ... From d91db0ca4fc842f539f2742e434eb94acb5340b9 Mon Sep 17 00:00:00 2001 From: Alberto Flores Date: Mon, 23 May 2022 20:38:42 -0500 Subject: [PATCH 228/529] Update ability syntax in the error message. Co-authored-by: Karthik Ravikanti --- parser-typechecker/src/Unison/PrintError.hs | 2 +- unison-src/transcripts/error-messages.output.md | 2 +- unison-src/transcripts/errors/unison-hide-all.output.md | 2 +- unison-src/transcripts/errors/unison-hide.output.md | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index c4e9fbd340..782c6b2a65 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -1410,7 +1410,7 @@ prettyParseError s = \case Code " + 1", "\n - An `ability` declaration, like " - <> style Code "ability Foo where ...", + <> style Code "unique|structural ability Foo where ...", "\n - A `type` declaration, like " <> style Code "structural type Optional a = None | Some a", "\n" diff --git a/unison-src/transcripts/error-messages.output.md b/unison-src/transcripts/error-messages.output.md index d1a57f856e..52f59be266 100644 --- a/unison-src/transcripts/error-messages.output.md +++ b/unison-src/transcripts/error-messages.output.md @@ -242,7 +242,7 @@ a ! b = 1 a : Nat a = 42 - A watch expression, like > a + 1 - - An `ability` declaration, like ability Foo where ... + - An `ability` declaration, like unique|structural ability Foo where ... - A `type` declaration, like structural type Optional a = None | Some a diff --git a/unison-src/transcripts/errors/unison-hide-all.output.md b/unison-src/transcripts/errors/unison-hide-all.output.md index d71d0849ae..d6e5092f0a 100644 --- a/unison-src/transcripts/errors/unison-hide-all.output.md +++ b/unison-src/transcripts/errors/unison-hide-all.output.md @@ -26,7 +26,7 @@ The transcript failed due to an error in the stanza above. The error is: g : Nat g = 42 - A watch expression, like > g + 1 - - An `ability` declaration, like ability Foo where ... + - An `ability` declaration, like unique|structural ability Foo where ... - A `type` declaration, like structural type Optional a = None | Some a diff --git a/unison-src/transcripts/errors/unison-hide.output.md b/unison-src/transcripts/errors/unison-hide.output.md index c2dbfed584..772624318b 100644 --- a/unison-src/transcripts/errors/unison-hide.output.md +++ b/unison-src/transcripts/errors/unison-hide.output.md @@ -26,7 +26,7 @@ The transcript failed due to an error in the stanza above. The error is: g : Nat g = 42 - A watch expression, like > g + 1 - - An `ability` declaration, like ability Foo where ... + - An `ability` declaration, like unique|structural ability Foo where ... - A `type` declaration, like structural type Optional a = None | Some a From 36546ce56ce9bbe4eb93e57a2f924d7060c7ef9d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 25 May 2022 15:01:15 -0600 Subject: [PATCH 229/529] Expose Codebase connection --- parser-typechecker/src/Unison/Codebase.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index e519dc9bbc..8a9070b219 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -90,6 +90,9 @@ module Unison.Codebase CodebasePath, SyncToDir, + -- * Sqlite Escape Hatch + connection, + -- * Misc (organize these better) addDefsToCodebase, componentReferencesForReference, From f21ba36720675e89c5b69f819abeaada7373c0bf Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 25 May 2022 15:10:18 -0600 Subject: [PATCH 230/529] Fix redundant import --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 80204e38fe..b688b89095 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -117,7 +117,6 @@ import U.Codebase.ShortHash (ShortBranchHash (ShortBranchHash)) import qualified U.Codebase.Sqlite.Branch.Diff as S.Branch import qualified U.Codebase.Sqlite.Branch.Diff as S.Branch.Diff import qualified U.Codebase.Sqlite.Branch.Diff as S.BranchDiff -import U.Codebase.Sqlite.Branch.Format (BranchLocalIds) import qualified U.Codebase.Sqlite.Branch.Format as S import qualified U.Codebase.Sqlite.Branch.Format as S.BranchFormat import qualified U.Codebase.Sqlite.Branch.Full as S From f789e4310fd63f529d0c62ffed42d839d41c7d8b Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Wed, 25 May 2022 18:18:32 -0400 Subject: [PATCH 231/529] reexport Data.Tuple.Only, move entityExists, update Sync error types --- .../U/Codebase/Sqlite/Queries.hs | 12 ++++- .../U/Codebase/Sqlite/Reference.hs | 3 +- .../U/Codebase/Sqlite/Referent.hs | 3 +- lib/unison-sqlite/src/Unison/Sqlite.hs | 1 + unison-cli/src/Unison/Share/Sync.hs | 18 ++------ unison-share-api/src/Unison/Sync/Types.hs | 45 +++++++++++++++---- 6 files changed, 54 insertions(+), 28 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 311b459103..0a8728e0d7 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -132,6 +132,7 @@ module U.Codebase.Sqlite.Queries garbageCollectWatchesWithoutObjects, -- * sync temp entities + entityExists, expectEntity, getMissingDependentsForTempEntity, getMissingDependencyJwtsForTempEntity, @@ -151,6 +152,7 @@ module U.Codebase.Sqlite.Queries where import qualified Control.Lens as Lens +import Control.Monad.Extra ((||^)) import Data.Bitraversable (bitraverse) import Data.Bytes.Put (runPutS) import qualified Data.Foldable as Foldable @@ -161,7 +163,6 @@ import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import Data.String.Here.Uninterpolated (here, hereFile) -import Data.Tuple.Only (Only (..)) import qualified Data.Vector as Vector import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) import U.Codebase.Reference (Reference' (..)) @@ -1412,6 +1413,15 @@ ancestorSql = -- * share sync / temp entities +-- | Does this entity already exist in the database, i.e. in the `object` or `causal` table? +entityExists :: Base32Hex -> Transaction Bool +entityExists b32 = do + -- first get hashId if exists + loadHashId b32 >>= \case + Nothing -> pure False + -- then check if is causal hash or if object exists for hash id + Just hashId -> isCausalHash hashId ||^ isObjectHash hashId + getMissingDependencyJwtsForTempEntity :: Base32Hex -> Transaction (Maybe (NESet Text)) getMissingDependencyJwtsForTempEntity h = do jwts <- diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs index fac223e1f6..7f68e9bed7 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs @@ -4,14 +4,13 @@ module U.Codebase.Sqlite.Reference where -import Data.Tuple.Only (Only (..)) import U.Codebase.Reference (Id' (Id), Reference' (ReferenceBuiltin, ReferenceDerived)) import U.Codebase.Sqlite.DbId (HashId, ObjectId, TextId) import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalHashId, LocalTextId) import U.Codebase.Sqlite.Orphans () import U.Util.Base32Hex import Unison.Prelude -import Unison.Sqlite (FromField, FromRow (fromRow), RowParser, SQLData (SQLNull), ToField, ToRow (toRow), field) +import Unison.Sqlite (FromField, FromRow (fromRow), Only (..), RowParser, SQLData (SQLNull), ToField, ToRow (toRow), field) type Reference = Reference' TextId ObjectId diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs index 9a9a641132..eda52b8f9f 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Referent.hs @@ -6,13 +6,12 @@ module U.Codebase.Sqlite.Referent where import Control.Applicative (liftA3) -import Data.Tuple.Only (Only (..)) import qualified U.Codebase.Reference as Reference import U.Codebase.Referent (Id', Referent') import qualified U.Codebase.Referent as Referent import U.Codebase.Sqlite.DbId (ObjectId) import qualified U.Codebase.Sqlite.Reference as Sqlite -import Unison.Sqlite (FromRow (..), SQLData (..), ToField (toField), ToRow (..), field) +import Unison.Sqlite (FromRow (..), Only (..), SQLData (..), ToField (toField), ToRow (..), field) type Referent = Referent' Sqlite.Reference Sqlite.Reference diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index e01d9c85c0..530e39ecb5 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -104,6 +104,7 @@ module Unison.Sqlite (Sqlite.Simple.:.) (..), Sqlite.Simple.FromField (fromField), Sqlite.Simple.FromRow (fromRow), + Sqlite.Simple.Only(..), Sqlite.Simple.RowParser, Sqlite.Simple.SQLData (..), Sqlite.Simple.ToField (toField), diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index e296fccc11..7ab105514f 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -26,7 +26,6 @@ module Unison.Share.Sync where import qualified Control.Lens as Lens -import Control.Monad.Extra ((||^)) import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader import qualified Data.Foldable as Foldable (find) @@ -454,22 +453,13 @@ data EntityLocation | -- | Nowhere EntityNotStored --- | Does this entity already exist in the database, i.e. in the `object` or `causal` table? -entityExists :: Share.Hash -> Sqlite.Transaction Bool -entityExists (Share.Hash b32) = do - -- first get hashId if exists - Q.loadHashId b32 >>= \case - Nothing -> pure False - -- then check if is causal hash or if object exists for hash id - Just hashId -> Q.isCausalHash hashId ||^ Q.isObjectHash hashId - -- | Where is an entity stored? entityLocation :: Share.Hash -> Sqlite.Transaction EntityLocation -entityLocation hash = - entityExists hash >>= \case +entityLocation (Share.Hash b32) = + Q.entityExists b32 >>= \case True -> pure EntityInMainStorage False -> - Q.getMissingDependencyJwtsForTempEntity (Share.toBase32Hex hash) <&> \case + Q.getMissingDependencyJwtsForTempEntity b32 <&> \case Nothing -> EntityNotStored Just missingDependencies -> EntityInTempStorage (NESet.map Share.HashJWT missingDependencies) @@ -525,7 +515,7 @@ upsertEntitySomewhere hash entity = -- otherwise add it to main storage. missingDependencies0 <- Set.filterM - (entityExists . Share.decodedHashJWTHash) + (Q.entityExists . Share.toBase32Hex . Share.decodedHashJWTHash) (Set.map Share.decodeHashJWT (Share.entityDependencies entity)) case NESet.nonEmptySet missingDependencies0 of Nothing -> insertEntity hash entity diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index c5929d9059..dc44433449 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -640,6 +640,10 @@ data UploadEntitiesResponse = UploadEntitiesSuccess | UploadEntitiesNeedDependencies (NeedDependencies Hash) | UploadEntitiesNoWritePermission RepoName + | UploadEntitiesHashMismatchForEntity HashMismatchForEntity + deriving stock (Show, Eq, Ord) + +data HashMismatchForEntity = HashMismatchForEntity {supplied :: Hash, computed :: Hash} deriving stock (Show, Eq, Ord) instance ToJSON UploadEntitiesResponse where @@ -647,15 +651,22 @@ instance ToJSON UploadEntitiesResponse where UploadEntitiesSuccess -> jsonUnion "success" (Object mempty) UploadEntitiesNeedDependencies nd -> jsonUnion "need_dependencies" nd UploadEntitiesNoWritePermission repoName -> jsonUnion "no_write_permission" repoName + UploadEntitiesHashMismatchForEntity mismatch -> jsonUnion "hash_mismatch_for_entity" mismatch instance FromJSON UploadEntitiesResponse where - parseJSON v = - v & Aeson.withObject "UploadEntitiesResponse" \obj -> - obj .: "type" >>= Aeson.withText "type" \case - "success" -> pure UploadEntitiesSuccess - "need_dependencies" -> UploadEntitiesNeedDependencies <$> obj .: "payload" - "no_write_permission" -> UploadEntitiesNoWritePermission <$> obj .: "payload" - t -> failText $ "Unexpected UploadEntitiesResponse type: " <> t + parseJSON = Aeson.withObject "UploadEntitiesResponse" \obj -> + obj .: "type" >>= Aeson.withText "type" \case + "success" -> pure UploadEntitiesSuccess + "need_dependencies" -> UploadEntitiesNeedDependencies <$> obj .: "payload" + "no_write_permission" -> UploadEntitiesNoWritePermission <$> obj .: "payload" + "hash_mismatch_for_entity" -> UploadEntitiesHashMismatchForEntity <$> obj .: "payload" + t -> failText $ "Unexpected UploadEntitiesResponse type: " <> t + +instance ToJSON HashMismatchForEntity where + toJSON (HashMismatchForEntity supplied computed) = object ["supplied" .= supplied, "computed" .= computed] + +instance FromJSON HashMismatchForEntity where + parseJSON = Aeson.withObject "HashMismatchForEntity" \obj -> HashMismatchForEntity <$> obj .: "supplied" <*> obj .: "computed" ------------------------------------------------------------------------------------------------------------------------ -- Fast-forward path @@ -684,8 +695,10 @@ instance FromJSON UploadEntitiesResponse where -- Note that if the client wants to begin a history at a new path on the server, it would use the "update path" endpoint -- instead. data FastForwardPathRequest = FastForwardPathRequest - { -- TODO non-empty - hashes :: [Hash], + { -- expected_hash :: Hash, + + -- | The sequence of causals to fast-forward, starting from the oldest new causal to the newest new causal + hashes :: NonEmpty Hash, -- | The path to fast-forward. path :: Path } @@ -713,6 +726,11 @@ data FastForwardPathResponse FastForwardPathNotFastForward HashJWT | -- | There was no history at this path; the client should use the "update path" endpoint instead. FastForwardPathNoHistory + | -- | This wasn't a fast-forward. You said the first hash was a parent of the second hash, but I disagree. + FastForwardPathInvalidParentage InvalidParentage + deriving stock (Show) + +data InvalidParentage = InvalidParentage {parent :: Hash, child :: Hash} deriving stock (Show) instance ToJSON FastForwardPathResponse where @@ -722,6 +740,7 @@ instance ToJSON FastForwardPathResponse where FastForwardPathNoWritePermission path -> jsonUnion "no_write_permission" path FastForwardPathNotFastForward hashJwt -> jsonUnion "not_fast_forward" hashJwt FastForwardPathNoHistory -> jsonUnion "no_history" (Object mempty) + FastForwardPathInvalidParentage invalidParentage -> jsonUnion "invalid_parentage" invalidParentage instance FromJSON FastForwardPathResponse where parseJSON = @@ -732,8 +751,16 @@ instance FromJSON FastForwardPathResponse where "no_write_permission" -> FastForwardPathNoWritePermission <$> o .: "payload" "not_fast_forward" -> FastForwardPathNotFastForward <$> o .: "payload" "no_history" -> pure FastForwardPathNoHistory + "invalid_parentage" -> FastForwardPathInvalidParentage <$> o .: "payload" t -> failText $ "Unexpected FastForwardPathResponse type: " <> t +instance ToJSON InvalidParentage where + toJSON (InvalidParentage parent child) = object ["parent" .= parent, "child" .= child] + +instance FromJSON InvalidParentage where + parseJSON = + Aeson.withObject "InvalidParentage" \o -> InvalidParentage <$> o .: "parent" <*> o .: "child" + ------------------------------------------------------------------------------------------------------------------------ -- Update path From 7af936320a70292667a73fb01708b30c2b28011f Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 26 May 2022 10:46:54 -0400 Subject: [PATCH 232/529] export HashMismatchForEntity and InvalidParentage --- unison-share-api/src/Unison/Sync/Types.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index dc44433449..e960e40b46 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -55,6 +55,8 @@ module Unison.Sync.Types HashMismatch (..), -- * Common/shared error types + HashMismatchForEntity (..), + InvalidParentage (..), NeedDependencies (..), ) where From a18ef837c59f652a0e2f61a434d83f739e7a2e91 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 26 May 2022 11:25:15 -0400 Subject: [PATCH 233/529] add FastForwardPathrequest.expectedHash field --- unison-share-api/src/Unison/Sync/Types.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index e960e40b46..6a73d1c4a1 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -697,8 +697,8 @@ instance FromJSON HashMismatchForEntity where -- Note that if the client wants to begin a history at a new path on the server, it would use the "update path" endpoint -- instead. data FastForwardPathRequest = FastForwardPathRequest - { -- expected_hash :: Hash, - + { -- | The causal that the client believes exists at `path` + expectedHash :: Hash, -- | The sequence of causals to fast-forward, starting from the oldest new causal to the newest new causal hashes :: NonEmpty Hash, -- | The path to fast-forward. From 2743c06edbdb62d177da4e75bbe60cce5873dfa3 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 26 May 2022 11:28:43 -0400 Subject: [PATCH 234/529] fix json instances --- unison-share-api/src/Unison/Sync/Types.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 6a73d1c4a1..c369fe45b3 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -707,18 +707,20 @@ data FastForwardPathRequest = FastForwardPathRequest deriving stock (Show) instance ToJSON FastForwardPathRequest where - toJSON FastForwardPathRequest {hashes, path} = + toJSON FastForwardPathRequest {expectedHash, hashes, path} = object - [ "hashes" .= hashes, + [ "expected_hash" .= expectedHash, + "hashes" .= hashes, "path" .= path ] instance FromJSON FastForwardPathRequest where parseJSON = Aeson.withObject "FastForwardPathRequest" \o -> do + expectedHash <- o .: "expected_hash" hashes <- o .: "hashes" path <- o .: "path" - pure FastForwardPathRequest {hashes, path} + pure FastForwardPathRequest {expectedHash, hashes, path} data FastForwardPathResponse = FastForwardPathSuccess From 6ddf2ee72e3d11f9296fffebab0125af4120d87f Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 26 May 2022 12:13:57 -0400 Subject: [PATCH 235/529] tweak fast-forward path to align with server's expectations --- unison-cli/src/Unison/Share/Sync.hs | 39 ++++++++++++----------- unison-share-api/src/Unison/Sync/Types.hs | 10 +++--- 2 files changed, 26 insertions(+), 23 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 7ab105514f..e8043453e3 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -159,11 +159,20 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a -- fast-forward push, so we don't bother trying - just report the error now. Nothing -> pure (Left (FastForwardPushErrorNotFastForward path)) - Just localTailHashes -> - doUpload (localHeadHash :| localTailHashes) >>= \case + Just localInnerHashes -> do + doUpload (localHeadHash :| localInnerHashes) >>= \case False -> pure (Left (FastForwardPushErrorNoWritePermission path)) - True -> - doFastForwardPath (localHeadHash : localTailHashes) <&> \case + True -> do + let doFastForwardPath = + httpFastForwardPath + httpClient + unisonShareUrl + Share.FastForwardPathRequest + { expectedHash = remoteHeadHash, + hashes = causalHashToHash <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), + path + } + doFastForwardPath <&> \case Share.FastForwardPathSuccess -> Right () Share.FastForwardPathMissingDependencies (Share.NeedDependencies dependencies) -> Left (FastForwardPushErrorServerMissingDependencies dependencies) @@ -185,32 +194,24 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = (Share.pathRepoName path) (NESet.singleton (causalHashToHash headHash)) - doFastForwardPath :: [CausalHash] -> IO Share.FastForwardPathResponse - doFastForwardPath causalSpine = - httpFastForwardPath - httpClient - unisonShareUrl - Share.FastForwardPathRequest - { hashes = map causalHashToHash causalSpine, - path = path - } - - -- Return a list from newest to oldest of the ancestors between (excluding) the latest local and the current remote hash. + -- Return a list from oldest to newst of the ancestors between (excluding) the latest local and the current remote + -- hash. -- note: seems like we /should/ cut this short, with another command to go longer? :grimace: fancyBfs :: CausalHash -> Share.Hash -> Sqlite.Transaction (Maybe [CausalHash]) fancyBfs h0 h1 = tweak <$> dagbfs (== Share.toBase32Hex h1) Q.loadCausalParentsByHash (Hash.toBase32Hex (unCausalHash h0)) where - -- Drop 1 and reverse (under a Maybe, and twddling hash types): + -- Drop 1 (under a Maybe, and twddling hash types): -- - -- tweak [] = [] - -- tweak [C,B,A] = [A,B] + -- tweak Nothing = Nothing + -- tweak (Just []) = Just [] + -- tweak (Just [C,B,A]) = Just [B,A] -- -- The drop 1 is because dagbfs returns the goal at the head of the returned list, but we know what the goal is -- already (the remote head hash). tweak :: Maybe [Base32Hex] -> Maybe [CausalHash] tweak = - fmap (map (CausalHash . Hash.fromBase32Hex) . reverse . drop 1) + fmap (map (CausalHash . Hash.fromBase32Hex) . drop 1) data Step a = DeadEnd diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index c369fe45b3..06c53b263a 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -674,7 +674,8 @@ instance FromJSON HashMismatchForEntity where -- Fast-forward path -- | A non-empty list of causal hashes, latest first, that show the lineage from wherever the client wants to --- fast-forward to back to wherever the (client believes the) server is (not including the server head). +-- fast-forward to back to wherever the (client believes the) server is (including the server head, in a separate +-- field). -- -- For example, if the client wants to update -- @@ -691,7 +692,8 @@ instance FromJSON HashMismatchForEntity where -- then it would send hashes -- -- @ --- [F, E, D] +-- expectedHash = C +-- hashes = [D, E, F] -- @ -- -- Note that if the client wants to begin a history at a new path on the server, it would use the "update path" endpoint @@ -699,9 +701,9 @@ instance FromJSON HashMismatchForEntity where data FastForwardPathRequest = FastForwardPathRequest { -- | The causal that the client believes exists at `path` expectedHash :: Hash, - -- | The sequence of causals to fast-forward, starting from the oldest new causal to the newest new causal + -- | The sequence of causals to fast-forward with, starting from the oldest new causal to the newest new causal hashes :: NonEmpty Hash, - -- | The path to fast-forward. + -- | The path to fast-forward path :: Path } deriving stock (Show) From 86c04e677153941c29841715071ce89fd564431f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 26 May 2022 11:31:28 -0600 Subject: [PATCH 236/529] Adds ToJWT/FromJWT instances for HashJWT --- unison-share-api/package.yaml | 1 + unison-share-api/src/Unison/Sync/Types.hs | 2 ++ unison-share-api/unison-share-api.cabal | 1 + 3 files changed, 4 insertions(+) diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index c1444162c8..777c7fdec8 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -32,6 +32,7 @@ dependencies: - servant-docs - servant-openapi3 - servant-server + - servant-auth - text - transformers - unison-codebase diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index c369fe45b3..03c9d33e70 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -76,6 +76,7 @@ import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text +import Servant.Auth.JWT import U.Util.Base32Hex (Base32Hex (..)) import Unison.Prelude import qualified Web.JWT as JWT @@ -144,6 +145,7 @@ data HashJWTClaims = HashJWTClaims entityType :: EntityType } deriving stock (Show, Eq, Ord) + deriving anyclass (ToJWT, FromJWT) -- uses JSON instances instance ToJSON HashJWTClaims where toJSON (HashJWTClaims hash entityType) = diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index f5da2143be..e73069769e 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -90,6 +90,7 @@ library , openapi3 , regex-tdfa , servant + , servant-auth , servant-docs , servant-openapi3 , servant-server From ad4d811388ae153f78e18a6c555b096ad26e73bd Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 26 May 2022 12:12:05 -0600 Subject: [PATCH 237/529] Add missing error handling --- unison-cli/src/Unison/CommandLine/OutputMessages.hs | 13 +++++++++---- unison-cli/src/Unison/Share/Sync.hs | 7 +++++++ 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 41d97ae987..a28bdd137a 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -636,8 +636,8 @@ notifyUser dir o = case o of CachedTests 0 _ -> pure . P.callout "๐Ÿ˜ถ" $ "No tests to run." CachedTests n n' | n == n' -> - pure $ - P.lines [cache, "", displayTestResults True ppe oks fails] + pure $ + P.lines [cache, "", displayTestResults True ppe oks fails] CachedTests _n m -> pure $ if m == 0 @@ -646,7 +646,6 @@ notifyUser dir o = case o of P.indentN 2 $ P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "โœ… "] where - NewlyComputed -> do clearCurrentLine pure $ @@ -1597,6 +1596,12 @@ notifyUser dir o = case o of (Share.FastForwardPushErrorNoHistory sharePath) -> expectedNonEmptyPushDest (sharePathToWriteRemotePathShare sharePath) (Share.FastForwardPushErrorNoReadPermission sharePath) -> noReadPermission sharePath + (Share.FastForwardPushInvalidParentage parent child) -> + P.fatalCallout + ( P.lines ["The server detected an error in the history being pushed, please report this as a bug in ucm." + , "The history in question is the hash: " <> prettyShareHash child <> " with the ancestor: " <> prettyShareHash parent + ] + ) Share.FastForwardPushErrorNotFastForward sharePath -> P.lines $ [ P.wrap $ @@ -2259,7 +2264,7 @@ showDiffNamespace :: (Pretty, NumberedArgs) showDiffNamespace _ _ _ _ diffOutput | OBD.isEmpty diffOutput = - ("The namespaces are identical.", mempty) + ("The namespaces are identical.", mempty) showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = (P.sepNonEmpty "\n\n" p, toList args) where diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index e8043453e3..5763162fc2 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -22,6 +22,9 @@ module Unison.Share.Sync -- ** Download entities downloadEntities, + + -- ** Exported for shared usage in the Sync Server + expectEntity, ) where @@ -135,6 +138,8 @@ data FastForwardPushError | FastForwardPushErrorNotFastForward Share.Path | FastForwardPushErrorNoWritePermission Share.Path | FastForwardPushErrorServerMissingDependencies (NESet Share.Hash) + -- Parent Child + | FastForwardPushInvalidParentage Share.Hash Share.Hash -- | Push a causal to Unison Share. -- FIXME reword this @@ -181,6 +186,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory path) Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission path) Share.FastForwardPathNotFastForward _ -> Left (FastForwardPushErrorNotFastForward path) + Share.FastForwardPathInvalidParentage (Share.InvalidParentage parent child) -> Left (FastForwardPushInvalidParentage parent child) where doUpload :: List.NonEmpty CausalHash -> IO Bool -- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes", but we @@ -440,6 +446,7 @@ uploadEntities httpClient unisonShareUrl conn repoName = uploadEntities >>= \case Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> loop moreHashes Share.UploadEntitiesNoWritePermission _ -> pure False + Share.UploadEntitiesHashMismatchForEntity {} -> pure False Share.UploadEntitiesSuccess -> pure True ------------------------------------------------------------------------------------------------------------------------ From aff981335cba140e1b51bdd70fb2c0433416ed5d Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 26 May 2022 16:05:23 -0400 Subject: [PATCH 238/529] use BranchHash / PatchHash where appropriate --- .../U/Codebase/Sqlite/Queries.hs | 4 +- lib/unison-sqlite/src/Unison/Sqlite.hs | 2 +- .../Migrations/MigrateSchema1To2.hs | 38 ++++++++++++++----- .../Migrations/MigrateSchema1To2/DbHelpers.hs | 14 +++---- unison-cli/src/Unison/Share/Sync.hs | 6 +-- 5 files changed, 41 insertions(+), 23 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 0a8728e0d7..5203178d4c 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -1415,9 +1415,9 @@ ancestorSql = -- | Does this entity already exist in the database, i.e. in the `object` or `causal` table? entityExists :: Base32Hex -> Transaction Bool -entityExists b32 = do +entityExists hash = do -- first get hashId if exists - loadHashId b32 >>= \case + loadHashId hash >>= \case Nothing -> pure False -- then check if is causal hash or if object exists for hash id Just hashId -> isCausalHash hashId ||^ isObjectHash hashId diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index 530e39ecb5..957b75417e 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -104,7 +104,7 @@ module Unison.Sqlite (Sqlite.Simple.:.) (..), Sqlite.Simple.FromField (fromField), Sqlite.Simple.FromRow (fromRow), - Sqlite.Simple.Only(..), + Sqlite.Simple.Only (..), Sqlite.Simple.RowParser, Sqlite.Simple.SQLData (..), Sqlite.Simple.ToField (toField), diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 7f882c3e22..1ea391eb21 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -171,7 +171,7 @@ data MigrationState = MigrationState -- Remember the hashes of term/decls that we have already migrated to avoid migrating them twice. migratedDefnHashes :: Set (Old Hash), numMigrated :: Int, - v2EmptyBranchHashInfo :: (BranchHashId, Hash) + v2EmptyBranchHashInfo :: (BranchHashId, BranchHash) } deriving (Generic) @@ -230,7 +230,7 @@ migrateCausal oldCausalHashId = fmap (either id id) . runExceptT $ do Nothing -> use (field @"v2EmptyBranchHashInfo") Just branchObjId -> do let (_, newBranchHashId, newBranchHash, _) = migratedObjIds ^?! ix branchObjId - pure (BranchHashId newBranchHashId, newBranchHash) + pure (BranchHashId newBranchHashId, BranchHash newBranchHash) let (newParentHashes, newParentHashIds) = oldCausalParentHashIds @@ -244,7 +244,7 @@ migrateCausal oldCausalHashId = fmap (either id id) . runExceptT $ do CausalHash . Cv.hash1to2 $ Hashing.hashCausal ( Hashing.Causal - { branchHash = newBranchHash, + { branchHash = unBranchHash newBranchHash, parents = Set.mapMonotonic Cv.hash2to1 newParentHashes } ) @@ -334,9 +334,16 @@ migrateBranch oldObjectId = fmap (either id id) . runExceptT $ do & S.childrenHashes_ %~ (remapBranchObjectId *** remapCausalHashId) newHash <- lift . lift $ Hashing.dbBranchHash newBranch - newHashId <- lift . lift $ Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash)) + newHashId <- lift . lift $ Q.saveBranchHash (coerce Cv.hash1to2 newHash) newObjectId <- lift . lift $ Ops.saveDbBranchUnderHashId newHashId newBranch - field @"objLookup" %= Map.insert oldObjectId (unBranchObjectId newObjectId, unBranchHashId newHashId, newHash, oldHash) + field @"objLookup" + %= Map.insert + oldObjectId + ( unBranchObjectId newObjectId, + unBranchHashId newHashId, + unBranchHash newHash, + oldHash + ) pure Sync.Done migratePatch :: Old PatchObjectId -> StateT MigrationState Sqlite.Transaction (Sync.TrySyncResult Entity) @@ -388,9 +395,20 @@ migratePatch oldObjectId = fmap (either id id) . runExceptT $ do let (localPatchIds, localPatch) = S.LocalizeObject.localizePatch newPatchWithIds newHash <- lift . lift $ Hashing.dbPatchHash newPatchWithIds - newObjectId <- lift . lift $ Ops.saveDbPatch (PatchHash (Cv.hash1to2 newHash)) (S.Patch.Format.Full localPatchIds localPatch) - newHashId <- lift . lift $ Q.expectHashIdByHash (Cv.hash1to2 newHash) - field @"objLookup" %= Map.insert (unPatchObjectId oldObjectId) (unPatchObjectId newObjectId, newHashId, newHash, oldHash) + newObjectId <- + lift . lift $ + Ops.saveDbPatch + (coerce Cv.hash1to2 newHash) + (S.Patch.Format.Full localPatchIds localPatch) + newHashId <- lift . lift $ Q.expectHashIdByHash (coerce Cv.hash1to2 newHash) + field @"objLookup" + %= Map.insert + (unPatchObjectId oldObjectId) + ( unPatchObjectId newObjectId, + newHashId, + unPatchHash newHash, + oldHash + ) pure Sync.Done -- | PLAN @@ -845,10 +863,10 @@ foldSetter t s = execWriter (s & t %%~ \a -> tell [a] *> pure a) -- | Save an empty branch and get its new hash to use when replacing -- branches which are missing due to database corruption. -saveV2EmptyBranch :: Sqlite.Transaction (BranchHashId, Hash) +saveV2EmptyBranch :: Sqlite.Transaction (BranchHashId, BranchHash) saveV2EmptyBranch = do let branch = S.emptyBranch newHash <- Hashing.dbBranchHash branch - newHashId <- Q.saveBranchHash (BranchHash (Cv.hash1to2 newHash)) + newHashId <- Q.saveBranchHash (coerce Cv.hash1to2 newHash) _ <- Ops.saveDbBranchUnderHashId newHashId branch pure (newHashId, newHash) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs index 4824838b00..e4ce73120d 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs @@ -7,7 +7,7 @@ where import qualified Data.Set as Set import qualified Data.Vector as Vector -import U.Codebase.HashTags (BranchHash (..), CausalHash (..)) +import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) import qualified U.Codebase.Reference as S hiding (Reference) import qualified U.Codebase.Reference as S.Reference import qualified U.Codebase.Referent as S.Referent @@ -45,16 +45,16 @@ import Unison.Sqlite (Transaction) import qualified Unison.Util.Map as Map import qualified Unison.Util.Set as Set -syncCausalHash :: S.SyncCausalFormat -> Transaction Hash +syncCausalHash :: S.SyncCausalFormat -> Transaction CausalHash syncCausalHash S.SyncCausalFormat {valueHash = valueHashId, parents = parentChIds} = do - fmap Hashing.Causal.hashCausal $ + fmap (CausalHash . Hashing.Causal.hashCausal) $ Hashing.Causal.Causal <$> coerce @(Transaction BranchHash) @(Transaction Hash) (Q.expectBranchHash valueHashId) <*> fmap (Set.fromList . coerce @[CausalHash] @[Hash] . Vector.toList) (traverse Q.expectCausalHash parentChIds) -dbBranchHash :: S.DbBranch -> Transaction Hash +dbBranchHash :: S.DbBranch -> Transaction BranchHash dbBranchHash (S.Branch.Full.Branch tms tps patches children) = - fmap Hashing.Branch.hashBranch $ + fmap (BranchHash . Hashing.Branch.hashBranch) $ Hashing.Branch.Raw <$> doTerms tms <*> doTypes tps @@ -85,9 +85,9 @@ dbBranchHash (S.Branch.Full.Branch tms tps patches children) = doChildren = Map.bitraverse s2hNameSegment \(_boId, chId) -> causalHashIdToHash chId -dbPatchHash :: S.Patch -> Transaction Hash +dbPatchHash :: S.Patch -> Transaction PatchHash dbPatchHash S.Patch {S.termEdits, S.typeEdits} = - fmap Hashing.Patch.hashPatch $ + fmap (PatchHash . Hashing.Patch.hashPatch) $ Hashing.Patch <$> doTermEdits termEdits <*> doTypeEdits typeEdits diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 5763162fc2..eab1d0b4a0 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -463,11 +463,11 @@ data EntityLocation -- | Where is an entity stored? entityLocation :: Share.Hash -> Sqlite.Transaction EntityLocation -entityLocation (Share.Hash b32) = - Q.entityExists b32 >>= \case +entityLocation (Share.Hash hash) = + Q.entityExists hash >>= \case True -> pure EntityInMainStorage False -> - Q.getMissingDependencyJwtsForTempEntity b32 <&> \case + Q.getMissingDependencyJwtsForTempEntity hash <&> \case Nothing -> EntityNotStored Just missingDependencies -> EntityInTempStorage (NESet.map Share.HashJWT missingDependencies) From 8b96376399e66a5600ef4c06176503c96264bb85 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 26 May 2022 14:20:06 -0600 Subject: [PATCH 239/529] Expose implementations for use in Share server --- unison-cli/src/Unison/Share/Sync.hs | 105 +------------------ unison-share-api/package.yaml | 3 + unison-share-api/src/Unison/Sync/Common.hs | 114 +++++++++++++++++++++ unison-share-api/unison-share-api.cabal | 4 + 4 files changed, 125 insertions(+), 101 deletions(-) create mode 100644 unison-share-api/src/Unison/Sync/Common.hs diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 5763162fc2..19572710f0 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -22,9 +22,6 @@ module Unison.Share.Sync -- ** Download entities downloadEntities, - - -- ** Exported for shared usage in the Sync Server - expectEntity, ) where @@ -42,7 +39,6 @@ import qualified Data.Sequence.NonEmpty as NESeq (fromList, nonEmptySeq, (><|)) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet -import Data.Vector (Vector) import qualified Data.Vector as Vector import qualified Servant.API as Servant ((:<|>) (..)) import Servant.Client (BaseUrl) @@ -65,6 +61,7 @@ import qualified Unison.Auth.HTTPClient as Auth import Unison.Prelude import qualified Unison.Sqlite as Sqlite import qualified Unison.Sync.API as Share (api) +import Unison.Sync.Common import qualified Unison.Sync.Types as Share import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set @@ -138,8 +135,8 @@ data FastForwardPushError | FastForwardPushErrorNotFastForward Share.Path | FastForwardPushErrorNoWritePermission Share.Path | FastForwardPushErrorServerMissingDependencies (NESet Share.Hash) - -- Parent Child - | FastForwardPushInvalidParentage Share.Hash Share.Hash + | -- Parent Child + FastForwardPushInvalidParentage Share.Hash Share.Hash -- | Push a causal to Unison Share. -- FIXME reword this @@ -186,7 +183,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory path) Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission path) Share.FastForwardPathNotFastForward _ -> Left (FastForwardPushErrorNotFastForward path) - Share.FastForwardPathInvalidParentage (Share.InvalidParentage parent child) -> Left (FastForwardPushInvalidParentage parent child) + Share.FastForwardPathInvalidParentage (Share.InvalidParentage parent child) -> Left (FastForwardPushInvalidParentage parent child) where doUpload :: List.NonEmpty CausalHash -> IO Bool -- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes", but we @@ -494,13 +491,6 @@ elaborateHashes = EntityInMainStorage -> loop hashes' outputs in \hashes -> loop (NESet.toSet hashes) Set.empty --- | Read an entity out of the database that we know is in main storage. -expectEntity :: Share.Hash -> Sqlite.Transaction (Share.Entity Text Share.Hash Share.Hash) -expectEntity hash = do - syncEntity <- Q.expectEntity (Share.toBase32Hex hash) - tempEntity <- Q.syncToTempEntity syncEntity - pure (tempEntityToEntity tempEntity) - -- | Upsert a downloaded entity "somewhere" - -- -- 1. Nowhere if we already had the entity (in main or temp storage). @@ -632,93 +622,6 @@ entityToTempEntity = \case jwt32 = Share.toBase32Hex . Share.hashJWTHash -tempEntityToEntity :: TempEntity -> Share.Entity Text Share.Hash Share.Hash -tempEntityToEntity = \case - Entity.TC (TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent terms)) -> - terms - & Vector.map (Lens.over Lens._1 mungeLocalIds) - & Vector.toList - & Share.TermComponent - & Share.TC - Entity.DC (DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent decls)) -> - decls - & Vector.map (Lens.over Lens._1 mungeLocalIds) - & Vector.toList - & Share.DeclComponent - & Share.DC - Entity.P format -> - case format of - PatchFormat.SyncFull PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} bytes -> - Share.P - Share.Patch - { textLookup = Vector.toList patchTextLookup, - oldHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchHashLookup), - newHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchDefnLookup), - bytes - } - PatchFormat.SyncDiff parent PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} bytes -> - Share.PD - Share.PatchDiff - { parent = Share.Hash parent, - textLookup = Vector.toList patchTextLookup, - oldHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchHashLookup), - newHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchDefnLookup), - bytes - } - Entity.N format -> - case format of - NamespaceFormat.SyncFull - NamespaceFormat.LocalIds - { branchTextLookup, - branchDefnLookup, - branchPatchLookup, - branchChildLookup - } - bytes -> - Share.N - Share.Namespace - { textLookup = Vector.toList branchTextLookup, - defnLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchDefnLookup), - patchLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchPatchLookup), - childLookup = - Vector.toList - (coerce @(Vector (Base32Hex, Base32Hex)) @(Vector (Share.Hash, Share.Hash)) branchChildLookup), - bytes - } - NamespaceFormat.SyncDiff - parent - NamespaceFormat.LocalIds - { branchTextLookup, - branchDefnLookup, - branchPatchLookup, - branchChildLookup - } - bytes -> - Share.ND - Share.NamespaceDiff - { parent = Share.Hash parent, - textLookup = Vector.toList branchTextLookup, - defnLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchDefnLookup), - patchLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchPatchLookup), - childLookup = - Vector.toList - (coerce @(Vector (Base32Hex, Base32Hex)) @(Vector (Share.Hash, Share.Hash)) branchChildLookup), - bytes - } - Entity.C Causal.SyncCausalFormat {valueHash, parents} -> - Share.C - Share.Causal - { namespaceHash = Share.Hash valueHash, - parents = Set.fromList (coerce @[Base32Hex] @[Share.Hash] (Vector.toList parents)) - } - where - mungeLocalIds :: LocalIds' Text Base32Hex -> Share.LocalIds Text Share.Hash - mungeLocalIds LocalIds {textLookup, defnLookup} = - Share.LocalIds - { texts = Vector.toList textLookup, - hashes = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) defnLookup) - } - ------------------------------------------------------------------------------------------------------------------------ -- HTTP calls diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 777c7fdec8..6ea021cc31 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -36,6 +36,7 @@ dependencies: - text - transformers - unison-codebase + - unison-codebase-sqlite - unison-core1 - unison-parser-typechecker - unison-prelude @@ -43,10 +44,12 @@ dependencies: - unison-util - unison-util-base32hex - unison-util-relation + - unison-sqlite - unliftio - unordered-containers - uri-encode - utf8-string + - vector - wai - warp - yaml diff --git a/unison-share-api/src/Unison/Sync/Common.hs b/unison-share-api/src/Unison/Sync/Common.hs new file mode 100644 index 0000000000..1d91befa04 --- /dev/null +++ b/unison-share-api/src/Unison/Sync/Common.hs @@ -0,0 +1,114 @@ +-- | Combinators or utilities shared by sync server AND client +module Unison.Sync.Common where + +import qualified Control.Lens as Lens +import qualified Data.Set as Set +import Data.Vector (Vector) +import qualified Data.Vector as Vector +import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat +import qualified U.Codebase.Sqlite.Causal as Causal +import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat +import qualified U.Codebase.Sqlite.Entity as Entity +import U.Codebase.Sqlite.LocalIds +import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat +import qualified U.Codebase.Sqlite.Queries as Q +import qualified U.Codebase.Sqlite.TempEntity as Sqlite +import qualified U.Codebase.Sqlite.Term.Format as TermFormat +import U.Util.Base32Hex (Base32Hex) +import Unison.Prelude +import qualified Unison.Sqlite as Sqlite +import qualified Unison.Sync.Types as Share + +-- | Read an entity out of the database that we know is in main storage. +expectEntity :: Share.Hash -> Sqlite.Transaction (Share.Entity Text Share.Hash Share.Hash) +expectEntity hash = do + syncEntity <- Q.expectEntity (Share.toBase32Hex hash) + tempEntity <- Q.syncToTempEntity syncEntity + pure (tempEntityToEntity tempEntity) + +tempEntityToEntity :: Sqlite.TempEntity -> Share.Entity Text Share.Hash Share.Hash +tempEntityToEntity = \case + Entity.TC (TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent terms)) -> + terms + & Vector.map (Lens.over Lens._1 mungeLocalIds) + & Vector.toList + & Share.TermComponent + & Share.TC + Entity.DC (DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent decls)) -> + decls + & Vector.map (Lens.over Lens._1 mungeLocalIds) + & Vector.toList + & Share.DeclComponent + & Share.DC + Entity.P format -> + case format of + PatchFormat.SyncFull PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} bytes -> + Share.P + Share.Patch + { textLookup = Vector.toList patchTextLookup, + oldHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchHashLookup), + newHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchDefnLookup), + bytes + } + PatchFormat.SyncDiff parent PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} bytes -> + Share.PD + Share.PatchDiff + { parent = Share.Hash parent, + textLookup = Vector.toList patchTextLookup, + oldHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchHashLookup), + newHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchDefnLookup), + bytes + } + Entity.N format -> + case format of + NamespaceFormat.SyncFull + NamespaceFormat.LocalIds + { branchTextLookup, + branchDefnLookup, + branchPatchLookup, + branchChildLookup + } + bytes -> + Share.N + Share.Namespace + { textLookup = Vector.toList branchTextLookup, + defnLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchDefnLookup), + patchLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchPatchLookup), + childLookup = + Vector.toList + (coerce @(Vector (Base32Hex, Base32Hex)) @(Vector (Share.Hash, Share.Hash)) branchChildLookup), + bytes + } + NamespaceFormat.SyncDiff + parent + NamespaceFormat.LocalIds + { branchTextLookup, + branchDefnLookup, + branchPatchLookup, + branchChildLookup + } + bytes -> + Share.ND + Share.NamespaceDiff + { parent = Share.Hash parent, + textLookup = Vector.toList branchTextLookup, + defnLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchDefnLookup), + patchLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchPatchLookup), + childLookup = + Vector.toList + (coerce @(Vector (Base32Hex, Base32Hex)) @(Vector (Share.Hash, Share.Hash)) branchChildLookup), + bytes + } + Entity.C Causal.SyncCausalFormat {valueHash, parents} -> + Share.C + Share.Causal + { namespaceHash = Share.Hash valueHash, + parents = Set.fromList (coerce @[Base32Hex] @[Share.Hash] (Vector.toList parents)) + } + where + mungeLocalIds :: LocalIds' Text Base32Hex -> Share.LocalIds Text Share.Hash + mungeLocalIds LocalIds {textLookup, defnLookup} = + Share.LocalIds + { texts = Vector.toList textLookup, + hashes = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) defnLookup) + } diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index e73069769e..b668ab4a27 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -34,6 +34,7 @@ library Unison.Server.Syntax Unison.Server.Types Unison.Sync.API + Unison.Sync.Common Unison.Sync.Types Unison.Util.Find other-modules: @@ -97,10 +98,12 @@ library , text , transformers , unison-codebase + , unison-codebase-sqlite , unison-core1 , unison-parser-typechecker , unison-prelude , unison-pretty-printer + , unison-sqlite , unison-util , unison-util-base32hex , unison-util-relation @@ -108,6 +111,7 @@ library , unordered-containers , uri-encode , utf8-string + , vector , wai , warp , yaml From cc34cb8242923037d07ec3f97d340b852df86856 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 26 May 2022 14:21:51 -0600 Subject: [PATCH 240/529] Remove entity type from hashjwt for now. --- unison-share-api/src/Unison/Sync/Types.hs | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index f94bd6bb98..3efd693755 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -141,23 +141,22 @@ hashJWTHash = decodedHashJWTHash . decodeHashJWT data HashJWTClaims = HashJWTClaims - { hash :: Hash, - entityType :: EntityType + { hash :: Hash + -- Currently unused + -- entityType :: EntityType } deriving stock (Show, Eq, Ord) deriving anyclass (ToJWT, FromJWT) -- uses JSON instances instance ToJSON HashJWTClaims where - toJSON (HashJWTClaims hash entityType) = + toJSON (HashJWTClaims hash) = object - [ "h" .= hash, - "t" .= entityType + [ "h" .= hash ] instance FromJSON HashJWTClaims where parseJSON = Aeson.withObject "HashJWTClaims" \obj -> do hash <- obj .: "h" - entityType <- obj .: "t" pure HashJWTClaims {..} -- | A decoded hash JWT that retains the original encoded JWT. From 92c5b33841745ae23d12f3afd2fa44950c30e9b9 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 26 May 2022 16:36:17 -0400 Subject: [PATCH 241/529] change upsertEntitySomewhere return type to be more clear --- unison-cli/src/Unison/Share/Sync.hs | 58 ++++++++++++++--------------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index d3c9f0ed2a..4408462422 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -340,9 +340,9 @@ pull httpClient unisonShareUrl conn repoPath = do Right (Just hashJwt) -> do let hash = Share.hashJWTHash hashJwt Sqlite.runTransaction conn (entityLocation hash) >>= \case - EntityInMainStorage -> pure () - EntityInTempStorage missingDependencies -> doDownload missingDependencies - EntityNotStored -> doDownload (NESet.singleton hashJwt) + Just EntityInMainStorage -> pure () + Just (EntityInTempStorage missingDependencies) -> doDownload missingDependencies + Nothing -> doDownload (NESet.singleton hashJwt) pure (Right (CausalHash (Hash.fromBase32Hex (Share.toBase32Hex hash)))) where doDownload :: NESet Share.HashJWT -> IO () @@ -392,7 +392,9 @@ downloadEntities httpClient unisonShareUrl conn repoName = missingDependencies0 <- Sqlite.runTransaction conn do NEMap.toList entities & foldMapM \(hash, entity) -> - upsertEntitySomewhere hash entity + upsertEntitySomewhere hash entity <&> \case + EntityInMainStorage -> Set.empty + EntityInTempStorage missingDependencies -> Set.map Share.decodeHashJWT (NESet.toSet missingDependencies) whenJust (NESet.nonEmptySet missingDependencies0) loop @@ -455,18 +457,16 @@ data EntityLocation EntityInMainStorage | -- | `temp_entity`, evidenced by these missing dependencies. EntityInTempStorage (NESet Share.HashJWT) - | -- | Nowhere - EntityNotStored -- | Where is an entity stored? -entityLocation :: Share.Hash -> Sqlite.Transaction EntityLocation +entityLocation :: Share.Hash -> Sqlite.Transaction (Maybe EntityLocation) entityLocation (Share.Hash hash) = Q.entityExists hash >>= \case - True -> pure EntityInMainStorage + True -> pure (Just EntityInMainStorage) False -> Q.getMissingDependencyJwtsForTempEntity hash <&> \case - Nothing -> EntityNotStored - Just missingDependencies -> EntityInTempStorage (NESet.map Share.HashJWT missingDependencies) + Nothing -> Nothing + Just missingDependencies -> Just (EntityInTempStorage (NESet.map Share.HashJWT missingDependencies)) -- | "Elaborate" a set of hashes that we are considering downloading from Unison Share. -- @@ -485,10 +485,10 @@ elaborateHashes = Nothing -> pure (NESet.nonEmptySet outputs) Just (Share.DecodedHashJWT (Share.HashJWTClaims {hash}) jwt, hashes') -> entityLocation hash >>= \case - EntityNotStored -> loop hashes' (Set.insert jwt outputs) - EntityInTempStorage missingDependencies -> + Nothing -> loop hashes' (Set.insert jwt outputs) + Just (EntityInTempStorage missingDependencies) -> loop (Set.union (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) hashes') outputs - EntityInMainStorage -> loop hashes' outputs + Just EntityInMainStorage -> loop hashes' outputs in \hashes -> loop (NESet.toSet hashes) Set.empty -- | Upsert a downloaded entity "somewhere" - @@ -496,29 +496,28 @@ elaborateHashes = -- 1. Nowhere if we already had the entity (in main or temp storage). -- 2. In main storage if we already have all of its dependencies in main storage. -- 3. In temp storage otherwise. --- --- Returns the set of dependencies we still need to store the entity in main storage (which will be empty if either it --- was already in main storage, or we just put it in main storage). upsertEntitySomewhere :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> - Sqlite.Transaction (Set Share.DecodedHashJWT) + Sqlite.Transaction EntityLocation upsertEntitySomewhere hash entity = entityLocation hash >>= \case - EntityInMainStorage -> pure Set.empty - EntityInTempStorage missingDependencies -> - pure (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) - EntityNotStored -> do + Just location -> pure location + Nothing -> do -- if it has missing dependencies, add it to temp storage; -- otherwise add it to main storage. missingDependencies0 <- Set.filterM - (Q.entityExists . Share.toBase32Hex . Share.decodedHashJWTHash) - (Set.map Share.decodeHashJWT (Share.entityDependencies entity)) + (Q.entityExists . Share.toBase32Hex . Share.hashJWTHash) + -- (Set.map Share.decodeHashJWT (Share.entityDependencies entity)) + (Share.entityDependencies entity) case NESet.nonEmptySet missingDependencies0 of - Nothing -> insertEntity hash entity - Just missingDependencies -> insertTempEntity hash entity missingDependencies - pure missingDependencies0 + Nothing -> do + insertEntity hash entity + pure EntityInMainStorage + Just missingDependencies -> do + insertTempEntity hash entity missingDependencies + pure (EntityInTempStorage missingDependencies) -- | Insert an entity that doesn't have any missing dependencies. insertEntity :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> Sqlite.Transaction () @@ -531,15 +530,16 @@ insertEntity hash entity = do insertTempEntity :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> - NESet Share.DecodedHashJWT -> + NESet Share.HashJWT -> Sqlite.Transaction () insertTempEntity hash entity missingDependencies = Q.insertTempEntity (Share.toBase32Hex hash) (entityToTempEntity entity) ( NESet.map - ( \Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}, hashJWT} -> - (Share.toBase32Hex hash, Share.unHashJWT hashJWT) + ( \hashJwt -> + let Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}} = Share.decodeHashJWT hashJwt + in (Share.toBase32Hex hash, Share.unHashJWT hashJwt) ) missingDependencies ) From 5bf8f1c204d7782a23682ed57b6286a8d28d96b6 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 26 May 2022 16:20:38 -0600 Subject: [PATCH 242/529] Causal hash/branch hash cleanup migration (#3073) * Rename Branch.Hash -> Branch.CausalHash for clarity. * WIP simplifying types for Causals and hashes * Single type for causal hashes. * Remove vestigial function * Clean up some rogue hashes * Formatting * Fix tests * Add namespace hash migration * Cleanup * Finish writing migration for bad branches, add some sanity checks too. * Keep hash_object mappings up to date. * Working migration * More checks * Dependency-order migration WIP * Finish first draft of crawled migration strategy * Improve speed and reliability of migration. * Better migration logging * Perform integrity checks once after all migrations are done. * Considerably speed up migration by only re-hashing branches which have the same causal hash as value hash. * Clarify migration docs * Move 'differing causal value hash' check to integrity checks * Bump schema version for new codebases * PR cleanup * Remove commented out migration * PR feedback cleanup * Add integrity check for hash_objects. * Correctly set 'changes' key * Don't check hash object integrity in migrations Some codebases (like mine) are borked in this area and we'll need to fix them later on. * Correct final migration number * Check namespace hash even if branch has no children * Rehash every branch regardless * Use v4 of base. --- .../U/Codebase/Sqlite/Queries.hs | 8 +- codebase2/codebase-sqlite/sql/create.sql | 2 +- codebase2/codebase-sync/U/Codebase/Sync.hs | 4 +- codebase2/util/src/U/Util/Hash.hs | 7 + lib/unison-prelude/src/Unison/Debug.hs | 14 + lib/unison-sqlite/src/Unison/Sqlite.hs | 1 + parser-typechecker/package.yaml | 3 + parser-typechecker/src/Unison/Codebase.hs | 2 +- .../src/Unison/Codebase/Branch.hs | 15 +- .../src/Unison/Codebase/Branch/Type.hs | 26 +- .../src/Unison/Codebase/Causal.hs | 100 ++--- .../src/Unison/Codebase/Causal/FoldHistory.hs | 10 +- .../src/Unison/Codebase/Causal/Type.hs | 70 ++-- .../src/Unison/Codebase/IntegrityCheck.hs | 184 ++++++++++ .../src/Unison/Codebase/SqliteCodebase.hs | 22 +- .../SqliteCodebase/Branch/Dependencies.hs | 11 +- .../Codebase/SqliteCodebase/Conversions.hs | 50 +-- .../Codebase/SqliteCodebase/Migrations.hs | 25 +- .../SqliteCodebase/Migrations/Helpers.hs | 14 + .../Migrations/MigrateSchema3To4.hs | 341 ++++++++++++++++++ .../Codebase/SqliteCodebase/Operations.hs | 18 +- .../src/Unison/Codebase/Type.hs | 16 +- .../src/Unison/Hashing/V2/Convert.hs | 13 +- .../src/Unison/Hashing/V2/Hashable.hs | 7 +- .../tests/Unison/Test/Codebase/Causal.hs | 33 +- .../unison-parser-typechecker.cabal | 6 + .../src/Unison/Codebase/Editor/Command.hs | 6 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 18 +- .../src/Unison/Codebase/Editor/Input.hs | 2 +- .../src/Unison/Codebase/Editor/Output.hs | 14 +- .../Codebase/Editor/Output/DumpNamespace.hs | 4 +- .../Unison/Codebase/Editor/VersionParser.hs | 6 +- .../src/Unison/CommandLine/OutputMessages.hs | 22 +- unison-cli/tests/Unison/Test/VersionParser.hs | 4 +- unison-core/src/Unison/Hash.hs | 3 +- unison-share-api/src/Unison/Server/Backend.hs | 28 +- .../Server/Endpoints/NamespaceListing.hs | 2 +- .../src/Unison/Server/Endpoints/Projects.hs | 2 +- unison-share-api/src/Unison/Server/Errors.hs | 4 +- unison-share-api/src/Unison/Server/Types.hs | 2 +- 40 files changed, 865 insertions(+), 254 deletions(-) create mode 100644 parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs create mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/Helpers.hs create mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 4898123275..6131dac524 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -43,6 +43,7 @@ module U.Codebase.Sqlite.Queries saveObject, expectObject, expectPrimaryHashByObjectId, + expectPrimaryHashIdForObject, expectObjectWithHashIdAndType, expectDeclObject, loadDeclObject, @@ -140,7 +141,6 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel import qualified Data.Set as Set import Data.String.Here.Uninterpolated (here, hereFile) -import Data.Tuple.Only (Only (..)) import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) import U.Codebase.Reference (Reference' (..)) import qualified U.Codebase.Reference as C.Reference @@ -387,6 +387,12 @@ expectTermObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either expectTermObject oid = expectObjectOfType oid TermComponent +expectPrimaryHashIdForObject :: ObjectId -> Transaction HashId +expectPrimaryHashIdForObject oId = do + queryOneCol sql (Only oId) + where + sql = "SELECT primary_hash_id FROM object WHERE id = ?" + expectObjectWithHashIdAndType :: ObjectId -> Transaction (HashId, ObjectType, ByteString) expectObjectWithHashIdAndType oId = queryOneRow sql (Only oId) where sql = [here| diff --git a/codebase2/codebase-sqlite/sql/create.sql b/codebase2/codebase-sqlite/sql/create.sql index 7681df382b..79fc52cdaa 100644 --- a/codebase2/codebase-sqlite/sql/create.sql +++ b/codebase2/codebase-sqlite/sql/create.sql @@ -3,7 +3,7 @@ CREATE TABLE schema_version ( version INTEGER NOT NULL ); -INSERT INTO schema_version (version) VALUES (3); +INSERT INTO schema_version (version) VALUES (4); -- actually stores the 512-byte hashes CREATE TABLE hash ( diff --git a/codebase2/codebase-sync/U/Codebase/Sync.hs b/codebase2/codebase-sync/U/Codebase/Sync.hs index 954694835d..a88b290ad8 100644 --- a/codebase2/codebase-sync/U/Codebase/Sync.hs +++ b/codebase2/codebase-sync/U/Codebase/Sync.hs @@ -14,10 +14,10 @@ import Debug.Trace (traceM) debug :: Bool debug = False -data TrySyncResult h = Missing [h] | Done | PreviouslyDone | NonFatalError +data TrySyncResult entity = Missing [entity] | Done | PreviouslyDone | NonFatalError deriving (Show) -data Sync m h = Sync {trySync :: h -> m (TrySyncResult h)} +data Sync m entity = Sync {trySync :: entity -> m (TrySyncResult entity)} transformSync :: (forall a. m a -> n a) -> Sync m h -> Sync n h transformSync f (Sync t) = Sync (f . t) diff --git a/codebase2/util/src/U/Util/Hash.hs b/codebase2/util/src/U/Util/Hash.hs index c05921f26b..bcda444003 100644 --- a/codebase2/util/src/U/Util/Hash.hs +++ b/codebase2/util/src/U/Util/Hash.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} module U.Util.Hash @@ -9,6 +10,7 @@ module U.Util.Hash toBase32Hex, toBase32HexText, toByteString, + HashFor (..), ) where @@ -46,3 +48,8 @@ fromByteString = Hash . B.Short.toShort instance Show Hash where show h = (show . toBase32HexText) h + +-- | A hash tagged with the type it's a hash of, useful for maintaining type safety +-- guarantees. +newtype HashFor t = HashFor {genericHash :: Hash} + deriving newtype (Show, Eq, Ord, Generic) diff --git a/lib/unison-prelude/src/Unison/Debug.hs b/lib/unison-prelude/src/Unison/Debug.hs index fe42dceccf..475a81fbce 100644 --- a/lib/unison-prelude/src/Unison/Debug.hs +++ b/lib/unison-prelude/src/Unison/Debug.hs @@ -24,6 +24,8 @@ data DebugFlag | Sqlite | Codebase | Auth + | Migration + | Integrity deriving (Eq, Ord, Show, Bounded, Enum) debugFlags :: Set DebugFlag @@ -39,6 +41,8 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of "SQLITE" -> pure Sqlite "CODEBASE" -> pure Codebase "AUTH" -> pure Auth + "MIGRATION" -> pure Migration + "INTEGRITY" -> pure Integrity _ -> empty {-# NOINLINE debugFlags #-} @@ -58,6 +62,14 @@ debugAuth :: Bool debugAuth = Auth `Set.member` debugFlags {-# NOINLINE debugAuth #-} +debugMigration :: Bool +debugMigration = Migration `Set.member` debugFlags +{-# NOINLINE debugMigration #-} + +debugIntegrity :: Bool +debugIntegrity = Integrity `Set.member` debugFlags +{-# NOINLINE debugIntegrity #-} + -- | Use for trace-style selective debugging. -- E.g. 1 + (debug Git "The second number" 2) -- @@ -102,3 +114,5 @@ shouldDebug = \case Sqlite -> debugSqlite Codebase -> debugCodebase Auth -> debugAuth + Migration -> debugMigration + Integrity -> debugIntegrity diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index f929cd6da2..d8e61e0b22 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -105,6 +105,7 @@ module Unison.Sqlite Sqlite.Simple.SQLData (..), Sqlite.Simple.ToField (toField), Sqlite.Simple.ToRow (toRow), + Sqlite.Simple.Only (..), ) where diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 05ce575f1c..389581d619 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -49,6 +49,7 @@ library: - hashable - hashtables - haskeline + - here - http-types - http-media - http-client @@ -68,6 +69,7 @@ library: - openapi3 - pem - prelude-extras + - pretty-simple - process - primitive - random >= 1.2.0 @@ -119,6 +121,7 @@ library: - unison-sqlite - unison-util - unison-util-relation + - unison-util-serialization - open-browser - uri-encode - generic-lens diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index b4c44955a8..4625613ecb 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -171,7 +171,7 @@ shallowBranchAtPath path causal = do Just childCausal -> shallowBranchAtPath p childCausal -- | Get a branch from the codebase. -getBranchForHash :: Monad m => Codebase m v a -> Branch.Hash -> m (Maybe (Branch m)) +getBranchForHash :: Monad m => Codebase m v a -> Branch.CausalHash -> m (Maybe (Branch m)) getBranchForHash codebase h = -- Attempt to find the Branch in the current codebase cache and root up to 3 levels deep -- If not found, attempt to find it in the Codebase (sqlite) diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index 56f452d91a..e56081b541 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -11,9 +11,9 @@ module Unison.Codebase.Branch Branch0 (..), Raw, Star, - Hash, + NamespaceHash, + CausalHash, EditHash, - pattern Hash, -- * Branch construction branch0, @@ -92,8 +92,9 @@ import Unison.Codebase.Branch.Raw (Raw) import Unison.Codebase.Branch.Type ( Branch (..), Branch0 (..), + CausalHash (..), EditHash, - Hash, + NamespaceHash, Star, UnwrappedBranch, edits, @@ -307,8 +308,6 @@ discardHistory b = before :: Monad m => Branch m -> Branch m -> m Bool before (Branch b1) (Branch b2) = Causal.before b1 b2 -pattern Hash h = Causal.RawHash h - -- | what does this do? โ€”AI toList0 :: Branch0 m -> [(Path, Branch0 m)] toList0 = go Path.empty @@ -373,7 +372,7 @@ step f = runIdentity . stepM (Identity . f) -- | Perform an update over the current branch and create a new causal step. stepM :: (Monad n, Applicative m) => (Branch0 m -> n (Branch0 m)) -> Branch m -> n (Branch m) stepM f = \case - Branch (Causal.One _h e) | e == empty0 -> Branch . Causal.one <$> f empty0 + Branch (Causal.One _h _eh e) | e == empty0 -> Branch . Causal.one <$> f empty0 b -> mapMOf history (Causal.stepDistinctM f) b cons :: Applicative m => Branch0 m -> Branch m -> Branch m @@ -643,8 +642,8 @@ transform f b = case _history b of transformB0s :: Functor m => (forall a. m a -> n a) -> - Causal m Raw (Branch0 m) -> - Causal m Raw (Branch0 n) + Causal m (Branch0 m) -> + Causal m (Branch0 n) transformB0s f = Causal.unsafeMapHashPreserving (transformB0 f) -- | Traverse the head branch of all direct children. diff --git a/parser-typechecker/src/Unison/Codebase/Branch/Type.hs b/parser-typechecker/src/Unison/Codebase/Branch/Type.hs index 98c3cc5f28..4871ac5643 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch/Type.hs @@ -1,12 +1,24 @@ {-# LANGUAGE TemplateHaskell #-} -module Unison.Codebase.Branch.Type where +module Unison.Codebase.Branch.Type + ( NamespaceHash, + CausalHash (..), + head, + headHash, + Branch (..), + Branch0 (..), + history, + edits, + Star, + EditHash, + UnwrappedBranch, + ) +where import Control.Lens import Data.Map (Map) import Data.Set (Set) -import Unison.Codebase.Branch.Raw (Raw) -import Unison.Codebase.Causal.Type (Causal) +import Unison.Codebase.Causal.Type (Causal, CausalHash) import qualified Unison.Codebase.Causal.Type as Causal import qualified Unison.Codebase.Metadata as Metadata import Unison.Codebase.Patch (Patch) @@ -17,15 +29,17 @@ import Unison.NameSegment (NameSegment) import Unison.Reference (Reference) import Unison.Referent (Referent) import Unison.Util.Relation (Relation) +import Prelude hiding (head) -- | A node in the Unison namespace hierarchy -- along with its history. newtype Branch m = Branch {_history :: UnwrappedBranch m} deriving (Eq, Ord) -type UnwrappedBranch m = Causal m Raw (Branch0 m) +type UnwrappedBranch m = Causal m (Branch0 m) -type Hash = Causal.RawHash Raw +-- | A Hash for a namespace itself, it doesn't incorporate any history. +type NamespaceHash m = Hash.HashFor (Branch0 m) type EditHash = Hash.Hash @@ -34,7 +48,7 @@ type Star r n = Metadata.Star r n head :: Branch m -> Branch0 m head (Branch c) = Causal.head c -headHash :: Branch m -> Hash +headHash :: Branch m -> CausalHash headHash (Branch c) = Causal.currentHash c -- | A node in the Unison namespace hierarchy. diff --git a/parser-typechecker/src/Unison/Codebase/Causal.hs b/parser-typechecker/src/Unison/Codebase/Causal.hs index bfa7dc1c69..8d3c51ddc4 100644 --- a/parser-typechecker/src/Unison/Codebase/Causal.hs +++ b/parser-typechecker/src/Unison/Codebase/Causal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} module Unison.Codebase.Causal @@ -7,7 +8,7 @@ module Unison.Codebase.Causal pattern One, pattern Cons, pattern Merge, - RawHash (RawHash, unRawHash), + CausalHash (..), head_, one, cons, @@ -43,7 +44,7 @@ import Unison.Codebase.Causal.Type tail, tails ), - RawHash (RawHash, unRawHash), + CausalHash (..), before, lca, predecessors, @@ -52,34 +53,34 @@ import Unison.Codebase.Causal.Type pattern One, ) import qualified Unison.Hashing.V2.Convert as Hashing -import Unison.Hashing.V2.Hashable (Hashable) +import Unison.Hashing.V2.Hashable (HashFor (HashFor), Hashable) import Unison.Prelude import Prelude hiding (head, read, tail) -- | Focus the current head, keeping the hash up to date. -head_ :: Hashable e => Lens.Lens' (Causal m h e) e +head_ :: Hashable e => Lens.Lens' (Causal m e) e head_ = Lens.lens getter setter where getter = head setter causal e = case causal of UnsafeOne {} -> one e - UnsafeCons _ _ tail -> fromListM e [tail] - UnsafeMerge _ _ tails -> mergeNode e tails + UnsafeCons {tail} -> fromListM e [tail] + UnsafeMerge {tails} -> mergeNode e tails -- A `squashMerge combine c1 c2` gives the same resulting `e` -- as a `threeWayMerge`, but doesn't introduce a merge node for the -- result. Instead, the resulting causal is a simple `Cons` onto `c2` -- (or is equal to `c2` if `c1` changes nothing). squashMerge' :: - forall m h e. + forall m e. (Monad m, Hashable e, Eq e) => - (Causal m h e -> Causal m h e -> m (Maybe (Causal m h e))) -> + (Causal m e -> Causal m e -> m (Maybe (Causal m e))) -> (e -> m e) -> (Maybe e -> e -> e -> m e) -> - Causal m h e -> - Causal m h e -> - m (Causal m h e) + Causal m e -> + Causal m e -> + m (Causal m e) squashMerge' lca discardHistory combine c1 c2 = do theLCA <- lca c1 c2 let done newHead = consDistinct newHead c2 @@ -91,22 +92,22 @@ squashMerge' lca discardHistory combine c1 c2 = do | otherwise -> done <$> combine (Just $ head lca) (head c1) (head c2) threeWayMerge :: - forall m h e. + forall m e. (Monad m, Hashable e) => (Maybe e -> e -> e -> m e) -> - Causal m h e -> - Causal m h e -> - m (Causal m h e) + Causal m e -> + Causal m e -> + m (Causal m e) threeWayMerge = threeWayMerge' lca threeWayMerge' :: - forall m h e. + forall m e. (Monad m, Hashable e) => - (Causal m h e -> Causal m h e -> m (Maybe (Causal m h e))) -> + (Causal m e -> Causal m e -> m (Maybe (Causal m e))) -> (Maybe e -> e -> e -> m e) -> - Causal m h e -> - Causal m h e -> - m (Causal m h e) + Causal m e -> + Causal m e -> + m (Causal m e) threeWayMerge' lca combine c1 c2 = do theLCA <- lca c1 c2 case theLCA of @@ -116,12 +117,12 @@ threeWayMerge' lca combine c1 c2 = do | lca == c2 -> pure c1 | otherwise -> done <$> combine (Just $ head lca) (head c1) (head c2) where - done :: e -> Causal m h e + done :: e -> Causal m e done newHead = fromList newHead [c1, c2] -- `True` if `h` is found in the history of `c` within `maxDepth` path length -- from the tip of `c` -beforeHash :: forall m h e. Monad m => Word -> RawHash h -> Causal m h e -> m Bool +beforeHash :: forall m e. Monad m => Word -> CausalHash -> Causal m e -> m Bool beforeHash maxDepth h c = Reader.runReaderT (State.evalStateT (go c) Set.empty) (0 :: Word) where @@ -137,70 +138,73 @@ beforeHash maxDepth h c = State.modify' (<> Set.fromList cs) Monad.anyM (Reader.local (1 +) . go) unseens -stepDistinct :: (Applicative m, Eq e, Hashable e) => (e -> e) -> Causal m h e -> Causal m h e +stepDistinct :: (Applicative m, Eq e, Hashable e) => (e -> e) -> Causal m e -> Causal m e stepDistinct f c = f (head c) `consDistinct` c stepDistinctM :: (Applicative m, Functor n, Eq e, Hashable e) => (e -> n e) -> - Causal m h e -> - n (Causal m h e) + Causal m e -> + n (Causal m e) stepDistinctM f c = (`consDistinct` c) <$> f (head c) -- | Causal construction should go through here for uniformity; -- with an exception for `one`, which avoids an Applicative constraint. -fromList :: (Applicative m, Hashable e) => e -> [Causal m h e] -> Causal m h e +fromList :: (Applicative m, Hashable e) => e -> [Causal m e] -> Causal m e fromList e cs = fromListM e (map (\c -> (currentHash c, pure c)) cs) -- | Construct a causal from a list of predecessors. The predecessors may be given in any order. -fromListM :: Hashable e => e -> [(RawHash h, m (Causal m h e))] -> Causal m h e +fromListM :: Hashable e => e -> [(CausalHash, m (Causal m e))] -> Causal m e fromListM e ts = case ts of - [] -> UnsafeOne h e - [t] -> UnsafeCons h e t - _ -> UnsafeMerge h e (Map.fromList ts) + [] -> UnsafeOne ch eh e + [t] -> UnsafeCons ch eh e t + _ -> UnsafeMerge ch eh e (Map.fromList ts) where - h = RawHash (Hashing.hashCausal e (Set.fromList (map fst ts))) + (ch, eh) = (Hashing.hashCausal e (Set.fromList (map fst ts))) -- | An optimized variant of 'fromListM' for when it is known we have 2+ predecessors (merge node). -mergeNode :: Hashable e => e -> Map (RawHash h) (m (Causal m h e)) -> Causal m h e +mergeNode :: Hashable e => e -> Map (CausalHash) (m (Causal m e)) -> Causal m e mergeNode newHead predecessors = - UnsafeMerge (RawHash (Hashing.hashCausal newHead (Map.keysSet predecessors))) newHead predecessors + let (ch, eh) = Hashing.hashCausal newHead (Map.keysSet predecessors) + in UnsafeMerge ch eh newHead predecessors -- duplicated logic here instead of delegating to `fromList` to avoid `Applicative m` constraint. -one :: Hashable e => e -> Causal m h e -one e = UnsafeOne h e +one :: Hashable e => e -> Causal m e +one e = UnsafeOne ch eh e where - h = RawHash $ Hashing.hashCausal e mempty + (ch, eh) = Hashing.hashCausal e mempty -cons :: (Applicative m, Hashable e) => e -> Causal m h e -> Causal m h e +cons :: (Applicative m, Hashable e) => e -> Causal m e -> Causal m e cons e tail = fromList e [tail] -consDistinct :: (Applicative m, Eq e, Hashable e) => e -> Causal m h e -> Causal m h e +consDistinct :: (Applicative m, Eq e, Hashable e) => e -> Causal m e -> Causal m e consDistinct e tl = if head tl == e then tl else cons e tl -uncons :: Applicative m => Causal m h e -> m (Maybe (e, Causal m h e)) +uncons :: Applicative m => Causal m e -> m (Maybe (e, Causal m e)) uncons c = case c of - Cons _ e (_, tl) -> fmap (e,) . Just <$> tl + Cons _ _ e (_, tl) -> fmap (e,) . Just <$> tl _ -> pure Nothing -- it's okay to call "Unsafe"* here with the existing hashes because `nt` can't -- affect `e`. -transform :: Functor m => (forall a. m a -> n a) -> Causal m h e -> Causal n h e +transform :: Functor m => (forall a. m a -> n a) -> Causal m e -> Causal n e transform nt c = case c of - One h e -> UnsafeOne h e - Cons h e (ht, tl) -> UnsafeCons h e (ht, nt (transform nt <$> tl)) - Merge h e tls -> UnsafeMerge h e $ Map.map (\mc -> nt (transform nt <$> mc)) tls + One h eh e -> UnsafeOne h eh e + Cons h eh e (ht, tl) -> UnsafeCons h eh e (ht, nt (transform nt <$> tl)) + Merge h eh e tls -> UnsafeMerge h eh e $ Map.map (\mc -> nt (transform nt <$> mc)) tls -- "unsafe" because the hashes will be wrong if `f` affects aspects of `e` that impact hashing -unsafeMapHashPreserving :: Functor m => (e -> e2) -> Causal m h e -> Causal m h e2 +unsafeMapHashPreserving :: forall m e e2. Functor m => (e -> e2) -> Causal m e -> Causal m e2 unsafeMapHashPreserving f c = case c of - One h e -> UnsafeOne h (f e) - Cons h e (ht, tl) -> UnsafeCons h (f e) (ht, unsafeMapHashPreserving f <$> tl) - Merge h e tls -> UnsafeMerge h (f e) $ Map.map (fmap $ unsafeMapHashPreserving f) tls + One h eh e -> UnsafeOne h (retagValueHash eh) (f e) + Cons h eh e (ht, tl) -> UnsafeCons h (retagValueHash eh) (f e) (ht, unsafeMapHashPreserving f <$> tl) + Merge h eh e tls -> UnsafeMerge h (retagValueHash eh) (f e) $ Map.map (fmap $ unsafeMapHashPreserving f) tls + where + retagValueHash = coerce @(HashFor e) @(HashFor e2) data FoldHistoryResult a = Satisfied a | Unsatisfied a deriving (Eq, Ord, Show) diff --git a/parser-typechecker/src/Unison/Codebase/Causal/FoldHistory.hs b/parser-typechecker/src/Unison/Codebase/Causal/FoldHistory.hs index 0666f8cd48..e2a23a398c 100644 --- a/parser-typechecker/src/Unison/Codebase/Causal/FoldHistory.hs +++ b/parser-typechecker/src/Unison/Codebase/Causal/FoldHistory.hs @@ -6,7 +6,7 @@ module Unison.Codebase.Causal.FoldHistory (FoldHistoryResult (..), foldHistoryUn import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set -import Unison.Codebase.Causal (Causal (..), RawHash, pattern Cons, pattern Merge, pattern One) +import Unison.Codebase.Causal (Causal (..), CausalHash, pattern Cons, pattern Merge, pattern One) import Unison.Prelude import Prelude hiding (head, tail) @@ -21,19 +21,19 @@ data FoldHistoryResult a = Satisfied a | Unsatisfied a deriving (Eq, Ord, Show) -- NOTE by Rร“B: this short-circuits immediately and only looks at the first -- entry in the history, since this operation is far too slow to be practical. foldHistoryUntil :: - forall m h e a. + forall m e a. (Monad m) => (a -> e -> (a, Bool)) -> a -> - Causal m h e -> + Causal m e -> m (FoldHistoryResult a) foldHistoryUntil f a c = step a mempty (pure c) where - step :: a -> Set (RawHash h) -> Seq (Causal m h e) -> m (FoldHistoryResult a) + step :: a -> Set CausalHash -> Seq (Causal m e) -> m (FoldHistoryResult a) step a _seen Seq.Empty = pure (Unsatisfied a) step a seen (c Seq.:<| rest) | currentHash c `Set.member` seen = - step a seen rest + step a seen rest step a seen (c Seq.:<| rest) = case f a (head c) of (a, True) -> pure (Satisfied a) (a, False) -> do diff --git a/parser-typechecker/src/Unison/Codebase/Causal/Type.hs b/parser-typechecker/src/Unison/Codebase/Causal/Type.hs index 959df8d902..9bb60c10fd 100644 --- a/parser-typechecker/src/Unison/Codebase/Causal/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Causal/Type.hs @@ -4,7 +4,7 @@ module Unison.Codebase.Causal.Type ( Causal (..), - RawHash (..), + CausalHash (..), pattern One, pattern Cons, pattern Merge, @@ -17,7 +17,7 @@ where import qualified Data.Map as Map import qualified Data.Sequence as Seq import qualified Data.Set as Set -import Unison.Hash (Hash) +import Unison.Hash (Hash, HashFor (..)) import Unison.Prelude import Prelude hiding (head, read, tail) @@ -41,58 +41,60 @@ import Prelude hiding (head, read, tail) * `head (sequence c1 c2) == head c2` -} -newtype RawHash a = RawHash {unRawHash :: Hash} - deriving (Eq, Ord, Generic) +-- | Represents a hash of a causal containing values of the provided type. +newtype CausalHash = CausalHash {unCausalHash :: Hash} + deriving newtype (Show) + deriving stock (Eq, Ord, Generic) -instance Show (RawHash a) where - show = show . unRawHash - -instance Show e => Show (Causal m h e) where +instance (Show e) => Show (Causal m e) where show = \case - UnsafeOne h e -> "One " ++ (take 3 . show) h ++ " " ++ show e - UnsafeCons h e t -> "Cons " ++ (take 3 . show) h ++ " " ++ show e ++ " " ++ (take 3 . show) (fst t) - UnsafeMerge h e ts -> "Merge " ++ (take 3 . show) h ++ " " ++ show e ++ " " ++ (show . fmap (take 3 . show) . toList) (Map.keysSet ts) + UnsafeOne h eh e -> "One " ++ (take 3 . show) h ++ " " ++ (take 3 . show) eh ++ " " ++ show e + UnsafeCons h eh e t -> "Cons " ++ (take 3 . show) h ++ " " ++ (take 3 . show) eh ++ " " ++ show e ++ " " ++ (take 3 . show) (fst t) + UnsafeMerge h eh e ts -> "Merge " ++ (take 3 . show) h ++ " " ++ (take 3 . show) eh ++ " " ++ show e ++ " " ++ (show . fmap (take 3 . show) . toList) (Map.keysSet ts) -- h is the type of the pure data structure that will be hashed and used as -- an index; e.g. h = Branch00, e = Branch0 m -data Causal m h e +data Causal m e = UnsafeOne - { currentHash :: RawHash h, + { currentHash :: CausalHash, + valueHash :: HashFor e, head :: e } | UnsafeCons - { currentHash :: RawHash h, + { currentHash :: CausalHash, + valueHash :: HashFor e, head :: e, - tail :: (RawHash h, m (Causal m h e)) + tail :: (CausalHash, m (Causal m e)) } | -- The merge operation `<>` flattens and normalizes for order UnsafeMerge - { currentHash :: RawHash h, + { currentHash :: CausalHash, + valueHash :: HashFor e, head :: e, - tails :: Map (RawHash h) (m (Causal m h e)) + tails :: Map CausalHash (m (Causal m e)) } -pattern One :: RawHash h -> e -> Causal m h e -pattern One h e <- UnsafeOne h e +pattern One :: CausalHash -> HashFor e -> e -> Causal m e +pattern One h eh e <- UnsafeOne h eh e -pattern Cons :: RawHash h -> e -> (RawHash h, m (Causal m h e)) -> Causal m h e -pattern Cons h e tail <- UnsafeCons h e tail +pattern Cons :: CausalHash -> HashFor e -> e -> (CausalHash, m (Causal m e)) -> Causal m e +pattern Cons h eh e tail <- UnsafeCons h eh e tail -pattern Merge :: RawHash h -> e -> Map (RawHash h) (m (Causal m h e)) -> Causal m h e -pattern Merge h e tails <- UnsafeMerge h e tails +pattern Merge :: CausalHash -> HashFor e -> e -> Map CausalHash (m (Causal m e)) -> Causal m e +pattern Merge h eh e tails <- UnsafeMerge h eh e tails {-# COMPLETE One, Cons, Merge #-} -predecessors :: Causal m h e -> Seq (m (Causal m h e)) -predecessors (UnsafeOne _ _) = Seq.empty -predecessors (UnsafeCons _ _ (_, t)) = Seq.singleton t -predecessors (UnsafeMerge _ _ ts) = Seq.fromList $ Map.elems ts +predecessors :: Causal m e -> Seq (m (Causal m e)) +predecessors (UnsafeOne _ _ _) = Seq.empty +predecessors (UnsafeCons _ _ _ (_, t)) = Seq.singleton t +predecessors (UnsafeMerge _ _ _ ts) = Seq.fromList $ Map.elems ts -before :: Monad m => Causal m h e -> Causal m h e -> m Bool +before :: Monad m => Causal m e -> Causal m e -> m Bool before a b = (== Just a) <$> lca a b -- Find the lowest common ancestor of two causals. -lca :: Monad m => Causal m h e -> Causal m h e -> m (Maybe (Causal m h e)) +lca :: Monad m => Causal m e -> Causal m e -> m (Maybe (Causal m e)) lca a b = lca' (Seq.singleton $ pure a) (Seq.singleton $ pure b) @@ -101,9 +103,9 @@ lca a b = -- This is a breadth-first search used in the implementation of `lca a b`. lca' :: Monad m => - Seq (m (Causal m h e)) -> - Seq (m (Causal m h e)) -> - m (Maybe (Causal m h e)) + Seq (m (Causal m e)) -> + Seq (m (Causal m e)) -> + m (Maybe (Causal m e)) lca' = go Set.empty Set.empty where go seenLeft seenRight remainingLeft remainingRight = @@ -130,8 +132,8 @@ lca' = go Set.empty Set.empty then pure $ Just current else search seen (as <> predecessors current) -instance Eq (Causal m h a) where +instance Eq (Causal m a) where a == b = currentHash a == currentHash b -instance Ord (Causal m h a) where +instance Ord (Causal m a) where a <= b = currentHash a <= currentHash b diff --git a/parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs b/parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs new file mode 100644 index 0000000000..7dbc30fd38 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | There are many invariants we expect to hold in our sqlite database and on codebase +-- objects which we can't maintain using database checks. This module performs checks for some +-- of these invariants, which can be useful to run after performing potentially dangerous +-- operations like migrations. +module Unison.Codebase.IntegrityCheck + ( integrityCheckFullCodebase, + integrityCheckAllBranches, + integrityCheckAllCausals, + IntegrityResult (..), + ) +where + +import Control.Lens +import Data.String.Here.Uninterpolated (here) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.IO as TL +import Data.Void +import Text.Pretty.Simple +import qualified U.Codebase.Sqlite.Branch.Full as DBBranch +import qualified U.Codebase.Sqlite.DbId as DB +import qualified U.Codebase.Sqlite.Operations as Ops +import qualified U.Codebase.Sqlite.Queries as Q +import qualified Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers as Helpers +import qualified Unison.Debug as Debug +import Unison.Hash (Hash) +import Unison.Prelude +import qualified Unison.Sqlite as Sqlite +import Unison.Util.Monoid (foldMapM) +import Prelude hiding (log) + +debugLog :: TL.Text -> Sqlite.Transaction () +debugLog msg = Debug.whenDebug Debug.Integrity $ logInfo msg + +logInfo :: TL.Text -> Sqlite.Transaction () +logInfo msg = Sqlite.unsafeIO $ TL.putStrLn msg + +logError :: TL.Text -> Sqlite.Transaction () +logError msg = logInfo $ " โš ๏ธ " <> msg + +data IntegrityResult = IntegrityErrorDetected | NoIntegrityErrors + deriving (Show, Eq) + +instance Semigroup IntegrityResult where + IntegrityErrorDetected <> _ = IntegrityErrorDetected + _ <> IntegrityErrorDetected = IntegrityErrorDetected + NoIntegrityErrors <> NoIntegrityErrors = NoIntegrityErrors + +instance Monoid IntegrityResult where + mempty = NoIntegrityErrors + +integrityCheckAllHashObjects :: Sqlite.Transaction IntegrityResult +integrityCheckAllHashObjects = do + logInfo "Checking Hash Object Integrity..." + Sqlite.queryOneCol_ anyObjectsWithoutHashObjectsSQL >>= \case + True -> do + failure $ "Detected Objects without any hash_object." + pure IntegrityErrorDetected + False -> do + pure NoIntegrityErrors + where + anyObjectsWithoutHashObjectsSQL = + [here| + -- Returns a boolean indicating whether any objects are missing a hash_object. + SELECT EXISTS ( + SELECT 1 FROM object AS o WHERE NOT EXISTS (SELECT 1 FROM hash_object as ho WHERE ho.object_id = o.id) + ) + |] + +-- | Performs a bevy of checks on causals. +integrityCheckAllCausals :: Sqlite.Transaction IntegrityResult +integrityCheckAllCausals = do + logInfo "Checking Causal Integrity..." + + branchObjIntegrity <- + Sqlite.queryListRow_ @(DB.CausalHashId, DB.BranchHashId) causalsWithMissingBranchObjects >>= \case + [] -> pure NoIntegrityErrors + badCausals -> do + logError $ "Detected " <> pShow (length badCausals) <> " causals with missing branch objects." + debugLog . pShow $ badCausals + pure IntegrityErrorDetected + + differingBranchHashIntegrity <- + Sqlite.queryOneCol_ @Bool anyCausalsWithMatchingValueHashAndSelfHash + <&> \case + False -> NoIntegrityErrors + True -> IntegrityErrorDetected + pure (branchObjIntegrity <> differingBranchHashIntegrity) + where + causalsWithMissingBranchObjects :: Sqlite.Sql + causalsWithMissingBranchObjects = + [here| + SELECT c.self_hash_id, c.value_hash_id + FROM causal c + WHERE NOT EXISTS (SELECT 1 from object o WHERE o.primary_hash_id = c.value_hash_id); + |] + anyCausalsWithMatchingValueHashAndSelfHash :: Sqlite.Sql + anyCausalsWithMatchingValueHashAndSelfHash = + [here| + SELECT EXISTS + (SELECT 1 FROM causal WHERE self_hash_id = value_hash_id + ) + |] + +-- | Performs a bevy of checks on branch objects and their relation to causals. +integrityCheckAllBranches :: Sqlite.Transaction IntegrityResult +integrityCheckAllBranches = do + logInfo "Checking Namespace Integrity..." + branchObjIds <- Sqlite.queryListCol_ allBranchObjectIdsSql + flip foldMapM branchObjIds integrityCheckBranch + where + allBranchObjectIdsSql :: Sqlite.Sql + allBranchObjectIdsSql = + [here| + SELECT id FROM object WHERE type_id = 2; + |] + + doesCausalExistForCausalHashId :: Sqlite.Sql + doesCausalExistForCausalHashId = + [here| + SELECT EXISTS (SELECT 1 FROM causal WHERE self_hash_id = ?) + |] + + integrityCheckBranch :: DB.BranchObjectId -> Sqlite.Transaction IntegrityResult + integrityCheckBranch objId = do + dbBranch <- Ops.expectDbBranch objId + expectedBranchHash <- Helpers.dbBranchHash dbBranch + actualBranchHash <- Q.expectPrimaryHashByObjectId (DB.unBranchObjectId objId) + branchHashCheck <- assertExpectedBranchHash expectedBranchHash actualBranchHash + branchChildChecks <- flip foldMapM (toListOf DBBranch.childrenHashes_ dbBranch) $ \(childObjId, childCausalHashId) -> do + let checks = + [ assertBranchObjExists childObjId, + assertCausalExists childCausalHashId, + assertCausalValueMatchesObject childCausalHashId childObjId + ] + fold <$> sequenceA checks + pure $ branchHashCheck <> branchChildChecks + where + assertExpectedBranchHash :: Hash -> Hash -> Sqlite.Transaction IntegrityResult + assertExpectedBranchHash expectedBranchHash actualBranchHash = do + if (expectedBranchHash /= actualBranchHash) + then do + failure $ "Expected hash for namespace doesn't match actual hash for namespace: " <> pShow (expectedBranchHash, actualBranchHash) + pure IntegrityErrorDetected + else do + pure NoIntegrityErrors + + assertBranchObjExists branchObjId = do + Q.loadNamespaceObject @Void (DB.unBranchObjectId branchObjId) (const $ Right ()) >>= \case + Just _ -> pure NoIntegrityErrors + Nothing -> do + failure $ "Expected namespace object for object ID: " <> pShow branchObjId + pure IntegrityErrorDetected + assertCausalExists causalHashId = do + Sqlite.queryOneCol doesCausalExistForCausalHashId (Sqlite.Only causalHashId) >>= \case + True -> pure NoIntegrityErrors + False -> do + failure $ "Expected causal for causal hash ID, but none was found: " <> pShow causalHashId + pure IntegrityErrorDetected + assertCausalValueMatchesObject causalHashId branchObjId = do + -- Assert the object for the causal hash ID matches the given object Id. + Q.loadBranchObjectIdByCausalHashId causalHashId >>= \case + Nothing -> do + failure $ "Expected branch object for causal hash ID: " <> pShow causalHashId + pure IntegrityErrorDetected + Just foundBranchId + | foundBranchId /= branchObjId -> do + failure $ "Expected child branch object to match canonical object ID for causal hash's namespace: " <> pShow (causalHashId, foundBranchId, branchObjId) + pure IntegrityErrorDetected + | otherwise -> pure NoIntegrityErrors + +failure :: TL.Text -> Sqlite.Transaction () +failure msg = do + logError msg + +-- | Performs all available integrity checks. +integrityCheckFullCodebase :: Sqlite.Transaction IntegrityResult +integrityCheckFullCodebase = do + fmap fold . sequenceA $ + [ integrityCheckAllHashObjects, + integrityCheckAllBranches, + integrityCheckAllCausals + ] diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 10182e20cb..f2d2c88378 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -274,7 +274,7 @@ sqliteCodebase debugName root localOrRemote action = do Sqlite.runTransaction conn do CodebaseOps.putRootBranch rootBranchCache (Branch.transform (Sqlite.unsafeIO . runInIO) branch1) - rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.Hash)) + rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.CausalHash)) rootBranchUpdates _rootBranchCache = do -- branchHeadChanges <- TQueue.newIO -- (cancelWatch, watcher) <- Watch.watchDirectory' (v2dir root) @@ -300,7 +300,7 @@ sqliteCodebase debugName root localOrRemote action = do -- -- case hashFromFilePath filePath of -- -- Nothing -> failWith $ CantParseBranchHead filePath -- -- Just h -> - -- -- atomically . TQueue.enqueue branchHeadChanges $ Branch.Hash h + -- -- atomically . TQueue.enqueue branchHeadChanges $ Branch.CausalHash h -- -- smooth out intermediate queue -- pure -- ( cancelWatch >> killThread watcher1 @@ -315,7 +315,7 @@ sqliteCodebase debugName root localOrRemote action = do -- if this blows up on cromulent hashes, then switch from `hashToHashId` -- to one that returns Maybe. - getBranchForHash :: Branch.Hash -> m (Maybe (Branch m)) + getBranchForHash :: Branch.CausalHash -> m (Maybe (Branch m)) getBranchForHash h = Sqlite.runReadOnlyTransaction conn \run -> fmap (Branch.transform run) <$> run (CodebaseOps.getBranchForHash getDeclType h) @@ -325,7 +325,7 @@ sqliteCodebase debugName root localOrRemote action = do withRunInIO \runInIO -> Sqlite.runTransaction conn (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch)) - isCausalHash :: Branch.Hash -> m Bool + isCausalHash :: Branch.CausalHash -> m Bool isCausalHash h = Sqlite.runTransaction conn (CodebaseOps.isCausalHash h) @@ -382,7 +382,7 @@ sqliteCodebase debugName root localOrRemote action = do clearWatches = Sqlite.runTransaction conn CodebaseOps.clearWatches - getReflog :: m [Reflog.Entry Branch.Hash] + getReflog :: m [Reflog.Entry Branch.CausalHash] getReflog = liftIO $ ( do @@ -436,11 +436,11 @@ sqliteCodebase debugName root localOrRemote action = do referentsByPrefix sh = Sqlite.runTransaction conn (CodebaseOps.referentsByPrefix getDeclType sh) - branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.Hash) + branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.CausalHash) branchHashesByPrefix sh = Sqlite.runTransaction conn (CodebaseOps.branchHashesByPrefix sh) - sqlLca :: Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash) + sqlLca :: Branch.CausalHash -> Branch.CausalHash -> m (Maybe (Branch.CausalHash)) sqlLca h1 h2 = Sqlite.runTransaction conn (CodebaseOps.sqlLca h1 h2) let codebase = @@ -549,7 +549,7 @@ syncInternal progress runSrc runDest b = time "syncInternal" do processBranches rest do when debugProcessBranches $ traceM $ " " ++ show b0 ++ " doesn't exist in dest db" - let h2 = CausalHash . Cv.hash1to2 $ Causal.unRawHash h + let h2 = CausalHash . Cv.hash1to2 $ Causal.unCausalHash h runSrc (Q.loadCausalHashIdByCausalHash h2) >>= \case Just chId -> do when debugProcessBranches $ traceM $ " " ++ show b0 ++ " exists in source db, so delegating to direct sync" @@ -587,7 +587,7 @@ syncInternal progress runSrc runDest b = time "syncInternal" do time "SyncInternal.processBranches" $ processBranches [B bHash (pure b)] data Entity m - = B Branch.Hash (m (Branch m)) + = B Branch.CausalHash (m (Branch m)) | O Hash instance Show (Entity m) where @@ -783,7 +783,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift case codebaseStatus of ExistingCodebase -> do -- the call to runDB "handles" the possible DB error by bombing - maybeOldRootHash <- fmap Cv.branchHash2to1 <$> run Ops.loadRootCausalHash + maybeOldRootHash <- fmap Cv.causalHash2to1 <$> run Ops.loadRootCausalHash case maybeOldRootHash of Nothing -> run (setRepoRoot newBranchHash) Just oldRootHash -> do @@ -802,7 +802,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift CreatedCodebase -> pure () run (setRepoRoot newBranchHash) repoString = Text.unpack $ printWriteRepo repo - setRepoRoot :: Branch.Hash -> Sqlite.Transaction () + setRepoRoot :: Branch.CausalHash -> Sqlite.Transaction () setRepoRoot h = do let h2 = Cv.causalHash1to2 h err = error $ "Called SqliteCodebase.setNamespaceRoot on unknown causal hash " ++ show h2 diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Branch/Dependencies.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Branch/Dependencies.hs index d7be9d940c..8eb722fefa 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Branch/Dependencies.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Branch/Dependencies.hs @@ -12,8 +12,7 @@ import Data.Monoid.Generic (GenericMonoid (..), GenericSemigroup (..)) import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) -import Unison.Codebase.Branch (Branch (Branch), Branch0, EditHash) -import qualified Unison.Codebase.Branch as Branch +import Unison.Codebase.Branch.Type as Branch import qualified Unison.Codebase.Causal as Causal import Unison.Codebase.Patch (Patch) import Unison.ConstructorReference (GConstructorReference (..)) @@ -25,7 +24,7 @@ import qualified Unison.Referent as Referent import qualified Unison.Util.Relation as R import qualified Unison.Util.Star3 as Star3 -type Branches m = [(Branch.Hash, m (Branch m))] +type Branches m = [(Branch.CausalHash, m (Branch m))] data Dependencies = Dependencies { patches :: Set EditHash, @@ -52,9 +51,9 @@ to' Dependencies {..} = Dependencies' (toList patches) (toList terms) (toList de fromBranch :: Applicative m => Branch m -> (Branches m, Dependencies) fromBranch (Branch c) = case c of - Causal.One _hh e -> fromBranch0 e - Causal.Cons _hh e (h, m) -> fromBranch0 e <> fromTails (Map.singleton h m) - Causal.Merge _hh e tails -> fromBranch0 e <> fromTails tails + Causal.One _hh _eh e -> fromBranch0 e + Causal.Cons _hh _eh e (h, m) -> fromBranch0 e <> fromTails (Map.singleton h m) + Causal.Merge _hh _eh e tails -> fromBranch0 e <> fromTails tails where fromTails m = ([(h, Branch <$> mc) | (h, mc) <- Map.toList m], mempty) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs index 33972f6899..1a9f9adfda 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs @@ -291,11 +291,11 @@ rreferenceid1to2 h (V1.Reference.Id h' i) = V2.Reference.Id oh i hash1to2 :: Hash -> V2.Hash hash1to2 (V1.Hash bs) = V2.Hash.Hash bs -branchHash1to2 :: V1.Branch.Hash -> V2.CausalHash -branchHash1to2 = V2.CausalHash . hash1to2 . V1.Causal.unRawHash +branchHash1to2 :: V1.Branch.NamespaceHash m -> V2.BranchHash +branchHash1to2 = V2.BranchHash . hash1to2 . V1.genericHash -branchHash2to1 :: V2.CausalHash -> V1.Branch.Hash -branchHash2to1 = V1.Causal.RawHash . hash2to1 . V2.unCausalHash +branchHash2to1 :: forall m. V2.BranchHash -> V1.Branch.NamespaceHash m +branchHash2to1 = V1.HashFor . hash2to1 . V2.unBranchHash patchHash1to2 :: V1.Branch.EditHash -> V2.PatchHash patchHash1to2 = V2.PatchHash . hash1to2 @@ -357,11 +357,11 @@ constructorType2to1 = \case hash2to1 :: V2.Hash.Hash -> Hash hash2to1 (V2.Hash.Hash sbs) = V1.Hash sbs -causalHash2to1 :: V2.CausalHash -> V1.Causal.RawHash V1.Branch.Raw -causalHash2to1 = V1.Causal.RawHash . hash2to1 . V2.unCausalHash +causalHash2to1 :: V2.CausalHash -> V1.Branch.CausalHash +causalHash2to1 = V1.Causal.CausalHash . hash2to1 . V2.unCausalHash -causalHash1to2 :: V1.Causal.RawHash V1.Branch.Raw -> V2.CausalHash -causalHash1to2 = V2.CausalHash . hash1to2 . V1.Causal.unRawHash +causalHash1to2 :: V1.Branch.CausalHash -> V2.CausalHash +causalHash1to2 = V2.CausalHash . hash1to2 . V1.Causal.unCausalHash ttype2to1 :: V2.Term.Type V2.Symbol -> V1.Type.Type V1.Symbol Ann ttype2to1 = type2to1' reference2to1 @@ -424,40 +424,30 @@ causalbranch2to1 :: Monad m => (V2.Reference -> m CT.ConstructorType) -> V2.Bran causalbranch2to1 lookupCT = fmap V1.Branch.Branch . causalbranch2to1' lookupCT causalbranch2to1' :: Monad m => (V2.Reference -> m CT.ConstructorType) -> V2.Branch.CausalBranch m -> m (V1.Branch.UnwrappedBranch m) -causalbranch2to1' lookupCT (V2.Causal hc _he (Map.toList -> parents) me) = do +causalbranch2to1' lookupCT (V2.Causal hc eh (Map.toList -> parents) me) = do let currentHash = causalHash2to1 hc + branchHash = branchHash2to1 eh case parents of - [] -> V1.Causal.UnsafeOne currentHash <$> (me >>= branch2to1 lookupCT) + [] -> V1.Causal.UnsafeOne currentHash branchHash <$> (me >>= branch2to1 lookupCT) [(hp, mp)] -> do let parentHash = causalHash2to1 hp - V1.Causal.UnsafeCons currentHash + V1.Causal.UnsafeCons currentHash branchHash <$> (me >>= branch2to1 lookupCT) <*> pure (parentHash, causalbranch2to1' lookupCT =<< mp) merge -> do let tailsList = map (bimap causalHash2to1 (causalbranch2to1' lookupCT =<<)) merge e <- me - V1.Causal.UnsafeMerge currentHash <$> branch2to1 lookupCT e <*> pure (Map.fromList tailsList) + V1.Causal.UnsafeMerge currentHash branchHash <$> branch2to1 lookupCT e <*> pure (Map.fromList tailsList) causalbranch1to2 :: forall m. Monad m => V1.Branch.Branch m -> V2.Branch.CausalBranch m -causalbranch1to2 (V1.Branch.Branch c) = causal1to2' hash1to2cb hash1to2c branch1to2 c +causalbranch1to2 (V1.Branch.Branch c) = + causal1to2 causalHash1to2 branchHash1to2 branch1to2 c where - hash1to2cb :: V1.Branch.Hash -> (V2.CausalHash, V2.BranchHash) - hash1to2cb (V1.Causal.RawHash h) = (hc, hb) - where - h2 = hash1to2 h - hc = V2.CausalHash h2 - hb = V2.BranchHash h2 - - hash1to2c :: V1.Branch.Hash -> V2.CausalHash - hash1to2c = V2.CausalHash . hash1to2 . V1.Causal.unRawHash - - causal1to2' = causal1to2 @m @V1.Branch.Raw @V2.CausalHash @V2.BranchHash @(V1.Branch.Branch0 m) @(V2.Branch.Branch m) - - causal1to2 :: forall m h h2c h2e e e2. (Monad m, Ord h2c) => (V1.Causal.RawHash h -> (h2c, h2e)) -> (V1.Causal.RawHash h -> h2c) -> (e -> m e2) -> V1.Causal.Causal m h e -> V2.Causal m h2c h2e e2 - causal1to2 h1to22 h1to2 e1to2 = \case - V1.Causal.One (h1to22 -> (hc, hb)) e -> V2.Causal hc hb Map.empty (e1to2 e) - V1.Causal.Cons (h1to22 -> (hc, hb)) e (ht, mt) -> V2.Causal hc hb (Map.singleton (h1to2 ht) (causal1to2 h1to22 h1to2 e1to2 <$> mt)) (e1to2 e) - V1.Causal.Merge (h1to22 -> (hc, hb)) e parents -> V2.Causal hc hb (Map.bimap h1to2 (causal1to2 h1to22 h1to2 e1to2 <$>) parents) (e1to2 e) + causal1to2 :: forall m h2c h2e e e2. (Monad m, Ord h2c) => (V1.Causal.CausalHash -> h2c) -> (V1.HashFor e -> h2e) -> (e -> m e2) -> V1.Causal.Causal m e -> V2.Causal m h2c h2e e2 + causal1to2 h1to2 eh1to2 e1to2 = \case + V1.Causal.One hc eh e -> V2.Causal (h1to2 hc) (eh1to2 eh) Map.empty (e1to2 e) + V1.Causal.Cons hc eh e (ht, mt) -> V2.Causal (h1to2 hc) (eh1to2 eh) (Map.singleton (h1to2 ht) (causal1to2 h1to2 eh1to2 e1to2 <$> mt)) (e1to2 e) + V1.Causal.Merge hc eh e parents -> V2.Causal (h1to2 hc) (eh1to2 eh) (Map.bimap h1to2 (causal1to2 h1to2 eh1to2 e1to2 <$>) parents) (e1to2 e) -- todo: this could be a pure function branch1to2 :: forall m. Monad m => V1.Branch.Branch0 m -> m (V2.Branch.Branch m) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index 2e8e9e3611..737d27fb97 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -12,8 +12,11 @@ import qualified U.Codebase.Sqlite.Queries as Q import Unison.Codebase (CodebasePath) import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (OpenCodebaseUnknownSchemaVersion)) import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase +import Unison.Codebase.IntegrityCheck (IntegrityResult (..), integrityCheckAllBranches, integrityCheckAllCausals) +import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3 (migrateSchema2To3) +import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4) import qualified Unison.Codebase.SqliteCodebase.Operations as Ops2 import Unison.Codebase.SqliteCodebase.Paths import Unison.Codebase.Type (LocalOrRemote (..)) @@ -36,7 +39,8 @@ migrations :: migrations getDeclType termBuffer declBuffer = Map.fromList [ (2, migrateSchema1To2 getDeclType termBuffer declBuffer), - (3, migrateSchema2To3) + (3, migrateSchema2To3), + (4, migrateSchema3To4) ] -- | Migrates a codebase up to the most recent version known to ucm. @@ -68,12 +72,27 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer co for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do putStrLn $ "๐Ÿ”จ Migrating codebase to version " <> show v <> "..." run migration - pure (not (null migrationsToRun)) + let ranMigrations = not (null migrationsToRun) + when ranMigrations $ do + putStrLn $ "๐Ÿ•ต๏ธ Checking codebase integrity..." + run do + result <- + fmap fold . sequenceA $ + [ -- Ideally we'd check everything here, but certain codebases are known to have objects + -- with missing Hash Objects, we'll want to clean that up in a future migration. + -- integrityCheckAllHashObjects, + integrityCheckAllBranches, + integrityCheckAllCausals + ] + case result of + NoIntegrityErrors -> pure () + IntegrityErrorDetected -> abortMigration "Codebase integrity error detected." + pure ranMigrations when ranMigrations do -- Vacuum once now that any migrations have taken place. putStrLn $ "Cleaning up..." Sqlite.Connection.vacuum conn - putStrLn $ "๐Ÿ Migration complete. ๐Ÿ" + putStrLn $ "๐Ÿ Migration complete ๐Ÿ" -- | Copy the sqlite database to a new file with a unique name based on current time. backupCodebase :: CodebasePath -> IO () diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/Helpers.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/Helpers.hs new file mode 100644 index 0000000000..65774ff7ef --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/Helpers.hs @@ -0,0 +1,14 @@ +module Unison.Codebase.SqliteCodebase.Migrations.Helpers where + +import qualified Unison.Sqlite as Sqlite + +abortMigration :: String -> Sqlite.Transaction a +abortMigration msg = do + error $ + unlines + [ "โš ๏ธ " <> msg, + "", + "An unrecoverable error occurred, the migration has been aborted.", + "Please report this bug to https://github.com/unisonweb/unison/issues and include your migration output.", + "Downgrading to the previous UCM version will allow you to continue using your codebase while we investigate your issue." + ] diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs new file mode 100644 index 0000000000..f67d45f291 --- /dev/null +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs @@ -0,0 +1,341 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE QuasiQuotes #-} + +module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 (migrateSchema3To4) where + +import Control.Lens +import Control.Monad.Except +import Control.Monad.State +import Data.Generics.Product +import qualified Data.Map as Map +import Data.Semigroup +import qualified Data.Set as Set +import Data.Set.Lens (setOf) +import Data.String.Here.Uninterpolated (here) +import qualified U.Codebase.HashTags as H +import qualified U.Codebase.Sqlite.Branch.Format as S.BranchFormat +import qualified U.Codebase.Sqlite.Branch.Full as DBBranch +import qualified U.Codebase.Sqlite.DbId as DB +import qualified U.Codebase.Sqlite.LocalizeObject as S.LocalizeObject +import qualified U.Codebase.Sqlite.Operations as Ops +import qualified U.Codebase.Sqlite.Queries as Q +import qualified U.Codebase.Sqlite.Serialization as S +import qualified U.Codebase.Sync as Sync +import qualified U.Util.Serialization as S +import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration) +import qualified Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers as Helpers +import qualified Unison.Debug as Debug +import Unison.Prelude +import qualified Unison.Sqlite as Sqlite +import Prelude hiding (log) + +data MigrationState = MigrationState + { -- A mapping from a causal hash to the _corrected_ and _canonicalized_ branch hash and + -- object. + _canonicalBranchForCausalHashId :: Map DB.CausalHashId (DB.BranchHashId, DB.BranchObjectId), + -- A mapping of branch hashes which were found to be correct and don't need to be + -- re-hashed/re-canonicalized, it allows us to skip some redundant work. + _validBranchHashIds :: Map DB.BranchHashId DB.BranchObjectId, + _numMigrated :: Int + } + deriving (Generic) + +canonicalBranchForCausalHashId :: Lens' MigrationState (Map DB.CausalHashId (DB.BranchHashId, DB.BranchObjectId)) +canonicalBranchForCausalHashId = + field @"_canonicalBranchForCausalHashId" + +validBranchHashIds :: Lens' MigrationState (Map DB.BranchHashId DB.BranchObjectId) +validBranchHashIds = + field @"_validBranchHashIds" + +numMigrated :: Lens' MigrationState Int +numMigrated = + field @"_numMigrated" + +-- | There was a bug in previous versions of UCM which incorrectly used causal hashes as branch hashes. +-- This remained undetected because there was never a need for this hash to be verifiable, +-- and the hashes were still unique because the namespace hash was PART of the causal hash. +-- It did however result in many identical branches being stored multiple times under +-- different `primary_hash_id`s. +-- +-- However, with the advent of Share and Sync, we now need to correctly verify these namespace +-- hashes. +-- +-- This migration fixes the issue by re-hashing namespace objects where the value_hash_id of a +-- causal matches the self_hash_id. +-- Luckily this doesn't change any causal hashes. +-- +-- However, due to the possibility of multiple identical objects stored under different +-- `primary_hash_id`s, we may now have multiple objects with the same `primary_hash_id`, which +-- our DB schema doesn't allow. +-- +-- To address this, we keep exactly one 'canonical' object for each hash, then remap all +-- references to old objects into this canonical object instead. Unfortunately this requires +-- mapping over every branch object and traversing the child references. +-- +-- It was also discovered that some developers had many branches which referenced objects +-- which weren't in their codebase. We're not yet sure how this happened, but it's unlikely +-- to be the case for most end users, and it turned out that these references were in causals +-- and branches which were unreachable from the root namespace. As a fix, this migration also +-- tracks every causal and branch which is reachable from the root namespace and deletes all +-- causals and namespaces which are unreachable. Note that this may orphan some definitions, +-- patches, etc. which were previously referenced in an 'unreachable' branch, but they were +-- already floating around in an unreachable state. +migrateSchema3To4 :: Sqlite.Transaction () +migrateSchema3To4 = do + Q.expectSchemaVersion 3 + rootCausalHashId <- Q.expectNamespaceRoot + totalCausals <- causalCount + migrationState <- flip execStateT (MigrationState mempty mempty 0) $ Sync.sync migrationSync (migrationProgress totalCausals) [rootCausalHashId] + let MigrationState {_canonicalBranchForCausalHashId = mapping} = migrationState + let reachableCausalHashes = Map.keysSet mapping + let reachableBranchObjIds = setOf (traversed . _2) mapping + log $ "๐Ÿ›  Cleaning up unreachable branches and causals..." + dropUnreachableCausalsAndBranches reachableCausalHashes reachableBranchObjIds + Q.setSchemaVersion 4 + where + causalCount :: Sqlite.Transaction Int + causalCount = do + Sqlite.queryOneCol_ + [here| + SELECT count(*) FROM causal; + |] + +migrationProgress :: Int -> Sync.Progress (StateT MigrationState Sqlite.Transaction) DB.CausalHashId +migrationProgress totalCausals = + Sync.Progress {Sync.need, Sync.done, Sync.error, Sync.allDone} + where + need e = lift $ debugLog $ "Need " <> show e + done _ = + do + numDone <- numMigrated <+= 1 + lift $ Sqlite.unsafeIO $ putStr $ "\r๐Ÿ— " <> show numDone <> " / ~" <> show totalCausals <> " entities migrated. ๐Ÿšง" + error e = lift . log $ "Error " <> show e + allDone = do + -- In some corrupted codebases we don't necessarily process every causal, or there may + -- be unreachable causals. We'll show the final number here just so everything looks + -- good to users. It's okay since we'll process the other branches and clean them up in + -- a batch step. + lift $ Sqlite.unsafeIO $ putStrLn $ "\r๐Ÿ— " <> show totalCausals <> " / ~" <> show totalCausals <> " entities migrated. ๐Ÿšง" + lift . Sqlite.unsafeIO . putStrLn $ "Finished." + +migrationSync :: Sync.Sync (StateT MigrationState Sqlite.Transaction) DB.CausalHashId +migrationSync = + Sync.Sync \e -> do + (runExceptT $ migrateCausal e) >>= \case + Left syncResult -> pure syncResult + Right _ -> pure Sync.Done + +liftT :: Sqlite.Transaction a -> ExceptT (Sync.TrySyncResult DB.CausalHashId) (StateT MigrationState Sqlite.Transaction) a +liftT = lift . lift + +dropUnreachableCausalsAndBranches :: Set DB.CausalHashId -> Set DB.BranchObjectId -> Sqlite.Transaction () +dropUnreachableCausalsAndBranches reachableCausals reachableBranchObjs = do + createReachabilityTables + Sqlite.executeMany insertReachableCausalSql (Sqlite.Only <$> Set.toList reachableCausals) + Sqlite.executeMany insertReachableBranchObjectSql (Sqlite.Only <$> Set.toList reachableBranchObjs) + Sqlite.execute_ deleteUnreachableHashObjects + Sqlite.execute_ deleteUnreachableBranchObjects + Sqlite.execute_ deleteUnreachableCausalParents + Sqlite.execute_ deleteUnreachableCausals + where + deleteUnreachableHashObjects = + [here| + DELETE FROM hash_object AS ho + WHERE + NOT EXISTS (SELECT 1 FROM reachable_branch_objects AS ro WHERE ho.object_id = ro.object_id) + -- Ensure hash objects we're deleting are for branch objects. + AND EXISTS (SELECT 1 FROM object AS o WHERE o.id = ho.object_id AND type_id = 2) + |] + deleteUnreachableBranchObjects = + [here| + DELETE FROM object AS o + WHERE + o.type_id = 2 -- Filter for only branches + AND NOT EXISTS (SELECT 1 FROM reachable_branch_objects AS ro WHERE o.id = ro.object_id) + |] + deleteUnreachableCausals = + [here| + DELETE FROM causal AS c + WHERE NOT EXISTS (SELECT 1 FROM reachable_causals AS rc WHERE c.self_hash_id = rc.self_hash_id) + |] + deleteUnreachableCausalParents = + [here| + DELETE FROM causal_parent AS cp + WHERE + -- We only need to check the children, because if it's impossible for a parent to be + -- unreachable if the child is reachable. A.k.a. reachable(child) =implies> reachable(parent) + NOT EXISTS (SELECT 1 FROM reachable_causals AS rc WHERE cp.causal_id = rc.self_hash_id) + |] + insertReachableCausalSql = + [here| + INSERT INTO reachable_causals (self_hash_id) VALUES (?) + ON CONFLICT DO NOTHING + |] + insertReachableBranchObjectSql = + [here| + INSERT INTO reachable_branch_objects (object_id) VALUES (?) + ON CONFLICT DO NOTHING + |] + createReachabilityTables = do + Sqlite.execute_ + [here| + CREATE TEMP TABLE IF NOT EXISTS reachable_branch_objects ( + object_id INTEGER PRIMARY KEY NOT NULL + ) + |] + Sqlite.execute_ + [here| + CREATE TEMP TABLE IF NOT EXISTS reachable_causals ( + self_hash_id INTEGER PRIMARY KEY NOT NULL + ) + |] + +migrateCausal :: DB.CausalHashId -> ExceptT (Sync.TrySyncResult DB.CausalHashId) (StateT MigrationState Sqlite.Transaction) () +migrateCausal causalHashId = do + preuse (canonicalBranchForCausalHashId . ix causalHashId) >>= \case + Just _ -> throwError Sync.PreviouslyDone + Nothing -> do + causalParents <- liftT $ Q.loadCausalParents causalHashId + unmigratedParents <- flip filterM causalParents $ \parentHashId -> (uses canonicalBranchForCausalHashId (Map.notMember parentHashId)) + when (not . null $ unmigratedParents) $ throwError (Sync.Missing unmigratedParents) + valueHashId <- liftT $ Q.expectCausalValueHashId causalHashId + preuse (validBranchHashIds . ix valueHashId) >>= \case + Nothing -> pure () + Just objId -> do + canonicalBranchForCausalHashId . at causalHashId ?= (valueHashId, objId) + throwError Sync.Done + liftT (Q.loadBranchObjectIdByCausalHashId causalHashId) >>= \case + Nothing -> do + liftT . abortMigration $ "Missing object for child branch of causal: " <> show causalHashId + Just branchObjId -> do + rehashAndCanonicalizeNamespace causalHashId valueHashId branchObjId + +rehashAndCanonicalizeNamespace :: DB.CausalHashId -> DB.BranchHashId -> DB.BranchObjectId -> ExceptT (Sync.TrySyncResult DB.CausalHashId) (StateT MigrationState Sqlite.Transaction) () +rehashAndCanonicalizeNamespace causalHashId possiblyIncorrectNamespaceHashId objId = do + dbBranch <- liftT $ Ops.expectDbBranch objId + canonicalBranchForCausalMap <- use canonicalBranchForCausalHashId + -- remap all of the object ID's of the child branches to the correct and canonical objects, + -- get a list of any unmigrated children, and also track whether any re-mappings actually + -- occurred, so we don't do extra work when nothing changed. + let ((unmigratedChildren, Any changes), remappedBranch) = + dbBranch & DBBranch.childrenHashes_ %%~ \(ids@(childBranchObjId, childCausalHashId)) -> do + case Map.lookup childCausalHashId canonicalBranchForCausalMap of + Nothing -> (([childCausalHashId], Any False), ids) + Just (_, canonicalObjId) -> + let changed = canonicalObjId /= childBranchObjId + in (([], Any changed), (canonicalObjId, childCausalHashId)) + when (not . null $ unmigratedChildren) $ throwError (Sync.Missing unmigratedChildren) + when changes $ do + liftT $ replaceBranch objId remappedBranch + correctNamespaceHash <- liftT $ Helpers.dbBranchHash remappedBranch + liftT . debugLog $ "Correct namespace hash: " <> show correctNamespaceHash + correctNamespaceHashId <- liftT $ Q.saveBranchHash (H.BranchHash correctNamespaceHash) + + when (correctNamespaceHashId == possiblyIncorrectNamespaceHashId) $ do + -- If the existing hash for this namespace was already correct, we don't need to + -- canonicalize the branch or worry about deleting/updating bad objects. + -- We just record the mapping and move on. + canonicalBranchForCausalHashId . at causalHashId ?= (correctNamespaceHashId, objId) + validBranchHashIds . at possiblyIncorrectNamespaceHashId ?= objId + throwError Sync.Done + + -- Update the value_hash_id on the causal to the correct hash for the branch + liftT $ Sqlite.execute updateCausalValueHash (correctNamespaceHashId, possiblyIncorrectNamespaceHashId) + -- It's possible that an object already exists for this new hash + mayCanonical <- getCanonicalObjectForHash correctNamespaceHashId + liftT . debugLog $ "(objId, Canonical object ID):" <> show (objId, mayCanonical) + liftT . debugLog $ "Updating causal value hash (from, to)" <> show (possiblyIncorrectNamespaceHashId, correctNamespaceHashId) + canonicalObjId <- case mayCanonical of + -- If there's an existing canonical object, record the mapping from this object id to + -- that one. + Just canonicalObjectId + | canonicalObjectId /= objId -> do + -- Found an existing but different object with this hash, so the current object is a duplicate and + -- needs to be deleted. + liftT . debugLog $ "Mapping objID: " <> show objId <> " to canonical: " <> show canonicalObjectId + liftT . debugLog $ "Unilaterally deleting: " <> show objId + -- Remove possible foreign-key references before deleting the objects themselves + liftT $ Sqlite.execute deleteHashObjectsByObjectId (Sqlite.Only objId) + liftT $ Sqlite.execute deleteObjectById (Sqlite.Only objId) + pure canonicalObjectId + | otherwise -> do + -- This should be impossible. + error $ "We proved that the new hash is different from the existing one, but somehow found the same object for each hash. Please report this as a bug." <> show (objId, canonicalObjectId) + Nothing -> do + -- There's no existing canonical object, this object BECOMES the canonical one by + -- reassigning its primary hash. + liftT . debugLog $ "Updating in place: " <> show objId + liftT $ Sqlite.execute deleteHashObjectsByObjectId (Sqlite.Only objId) + liftT $ Sqlite.execute updateHashIdForObject (correctNamespaceHashId, objId) + liftT $ Q.saveHashObject (DB.unBranchHashId correctNamespaceHashId) (DB.unBranchObjectId objId) 2 + pure objId + -- Save the canonical branch info for the causal for use in remappings. + canonicalBranchForCausalHashId . at causalHashId ?= (correctNamespaceHashId, canonicalObjId) + where + updateCausalValueHash :: Sqlite.Sql + updateCausalValueHash = + [here| + UPDATE causal + SET value_hash_id = ? + WHERE value_hash_id = ? + |] + + getCanonicalObjectForHash :: + DB.BranchHashId -> + ExceptT + (Sync.TrySyncResult DB.CausalHashId) + (StateT MigrationState Sqlite.Transaction) + (Maybe DB.BranchObjectId) + getCanonicalObjectForHash namespaceHashId = + liftT $ Sqlite.queryMaybeCol sql (Sqlite.Only $ DB.unBranchHashId namespaceHashId) + where + sql = + [here| + SELECT id + FROM object + WHERE primary_hash_id = ? + |] + + updateHashIdForObject :: Sqlite.Sql + updateHashIdForObject = + [here| + UPDATE object + SET primary_hash_id = ? + WHERE id = ? + |] + + -- Replace the bytes payload of a given branch in-place. + -- This does NOT update the hash of the object. + replaceBranch :: DB.BranchObjectId -> DBBranch.DbBranch -> Sqlite.Transaction () + replaceBranch objId branch = do + let (localBranchIds, localBranch) = S.LocalizeObject.localizeBranch branch + let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full localBranchIds localBranch + Sqlite.execute sql (bytes, objId) + where + sql = + [here| + UPDATE object + SET bytes = ? + WHERE id = ? + |] + + deleteHashObjectsByObjectId :: Sqlite.Sql + deleteHashObjectsByObjectId = + [here| + DELETE FROM hash_object + WHERE object_id = ? + |] + + deleteObjectById :: Sqlite.Sql + deleteObjectById = + [here| + DELETE FROM object + WHERE id = ? + |] + +log :: String -> Sqlite.Transaction () +log = Sqlite.unsafeIO . putStrLn + +debugLog :: String -> Sqlite.Transaction () +debugLog = Debug.whenDebug Debug.Migration . Sqlite.unsafeIO . putStrLn diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index c71059104b..31d0d335f3 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -351,7 +351,7 @@ getRootBranch doGetDeclType rootBranchCache = then pure b else do newRootHash <- Ops.expectRootCausalHash - if Branch.headHash b == Cv.branchHash2to1 newRootHash + if Branch.headHash b == Cv.causalHash2to1 newRootHash then pure b else do traceM $ "database was externally modified (" ++ show v ++ " -> " ++ show v' ++ ")" @@ -381,10 +381,10 @@ putRootBranch rootBranchCache branch1 = do getBranchForHash :: -- | A 'getDeclType'-like lookup, possibly backed by a cache. (C.Reference.Reference -> Transaction CT.ConstructorType) -> - Branch.Hash -> + Branch.CausalHash -> Transaction (Maybe (Branch Transaction)) getBranchForHash doGetDeclType h = do - Ops.loadCausalBranchByCausalHash (Cv.branchHash1to2 h) >>= \case + Ops.loadCausalBranchByCausalHash (Cv.causalHash1to2 h) >>= \case Nothing -> pure Nothing Just causal2 -> do branch1 <- Cv.causalbranch2to1 doGetDeclType causal2 @@ -394,8 +394,8 @@ putBranch :: Branch Transaction -> Transaction () putBranch = void . Ops.saveBranch . Cv.causalbranch1to2 -isCausalHash :: Branch.Hash -> Transaction Bool -isCausalHash (Causal.RawHash h) = +isCausalHash :: Branch.CausalHash -> Transaction Bool +isCausalHash (Causal.CausalHash h) = Q.loadHashIdByHash (Cv.hash1to2 h) >>= \case Nothing -> pure False Just hId -> Q.isCausalHash hId @@ -513,15 +513,15 @@ referentsByPrefix doGetDeclType (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to ] pure . Set.fromList $ termReferents <> declReferents -branchHashesByPrefix :: ShortBranchHash -> Transaction (Set Branch.Hash) +branchHashesByPrefix :: ShortBranchHash -> Transaction (Set Branch.CausalHash) branchHashesByPrefix sh = do -- given that a Branch is shallow, it's really `CausalHash` that you'd -- refer to to specify a full namespace w/ history. -- but do we want to be able to refer to a namespace without its history? cs <- Ops.causalHashesByPrefix (Cv.sbh1to2 sh) - pure $ Set.map (Causal.RawHash . Cv.hash2to1 . unCausalHash) cs + pure $ Set.map (Causal.CausalHash . Cv.hash2to1 . unCausalHash) cs -sqlLca :: Branch.Hash -> Branch.Hash -> Transaction (Maybe Branch.Hash) +sqlLca :: Branch.CausalHash -> Branch.CausalHash -> Transaction (Maybe Branch.CausalHash) sqlLca h1 h2 = do h3 <- Ops.lca (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) pure (Cv.causalHash2to1 <$> h3) @@ -531,7 +531,7 @@ termExists, declExists :: Hash -> Transaction Bool termExists = fmap isJust . Q.loadObjectIdForPrimaryHash . Cv.hash1to2 declExists = termExists -before :: Branch.Hash -> Branch.Hash -> Transaction (Maybe Bool) +before :: Branch.CausalHash -> Branch.CausalHash -> Transaction (Maybe Bool) before h1 h2 = Ops.before (Cv.causalHash1to2 h1) (Cv.causalHash1to2 h2) diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 5558d35b8d..6c7e99dbe7 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -84,16 +84,16 @@ data Codebase m v a = Codebase getRootBranchExists :: m Bool, -- | Like 'putBranch', but also adjusts the root branch pointer afterwards. putRootBranch :: Branch m -> m (), - rootBranchUpdates :: m (IO (), IO (Set Branch.Hash)), + rootBranchUpdates :: m (IO (), IO (Set Branch.CausalHash)), getShallowBranchForHash :: V2.CausalHash -> m (V2.CausalBranch m), - getBranchForHashImpl :: Branch.Hash -> m (Maybe (Branch m)), + getBranchForHashImpl :: Branch.CausalHash -> m (Maybe (Branch m)), -- | Put a branch into the codebase, which includes its children, its patches, and the branch itself, if they don't -- already exist. -- -- The terms and type declarations that a branch references must already exist in the codebase. putBranch :: Branch m -> m (), -- | Check whether the given branch exists in the codebase. - branchExists :: Branch.Hash -> m Bool, + branchExists :: Branch.CausalHash -> m Bool, -- | Get a patch from the codebase. getPatch :: Branch.EditHash -> m (Maybe Patch), -- | Put a patch into the codebase. @@ -132,7 +132,7 @@ data Codebase m v a = Codebase -- | Delete all watches that were put by 'putWatch'. clearWatches :: m (), -- | Get the entire reflog. - getReflog :: m [Reflog.Entry Branch.Hash], + getReflog :: m [Reflog.Entry Branch.CausalHash], -- | @appendReflog reason before after@ appends a reflog entry. -- -- FIXME: this could have type @@ -156,17 +156,17 @@ data Codebase m v a = Codebase -- | The number of base32 characters needed to distinguish any two branch in the codebase. branchHashLength :: m Int, -- | Get the set of branches whose hash matches the given prefix. - branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.Hash), + branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.CausalHash), -- returns `Nothing` to not implemented, fallback to in-memory -- also `Nothing` if no LCA -- The result is undefined if the two hashes are not in the codebase. -- Use `Codebase.lca` which wraps this in a nice API. - lcaImpl :: Maybe (Branch.Hash -> Branch.Hash -> m (Maybe Branch.Hash)), + lcaImpl :: Maybe (Branch.CausalHash -> Branch.CausalHash -> m (Maybe Branch.CausalHash)), -- `beforeImpl` returns `Nothing` if not implemented by the codebase -- `beforeImpl b1 b2` is undefined if `b2` not in the codebase -- -- Use `Codebase.before` which wraps this in a nice API. - beforeImpl :: Maybe (Branch.Hash -> Branch.Hash -> m Bool), + beforeImpl :: Maybe (Branch.CausalHash -> Branch.CausalHash -> m Bool), -- Use the name lookup index to build a 'Names' for all names found within 'Path' of the current root namespace. -- -- NOTE: this method requires an up-to-date name lookup index, which is @@ -191,7 +191,7 @@ data PushGitBranchOpts = PushGitBranchOpts data GitError = GitProtocolError GitProtocolError - | GitCodebaseError (GitCodebaseError Branch.Hash) + | GitCodebaseError (GitCodebaseError Branch.CausalHash) | GitSqliteCodebaseError GitSqliteCodebaseError deriving (Show) diff --git a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs index 29588670a8..184ff626f9 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs @@ -42,7 +42,7 @@ import Unison.Hash (Hash) import qualified Unison.Hashing.V2.Branch as Hashing.Branch import qualified Unison.Hashing.V2.Causal as Hashing.Causal import qualified Unison.Hashing.V2.DataDeclaration as Hashing.DD -import Unison.Hashing.V2.Hashable (Hashable) +import Unison.Hashing.V2.Hashable (HashFor (HashFor), Hashable) import qualified Unison.Hashing.V2.Hashable as Hashable import qualified Unison.Hashing.V2.Kind as Hashing.Kind import qualified Unison.Hashing.V2.Patch as Hashing.Patch @@ -359,10 +359,13 @@ hashPatch = Hashing.Patch.hashPatch . m2hPatch hashBranch0 :: Memory.Branch.Branch0 m -> Hash hashBranch0 = Hashing.Branch.hashBranch . m2hBranch0 -hashCausal :: Hashable e => e -> Set (Memory.Causal.RawHash h) -> Hash +hashCausal :: Hashable e => e -> Set Memory.Causal.CausalHash -> (Memory.Causal.CausalHash, HashFor e) hashCausal e tails = - Hashing.Causal.hashCausal $ - Hashing.Causal.Causal (Hashable.hash e) (Set.map Memory.Causal.unRawHash tails) + let valueHash@(HashFor vh) = (Hashable.hashFor e) + causalHash = + Memory.Causal.CausalHash . Hashing.Causal.hashCausal $ + Hashing.Causal.Causal vh (Set.map Memory.Causal.unCausalHash tails) + in (causalHash, valueHash) m2hBranch0 :: Memory.Branch.Branch0 m -> Hashing.Branch.Raw m2hBranch0 b = @@ -414,7 +417,7 @@ m2hBranch0 b = doChildren :: Map Memory.NameSegment.NameSegment (Memory.Branch.Branch m) -> Map Hashing.Branch.NameSegment Hash - doChildren = Map.bimap m2hNameSegment (Memory.Causal.unRawHash . Memory.Branch.headHash) + doChildren = Map.bimap m2hNameSegment (Memory.Causal.unCausalHash . Memory.Branch.headHash) m2hNameSegment :: Memory.NameSegment.NameSegment -> Hashing.Branch.NameSegment m2hNameSegment (Memory.NameSegment.NameSegment s) = Hashing.Branch.NameSegment s diff --git a/parser-typechecker/src/Unison/Hashing/V2/Hashable.hs b/parser-typechecker/src/Unison/Hashing/V2/Hashable.hs index 13ed364b95..f6ed2ece75 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/Hashable.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/Hashable.hs @@ -1,11 +1,13 @@ module Unison.Hashing.V2.Hashable ( Hashable (..), + hashFor, + HashFor (..), ) where import Data.Int (Int64) import Data.Set (Set) -import Unison.Hash (Hash (..)) +import Unison.Hash (Hash (..), HashFor (..)) import qualified Unison.Hashing.V2.Tokenizable as Tokenizable -- | This typeclass provides a mechanism for obtaining a content-based hash for Unison types & @@ -23,3 +25,6 @@ instance Tokenizable.Tokenizable a => Hashable (Set a) where instance Hashable Int64 where hash = Tokenizable.hashTokenizable + +hashFor :: Hashable t => t -> HashFor t +hashFor = HashFor . hash diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs b/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs index 9227320183..c556aa4048 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs @@ -10,7 +10,6 @@ import qualified Data.Set as Set import EasyTest import Unison.Codebase.Causal (Causal, one) import qualified Unison.Codebase.Causal as Causal -import Unison.Hash (Hash) test :: Test () test = @@ -78,14 +77,14 @@ int64 = random extend :: Int -> - Causal Identity Hash Int64 -> - Test (Causal Identity Hash Int64) + Causal Identity Int64 -> + Test (Causal Identity Int64) extend 0 ca = pure ca extend n ca = do i <- int64 extend (n - 1) (Causal.cons i ca) -lcaPair :: Test (Causal Identity Hash Int64, Causal Identity Hash Int64) +lcaPair :: Test (Causal Identity Int64, Causal Identity Int64) lcaPair = do base <- one <$> int64 ll <- int' 0 20 @@ -101,7 +100,7 @@ lcaPairTest = replicateM_ 50 test >> ok Nothing -> crash "expected lca" noLcaPair :: - Test (Causal Identity Hash Int64, Causal Identity Hash Int64) + Test (Causal Identity Int64, Causal Identity Int64) noLcaPair = do basel <- one <$> int64 baser <- one <$> int64 @@ -117,21 +116,21 @@ noLcaPairTest = replicateM_ 50 test >> ok Nothing -> pure () Just _ -> crash "expected no lca" -oneRemoved :: Causal Identity Hash (Set Int64) +oneRemoved :: Causal Identity (Set Int64) oneRemoved = foldr Causal.cons (one (Set.singleton 1)) (Set.fromList <$> [[2, 3, 4], [1, 2, 3, 4], [1, 2]]) -twoRemoved :: Causal Identity Hash (Set Int64) +twoRemoved :: Causal Identity (Set Int64) twoRemoved = foldr Causal.cons (one (Set.singleton 1)) (Set.fromList <$> [[1, 3, 4], [1, 2, 3], [1, 2]]) -testThreeWay :: Causal Identity Hash (Set Int64) +testThreeWay :: Causal Identity (Set Int64) testThreeWay = runIdentity $ threeWayMerge' oneRemoved twoRemoved @@ -146,7 +145,7 @@ setPatch :: Applicative m => Ord a => Set a -> (Set a, Set a) -> m (Set a) setPatch s (added, removed) = pure (added <> Set.difference s removed) -- merge x x == x, should not add a new head, and also the value at the head should be the same of course -testIdempotent :: Causal Identity Hash (Set Int64) -> Bool -- Causal Identity Hash (Set Int64) +testIdempotent :: Causal Identity (Set Int64) -> Bool -- Causal Identity (Set Int64) testIdempotent causal = runIdentity (threeWayMerge' causal causal) == causal @@ -154,10 +153,10 @@ testIdempotent causal = -- prop_mergeIdempotent :: Bool -- prop_mergeIdempotent = and (map testIdempotent (take 1000 generateRandomCausals)) -oneCausal :: Causal Identity Hash (Set Int64) +oneCausal :: Causal Identity (Set Int64) oneCausal = Causal.one (Set.fromList [1]) --- generateRandomCausals :: Causal Identity Hash (Set Int64) +-- generateRandomCausals :: Causal Identity (Set Int64) -- generateRandomCausals = undefined easyCombine :: @@ -173,22 +172,22 @@ easyCombine _ diff appl (Just ca) l r = do appl ca (dl <> dr) threeWayMerge' :: - Causal Identity Hash (Set Int64) -> - Causal Identity Hash (Set Int64) -> - Identity (Causal Identity Hash (Set Int64)) + Causal Identity (Set Int64) -> + Causal Identity (Set Int64) -> + Identity (Causal Identity (Set Int64)) threeWayMerge' = Causal.threeWayMerge (easyCombine setCombine setDiff setPatch) -- merge x mempty == x, merge mempty x == x -testIdentity :: Causal Identity Hash (Set Int64) -> Causal Identity Hash (Set Int64) -> Bool +testIdentity :: Causal Identity (Set Int64) -> Causal Identity (Set Int64) -> Bool testIdentity causal mempty = (threeWayMerge' causal mempty) == (threeWayMerge' mempty causal) -emptyCausal :: Causal Identity Hash (Set Int64) +emptyCausal :: Causal Identity (Set Int64) emptyCausal = one (Set.empty) -- merge (cons hd tl) tl == cons hd tl, merge tl (cons hd tl) == cons hd tl -testCommutative :: Set Int64 -> Causal Identity Hash (Set Int64) -> Bool +testCommutative :: Set Int64 -> Causal Identity (Set Int64) -> Bool testCommutative hd tl = (threeWayMerge' (Causal.cons hd tl) tl) == (threeWayMerge' tl (Causal.cons hd tl)) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 3c278fcc11..79cc7e7dc0 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -51,6 +51,7 @@ library Unison.Codebase.Init.CreateCodebaseError Unison.Codebase.Init.OpenCodebaseError Unison.Codebase.Init.Type + Unison.Codebase.IntegrityCheck Unison.Codebase.MainTerm Unison.Codebase.Metadata Unison.Codebase.Patch @@ -66,9 +67,11 @@ library Unison.Codebase.SqliteCodebase.Conversions Unison.Codebase.SqliteCodebase.GitError Unison.Codebase.SqliteCodebase.Migrations + Unison.Codebase.SqliteCodebase.Migrations.Helpers Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3 + Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema3To4 Unison.Codebase.SqliteCodebase.Operations Unison.Codebase.SqliteCodebase.Paths Unison.Codebase.SqliteCodebase.SyncEphemeral @@ -227,6 +230,7 @@ library , hashable , hashtables , haskeline + , here , http-client , http-media , http-types @@ -248,6 +252,7 @@ library , optparse-applicative >=0.16.1.0 , pem , prelude-extras + , pretty-simple , primitive , process , random >=1.2.0 @@ -284,6 +289,7 @@ library , unison-sqlite , unison-util , unison-util-relation + , unison-util-serialization , unliftio , uri-encode , utf8-string diff --git a/unison-cli/src/Unison/Codebase/Editor/Command.hs b/unison-cli/src/Unison/Codebase/Editor/Command.hs index 168e377b6e..5a59e8532b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Command.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Command.hs @@ -146,7 +146,7 @@ data TermReferentsByShortHash :: ShortHash -> Command m i v (Set Referent) -- the hash length needed to disambiguate any branch in the codebase BranchHashLength :: Command m i v Int - BranchHashesByPrefix :: ShortBranchHash -> Command m i v (Set Branch.Hash) + BranchHashesByPrefix :: ShortBranchHash -> Command m i v (Set Branch.CausalHash) ParseType :: NamesWithHistory -> LexedSource -> @@ -194,7 +194,7 @@ data -- codebase are copied there. LoadLocalRootBranch :: Command m i v (Branch m) -- Like `LoadLocalRootBranch`. - LoadLocalBranch :: Branch.Hash -> Command m i v (Branch m) + LoadLocalBranch :: Branch.CausalHash -> Command m i v (Branch m) -- Merge two branches, using the codebase for the LCA calculation where possible. Merge :: Branch.MergeMode -> Branch m -> Branch m -> Command m i v (Branch m) ViewRemoteBranch :: @@ -220,7 +220,7 @@ data SyncRemoteBranch :: WriteRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> Command m i v (Either GitError (Either e (Branch m))) AppendToReflog :: Text -> Branch m -> Branch m -> Command m i v () -- load the reflog in file (chronological) order - LoadReflog :: Command m i v [Reflog.Entry Branch.Hash] + LoadReflog :: Command m i v [Reflog.Entry Branch.CausalHash] LoadTerm :: Reference.Id -> Command m i v (Maybe (Term v Ann)) -- LoadTermComponent :: H.Hash -> Command m i v (Maybe [Term v Ann]) LoadTermComponentWithTypes :: H.Hash -> Command m i v (Maybe [(Term v Ann, Type v Ann)]) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 5782308195..8e00808285 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -552,9 +552,9 @@ loop = do -- reverses & formats entries, adds synthetic entries when there is a -- discontinuity in the reflog. convertEntries :: - Maybe Branch.Hash -> + Maybe Branch.CausalHash -> [Output.ReflogEntry] -> - [Reflog.Entry Branch.Hash] -> + [Reflog.Entry Branch.CausalHash] -> [Output.ReflogEntry] convertEntries _ acc [] = acc convertEntries Nothing acc entries@(Reflog.Entry old _ _ : _) = @@ -828,9 +828,9 @@ loop = do else case Branch._history b of Causal.One {} -> respondNumbered $ History diffCap sbhLength acc (EndOfLog $ Branch.headHash b) - Causal.Merge _ _ tails -> + Causal.Merge _ _ _ tails -> respondNumbered $ History diffCap sbhLength acc (MergeTail (Branch.headHash b) $ Map.keys tails) - Causal.Cons _ _ tail -> do + Causal.Cons _ _ _ tail -> do b' <- fmap Branch.Branch . eval . Eval $ snd tail let elem = (Branch.headHash b, Branch.namesDiff b' b) doHistory (n + 1) b' (elem : acc) @@ -1577,15 +1577,15 @@ loop = do let seen h = State.gets (Set.member h) set h = State.modify (Set.insert h) getCausal b = (Branch.headHash b, pure $ Branch._history b) - goCausal :: forall m. Monad m => [(Branch.Hash, m (Branch.UnwrappedBranch m))] -> StateT (Set Branch.Hash) m () + goCausal :: forall m. Monad m => [(Branch.CausalHash, m (Branch.UnwrappedBranch m))] -> StateT (Set Branch.CausalHash) m () goCausal [] = pure () goCausal ((h, mc) : queue) = do ifM (seen h) (goCausal queue) do lift mc >>= \case - Causal.One h b -> goBranch h b mempty queue - Causal.Cons h b tail -> goBranch h b [fst tail] (tail : queue) - Causal.Merge h b (Map.toList -> tails) -> goBranch h b (map fst tails) (tails ++ queue) - goBranch :: forall m. Monad m => Branch.Hash -> Branch0 m -> [Branch.Hash] -> [(Branch.Hash, m (Branch.UnwrappedBranch m))] -> StateT (Set Branch.Hash) m () + Causal.One h _bh b -> goBranch h b mempty queue + Causal.Cons h _bh b tail -> goBranch h b [fst tail] (tail : queue) + Causal.Merge h _bh b (Map.toList -> tails) -> goBranch h b (map fst tails) (tails ++ queue) + goBranch :: forall m. Monad m => Branch.CausalHash -> Branch0 m -> [Branch.CausalHash] -> [(Branch.CausalHash, m (Branch.UnwrappedBranch m))] -> StateT (Set Branch.CausalHash) m () goBranch h b (Set.fromList -> causalParents) queue = case b of Branch0 terms0 types0 children0 patches0 _ _ _ _ _ _ -> let wrangleMetadata :: (Ord r, Ord n) => Metadata.Star r n -> r -> (r, (Set n, Set Metadata.Value)) diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 96bb1effc7..ecc73677f6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -36,7 +36,7 @@ import qualified Unison.Util.Pretty as P data Event = UnisonFileChanged SourceName Source - | IncomingRootBranch (Set Branch.Hash) + | IncomingRootBranch (Set Branch.CausalHash) type Source = Text -- "id x = x\nconst a b = a" diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index ca0251f1e8..b2258d8a8a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -105,7 +105,7 @@ data NumberedOutput v History (Maybe Int) -- Amount of history to print HashLength - [(Branch.Hash, Names.Diff)] + [(Branch.CausalHash, Names.Diff)] HistoryTail -- 'origin point' of this view of history. | ListEdits Patch PPE.PrettyPrintEnv @@ -238,18 +238,18 @@ data Output v Path.Absolute -- The namespace we're checking dependencies for. (Map LabeledDependency (Set Name)) -- Mapping of external dependencies to their local dependents. | DumpNumberedArgs NumberedArgs - | DumpBitBooster Branch.Hash (Map Branch.Hash [Branch.Hash]) + | DumpBitBooster Branch.CausalHash (Map Branch.CausalHash [Branch.CausalHash]) | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] | BadName String | DefaultMetadataNotification - | CouldntLoadBranch Branch.Hash + | CouldntLoadBranch Branch.CausalHash | HelpMessage Input.InputPattern | NamespaceEmpty (NonEmpty AbsBranchId) | NoOp | -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace. RefusedToPush PushBehavior | -- | @GistCreated repo hash@ means causal @hash@ was just published to @repo@. - GistCreated Int WriteRepo Branch.Hash + GistCreated Int WriteRepo Branch.CausalHash | -- | Directs the user to URI to begin an authorization flow. InitiateAuthFlow URI | UnknownCodeServer Text @@ -260,9 +260,9 @@ data ReflogEntry = ReflogEntry {hash :: ShortBranchHash, reason :: Text} deriving (Show) data HistoryTail - = EndOfLog Branch.Hash - | MergeTail Branch.Hash [Branch.Hash] - | PageEnd Branch.Hash Int -- PageEnd nextHash nextIndex + = EndOfLog Branch.CausalHash + | MergeTail Branch.CausalHash [Branch.CausalHash] + | PageEnd Branch.CausalHash Int -- PageEnd nextHash nextIndex deriving (Show) data TestReportStats diff --git a/unison-cli/src/Unison/Codebase/Editor/Output/DumpNamespace.hs b/unison-cli/src/Unison/Codebase/Editor/Output/DumpNamespace.hs index e642392b5a..0e22fa4273 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output/DumpNamespace.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output/DumpNamespace.hs @@ -11,7 +11,7 @@ data DumpNamespace = DumpNamespace { terms :: Map Referent (Set NameSegment, Set Reference), types :: Map Reference (Set NameSegment, Set Reference), patches :: Map NameSegment Branch.EditHash, - children :: Map NameSegment Branch.Hash, - causalParents :: Set Branch.Hash + children :: Map NameSegment Branch.CausalHash, + causalParents :: Set Branch.CausalHash } deriving (Show) diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index 4dc9ca87c6..fb4a5939e3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -27,11 +27,11 @@ defaultBaseLib = fmap makeNS $ latest <|> release makeNS t = ( ReadGitRepo { url = "https://github.com/unisonweb/base", - -- Use the 'v3' branch of base for now. + -- Use the 'v4' branch of base for now. -- We can revert back to the main branch once enough people have upgraded ucm and - -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm + -- we're okay with pushing the v4 base codebase to main (perhaps by the next ucm -- release). - ref = Just "v3" + ref = Just "v4" }, Nothing, Path.fromText t diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index c5675f190d..c42dfee422 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -343,16 +343,16 @@ notifyNumbered o = case o of "", tailMsg ] - branchHashes :: [Branch.Hash] + branchHashes :: [Branch.CausalHash] branchHashes = (fst <$> reversedHistory) <> tailHashes in (msg, displayBranchHash <$> branchHashes) where - toSBH :: Branch.Hash -> ShortBranchHash + toSBH :: Branch.CausalHash -> ShortBranchHash toSBH h = SBH.fromHash sbhLength h reversedHistory = reverse history showNum :: Int -> Pretty showNum n = P.shown n <> ". " - handleTail :: Int -> (Pretty, [Branch.Hash]) + handleTail :: Int -> (Pretty, [Branch.CausalHash]) handleTail n = case tail of E.EndOfLog h -> ( P.lines @@ -1127,7 +1127,7 @@ notifyUser dir o = case o of CouldntLoadRootBranch repo hash -> P.wrap $ "I couldn't load the designated root hash" - <> P.group ("(" <> P.text (Hash.base32Hex $ Causal.unRawHash hash) <> ")") + <> P.group ("(" <> P.text (Hash.base32Hex $ Causal.unCausalHash hash) <> ")") <> "from the repository at" <> prettyReadRepo repo CouldntLoadSyncedBranch ns h -> @@ -1410,10 +1410,10 @@ notifyUser dir o = case o of Nothing -> go (renderLine head [] : output) queue Just tails -> go (renderLine head tails : output) (queue ++ tails) where - renderHash = take 10 . Text.unpack . Hash.base32Hex . Causal.unRawHash + renderHash = take 10 . Text.unpack . Hash.base32Hex . Causal.unCausalHash renderLine head tail = (renderHash head) ++ "|" ++ intercalateMap " " renderHash tail - ++ case Map.lookup (Hash.base32Hex . Causal.unRawHash $ head) tags of + ++ case Map.lookup (Hash.base32Hex . Causal.unCausalHash $ head) tags of Just t -> "|tag: " ++ t Nothing -> "" -- some specific hashes that we want to label in the output @@ -1634,8 +1634,8 @@ prettyAbsolute = P.blue . P.shown prettySBH :: IsString s => ShortBranchHash -> P.Pretty s prettySBH hash = P.group $ "#" <> P.text (SBH.toText hash) -prettyCausalHash :: IsString s => Causal.RawHash x -> P.Pretty s -prettyCausalHash hash = P.group $ "#" <> P.text (Hash.toBase32HexText . Causal.unRawHash $ hash) +prettyCausalHash :: IsString s => Causal.CausalHash -> P.Pretty s +prettyCausalHash hash = P.group $ "#" <> P.text (Hash.toBase32HexText . Causal.unCausalHash $ hash) formatMissingStuff :: (Show tm, Show typ) => @@ -2886,6 +2886,6 @@ endangeredDependentsTable ppeDecl m = & fmap (\(n, dep) -> numArg n <> prettyLabeled fqnEnv dep) & P.lines --- | Displays a full, non-truncated Branch Hash to a string, e.g. #abcdef -displayBranchHash :: Branch.Hash -> String -displayBranchHash = ("#" <>) . Text.unpack . Hash.base32Hex . Causal.unRawHash +-- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef +displayBranchHash :: Branch.CausalHash -> String +displayBranchHash = ("#" <>) . Text.unpack . Hash.base32Hex . Causal.unCausalHash diff --git a/unison-cli/tests/Unison/Test/VersionParser.hs b/unison-cli/tests/Unison/Test/VersionParser.hs index f01218fc80..520fb26f60 100644 --- a/unison-cli/tests/Unison/Test/VersionParser.hs +++ b/unison-cli/tests/Unison/Test/VersionParser.hs @@ -26,8 +26,8 @@ makeTest (version, path) = expectEqual (rightMay $ runParser defaultBaseLib "versionparser" version) ( Just - -- We've hard-coded the v3 branch for base for now. See 'defaultBaseLib' - ( ReadGitRepo "https://github.com/unisonweb/base" (Just "v3"), + -- We've hard-coded the v4 branch for base for now. See 'defaultBaseLib' + ( ReadGitRepo "https://github.com/unisonweb/base" (Just "v4"), Nothing, Path.fromText path ) diff --git a/unison-core/src/Unison/Hash.hs b/unison-core/src/Unison/Hash.hs index 015d02caaa..04c2e65cbc 100644 --- a/unison-core/src/Unison/Hash.hs +++ b/unison-core/src/Unison/Hash.hs @@ -3,6 +3,7 @@ module Unison.Hash ( Hash (Hash), + HashFor (..), base32Hex, fromBase32Hex, Hash.toByteString, @@ -11,7 +12,7 @@ module Unison.Hash where import qualified U.Util.Base32Hex as Base32Hex -import U.Util.Hash (Hash (Hash)) +import U.Util.Hash (Hash (Hash), HashFor (..)) import qualified U.Util.Hash as Hash import Unison.Prelude diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index c5ae69645a..d2de690443 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -119,7 +119,7 @@ data ShallowListEntry v a | ShallowTypeEntry TypeEntry | -- The integer here represents the number of children. -- it may be omitted depending on the context the query is run in. - ShallowBranchEntry NameSegment Branch.Hash (Maybe Int) + ShallowBranchEntry NameSegment Branch.CausalHash (Maybe Int) | ShallowPatchEntry NameSegment deriving (Eq, Ord, Show, Generic) @@ -140,8 +140,8 @@ data BackendError -- ^ namespace | CouldntExpandBranchHash ShortBranchHash | AmbiguousBranchHash ShortBranchHash (Set ShortBranchHash) - | NoBranchForHash Branch.Hash - | CouldntLoadBranch Branch.Hash + | NoBranchForHash Branch.CausalHash + | CouldntLoadBranch Branch.CausalHash | MissingSignatureForTerm Reference data BackendEnv = BackendEnv @@ -765,7 +765,7 @@ data DefinitionResults v = DefinitionResults } expandShortBranchHash :: - Monad m => Codebase m v a -> ShortBranchHash -> Backend m Branch.Hash + Monad m => Codebase m v a -> ShortBranchHash -> Backend m (Branch.CausalHash) expandShortBranchHash codebase hash = do hashSet <- lift $ Codebase.branchHashesByPrefix codebase hash len <- lift $ Codebase.branchHashLength codebase @@ -776,12 +776,12 @@ expandShortBranchHash codebase hash = do throwError . AmbiguousBranchHash hash $ Set.map (SBH.fromHash len) hashSet -- | Efficiently resolve a root hash and path to a shallow branch's causal. -getShallowCausalAtPathFromRootHash :: Monad m => Codebase m v a -> Maybe Branch.Hash -> Path -> Backend m (V2Branch.CausalBranch m) +getShallowCausalAtPathFromRootHash :: Monad m => Codebase m v a -> Maybe (Branch.CausalHash) -> Path -> Backend m (V2Branch.CausalBranch m) getShallowCausalAtPathFromRootHash codebase mayRootHash path = do shallowRoot <- case mayRootHash of Nothing -> lift (Codebase.getShallowRootBranch codebase) Just h -> do - lift $ Codebase.getShallowBranchForHash codebase (Cv.branchHash1to2 h) + lift $ Codebase.getShallowBranchForHash codebase (Cv.causalHash1to2 h) causal <- (lift $ Codebase.shallowBranchAtPath path shallowRoot) >>= \case Nothing -> pure $ Cv.causalbranch1to2 (Branch.empty) @@ -809,7 +809,7 @@ mungeSyntaxText = fmap Syntax.convertElement prettyDefinitionsBySuffixes :: Path -> - Maybe Branch.Hash -> + Maybe (Branch.CausalHash) -> Maybe Width -> Suffixify -> Rt.Runtime Symbol -> @@ -1070,7 +1070,7 @@ bestNameForType ppe width = . TypePrinter.pretty0 @v ppe mempty (-1) . Type.ref () -scopedNamesForBranchHash :: forall m v a. Monad m => Codebase m v a -> Maybe Branch.Hash -> Path -> Backend m (Names, Names) +scopedNamesForBranchHash :: forall m v a. Monad m => Codebase m v a -> Maybe (Branch.CausalHash) -> Path -> Backend m (Names, Names) scopedNamesForBranchHash codebase mbh path = do shouldUseNamesIndex <- asks useNamesIndex case mbh of @@ -1081,18 +1081,18 @@ scopedNamesForBranchHash codebase mbh path = do pure $ prettyAndParseNamesForBranch rootBranch (AllNames path) Just bh -> do rootHash <- lift $ Codebase.getRootBranchHash codebase - if (Causal.unRawHash bh == V2.Hash.unCausalHash rootHash) && shouldUseNamesIndex + if (Causal.unCausalHash bh == V2.Hash.unCausalHash rootHash) && shouldUseNamesIndex then indexPrettyAndParseNames - else flip prettyAndParseNamesForBranch (AllNames path) <$> resolveBranchHash (Just bh) codebase + else flip prettyAndParseNamesForBranch (AllNames path) <$> resolveCausalHash (Just bh) codebase where indexPrettyAndParseNames :: Backend m (Names, Names) indexPrettyAndParseNames = do names <- lift $ Codebase.namesAtPath codebase path pure (ScopedNames.parseNames names, ScopedNames.prettyNames names) -resolveBranchHash :: - Monad m => Maybe Branch.Hash -> Codebase m v a -> Backend m (Branch m) -resolveBranchHash h codebase = case h of +resolveCausalHash :: + Monad m => Maybe (Branch.CausalHash) -> Codebase m v a -> Backend m (Branch m) +resolveCausalHash h codebase = case h of Nothing -> lift (Codebase.getRootBranch codebase) Just bhash -> do mayBranch <- lift $ Codebase.getBranchForHash codebase bhash @@ -1105,7 +1105,7 @@ resolveRootBranchHash mayRoot codebase = case mayRoot of lift (Codebase.getRootBranch codebase) Just sbh -> do h <- expandShortBranchHash codebase sbh - resolveBranchHash (Just h) codebase + resolveCausalHash (Just h) codebase -- | Determines whether we include full cycles in the results, (e.g. if I search for `isEven`, will I find `isOdd` too?) data IncludeCycles diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs index e2e64ce315..c64469e5c8 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs @@ -140,7 +140,7 @@ backendListEntryToNamespaceObject ppe typeWidth = \case Subnamespace $ NamedNamespace { namespaceName = NameSegment.toText name, - namespaceHash = "#" <> Hash.toBase32HexText (Causal.unRawHash hash) + namespaceHash = "#" <> Hash.toBase32HexText (Causal.unCausalHash hash) } Backend.ShallowPatchEntry name -> PatchObject . NamedPatch $ NameSegment.toText name diff --git a/unison-share-api/src/Unison/Server/Endpoints/Projects.hs b/unison-share-api/src/Unison/Server/Endpoints/Projects.hs index 52d36b58c8..6bcbdf47a7 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/Projects.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/Projects.hs @@ -108,7 +108,7 @@ backendListEntryToProjectListing owner = \case ProjectListing { owner = owner, name = NameSegment.toText name, - hash = "#" <> Hash.toBase32HexText (Causal.unRawHash hash) + hash = "#" <> Hash.toBase32HexText (Causal.unCausalHash hash) } _ -> Nothing diff --git a/unison-share-api/src/Unison/Server/Errors.hs b/unison-share-api/src/Unison/Server/Errors.hs index 7df275cee5..f66b7d117b 100644 --- a/unison-share-api/src/Unison/Server/Errors.hs +++ b/unison-share-api/src/Unison/Server/Errors.hs @@ -10,7 +10,7 @@ import qualified Data.Set as Set import qualified Data.Text.Lazy as Text import qualified Data.Text.Lazy.Encoding as Text import Servant (ServerError (..), err400, err404, err409, err500) -import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.ShortBranchHash as SBH import qualified Unison.Reference as Reference @@ -60,7 +60,7 @@ noSuchNamespace :: HashQualifiedName -> ServerError noSuchNamespace namespace = err404 {errBody = "The namespace " <> munge namespace <> " does not exist."} -couldntLoadBranch :: Branch.Hash -> ServerError +couldntLoadBranch :: Causal.CausalHash -> ServerError couldntLoadBranch h = err404 { errBody = diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 1262313f7a..928ac4679a 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -192,7 +192,7 @@ setCacheControl = addHeader @"Cache-Control" "public" branchToUnisonHash :: Branch.Branch m -> UnisonHash branchToUnisonHash b = - ("#" <>) . Hash.base32Hex . Causal.unRawHash $ Branch.headHash b + ("#" <>) . Hash.base32Hex . Causal.unCausalHash $ Branch.headHash b v2CausalBranchToUnisonHash :: V2Branch.CausalBranch m -> UnisonHash v2CausalBranchToUnisonHash b = From 535b8589b8a548ff75032c8aea55ac953a99a282 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 26 May 2022 19:22:26 -0400 Subject: [PATCH 243/529] download entities --- unison-share-api/src/Unison/Sync/Types.hs | 17 +++++++++++------ 1 file changed, 11 insertions(+), 6 deletions(-) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 3efd693755..7a429366d6 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -55,6 +55,7 @@ module Unison.Sync.Types HashMismatch (..), -- * Common/shared error types + DownloadEntities (..), HashMismatchForEntity (..), InvalidParentage (..), NeedDependencies (..), @@ -602,20 +603,24 @@ instance FromJSON DownloadEntitiesRequest where hashes <- obj .: "hashes" pure DownloadEntitiesRequest {..} -data DownloadEntitiesResponse = DownloadEntitiesResponse +data DownloadEntitiesResponse + = DownloadEntitiesSuccess DownloadEntities + | DownloadEntitiesNoReadPermission + +data DownloadEntities = DownloadEntities { entities :: NEMap Hash (Entity Text Hash HashJWT) } deriving stock (Show, Eq, Ord) -instance ToJSON DownloadEntitiesResponse where - toJSON (DownloadEntitiesResponse entities) = +instance ToJSON DownloadEntities where + toJSON (DownloadEntities entities) = object [ "entities" .= entities ] -instance FromJSON DownloadEntitiesResponse where - parseJSON = Aeson.withObject "DownloadEntitiesResponse" \obj -> do - DownloadEntitiesResponse <$> obj .: "entities" +instance FromJSON DownloadEntities where + parseJSON = Aeson.withObject "DownloadEntities" \obj -> do + DownloadEntities <$> obj .: "entities" ------------------------------------------------------------------------------------------------------------------------ -- Upload entities From 461ac1f9926a246836c53a7aae93f072bd56fc0b Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 26 May 2022 19:40:30 -0400 Subject: [PATCH 244/529] json instances for DownloadEntitiesResponse --- unison-share-api/src/Unison/Sync/Types.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 7a429366d6..ed443782d5 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -605,13 +605,25 @@ instance FromJSON DownloadEntitiesRequest where data DownloadEntitiesResponse = DownloadEntitiesSuccess DownloadEntities - | DownloadEntitiesNoReadPermission + | DownloadEntitiesNoReadPermission RepoName data DownloadEntities = DownloadEntities { entities :: NEMap Hash (Entity Text Hash HashJWT) } deriving stock (Show, Eq, Ord) +instance ToJSON DownloadEntitiesResponse where + toJSON = \case + DownloadEntitiesSuccess entities -> jsonUnion "success" entities + DownloadEntitiesNoReadPermission repoName -> jsonUnion "no_read_permission" repoName + +instance FromJSON DownloadEntitiesResponse where + parseJSON = Aeson.withObject "DownloadEntitiesResponse" \obj -> + obj .: "type" >>= Aeson.withText "type" \case + "success" -> DownloadEntitiesSuccess <$> obj .: "payload" + "no_read_permission" -> DownloadEntitiesNoReadPermission <$> obj .: "payload" + t -> failText $ "Unexpected DownloadEntitiesResponse type: " <> t + instance ToJSON DownloadEntities where toJSON (DownloadEntities entities) = object From d3105991faddb9ece2bad35443ce821b57626175 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 26 May 2022 17:35:11 -0600 Subject: [PATCH 245/529] Add traversals for Entity types --- unison-share-api/src/Unison/Sync/Types.hs | 48 +++++++++++++++++++++++ 1 file changed, 48 insertions(+) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 3efd693755..5704887bfd 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -1,4 +1,8 @@ +{-# LANGUAGE ApplicativeDo #-} {-# LANGUAGE RecordWildCards #-} +-- Name shadowing is really helpful for writing some custom traversals +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} + module Unison.Sync.Types ( -- * Misc. types @@ -31,6 +35,13 @@ module Unison.Sync.Types entityDependencies, EntityType (..), + -- *** Entity Traversals + entityHashes_, + patchHashes_, + patchDiffHashes_, + namespaceDiffHashes_, + causalHashes_, + -- * Request/response types -- ** Get causal hash by path @@ -61,6 +72,7 @@ module Unison.Sync.Types ) where +import Control.Lens (both, traverseOf) import Data.Aeson import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson @@ -79,6 +91,7 @@ import qualified Data.Text.Encoding as Text import Servant.Auth.JWT import U.Util.Base32Hex (Base32Hex (..)) import Unison.Prelude +import qualified Unison.Util.Set as Set import qualified Web.JWT as JWT ------------------------------------------------------------------------------------------------------------------------ @@ -234,6 +247,16 @@ instance (FromJSON text, FromJSON noSyncHash, FromJSON hash, Ord hash) => FromJS NamespaceDiffType -> ND <$> obj .: "object" CausalType -> C <$> obj .: "object" +entityHashes_ :: (Applicative m, Ord hash') => (hash -> m hash') -> Entity text noSyncHash hash -> m (Entity text noSyncHash hash') +entityHashes_ f = \case + TC tc -> TC <$> bitraverse pure f tc + DC dc -> DC <$> bitraverse pure f dc + P patch -> P <$> patchHashes_ f patch + PD patch -> PD <$> patchDiffHashes_ f patch + N ns -> N <$> bitraverse pure f ns + ND ns -> ND <$> namespaceDiffHashes_ f ns + C causal -> C <$> causalHashes_ f causal + -- | Get the direct dependencies of an entity (which are actually sync'd). -- -- FIXME use generic-lens here? (typed @hash) @@ -386,6 +409,11 @@ instance (FromJSON text, FromJSON oldHash, FromJSON newHash) => FromJSON (Patch Base64Bytes bytes <- obj .: "bytes" pure Patch {..} +patchHashes_ :: Applicative m => (hash -> m hash') -> Patch text noSyncHash hash -> m (Patch text noSyncHash hash') +patchHashes_ f (Patch {..}) = do + newHashLookup <- traverse f newHashLookup + pure (Patch {..}) + data PatchDiff text oldHash hash = PatchDiff { parent :: hash, textLookup :: [text], @@ -414,6 +442,12 @@ instance (FromJSON text, FromJSON oldHash, FromJSON hash) => FromJSON (PatchDiff Base64Bytes bytes <- obj .: "bytes" pure PatchDiff {..} +patchDiffHashes_ :: Applicative m => (hash -> m hash') -> PatchDiff text noSyncHash hash -> m (PatchDiff text noSyncHash hash') +patchDiffHashes_ f (PatchDiff {..}) = do + parent <- f parent + newHashLookup <- traverse f newHashLookup + pure (PatchDiff {..}) + data Namespace text hash = Namespace { textLookup :: [text], defnLookup :: [hash], @@ -488,6 +522,14 @@ instance (FromJSON text, FromJSON hash) => FromJSON (NamespaceDiff text hash) wh Base64Bytes bytes <- obj .: "bytes" pure NamespaceDiff {..} +namespaceDiffHashes_ :: Applicative m => (hash -> m hash') -> NamespaceDiff text hash -> m (NamespaceDiff text hash') +namespaceDiffHashes_ f (NamespaceDiff {..}) = do + parent <- f parent + defnLookup <- traverse f defnLookup + patchLookup <- traverse f patchLookup + childLookup <- traverseOf (traverse . both) f childLookup + pure (NamespaceDiff {..}) + -- Client _may_ choose not to download the namespace entity in the future, but -- we still send them the hash/hashjwt. data Causal hash = Causal @@ -496,6 +538,12 @@ data Causal hash = Causal } deriving stock (Eq, Ord, Show) +causalHashes_ :: (Applicative m, Ord hash') => (hash -> m hash') -> Causal hash -> m (Causal hash') +causalHashes_ f (Causal {..}) = do + namespaceHash <- f namespaceHash + parents <- Set.traverse f parents + pure (Causal {..}) + instance (ToJSON hash) => ToJSON (Causal hash) where toJSON (Causal namespaceHash parents) = object From d910b1a74d291f27f21f0b5ef8dd89e8387c4924 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 26 May 2022 17:51:07 -0600 Subject: [PATCH 246/529] Allow overriding share host via UNISON_SHARE_HOST env var. (#3079) * Allow overriding share host via UNISON_SHARE_HOST env var. * Use staging share for now. --- .../Unison/Codebase/Editor/HandleInput/AuthLogin.hs | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs index 27032e72d0..bfb4448653 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs @@ -1,17 +1,23 @@ -{-# LANGUAGE RecordWildCards #-} - module Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin) where import Control.Monad.Reader +import qualified Data.Text as Text +import System.IO.Unsafe (unsafePerformIO) import Unison.Auth.OAuth import Unison.Auth.Types (Host (..)) import Unison.Codebase.Editor.HandleInput.LoopState import Unison.Codebase.Editor.Output (Output (CredentialFailureMsg, Success)) import Unison.Prelude import qualified UnliftIO +import UnliftIO.Environment (lookupEnv) defaultShareHost :: Host -defaultShareHost = Host "enlil.unison-lang.org" +defaultShareHost = unsafePerformIO $ do + lookupEnv "UNISON_SHARE_HOST" <&> \case + -- TODO: swap to production share before release. + Nothing -> Host "share-next.us-west-2.unison-lang.org" + Just shareHost -> Host (Text.pack shareHost) +{-# NOINLINE defaultShareHost #-} authLogin :: UnliftIO.MonadUnliftIO m => Maybe Host -> Action m i v () authLogin mayHost = do From 63ecd5dad4d8965e934ad94c61ed9ed1b2ccbb32 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 26 May 2022 23:32:52 -0400 Subject: [PATCH 247/529] comment out `DownloadEntities` --- unison-cli/src/Unison/Share/Sync.hs | 2 +- unison-share-api/src/Unison/Sync/Types.hs | 28 +++++++++++------------ 2 files changed, 14 insertions(+), 16 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 4408462422..6c6a188867 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -400,7 +400,7 @@ downloadEntities httpClient unisonShareUrl conn repoName = doDownload :: NESet Share.HashJWT -> IO (NEMap Share.Hash (Share.Entity Text Share.Hash Share.HashJWT)) doDownload hashes = do - Share.DownloadEntitiesResponse entities <- + Share.DownloadEntitiesSuccess entities <- httpDownloadEntities httpClient unisonShareUrl diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index c0f73f59aa..c2edd7a79d 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -3,7 +3,6 @@ -- Name shadowing is really helpful for writing some custom traversals {-# OPTIONS_GHC -fno-warn-name-shadowing #-} - module Unison.Sync.Types ( -- * Misc. types Base64Bytes (..), @@ -66,7 +65,6 @@ module Unison.Sync.Types HashMismatch (..), -- * Common/shared error types - DownloadEntities (..), HashMismatchForEntity (..), InvalidParentage (..), NeedDependencies (..), @@ -652,13 +650,13 @@ instance FromJSON DownloadEntitiesRequest where pure DownloadEntitiesRequest {..} data DownloadEntitiesResponse - = DownloadEntitiesSuccess DownloadEntities + = DownloadEntitiesSuccess (NEMap Hash (Entity Text Hash HashJWT)) | DownloadEntitiesNoReadPermission RepoName -data DownloadEntities = DownloadEntities - { entities :: NEMap Hash (Entity Text Hash HashJWT) - } - deriving stock (Show, Eq, Ord) +-- data DownloadEntities = DownloadEntities +-- { entities :: NEMap Hash (Entity Text Hash HashJWT) +-- } +-- deriving stock (Show, Eq, Ord) instance ToJSON DownloadEntitiesResponse where toJSON = \case @@ -672,15 +670,15 @@ instance FromJSON DownloadEntitiesResponse where "no_read_permission" -> DownloadEntitiesNoReadPermission <$> obj .: "payload" t -> failText $ "Unexpected DownloadEntitiesResponse type: " <> t -instance ToJSON DownloadEntities where - toJSON (DownloadEntities entities) = - object - [ "entities" .= entities - ] +-- instance ToJSON DownloadEntities where +-- toJSON (DownloadEntities entities) = +-- object +-- [ "entities" .= entities +-- ] -instance FromJSON DownloadEntities where - parseJSON = Aeson.withObject "DownloadEntities" \obj -> do - DownloadEntities <$> obj .: "entities" +-- instance FromJSON DownloadEntities where +-- parseJSON = Aeson.withObject "DownloadEntities" \obj -> do +-- DownloadEntities <$> obj .: "entities" ------------------------------------------------------------------------------------------------------------------------ -- Upload entities From 3defc941bf504ebd3bb92565f9a2db0f09a026ec Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Fri, 27 May 2022 00:08:38 -0400 Subject: [PATCH 248/529] Update parser-typechecker/src/Unison/PrintError.hs --- parser-typechecker/src/Unison/PrintError.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 782c6b2a65..58433d114a 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -1410,7 +1410,7 @@ prettyParseError s = \case Code " + 1", "\n - An `ability` declaration, like " - <> style Code "unique|structural ability Foo where ...", + <> style Code "unique ability Foo where ...", "\n - A `type` declaration, like " <> style Code "structural type Optional a = None | Some a", "\n" From 1dfa91683654b261e61d36c2a4c0c50680621443 Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Fri, 27 May 2022 00:09:02 -0400 Subject: [PATCH 249/529] Update unison-src/transcripts/error-messages.output.md --- unison-src/transcripts/error-messages.output.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-src/transcripts/error-messages.output.md b/unison-src/transcripts/error-messages.output.md index 52f59be266..2fc4bb0922 100644 --- a/unison-src/transcripts/error-messages.output.md +++ b/unison-src/transcripts/error-messages.output.md @@ -242,7 +242,7 @@ a ! b = 1 a : Nat a = 42 - A watch expression, like > a + 1 - - An `ability` declaration, like unique|structural ability Foo where ... + - An `ability` declaration, like unique ability Foo where ... - A `type` declaration, like structural type Optional a = None | Some a From 3dec0b27b018961432fc7c3f44ca195e860719f7 Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Fri, 27 May 2022 00:09:41 -0400 Subject: [PATCH 250/529] Update unison-src/transcripts/errors/unison-hide-all.output.md --- unison-src/transcripts/errors/unison-hide-all.output.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-src/transcripts/errors/unison-hide-all.output.md b/unison-src/transcripts/errors/unison-hide-all.output.md index d6e5092f0a..9b313c82a6 100644 --- a/unison-src/transcripts/errors/unison-hide-all.output.md +++ b/unison-src/transcripts/errors/unison-hide-all.output.md @@ -26,7 +26,7 @@ The transcript failed due to an error in the stanza above. The error is: g : Nat g = 42 - A watch expression, like > g + 1 - - An `ability` declaration, like unique|structural ability Foo where ... + - An `ability` declaration, like unique ability Foo where ... - A `type` declaration, like structural type Optional a = None | Some a From 0daed483b7d4eb0db52669a6c653c7204927ef4b Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Fri, 27 May 2022 00:09:56 -0400 Subject: [PATCH 251/529] Update unison-src/transcripts/errors/unison-hide.output.md --- unison-src/transcripts/errors/unison-hide.output.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-src/transcripts/errors/unison-hide.output.md b/unison-src/transcripts/errors/unison-hide.output.md index 772624318b..bf410ca30e 100644 --- a/unison-src/transcripts/errors/unison-hide.output.md +++ b/unison-src/transcripts/errors/unison-hide.output.md @@ -26,7 +26,7 @@ The transcript failed due to an error in the stanza above. The error is: g : Nat g = 42 - A watch expression, like > g + 1 - - An `ability` declaration, like unique|structural ability Foo where ... + - An `ability` declaration, like unique ability Foo where ... - A `type` declaration, like structural type Optional a = None | Some a From d9a0ddd2cab6050bcd039329d493e56446805ccc Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Fri, 27 May 2022 00:11:04 -0400 Subject: [PATCH 252/529] Update lib/unison-prelude/src/Unison/Prelude.hs Co-authored-by: Chris Penner --- lib/unison-prelude/src/Unison/Prelude.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index b3de550cd3..cd103768c8 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -168,5 +168,5 @@ reportBug bugId msg = ] {-# WARNING wundefined "You left this wundefined." #-} -wundefined :: a +wundefined :: HasCallStack => a wundefined = undefined From 53156a3008ef9b9e7b3b73081b8f7d298fdb0c6d Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 27 May 2022 11:13:08 -0400 Subject: [PATCH 253/529] fix bug in entityLocation --- unison-cli/src/Unison/Share/Sync.hs | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 6c6a188867..4214fc7368 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -504,12 +504,9 @@ upsertEntitySomewhere hash entity = entityLocation hash >>= \case Just location -> pure location Nothing -> do - -- if it has missing dependencies, add it to temp storage; - -- otherwise add it to main storage. missingDependencies0 <- Set.filterM - (Q.entityExists . Share.toBase32Hex . Share.hashJWTHash) - -- (Set.map Share.decodeHashJWT (Share.entityDependencies entity)) + (fmap not . Q.entityExists . Share.toBase32Hex . Share.hashJWTHash) (Share.entityDependencies entity) case NESet.nonEmptySet missingDependencies0 of Nothing -> do From c167fcd603f88838f163481a8c0f9502d25b2e33 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 27 May 2022 11:24:47 -0400 Subject: [PATCH 254/529] generalize entityToTempEntity --- unison-cli/src/Unison/Share/Sync.hs | 86 +--------------------- unison-share-api/src/Unison/Sync/Common.hs | 81 +++++++++++++++++++- 2 files changed, 82 insertions(+), 85 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 4214fc7368..f33c116a10 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -25,7 +25,6 @@ module Unison.Share.Sync ) where -import qualified Control.Lens as Lens import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader import qualified Data.Foldable as Foldable (find) @@ -39,21 +38,11 @@ import qualified Data.Sequence.NonEmpty as NESeq (fromList, nonEmptySeq, (><|)) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet -import qualified Data.Vector as Vector import qualified Servant.API as Servant ((:<|>) (..)) import Servant.Client (BaseUrl) import qualified Servant.Client as Servant (ClientEnv, ClientM, client, hoistClient, mkClientEnv, runClientM) import U.Codebase.HashTags (CausalHash (..)) -import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat -import qualified U.Codebase.Sqlite.Causal as Causal -import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat -import qualified U.Codebase.Sqlite.Entity as Entity -import U.Codebase.Sqlite.LocalIds (LocalIds' (..)) -import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat import qualified U.Codebase.Sqlite.Queries as Q -import U.Codebase.Sqlite.TempEntity (TempEntity) -import qualified U.Codebase.Sqlite.TempEntity as TempEntity -import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Hash as Hash import Unison.Auth.HTTPClient (AuthorizedHttpClient) @@ -519,7 +508,7 @@ upsertEntitySomewhere hash entity = -- | Insert an entity that doesn't have any missing dependencies. insertEntity :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> Sqlite.Transaction () insertEntity hash entity = do - syncEntity <- Q.tempToSyncEntity (entityToTempEntity entity) + syncEntity <- Q.tempToSyncEntity (entityToTempEntity (Share.toBase32Hex . Share.hashJWTHash) entity) _id <- Q.saveSyncEntity (Share.toBase32Hex hash) syncEntity pure () @@ -532,7 +521,7 @@ insertTempEntity :: insertTempEntity hash entity missingDependencies = Q.insertTempEntity (Share.toBase32Hex hash) - (entityToTempEntity entity) + (entityToTempEntity (Share.toBase32Hex . Share.hashJWTHash) entity) ( NESet.map ( \hashJwt -> let Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}} = Share.decodeHashJWT hashJwt @@ -548,77 +537,6 @@ causalHashToHash :: CausalHash -> Share.Hash causalHashToHash = Share.Hash . Hash.toBase32Hex . unCausalHash --- | Convert an entity that came over the wire from Unison Share into an equivalent type that we can store in the --- `temp_entity` table. -entityToTempEntity :: Share.Entity Text Share.Hash Share.HashJWT -> TempEntity -entityToTempEntity = \case - Share.TC (Share.TermComponent terms) -> - terms - & Vector.fromList - & Vector.map (Lens.over Lens._1 mungeLocalIds) - & TermFormat.SyncLocallyIndexedComponent - & TermFormat.SyncTerm - & Entity.TC - Share.DC (Share.DeclComponent decls) -> - decls - & Vector.fromList - & Vector.map (Lens.over Lens._1 mungeLocalIds) - & DeclFormat.SyncLocallyIndexedComponent - & DeclFormat.SyncDecl - & Entity.DC - Share.P Share.Patch {textLookup, oldHashLookup, newHashLookup, bytes} -> - Entity.P (PatchFormat.SyncFull (mungePatchLocalIds textLookup oldHashLookup newHashLookup) bytes) - Share.PD Share.PatchDiff {parent, textLookup, oldHashLookup, newHashLookup, bytes} -> - Entity.P (PatchFormat.SyncDiff (jwt32 parent) (mungePatchLocalIds textLookup oldHashLookup newHashLookup) bytes) - Share.N Share.Namespace {textLookup, defnLookup, patchLookup, childLookup, bytes} -> - Entity.N (NamespaceFormat.SyncFull (mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup) bytes) - Share.ND Share.NamespaceDiff {parent, textLookup, defnLookup, patchLookup, childLookup, bytes} -> - Entity.N - ( NamespaceFormat.SyncDiff - (jwt32 parent) - (mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup) - bytes - ) - Share.C Share.Causal {namespaceHash, parents} -> - Entity.C - Causal.SyncCausalFormat - { valueHash = jwt32 namespaceHash, - parents = Vector.fromList (map jwt32 (Set.toList parents)) - } - where - mungeLocalIds :: Share.LocalIds Text Share.HashJWT -> TempEntity.TempLocalIds - mungeLocalIds Share.LocalIds {texts, hashes} = - LocalIds - { textLookup = Vector.fromList texts, - defnLookup = Vector.map jwt32 (Vector.fromList hashes) - } - - mungeNamespaceLocalIds :: - [Text] -> - [Share.HashJWT] -> - [Share.HashJWT] -> - [(Share.HashJWT, Share.HashJWT)] -> - TempEntity.TempNamespaceLocalIds - mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup = - NamespaceFormat.LocalIds - { branchTextLookup = Vector.fromList textLookup, - branchDefnLookup = Vector.fromList (map jwt32 defnLookup), - branchPatchLookup = Vector.fromList (map jwt32 patchLookup), - branchChildLookup = Vector.fromList (map (\(x, y) -> (jwt32 x, jwt32 y)) childLookup) - } - - mungePatchLocalIds :: [Text] -> [Share.Hash] -> [Share.HashJWT] -> TempEntity.TempPatchLocalIds - mungePatchLocalIds textLookup oldHashLookup newHashLookup = - PatchFormat.LocalIds - { patchTextLookup = Vector.fromList textLookup, - patchHashLookup = Vector.fromList (coerce @[Share.Hash] @[Base32Hex] oldHashLookup), - patchDefnLookup = Vector.fromList (map jwt32 newHashLookup) - } - - jwt32 :: Share.HashJWT -> Base32Hex - jwt32 = - Share.toBase32Hex . Share.hashJWTHash - ------------------------------------------------------------------------------------------------------------------------ -- HTTP calls diff --git a/unison-share-api/src/Unison/Sync/Common.hs b/unison-share-api/src/Unison/Sync/Common.hs index 1d91befa04..07520018c6 100644 --- a/unison-share-api/src/Unison/Sync/Common.hs +++ b/unison-share-api/src/Unison/Sync/Common.hs @@ -1,5 +1,10 @@ -- | Combinators or utilities shared by sync server AND client -module Unison.Sync.Common where +module Unison.Sync.Common + ( expectEntity, + entityToTempEntity, + tempEntityToEntity, + ) +where import qualified Control.Lens as Lens import qualified Data.Set as Set @@ -12,7 +17,9 @@ import qualified U.Codebase.Sqlite.Entity as Entity import U.Codebase.Sqlite.LocalIds import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat import qualified U.Codebase.Sqlite.Queries as Q +import U.Codebase.Sqlite.TempEntity (TempEntity) import qualified U.Codebase.Sqlite.TempEntity as Sqlite +import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Util.Base32Hex (Base32Hex) import Unison.Prelude @@ -26,6 +33,78 @@ expectEntity hash = do tempEntity <- Q.syncToTempEntity syncEntity pure (tempEntityToEntity tempEntity) +-- | Convert an entity that came over the wire from Unison Share into an equivalent type that we can store in the +-- `temp_entity` table. +entityToTempEntity :: forall hash. (hash -> Base32Hex) -> Share.Entity Text Share.Hash hash -> TempEntity +entityToTempEntity toBase32Hex = \case + Share.TC (Share.TermComponent terms) -> + terms + & Vector.fromList + & Vector.map (Lens.over Lens._1 mungeLocalIds) + & TermFormat.SyncLocallyIndexedComponent + & TermFormat.SyncTerm + & Entity.TC + Share.DC (Share.DeclComponent decls) -> + decls + & Vector.fromList + & Vector.map (Lens.over Lens._1 mungeLocalIds) + & DeclFormat.SyncLocallyIndexedComponent + & DeclFormat.SyncDecl + & Entity.DC + Share.P Share.Patch {textLookup, oldHashLookup, newHashLookup, bytes} -> + Entity.P (PatchFormat.SyncFull (mungePatchLocalIds textLookup oldHashLookup newHashLookup) bytes) + Share.PD Share.PatchDiff {parent, textLookup, oldHashLookup, newHashLookup, bytes} -> + Entity.P + ( PatchFormat.SyncDiff + (toBase32Hex parent) + (mungePatchLocalIds textLookup oldHashLookup newHashLookup) + bytes + ) + Share.N Share.Namespace {textLookup, defnLookup, patchLookup, childLookup, bytes} -> + Entity.N (NamespaceFormat.SyncFull (mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup) bytes) + Share.ND Share.NamespaceDiff {parent, textLookup, defnLookup, patchLookup, childLookup, bytes} -> + Entity.N + ( NamespaceFormat.SyncDiff + (toBase32Hex parent) + (mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup) + bytes + ) + Share.C Share.Causal {namespaceHash, parents} -> + Entity.C + Causal.SyncCausalFormat + { valueHash = toBase32Hex namespaceHash, + parents = Vector.fromList (map toBase32Hex (Set.toList parents)) + } + where + mungeLocalIds :: Share.LocalIds Text hash -> TempEntity.TempLocalIds + mungeLocalIds Share.LocalIds {texts, hashes} = + LocalIds + { textLookup = Vector.fromList texts, + defnLookup = Vector.map toBase32Hex (Vector.fromList hashes) + } + + mungeNamespaceLocalIds :: + [Text] -> + [hash] -> + [hash] -> + [(hash, hash)] -> + TempEntity.TempNamespaceLocalIds + mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup = + NamespaceFormat.LocalIds + { branchTextLookup = Vector.fromList textLookup, + branchDefnLookup = Vector.fromList (map toBase32Hex defnLookup), + branchPatchLookup = Vector.fromList (map toBase32Hex patchLookup), + branchChildLookup = Vector.fromList (map (\(x, y) -> (toBase32Hex x, toBase32Hex y)) childLookup) + } + + mungePatchLocalIds :: [Text] -> [Share.Hash] -> [hash] -> TempEntity.TempPatchLocalIds + mungePatchLocalIds textLookup oldHashLookup newHashLookup = + PatchFormat.LocalIds + { patchTextLookup = Vector.fromList textLookup, + patchHashLookup = Vector.fromList (coerce @[Share.Hash] @[Base32Hex] oldHashLookup), + patchDefnLookup = Vector.fromList (map toBase32Hex newHashLookup) + } + tempEntityToEntity :: Sqlite.TempEntity -> Share.Entity Text Share.Hash Share.Hash tempEntityToEntity = \case Entity.TC (TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent terms)) -> From 99075cc4e62abbb0e80b5942256734f5b06aa7e5 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 27 May 2022 11:27:11 -0400 Subject: [PATCH 255/529] move causalHashToShareHash to common --- unison-cli/src/Unison/Share/Sync.hs | 14 ++++---------- unison-share-api/src/Unison/Sync/Common.hs | 9 +++++++++ 2 files changed, 13 insertions(+), 10 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index f33c116a10..a203634a34 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -114,7 +114,7 @@ checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash = do Share.UpdatePathRequest { path, expectedHash, - newHash = causalHashToHash causalHash + newHash = causalHashToShareHash causalHash } -- | An error occurred while fast-forward pushing code to Unison Share. @@ -160,7 +160,8 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = unisonShareUrl Share.FastForwardPathRequest { expectedHash = remoteHeadHash, - hashes = causalHashToHash <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), + hashes = + causalHashToShareHash <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), path } doFastForwardPath <&> \case @@ -184,7 +185,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = unisonShareUrl conn (Share.pathRepoName path) - (NESet.singleton (causalHashToHash headHash)) + (NESet.singleton (causalHashToShareHash headHash)) -- Return a list from oldest to newst of the ancestors between (excluding) the latest local and the current remote -- hash. @@ -530,13 +531,6 @@ insertTempEntity hash entity missingDependencies = missingDependencies ) ------------------------------------------------------------------------------------------------------------------------- --- Conversions to/from Share API types - -causalHashToHash :: CausalHash -> Share.Hash -causalHashToHash = - Share.Hash . Hash.toBase32Hex . unCausalHash - ------------------------------------------------------------------------------------------------------------------------ -- HTTP calls diff --git a/unison-share-api/src/Unison/Sync/Common.hs b/unison-share-api/src/Unison/Sync/Common.hs index 07520018c6..af7fb4f370 100644 --- a/unison-share-api/src/Unison/Sync/Common.hs +++ b/unison-share-api/src/Unison/Sync/Common.hs @@ -1,6 +1,9 @@ -- | Combinators or utilities shared by sync server AND client module Unison.Sync.Common ( expectEntity, + + -- * Type conversions + causalHashToShareHash, entityToTempEntity, tempEntityToEntity, ) @@ -10,6 +13,7 @@ import qualified Control.Lens as Lens import qualified Data.Set as Set import Data.Vector (Vector) import qualified Data.Vector as Vector +import U.Codebase.HashTags (CausalHash (..)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import qualified U.Codebase.Sqlite.Causal as Causal import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat @@ -22,6 +26,7 @@ import qualified U.Codebase.Sqlite.TempEntity as Sqlite import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Util.Base32Hex (Base32Hex) +import qualified U.Util.Hash as Hash import Unison.Prelude import qualified Unison.Sqlite as Sqlite import qualified Unison.Sync.Types as Share @@ -33,6 +38,10 @@ expectEntity hash = do tempEntity <- Q.syncToTempEntity syncEntity pure (tempEntityToEntity tempEntity) +causalHashToShareHash :: CausalHash -> Share.Hash +causalHashToShareHash = + Share.Hash . Hash.toBase32Hex . unCausalHash + -- | Convert an entity that came over the wire from Unison Share into an equivalent type that we can store in the -- `temp_entity` table. entityToTempEntity :: forall hash. (hash -> Base32Hex) -> Share.Entity Text Share.Hash hash -> TempEntity From 36b8ac2155eb63390d22ed0697fcf079e5e69dcf Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 27 May 2022 10:51:01 -0600 Subject: [PATCH 256/529] Add "debug.doctor" command for assessing codebase integrity (#3078) * Collect and pretty-print errors * Add debug.doctor command * Improved formatting --- parser-typechecker/src/Unison/Codebase.hs | 3 + .../src/Unison/Codebase/IntegrityCheck.hs | 164 ++++++++++++++---- .../src/Unison/Codebase/SqliteCodebase.hs | 3 +- .../Codebase/SqliteCodebase/Migrations.hs | 9 +- .../src/Unison/Codebase/Type.hs | 9 +- unison-cli/package.yaml | 1 + .../src/Unison/Codebase/Editor/Command.hs | 3 + .../Unison/Codebase/Editor/HandleCommand.hs | 4 + .../src/Unison/Codebase/Editor/HandleInput.hs | 4 + .../src/Unison/Codebase/Editor/Input.hs | 1 + .../src/Unison/Codebase/Editor/Output.hs | 6 + .../src/Unison/CommandLine/InputPatterns.hs | 15 ++ .../src/Unison/CommandLine/OutputMessages.hs | 4 + unison-cli/unison-cli.cabal | 5 + 14 files changed, 189 insertions(+), 42 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 4625613ecb..fd6627351c 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -90,6 +90,9 @@ module Unison.Codebase CodebasePath, SyncToDir, + -- * Sqlite escape hatch + connection, + -- * Misc (organize these better) addDefsToCodebase, componentReferencesForReference, diff --git a/parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs b/parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs index 7dbc30fd38..51dec164ee 100644 --- a/parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs +++ b/parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs @@ -8,11 +8,16 @@ module Unison.Codebase.IntegrityCheck ( integrityCheckFullCodebase, integrityCheckAllBranches, integrityCheckAllCausals, + prettyPrintIntegrityErrors, IntegrityResult (..), ) where import Control.Lens +import qualified Data.List.NonEmpty as NEList +import qualified Data.Set as Set +import Data.Set.NonEmpty (NESet) +import qualified Data.Set.NonEmpty as NESet import Data.String.Here.Uninterpolated (here) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL @@ -22,12 +27,14 @@ import qualified U.Codebase.Sqlite.Branch.Full as DBBranch import qualified U.Codebase.Sqlite.DbId as DB import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Q +import qualified U.Util.Hash as Hash import qualified Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers as Helpers import qualified Unison.Debug as Debug import Unison.Hash (Hash) import Unison.Prelude import qualified Unison.Sqlite as Sqlite import Unison.Util.Monoid (foldMapM) +import qualified Unison.Util.Pretty as P import Prelude hiding (log) debugLog :: TL.Text -> Sqlite.Transaction () @@ -37,14 +44,32 @@ logInfo :: TL.Text -> Sqlite.Transaction () logInfo msg = Sqlite.unsafeIO $ TL.putStrLn msg logError :: TL.Text -> Sqlite.Transaction () -logError msg = logInfo $ " โš ๏ธ " <> msg +logError msg = logInfo $ " โš ๏ธ " <> msg -data IntegrityResult = IntegrityErrorDetected | NoIntegrityErrors - deriving (Show, Eq) +data IntegrityError + = DetectedObjectsWithoutCorrespondingHashObjects (NESet DB.ObjectId) + | -- (causal hash, branch hash) + DetectedCausalsWithoutCorrespondingBranchObjects (NESet (Hash, Hash)) + | DetectedCausalsWithCausalHashAsBranchHash (NESet Hash) + | DetectedBranchErrors Hash (NESet BranchError) + deriving stock (Show, Eq, Ord) + +data BranchError + = IncorrectHashForBranch Hash Hash + | MismatchedObjectForChild Hash DB.BranchObjectId DB.BranchObjectId + | MissingObjectForChildCausal Hash + | MissingObject DB.BranchObjectId + | MissingCausalForChild Hash + | ChildCausalHashObjectIdMismatch Hash DB.BranchObjectId + deriving stock (Show, Eq, Ord) + +data IntegrityResult = IntegrityErrorDetected (NESet IntegrityError) | NoIntegrityErrors + deriving stock (Show, Eq, Ord) instance Semigroup IntegrityResult where - IntegrityErrorDetected <> _ = IntegrityErrorDetected - _ <> IntegrityErrorDetected = IntegrityErrorDetected + IntegrityErrorDetected errA <> IntegrityErrorDetected errB = IntegrityErrorDetected (errA <> errB) + NoIntegrityErrors <> IntegrityErrorDetected err = IntegrityErrorDetected err + IntegrityErrorDetected err <> NoIntegrityErrors = IntegrityErrorDetected err NoIntegrityErrors <> NoIntegrityErrors = NoIntegrityErrors instance Monoid IntegrityResult where @@ -53,19 +78,16 @@ instance Monoid IntegrityResult where integrityCheckAllHashObjects :: Sqlite.Transaction IntegrityResult integrityCheckAllHashObjects = do logInfo "Checking Hash Object Integrity..." - Sqlite.queryOneCol_ anyObjectsWithoutHashObjectsSQL >>= \case - True -> do - failure $ "Detected Objects without any hash_object." - pure IntegrityErrorDetected - False -> do + Sqlite.queryListCol_ @DB.ObjectId objectsWithoutHashObjectsSQL >>= \case + (o : os) -> do + let badObjects = NESet.fromList (o NEList.:| os) + pure $ IntegrityErrorDetected (NESet.singleton $ DetectedObjectsWithoutCorrespondingHashObjects badObjects) + [] -> do pure NoIntegrityErrors where - anyObjectsWithoutHashObjectsSQL = + objectsWithoutHashObjectsSQL = [here| - -- Returns a boolean indicating whether any objects are missing a hash_object. - SELECT EXISTS ( - SELECT 1 FROM object AS o WHERE NOT EXISTS (SELECT 1 FROM hash_object as ho WHERE ho.object_id = o.id) - ) + SELECT o.id FROM object AS o WHERE NOT EXISTS (SELECT 1 FROM hash_object as ho WHERE ho.object_id = o.id) |] -- | Performs a bevy of checks on causals. @@ -76,16 +98,21 @@ integrityCheckAllCausals = do branchObjIntegrity <- Sqlite.queryListRow_ @(DB.CausalHashId, DB.BranchHashId) causalsWithMissingBranchObjects >>= \case [] -> pure NoIntegrityErrors - badCausals -> do + (c : cs) -> do + badCausals <- for (c NEList.:| cs) $ \(causalHashId, branchHashId) -> do + ch <- Q.expectHash (DB.unCausalHashId causalHashId) + bh <- Q.expectHash (DB.unBranchHashId branchHashId) + pure (ch, bh) logError $ "Detected " <> pShow (length badCausals) <> " causals with missing branch objects." debugLog . pShow $ badCausals - pure IntegrityErrorDetected + pure $ IntegrityErrorDetected (NESet.singleton $ DetectedCausalsWithoutCorrespondingBranchObjects $ NESet.fromList badCausals) differingBranchHashIntegrity <- - Sqlite.queryOneCol_ @Bool anyCausalsWithMatchingValueHashAndSelfHash - <&> \case - False -> NoIntegrityErrors - True -> IntegrityErrorDetected + Sqlite.queryListCol_ @DB.HashId causalsWithMatchingValueHashAndSelfHash >>= \case + [] -> pure NoIntegrityErrors + (c : cs) -> do + badCausalHashes <- for (c NEList.:| cs) Q.expectHash + pure (IntegrityErrorDetected (NESet.singleton $ DetectedCausalsWithCausalHashAsBranchHash $ NESet.fromList badCausalHashes)) pure (branchObjIntegrity <> differingBranchHashIntegrity) where causalsWithMissingBranchObjects :: Sqlite.Sql @@ -95,12 +122,10 @@ integrityCheckAllCausals = do FROM causal c WHERE NOT EXISTS (SELECT 1 from object o WHERE o.primary_hash_id = c.value_hash_id); |] - anyCausalsWithMatchingValueHashAndSelfHash :: Sqlite.Sql - anyCausalsWithMatchingValueHashAndSelfHash = + causalsWithMatchingValueHashAndSelfHash :: Sqlite.Sql + causalsWithMatchingValueHashAndSelfHash = [here| - SELECT EXISTS - (SELECT 1 FROM causal WHERE self_hash_id = value_hash_id - ) + SELECT self_hash_id FROM causal WHERE self_hash_id = value_hash_id |] -- | Performs a bevy of checks on branch objects and their relation to causals. @@ -134,46 +159,109 @@ integrityCheckAllBranches = do assertCausalExists childCausalHashId, assertCausalValueMatchesObject childCausalHashId childObjId ] - fold <$> sequenceA checks - pure $ branchHashCheck <> branchChildChecks + (fold <$> sequenceA checks) + case NESet.nonEmptySet (branchHashCheck <> branchChildChecks) of + Nothing -> pure NoIntegrityErrors + Just errs -> pure . IntegrityErrorDetected . NESet.singleton $ DetectedBranchErrors actualBranchHash errs where - assertExpectedBranchHash :: Hash -> Hash -> Sqlite.Transaction IntegrityResult + assertExpectedBranchHash :: Hash -> Hash -> Sqlite.Transaction (Set BranchError) assertExpectedBranchHash expectedBranchHash actualBranchHash = do if (expectedBranchHash /= actualBranchHash) then do failure $ "Expected hash for namespace doesn't match actual hash for namespace: " <> pShow (expectedBranchHash, actualBranchHash) - pure IntegrityErrorDetected + pure (Set.singleton $ IncorrectHashForBranch expectedBranchHash actualBranchHash) else do - pure NoIntegrityErrors + pure mempty + assertBranchObjExists :: DB.BranchObjectId -> Sqlite.Transaction (Set BranchError) assertBranchObjExists branchObjId = do Q.loadNamespaceObject @Void (DB.unBranchObjectId branchObjId) (const $ Right ()) >>= \case - Just _ -> pure NoIntegrityErrors + Just _ -> pure mempty Nothing -> do failure $ "Expected namespace object for object ID: " <> pShow branchObjId - pure IntegrityErrorDetected + pure (Set.singleton $ MissingObject branchObjId) + assertCausalExists :: DB.CausalHashId -> Sqlite.Transaction (Set BranchError) assertCausalExists causalHashId = do Sqlite.queryOneCol doesCausalExistForCausalHashId (Sqlite.Only causalHashId) >>= \case - True -> pure NoIntegrityErrors + True -> pure mempty False -> do + ch <- Q.expectHash (DB.unCausalHashId causalHashId) failure $ "Expected causal for causal hash ID, but none was found: " <> pShow causalHashId - pure IntegrityErrorDetected + pure (Set.singleton $ MissingCausalForChild ch) + assertCausalValueMatchesObject :: + DB.CausalHashId -> + DB.BranchObjectId -> + Sqlite.Transaction (Set BranchError) assertCausalValueMatchesObject causalHashId branchObjId = do -- Assert the object for the causal hash ID matches the given object Id. Q.loadBranchObjectIdByCausalHashId causalHashId >>= \case Nothing -> do + ch <- Q.expectHash (DB.unCausalHashId causalHashId) failure $ "Expected branch object for causal hash ID: " <> pShow causalHashId - pure IntegrityErrorDetected + pure (Set.singleton $ MissingObjectForChildCausal ch) Just foundBranchId | foundBranchId /= branchObjId -> do failure $ "Expected child branch object to match canonical object ID for causal hash's namespace: " <> pShow (causalHashId, foundBranchId, branchObjId) - pure IntegrityErrorDetected - | otherwise -> pure NoIntegrityErrors + ch <- Q.expectHash (DB.unCausalHashId causalHashId) + pure (Set.singleton $ MismatchedObjectForChild ch branchObjId foundBranchId) + | otherwise -> pure mempty failure :: TL.Text -> Sqlite.Transaction () failure msg = do logError msg +prettyPrintIntegrityErrors :: Foldable f => f IntegrityError -> P.Pretty P.ColorText +prettyPrintIntegrityErrors xs + | null xs = mempty + | otherwise = + xs + & toList + & fmap + ( \case + DetectedObjectsWithoutCorrespondingHashObjects objs -> + P.hang + "Detected objects without any corresponding hash_object. Object IDs:" + (P.commas (prettyObjectId <$> NESet.toList objs)) + DetectedCausalsWithoutCorrespondingBranchObjects hashes -> + P.hang + "Detected causals without a corresponding branch object:\n" + ( P.column2Header + "Causal Hash" + "Branch Hash" + (toList hashes <&> bimap prettyHash prettyHash) + ) + DetectedCausalsWithCausalHashAsBranchHash ns -> + P.hang + "Detected causals with the same causal hash as branch hash:" + (P.commas (prettyHash <$> toList ns)) + DetectedBranchErrors bh errs -> + P.hang + ("Detected errors in branch: " <> prettyHash bh) + (P.lines . fmap (<> "\n") . fmap prettyBranchError . toList $ errs) + ) + & fmap (<> "\n") + & P.lines + & P.warnCallout + where + prettyHash :: Hash -> P.Pretty P.ColorText + prettyHash h = P.blue . P.text $ ("#" <> Hash.toBase32HexText h) + prettyBranchObjectId :: DB.BranchObjectId -> P.Pretty P.ColorText + prettyBranchObjectId = prettyObjectId . DB.unBranchObjectId + prettyObjectId :: DB.ObjectId -> P.Pretty P.ColorText + prettyObjectId (DB.ObjectId n) = P.green (P.shown n) + prettyBranchError :: BranchError -> P.Pretty P.ColorText + prettyBranchError = + P.wrap . \case + IncorrectHashForBranch expected actual -> "The Branch hash for this branch is incorrect. Expected Hash: " <> prettyHash expected <> ", Actual Hash: " <> prettyHash actual + MismatchedObjectForChild ha obj1 obj2 -> + "The child with causal hash: " <> prettyHash ha <> " is mapped to object ID " <> prettyBranchObjectId obj1 <> " but should map to " <> prettyBranchObjectId obj2 <> "." + MissingObjectForChildCausal ha -> + "There's no corresponding branch object for the causal hash: " <> prettyHash ha + MissingObject objId -> "Expected an object for the child reference to object id: " <> prettyBranchObjectId objId + MissingCausalForChild ch -> "Expected a causal to exist for hash: " <> prettyHash ch + ChildCausalHashObjectIdMismatch ch objId -> + "Expected the object ID reference " <> prettyHash ch <> " to match the provided object ID: " <> prettyBranchObjectId objId + -- | Performs all available integrity checks. integrityCheckFullCodebase :: Sqlite.Transaction IntegrityResult integrityCheckFullCodebase = do diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index f2d2c88378..8a57a57a71 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -492,7 +492,8 @@ sqliteCodebase debugName root localOrRemote action = do runTx (CodebaseOps.namesAtPath path), updateNameLookup = Sqlite.runTransaction conn $ do root <- (CodebaseOps.getRootBranch getDeclType rootBranchCache) - CodebaseOps.saveRootNamesIndex (Branch.toNames . Branch.head $ root) + CodebaseOps.saveRootNamesIndex (Branch.toNames . Branch.head $ root), + connection = conn } let finalizer :: MonadIO m => m () finalizer = do diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index 737d27fb97..6cf0376fe0 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -12,7 +12,7 @@ import qualified U.Codebase.Sqlite.Queries as Q import Unison.Codebase (CodebasePath) import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (OpenCodebaseUnknownSchemaVersion)) import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase -import Unison.Codebase.IntegrityCheck (IntegrityResult (..), integrityCheckAllBranches, integrityCheckAllCausals) +import Unison.Codebase.IntegrityCheck (IntegrityResult (..), integrityCheckAllBranches, integrityCheckAllCausals, prettyPrintIntegrityErrors) import Unison.Codebase.SqliteCodebase.Migrations.Helpers (abortMigration) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2 (migrateSchema1To2) import Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema2To3 (migrateSchema2To3) @@ -25,6 +25,7 @@ import Unison.Hash (Hash) import Unison.Prelude import qualified Unison.Sqlite as Sqlite import qualified Unison.Sqlite.Connection as Sqlite.Connection +import qualified Unison.Util.Pretty as Pretty import qualified UnliftIO -- | Mapping from schema version to the migration required to get there. @@ -86,7 +87,11 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer co ] case result of NoIntegrityErrors -> pure () - IntegrityErrorDetected -> abortMigration "Codebase integrity error detected." + IntegrityErrorDetected errs -> do + let msg = prettyPrintIntegrityErrors errs + let rendered = Pretty.toPlain 80 (Pretty.border 2 msg) + Sqlite.unsafeIO $ putStrLn rendered + abortMigration "Codebase integrity error detected." pure ranMigrations when ranMigrations do -- Vacuum once now that any migrations have taken place. diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 6c7e99dbe7..ecfe0a5788 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -36,6 +36,7 @@ import Unison.Reference (Reference) import qualified Unison.Reference as Reference import qualified Unison.Referent as Referent import Unison.ShortHash (ShortHash) +import qualified Unison.Sqlite as Sqlite import Unison.Term (Term) import Unison.Type (Type) import qualified Unison.WatchKind as WK @@ -174,7 +175,13 @@ data Codebase m v a = Codebase namesAtPath :: Path -> m ScopedNames, -- Updates the root namespace names index. -- This isn't run automatically because it can be a bit slow. - updateNameLookup :: m () + updateNameLookup :: m (), + -- | The SQLite connection this codebase closes over. + -- + -- At one time the codebase was meant to abstract over the storage layer, but it has been cumbersome. Now we prefer + -- to interact with SQLite directly, and so provide this temporary escape hatch, until we can eliminate this + -- interface entirely. + connection :: Sqlite.Connection } -- | Whether a codebase is local or remote. diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 2fee4e8047..7b62d539a6 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -36,6 +36,7 @@ dependencies: - stm - text - unison-codebase-sqlite + - unison-sqlite - unison-core1 - unison-parser-typechecker - unison-prelude diff --git a/unison-cli/src/Unison/Codebase/Editor/Command.hs b/unison-cli/src/Unison/Codebase/Editor/Command.hs index 5a59e8532b..b2a4e6c429 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Command.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Command.hs @@ -30,6 +30,7 @@ import Unison.Codebase.Editor.AuthorInfo (AuthorInfo) import qualified Unison.Codebase.Editor.Git as Git import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.RemoteRepo +import Unison.Codebase.IntegrityCheck (IntegrityResult) import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Reflog as Reflog @@ -252,6 +253,7 @@ data RuntimeMain :: Command m i v (Type v Ann) RuntimeTest :: Command m i v (Type v Ann) ClearWatchCache :: Command m i v () + AnalyzeCodebaseIntegrity :: Command m i v IntegrityResult MakeStandalone :: PPE.PrettyPrintEnv -> Reference -> String -> Command m i v (Maybe Runtime.Error) -- | Trigger an interactive fuzzy search over the provided options and return all -- selected results. @@ -348,3 +350,4 @@ commandName = \case FuzzySelect {} -> "FuzzySelect" CmdUnliftIO {} -> "UnliftIO" UCMVersion {} -> "UCMVersion" + AnalyzeCodebaseIntegrity -> "AnalyzeCodebaseIntegrity" diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs index 0419d1c279..5706dca543 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs @@ -24,6 +24,7 @@ import qualified Unison.Codebase.Branch.Merge as Branch import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UCMVersion, UseCache) import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output (PrintMessage)) +import Unison.Codebase.IntegrityCheck (integrityCheckFullCodebase) import qualified Unison.Codebase.Path as Path import Unison.Codebase.Runtime (Runtime) import qualified Unison.Codebase.Runtime as Runtime @@ -41,6 +42,7 @@ import qualified Unison.Reference as Reference import qualified Unison.Result as Result import qualified Unison.Server.Backend as Backend import qualified Unison.Server.CodebaseServer as Server +import qualified Unison.Sqlite as Sqlite import Unison.Symbol (Symbol) import Unison.Term (Term) import qualified Unison.Term as Term @@ -240,6 +242,8 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour UnliftIO.UnliftIO toIO -> toIO . Free.fold go pure runF UCMVersion -> pure ucmVersion + AnalyzeCodebaseIntegrity -> do + Sqlite.runTransaction (Codebase.connection codebase) integrityCheckFullCodebase watchCache :: Reference.Id -> IO (Maybe (Term Symbol ())) watchCache h = do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 8e00808285..aa5853c961 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -455,6 +455,7 @@ loop = do DebugDumpNamespacesI {} -> wat DebugDumpNamespaceSimpleI {} -> wat DebugClearWatchI {} -> wat + DebugDoctorI {} -> wat QuitI {} -> wat DeprecateTermI {} -> undefined DeprecateTypeI {} -> undefined @@ -1624,6 +1625,9 @@ loop = do for_ (Relation.toList . Branch.deepTerms . Branch.head $ root') \(r, name) -> traceM $ show name ++ ",Term," ++ Text.unpack (Referent.toText r) DebugClearWatchI {} -> eval ClearWatchCache + DebugDoctorI {} -> do + r <- eval AnalyzeCodebaseIntegrity + respond (IntegrityCheck r) DeprecateTermI {} -> notImplemented DeprecateTypeI {} -> notImplemented RemoveTermReplacementI from patchPath -> diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index ecc73677f6..b586ee6130 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -180,6 +180,7 @@ data Input | DebugDumpNamespacesI | DebugDumpNamespaceSimpleI | DebugClearWatchI + | DebugDoctorI | QuitI | ApiI | UiI diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index b2258d8a8a..dd64d41d1d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -29,6 +29,7 @@ import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.SlurpResult (SlurpResult (..)) import qualified Unison.Codebase.Editor.SlurpResult as SR import qualified Unison.Codebase.Editor.TodoOutput as TO +import Unison.Codebase.IntegrityCheck (IntegrityResult (..)) import Unison.Codebase.Patch (Patch) import Unison.Codebase.Path (Path') import qualified Unison.Codebase.Path as Path @@ -255,6 +256,7 @@ data Output v | UnknownCodeServer Text | CredentialFailureMsg CredentialFailure | PrintVersion Text + | IntegrityCheck IntegrityResult data ReflogEntry = ReflogEntry {hash :: ShortBranchHash, reason :: Text} deriving (Show) @@ -381,6 +383,10 @@ isFailure o = case o of UnknownCodeServer {} -> True CredentialFailureMsg {} -> True PrintVersion {} -> False + IntegrityCheck r -> + case r of + NoIntegrityErrors -> False + IntegrityErrorDetected {} -> True isNumberedFailure :: NumberedOutput v -> Bool isNumberedFailure = \case diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 5e9f196861..68fd8efd8e 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1875,6 +1875,20 @@ debugClearWatchCache = "Clear the watch expression cache" (const $ Right Input.DebugClearWatchI) +debugDoctor :: InputPattern +debugDoctor = + InputPattern + "debug.doctor" + [] + I.Visible + [] + ( P.wrap "Analyze your codebase for errors and inconsistencies." + ) + ( \case + [] -> Right $ Input.DebugDoctorI + _ -> Left (showPatternHelp debugDoctor) + ) + test :: InputPattern test = InputPattern @@ -2145,6 +2159,7 @@ validInputs = debugDumpNamespace, debugDumpNamespaceSimple, debugClearWatchCache, + debugDoctor, gist, authLogin, printVersion diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index c42dfee422..083c317f4f 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -49,6 +49,7 @@ import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo import qualified Unison.Codebase.Editor.SlurpResult as SlurpResult import qualified Unison.Codebase.Editor.TodoOutput as TO import Unison.Codebase.GitError +import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors) import Unison.Codebase.Patch (Patch (..)) import qualified Unison.Codebase.Patch as Patch import qualified Unison.Codebase.Path as Path @@ -1580,6 +1581,9 @@ notifyUser dir o = case o of "Host names should NOT include a schema or path." ] PrintVersion ucmVersion -> pure (P.text ucmVersion) + IntegrityCheck result -> pure $ case result of + NoIntegrityErrors -> "๐ŸŽ‰ No issues detected ๐ŸŽ‰" + IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 488edb9c88..50d4ba2e96 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -134,6 +134,7 @@ library , unison-prelude , unison-pretty-printer , unison-share-api + , unison-sqlite , unison-util , unison-util-relation , unliftio @@ -228,6 +229,7 @@ executable cli-integration-tests , unison-prelude , unison-pretty-printer , unison-share-api + , unison-sqlite , unison-util , unison-util-relation , unliftio @@ -317,6 +319,7 @@ executable transcripts , unison-prelude , unison-pretty-printer , unison-share-api + , unison-sqlite , unison-util , unison-util-relation , unliftio @@ -410,6 +413,7 @@ executable unison , unison-prelude , unison-pretty-printer , unison-share-api + , unison-sqlite , unison-util , unison-util-relation , unliftio @@ -507,6 +511,7 @@ test-suite cli-tests , unison-prelude , unison-pretty-printer , unison-share-api + , unison-sqlite , unison-util , unison-util-relation , unliftio From acff5af2beb397d4a8bcdeb0066e42627941e572 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 27 May 2022 15:34:50 -0400 Subject: [PATCH 257/529] fix up merge compilation errors and formatting differences --- .../src/Unison/Codebase/IntegrityCheck.hs | 73 ++++++++++--------- .../Codebase/SqliteCodebase/Migrations.hs | 2 +- .../Migrations/MigrateSchema3To4.hs | 23 +++--- .../src/Unison/Codebase/Editor/HandleInput.hs | 2 +- 4 files changed, 50 insertions(+), 50 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs b/parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs index 51dec164ee..31b8a1c5f8 100644 --- a/parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs +++ b/parser-typechecker/src/Unison/Codebase/IntegrityCheck.hs @@ -23,6 +23,7 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.IO as TL import Data.Void import Text.Pretty.Simple +import U.Codebase.HashTags (BranchHash (..)) import qualified U.Codebase.Sqlite.Branch.Full as DBBranch import qualified U.Codebase.Sqlite.DbId as DB import qualified U.Codebase.Sqlite.Operations as Ops @@ -51,11 +52,11 @@ data IntegrityError | -- (causal hash, branch hash) DetectedCausalsWithoutCorrespondingBranchObjects (NESet (Hash, Hash)) | DetectedCausalsWithCausalHashAsBranchHash (NESet Hash) - | DetectedBranchErrors Hash (NESet BranchError) + | DetectedBranchErrors BranchHash (NESet BranchError) deriving stock (Show, Eq, Ord) data BranchError - = IncorrectHashForBranch Hash Hash + = IncorrectHashForBranch BranchHash BranchHash | MismatchedObjectForChild Hash DB.BranchObjectId DB.BranchObjectId | MissingObjectForChildCausal Hash | MissingObject DB.BranchObjectId @@ -151,7 +152,7 @@ integrityCheckAllBranches = do integrityCheckBranch objId = do dbBranch <- Ops.expectDbBranch objId expectedBranchHash <- Helpers.dbBranchHash dbBranch - actualBranchHash <- Q.expectPrimaryHashByObjectId (DB.unBranchObjectId objId) + actualBranchHash <- BranchHash <$> Q.expectPrimaryHashByObjectId (DB.unBranchObjectId objId) branchHashCheck <- assertExpectedBranchHash expectedBranchHash actualBranchHash branchChildChecks <- flip foldMapM (toListOf DBBranch.childrenHashes_ dbBranch) $ \(childObjId, childCausalHashId) -> do let checks = @@ -164,7 +165,7 @@ integrityCheckAllBranches = do Nothing -> pure NoIntegrityErrors Just errs -> pure . IntegrityErrorDetected . NESet.singleton $ DetectedBranchErrors actualBranchHash errs where - assertExpectedBranchHash :: Hash -> Hash -> Sqlite.Transaction (Set BranchError) + assertExpectedBranchHash :: BranchHash -> BranchHash -> Sqlite.Transaction (Set BranchError) assertExpectedBranchHash expectedBranchHash actualBranchHash = do if (expectedBranchHash /= actualBranchHash) then do @@ -201,9 +202,9 @@ integrityCheckAllBranches = do pure (Set.singleton $ MissingObjectForChildCausal ch) Just foundBranchId | foundBranchId /= branchObjId -> do - failure $ "Expected child branch object to match canonical object ID for causal hash's namespace: " <> pShow (causalHashId, foundBranchId, branchObjId) - ch <- Q.expectHash (DB.unCausalHashId causalHashId) - pure (Set.singleton $ MismatchedObjectForChild ch branchObjId foundBranchId) + failure $ "Expected child branch object to match canonical object ID for causal hash's namespace: " <> pShow (causalHashId, foundBranchId, branchObjId) + ch <- Q.expectHash (DB.unCausalHashId causalHashId) + pure (Set.singleton $ MismatchedObjectForChild ch branchObjId foundBranchId) | otherwise -> pure mempty failure :: TL.Text -> Sqlite.Transaction () @@ -214,34 +215,34 @@ prettyPrintIntegrityErrors :: Foldable f => f IntegrityError -> P.Pretty P.Color prettyPrintIntegrityErrors xs | null xs = mempty | otherwise = - xs - & toList - & fmap - ( \case - DetectedObjectsWithoutCorrespondingHashObjects objs -> - P.hang - "Detected objects without any corresponding hash_object. Object IDs:" - (P.commas (prettyObjectId <$> NESet.toList objs)) - DetectedCausalsWithoutCorrespondingBranchObjects hashes -> - P.hang - "Detected causals without a corresponding branch object:\n" - ( P.column2Header - "Causal Hash" - "Branch Hash" - (toList hashes <&> bimap prettyHash prettyHash) - ) - DetectedCausalsWithCausalHashAsBranchHash ns -> - P.hang - "Detected causals with the same causal hash as branch hash:" - (P.commas (prettyHash <$> toList ns)) - DetectedBranchErrors bh errs -> - P.hang - ("Detected errors in branch: " <> prettyHash bh) - (P.lines . fmap (<> "\n") . fmap prettyBranchError . toList $ errs) - ) - & fmap (<> "\n") - & P.lines - & P.warnCallout + xs + & toList + & fmap + ( \case + DetectedObjectsWithoutCorrespondingHashObjects objs -> + P.hang + "Detected objects without any corresponding hash_object. Object IDs:" + (P.commas (prettyObjectId <$> NESet.toList objs)) + DetectedCausalsWithoutCorrespondingBranchObjects hashes -> + P.hang + "Detected causals without a corresponding branch object:\n" + ( P.column2Header + "Causal Hash" + "Branch Hash" + (toList hashes <&> bimap prettyHash prettyHash) + ) + DetectedCausalsWithCausalHashAsBranchHash ns -> + P.hang + "Detected causals with the same causal hash as branch hash:" + (P.commas (prettyHash <$> toList ns)) + DetectedBranchErrors bh errs -> + P.hang + ("Detected errors in branch: " <> prettyHash (unBranchHash bh)) + (P.lines . fmap (<> "\n") . fmap prettyBranchError . toList $ errs) + ) + & fmap (<> "\n") + & P.lines + & P.warnCallout where prettyHash :: Hash -> P.Pretty P.ColorText prettyHash h = P.blue . P.text $ ("#" <> Hash.toBase32HexText h) @@ -252,7 +253,7 @@ prettyPrintIntegrityErrors xs prettyBranchError :: BranchError -> P.Pretty P.ColorText prettyBranchError = P.wrap . \case - IncorrectHashForBranch expected actual -> "The Branch hash for this branch is incorrect. Expected Hash: " <> prettyHash expected <> ", Actual Hash: " <> prettyHash actual + IncorrectHashForBranch expected actual -> "The Branch hash for this branch is incorrect. Expected Hash: " <> prettyHash (unBranchHash expected) <> ", Actual Hash: " <> prettyHash (unBranchHash actual) MismatchedObjectForChild ha obj1 obj2 -> "The child with causal hash: " <> prettyHash ha <> " is mapped to object ID " <> prettyBranchObjectId obj1 <> " but should map to " <> prettyBranchObjectId obj2 <> "." MissingObjectForChildCausal ha -> diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index 46190af70c..8a3372dd87 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -43,7 +43,7 @@ migrations getDeclType termBuffer declBuffer = [ (2, migrateSchema1To2 getDeclType termBuffer declBuffer), (3, migrateSchema2To3), (4, migrateSchema3To4), - (5, migrateSchema4To5), + (5, migrateSchema4To5) ] -- | Migrates a codebase up to the most recent version known to ucm. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs index f67d45f291..b83aa8af05 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema3To4.hs @@ -12,7 +12,6 @@ import Data.Semigroup import qualified Data.Set as Set import Data.Set.Lens (setOf) import Data.String.Here.Uninterpolated (here) -import qualified U.Codebase.HashTags as H import qualified U.Codebase.Sqlite.Branch.Format as S.BranchFormat import qualified U.Codebase.Sqlite.Branch.Full as DBBranch import qualified U.Codebase.Sqlite.DbId as DB @@ -230,7 +229,7 @@ rehashAndCanonicalizeNamespace causalHashId possiblyIncorrectNamespaceHashId obj liftT $ replaceBranch objId remappedBranch correctNamespaceHash <- liftT $ Helpers.dbBranchHash remappedBranch liftT . debugLog $ "Correct namespace hash: " <> show correctNamespaceHash - correctNamespaceHashId <- liftT $ Q.saveBranchHash (H.BranchHash correctNamespaceHash) + correctNamespaceHashId <- liftT $ Q.saveBranchHash correctNamespaceHash when (correctNamespaceHashId == possiblyIncorrectNamespaceHashId) $ do -- If the existing hash for this namespace was already correct, we don't need to @@ -251,17 +250,17 @@ rehashAndCanonicalizeNamespace causalHashId possiblyIncorrectNamespaceHashId obj -- that one. Just canonicalObjectId | canonicalObjectId /= objId -> do - -- Found an existing but different object with this hash, so the current object is a duplicate and - -- needs to be deleted. - liftT . debugLog $ "Mapping objID: " <> show objId <> " to canonical: " <> show canonicalObjectId - liftT . debugLog $ "Unilaterally deleting: " <> show objId - -- Remove possible foreign-key references before deleting the objects themselves - liftT $ Sqlite.execute deleteHashObjectsByObjectId (Sqlite.Only objId) - liftT $ Sqlite.execute deleteObjectById (Sqlite.Only objId) - pure canonicalObjectId + -- Found an existing but different object with this hash, so the current object is a duplicate and + -- needs to be deleted. + liftT . debugLog $ "Mapping objID: " <> show objId <> " to canonical: " <> show canonicalObjectId + liftT . debugLog $ "Unilaterally deleting: " <> show objId + -- Remove possible foreign-key references before deleting the objects themselves + liftT $ Sqlite.execute deleteHashObjectsByObjectId (Sqlite.Only objId) + liftT $ Sqlite.execute deleteObjectById (Sqlite.Only objId) + pure canonicalObjectId | otherwise -> do - -- This should be impossible. - error $ "We proved that the new hash is different from the existing one, but somehow found the same object for each hash. Please report this as a bug." <> show (objId, canonicalObjectId) + -- This should be impossible. + error $ "We proved that the new hash is different from the existing one, but somehow found the same object for each hash. Please report this as a bug." <> show (objId, canonicalObjectId) Nothing -> do -- There's no existing canonical object, this object BECOMES the canonical one by -- reassigning its primary hash. diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f79364bb45..8107ed1e05 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -2271,7 +2271,7 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = liftIO (Share.pull authHTTPClient (shareRepoToBaseUrl server) connection shareFlavoredPath) >>= \case Left e -> pure (Left (Output.ShareErrorPull e)) Right causalHash -> do - (eval . Eval) (Codebase.getBranchForHash codebase (Cv.branchHash2to1 causalHash)) >>= \case + (eval . Eval) (Codebase.getBranchForHash codebase (Cv.causalHash2to1 causalHash)) >>= \case Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" Just branch -> pure (Right branch) From bb254c00a1a46150c9a5cdc3797a66e51b801e51 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 27 May 2022 16:42:25 -0400 Subject: [PATCH 258/529] fix up tests --- codebase2/codebase-sqlite/sql/create.sql | 2 +- unison-cli/tests/Unison/Test/UriParser.hs | 96 ++++++++++++------- unison-cli/tests/Unison/Test/VersionParser.hs | 7 +- 3 files changed, 65 insertions(+), 40 deletions(-) diff --git a/codebase2/codebase-sqlite/sql/create.sql b/codebase2/codebase-sqlite/sql/create.sql index 702e8776b3..9e892c0caa 100644 --- a/codebase2/codebase-sqlite/sql/create.sql +++ b/codebase2/codebase-sqlite/sql/create.sql @@ -3,7 +3,7 @@ CREATE TABLE schema_version ( version INTEGER NOT NULL ); -INSERT INTO schema_version (version) VALUES (4); +INSERT INTO schema_version (version) VALUES (5); -- actually stores the 512-byte hashes CREATE TABLE hash ( diff --git a/unison-cli/tests/Unison/Test/UriParser.hs b/unison-cli/tests/Unison/Test/UriParser.hs index 5d5c78c0c9..850c951909 100644 --- a/unison-cli/tests/Unison/Test/UriParser.hs +++ b/unison-cli/tests/Unison/Test/UriParser.hs @@ -1,13 +1,21 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Unison.Test.UriParser where +import Data.Functor (void) import qualified Data.Sequence as Seq import Data.Text (Text) import qualified Data.Text as Text import EasyTest import qualified Text.Megaparsec as P -import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..)) +import Unison.Codebase.Editor.RemoteRepo + ( ReadGitRepo (..), + ReadRemoteNamespace (..), + ShareRepo (..), + pattern ReadGitRemoteNamespace, + pattern ReadShareRemoteNamespace, + ) import qualified Unison.Codebase.Editor.UriParser as UriParser import Unison.Codebase.Path (Path (..)) import qualified Unison.Codebase.Path as Path @@ -15,84 +23,100 @@ import Unison.Codebase.ShortBranchHash (ShortBranchHash (..)) import Unison.NameSegment (NameSegment (..)) test :: Test () -test = scope "uriparser" . tests $ [testAugmented] +test = scope "uriparser" . tests $ [testShare, testGit] -testAugmented :: Test () -testAugmented = - scope "augmented" . tests $ +gitHelper :: (ReadGitRepo, Maybe ShortBranchHash, Path) -> ReadRemoteNamespace +gitHelper (repo, sbh, path) = ReadRemoteNamespaceGit (ReadGitRemoteNamespace repo sbh path) + +testShare :: Test () +testShare = + scope "share" . tests $ + [ parseAugmented + ( "unisonweb.base._releases.M4", + ReadRemoteNamespaceShare (ReadShareRemoteNamespace ShareRepo "unisonweb" (path ["base", "_releases", "M4"])) + ), + expectParseFailure ".unisonweb.base" + ] + +testGit :: Test () +testGit = + scope "git" . tests $ -- Local Protocol -- $ git clone /srv/git/project.git -- $ git clone /srv/git/project.git[:treeish][:[#hash][.path]] [ scope "local-protocol" . tests . map parseAugmented $ - [ ( "/srv/git/project.git", - (ReadGitRepo "/srv/git/project.git" Nothing, Nothing, Path.empty) + [ ( "git(/srv/git/project.git)", + gitHelper (ReadGitRepo "/srv/git/project.git" Nothing, Nothing, Path.empty) ), - ( "/srv/git/project.git:abc:#def.hij.klm", - (ReadGitRepo "/srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) + ( "git(/srv/git/project.git:abc)#def.hij.klm", + gitHelper (ReadGitRepo "/srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) ), - ( "srv/git/project.git", - (ReadGitRepo "srv/git/project.git" Nothing, Nothing, Path.empty) + ( "git(srv/git/project.git)", + gitHelper (ReadGitRepo "srv/git/project.git" Nothing, Nothing, Path.empty) ), - ( "srv/git/project.git:abc:#def.hij.klm", - (ReadGitRepo "srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) + ( "git(srv/git/project.git:abc)#def.hij.klm", + gitHelper (ReadGitRepo "srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) ) ], -- File Protocol -- $ git clone file:///srv/git/project.git[:treeish][:[#hash][.path]] <- imagined scope "file-protocol" . tests . map parseAugmented $ - [ ( "file:///srv/git/project.git", - (ReadGitRepo "file:///srv/git/project.git" Nothing, Nothing, Path.empty) + [ ( "git(file:///srv/git/project.git)", + gitHelper (ReadGitRepo "file:///srv/git/project.git" Nothing, Nothing, Path.empty) ), - ( "file:///srv/git/project.git:abc:#def.hij.klm", - (ReadGitRepo "file:///srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) + ( "git(file:///srv/git/project.git:abc)#def.hij.klm", + gitHelper (ReadGitRepo "file:///srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) ), - ( "file://srv/git/project.git", - (ReadGitRepo "file://srv/git/project.git" Nothing, Nothing, Path.empty) + ( "git(file://srv/git/project.git)", + gitHelper (ReadGitRepo "file://srv/git/project.git" Nothing, Nothing, Path.empty) ), - ( "file://srv/git/project.git:abc:#def.hij.klm", - (ReadGitRepo "file://srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) + ( "git(file://srv/git/project.git:abc)#def.hij.klm", + gitHelper (ReadGitRepo "file://srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) ) ], -- Smart / Dumb HTTP protocol -- $ git clone https://example.com/gitproject.git[:treeish][:[#hash][.path]] <- imagined scope "http-protocol" . tests . map parseAugmented $ - [ ( "https://example.com/git/project.git", - (ReadGitRepo "https://example.com/git/project.git" Nothing, Nothing, Path.empty) + [ ( "git(https://example.com/git/project.git)", + gitHelper (ReadGitRepo "https://example.com/git/project.git" Nothing, Nothing, Path.empty) ), - ( "https://user@example.com/git/project.git:abc:#def.hij.klm]", - (ReadGitRepo "https://user@example.com/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) + ( "git(https://user@example.com/git/project.git:abc)#def.hij.klm]", + gitHelper (ReadGitRepo "https://user@example.com/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) ) ], -- SSH Protocol -- $ git clone ssh://[user@]server/project.git[:treeish][:[#hash][.path]] scope "ssh-protocol" . tests . map parseAugmented $ - [ ( "ssh://git@8.8.8.8:222/user/project.git", - (ReadGitRepo "ssh://git@8.8.8.8:222/user/project.git" Nothing, Nothing, Path.empty) + [ ( "git(ssh://git@8.8.8.8:222/user/project.git)", + gitHelper (ReadGitRepo "ssh://git@8.8.8.8:222/user/project.git" Nothing, Nothing, Path.empty) ), - ( "ssh://git@github.com/user/project.git:abc:#def.hij.klm", - (ReadGitRepo "ssh://git@github.com/user/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) + ( "git(ssh://git@github.com/user/project.git:abc)#def.hij.klm", + gitHelper (ReadGitRepo "ssh://git@github.com/user/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) ) ], -- $ git clone [user@]server:project.git[:treeish][:[#hash][.path]] scope "scp-protocol" . tests . map parseAugmented $ - [ ( "git@github.com:user/project.git", - (ReadGitRepo "git@github.com:user/project.git" Nothing, Nothing, Path.empty) + [ ( "git(git@github.com:user/project.git)", + gitHelper (ReadGitRepo "git@github.com:user/project.git" Nothing, Nothing, Path.empty) ), - ( "github.com:user/project.git", - (ReadGitRepo "github.com:user/project.git" Nothing, Nothing, Path.empty) + ( "git(github.com:user/project.git)", + gitHelper (ReadGitRepo "github.com:user/project.git" Nothing, Nothing, Path.empty) ), - ( "git@github.com:user/project.git:abc:#def.hij.klm", - (ReadGitRepo "git@github.com:user/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) + ( "git(git@github.com:user/project.git:abc)#def.hij.klm", + gitHelper (ReadGitRepo "git@github.com:user/project.git" (Just "abc"), sbh "def", path ["hij", "klm"]) ) ] ] -parseAugmented :: (Text, (ReadGitRepo, Maybe ShortBranchHash, Path)) -> Test () +parseAugmented :: (Text, ReadRemoteNamespace) -> Test () parseAugmented (s, r) = scope (Text.unpack s) $ case P.parse UriParser.repoPath "test case" s of Left x -> crash $ show x Right x -> expectEqual x r +expectParseFailure :: Text -> Test () +expectParseFailure s = void . scope (Text.unpack s) . expectLeft . P.parse UriParser.repoPath "negative test case" $ s + path :: [Text] -> Path path = Path . Seq.fromList . fmap NameSegment diff --git a/unison-cli/tests/Unison/Test/VersionParser.hs b/unison-cli/tests/Unison/Test/VersionParser.hs index 520fb26f60..51f83333db 100644 --- a/unison-cli/tests/Unison/Test/VersionParser.hs +++ b/unison-cli/tests/Unison/Test/VersionParser.hs @@ -27,8 +27,9 @@ makeTest (version, path) = (rightMay $ runParser defaultBaseLib "versionparser" version) ( Just -- We've hard-coded the v4 branch for base for now. See 'defaultBaseLib' - ( ReadGitRepo "https://github.com/unisonweb/base" (Just "v4"), - Nothing, - Path.fromText path + ( ReadGitRemoteNamespace + (ReadGitRepo "https://github.com/unisonweb/base" (Just "v4")) + Nothing + (Path.fromText path) ) ) From f61a4dd2087a3034488ffc3d93e0b8ab855ae3b1 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 31 May 2022 09:56:29 -0600 Subject: [PATCH 259/529] Add more flexibility in our ability to specify codeservers (#3081) * Add explicit types for share host and uri * Ensure we identify servers correctly * Remove ability to pass args to auth.login and remove logic for CodeServers config * PR feedback: special structure for coderserver URI * Add port to CodeserverId --- .../src/Unison/Auth/CredentialManager.hs | 5 +- unison-cli/src/Unison/Auth/Discovery.hs | 16 ++-- unison-cli/src/Unison/Auth/HTTPClient.hs | 13 ++-- unison-cli/src/Unison/Auth/OAuth.hs | 14 ++-- unison-cli/src/Unison/Auth/Tokens.hs | 7 +- unison-cli/src/Unison/Auth/Types.hs | 20 ++--- .../src/Unison/Codebase/Editor/HandleInput.hs | 10 +-- .../Codebase/Editor/HandleInput/AuthLogin.hs | 33 +++++--- .../src/Unison/Codebase/Editor/Input.hs | 4 +- .../src/Unison/CommandLine/InputPatterns.hs | 45 +++++------ .../src/Unison/CommandLine/OutputMessages.hs | 8 +- unison-cli/src/Unison/Share/Types.hs | 75 +++++++++++++++++++ unison-cli/unison-cli.cabal | 1 + 13 files changed, 161 insertions(+), 90 deletions(-) create mode 100644 unison-cli/src/Unison/Share/Types.hs diff --git a/unison-cli/src/Unison/Auth/CredentialManager.hs b/unison-cli/src/Unison/Auth/CredentialManager.hs index 2fe907c508..07ac0847fb 100644 --- a/unison-cli/src/Unison/Auth/CredentialManager.hs +++ b/unison-cli/src/Unison/Auth/CredentialManager.hs @@ -11,6 +11,7 @@ where import Unison.Auth.CredentialFile import Unison.Auth.Types import Unison.Prelude +import Unison.Share.Types (CodeserverId) import qualified UnliftIO -- | A 'CredentialManager' knows how to load, save, and cache credentials. @@ -21,7 +22,7 @@ import qualified UnliftIO newtype CredentialManager = CredentialManager (UnliftIO.MVar Credentials) -- | Saves credentials to the active profile. -saveTokens :: UnliftIO.MonadUnliftIO m => CredentialManager -> Host -> Tokens -> m () +saveTokens :: UnliftIO.MonadUnliftIO m => CredentialManager -> CodeserverId -> Tokens -> m () saveTokens credManager aud tokens = do void . modifyCredentials credManager $ setActiveTokens aud tokens @@ -32,7 +33,7 @@ modifyCredentials (CredentialManager credsVar) f = do newCreds <- atomicallyModifyCredentialsFile f pure (newCreds, newCreds) -getTokens :: MonadIO m => CredentialManager -> Host -> m (Either CredentialFailure Tokens) +getTokens :: MonadIO m => CredentialManager -> CodeserverId -> m (Either CredentialFailure Tokens) getTokens (CredentialManager credsVar) aud = do creds <- UnliftIO.readMVar credsVar pure $ getActiveTokens aud creds diff --git a/unison-cli/src/Unison/Auth/Discovery.hs b/unison-cli/src/Unison/Auth/Discovery.hs index c81a7eee36..f95a7d828b 100644 --- a/unison-cli/src/Unison/Auth/Discovery.hs +++ b/unison-cli/src/Unison/Auth/Discovery.hs @@ -4,19 +4,19 @@ import qualified Data.Aeson as Aeson import qualified Data.Text as Text import qualified Network.HTTP.Client as HTTP import Network.URI -import qualified Network.URI as URI import Unison.Auth.Types import Unison.Prelude +import Unison.Share.Types (CodeserverURI (..), codeserverToURI) import qualified UnliftIO -discoveryURI :: Host -> Either CredentialFailure URI -discoveryURI (Host host) = - maybeToEither (InvalidHost (Host host)) (URI.parseURI ("https://" <> Text.unpack host)) <&> \host -> - host {uriPath = "/.well-known/openid-configuration"} +discoveryURI :: CodeserverURI -> URI +discoveryURI cs = + let uri = codeserverToURI cs + in uri {uriPath = uriPath uri <> "/.well-known/openid-configuration"} -discoveryForHost :: MonadIO m => HTTP.Manager -> Host -> m (Either CredentialFailure DiscoveryDoc) -discoveryForHost httpClient host = liftIO . UnliftIO.try @_ @CredentialFailure $ do - uri <- UnliftIO.fromEither $ discoveryURI host +discoveryForCodeserver :: MonadIO m => HTTP.Manager -> CodeserverURI -> m (Either CredentialFailure DiscoveryDoc) +discoveryForCodeserver httpClient host = liftIO . UnliftIO.try @_ @CredentialFailure $ do + let uri = discoveryURI host req <- HTTP.requestFromURI uri resp <- HTTP.httpLbs req httpClient case Aeson.eitherDecode (HTTP.responseBody $ resp) of diff --git a/unison-cli/src/Unison/Auth/HTTPClient.hs b/unison-cli/src/Unison/Auth/HTTPClient.hs index 60f22db599..fe98a1ac1f 100644 --- a/unison-cli/src/Unison/Auth/HTTPClient.hs +++ b/unison-cli/src/Unison/Auth/HTTPClient.hs @@ -1,4 +1,4 @@ -module Unison.Auth.HTTPClient (newAuthorizedHTTPClient, AuthorizedHttpClient(..)) where +module Unison.Auth.HTTPClient (newAuthorizedHTTPClient, AuthorizedHttpClient (..)) where import qualified Data.Text.Encoding as Text import Network.HTTP.Client (Request) @@ -6,9 +6,9 @@ import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTP import Unison.Auth.CredentialManager (CredentialManager) import Unison.Auth.Tokens (TokenProvider, newTokenProvider) -import Unison.Auth.Types import Unison.Codebase.Editor.Command (UCMVersion) import Unison.Prelude +import Unison.Share.Types (codeserverIdFromURI) import qualified Unison.Util.HTTP as HTTP -- | Newtype to delineate HTTP Managers with access-token logic. @@ -32,7 +32,10 @@ newAuthorizedHTTPClient credsMan ucmVersion = liftIO $ do -- If a host isn't associated with any credentials auth is omitted. authMiddleware :: TokenProvider -> (Request -> IO Request) authMiddleware tokenProvider req = do - result <- tokenProvider (Host . Text.decodeUtf8 $ HTTP.host req) - case result of - Right token -> pure $ HTTP.applyBearerAuth (Text.encodeUtf8 token) req + case (codeserverIdFromURI $ (HTTP.getUri req)) of Left _ -> pure req + Right codeserverHost -> do + result <- tokenProvider codeserverHost + case result of + Right token -> pure $ HTTP.applyBearerAuth (Text.encodeUtf8 token) req + Left _ -> pure req diff --git a/unison-cli/src/Unison/Auth/OAuth.hs b/unison-cli/src/Unison/Auth/OAuth.hs index cc46ceeebd..0a0d8c46cf 100644 --- a/unison-cli/src/Unison/Auth/OAuth.hs +++ b/unison-cli/src/Unison/Auth/OAuth.hs @@ -1,6 +1,6 @@ {-# LANGUAGE RecordWildCards #-} -module Unison.Auth.OAuth (authenticateHost) where +module Unison.Auth.OAuth (authenticateCodeserver) where import qualified Crypto.Hash as Crypto import Crypto.Random (getRandomBytes) @@ -18,12 +18,13 @@ import Network.Wai import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp import Unison.Auth.CredentialManager (CredentialManager, saveTokens) -import Unison.Auth.Discovery (discoveryForHost) +import Unison.Auth.Discovery (discoveryForCodeserver) import Unison.Auth.Types import Unison.Codebase.Editor.HandleInput.LoopState (MonadCommand, respond) import qualified Unison.Codebase.Editor.Output as Output import Unison.Debug import Unison.Prelude +import Unison.Share.Types (CodeserverURI, codeserverIdFromCodeserverURI) import qualified UnliftIO import qualified Web.Browser as Web @@ -46,10 +47,10 @@ authTransferServer callback req respond = -- | Direct the user through an authentication flow with the given server and store the -- credentials in the provided credential manager. -authenticateHost :: forall m n i v. (UnliftIO.MonadUnliftIO m, MonadCommand m n i v) => CredentialManager -> Host -> m (Either CredentialFailure ()) -authenticateHost credsManager host = UnliftIO.try @_ @CredentialFailure $ do +authenticateCodeserver :: forall m n i v. (UnliftIO.MonadUnliftIO m, MonadCommand m n i v) => CredentialManager -> CodeserverURI -> m (Either CredentialFailure ()) +authenticateCodeserver credsManager codeserverURI = UnliftIO.try @_ @CredentialFailure $ do httpClient <- liftIO HTTP.getGlobalManager - doc@(DiscoveryDoc {authorizationEndpoint, tokenEndpoint}) <- throwCredFailure $ discoveryForHost httpClient host + doc@(DiscoveryDoc {authorizationEndpoint, tokenEndpoint}) <- throwCredFailure $ discoveryForCodeserver httpClient codeserverURI debugM Auth "Discovery Doc" doc authResultVar <- UnliftIO.newEmptyMVar @_ @(Either CredentialFailure Tokens) -- The redirect_uri depends on the port, so we need to spin up the server first, but @@ -76,7 +77,8 @@ authenticateHost credsManager host = UnliftIO.try @_ @CredentialFailure $ do void . liftIO $ Web.openBrowser (show authorizationKickoff) respond . Output.InitiateAuthFlow $ authorizationKickoff tokens <- throwCredFailure $ UnliftIO.readMVar authResultVar - saveTokens credsManager host tokens + let codeserverId = codeserverIdFromCodeserverURI codeserverURI + saveTokens credsManager codeserverId tokens where throwCredFailure :: m (Either CredentialFailure a) -> m a throwCredFailure = throwEitherM diff --git a/unison-cli/src/Unison/Auth/Tokens.hs b/unison-cli/src/Unison/Auth/Tokens.hs index 5504934084..05d375197e 100644 --- a/unison-cli/src/Unison/Auth/Tokens.hs +++ b/unison-cli/src/Unison/Auth/Tokens.hs @@ -7,6 +7,7 @@ import Unison.Auth.Types import Unison.CommandLine.InputPattern (patternName) import qualified Unison.CommandLine.InputPatterns as IP import Unison.Prelude +import Unison.Share.Types (CodeserverId) import qualified UnliftIO import UnliftIO.Exception import Web.JWT @@ -21,9 +22,9 @@ isExpired accessToken = liftIO do let expiry = JWT.secondsSinceEpoch expDate pure (now >= expiry) --- | Given a 'Host', provide a valid 'AccessToken' for the associated host. +-- | Given a 'CodeserverId', provide a valid 'AccessToken' for the associated host. -- The TokenProvider may automatically refresh access tokens if we have a refresh token. -type TokenProvider = Host -> IO (Either CredentialFailure AccessToken) +type TokenProvider = CodeserverId -> IO (Either CredentialFailure AccessToken) -- | Creates a 'TokenProvider' using the given 'CredentialManager' newTokenProvider :: CredentialManager -> TokenProvider @@ -38,7 +39,7 @@ newTokenProvider manager host = UnliftIO.try @_ @CredentialFailure $ do else pure accessToken -- | Don't yet support automatically refreshing tokens. -refreshTokens :: MonadIO m => CredentialManager -> Host -> Tokens -> m (Either CredentialFailure Tokens) +refreshTokens :: MonadIO m => CredentialManager -> CodeserverId -> Tokens -> m (Either CredentialFailure Tokens) refreshTokens _manager _host _tokens = -- Refreshing tokens is currently unsupported. pure (Left (RefreshFailure . Text.pack $ "Unable to refresh authentication, please run " <> patternName IP.authLogin <> " and try again.")) diff --git a/unison-cli/src/Unison/Auth/Types.hs b/unison-cli/src/Unison/Auth/Types.hs index 5afd50a5cf..13b745568b 100644 --- a/unison-cli/src/Unison/Auth/Types.hs +++ b/unison-cli/src/Unison/Auth/Types.hs @@ -14,7 +14,6 @@ module Unison.Auth.Types PKCEChallenge, ProfileName, CredentialFailure (..), - Host (..), getActiveTokens, setActiveTokens, emptyCredentials, @@ -22,7 +21,7 @@ module Unison.Auth.Types where import Control.Lens hiding ((.=)) -import Data.Aeson (FromJSON (..), FromJSONKey, KeyValue ((.=)), ToJSON (..), ToJSONKey, (.:), (.:?)) +import Data.Aeson (FromJSON (..), KeyValue ((.=)), ToJSON (..), (.:), (.:?)) import qualified Data.Aeson as Aeson import qualified Data.Map as Map import qualified Data.Text as Text @@ -30,18 +29,19 @@ import Data.Time (NominalDiffTime) import Network.URI import qualified Network.URI as URI import Unison.Prelude +import Unison.Share.Types (CodeserverId, CodeserverURI) defaultProfileName :: ProfileName defaultProfileName = "default" data CredentialFailure - = ReauthRequired Host + = ReauthRequired CodeserverId | CredentialParseFailure FilePath Text | InvalidDiscoveryDocument URI Text | InvalidJWT Text | RefreshFailure Text | InvalidTokenResponse URI Text - | InvalidHost Host + | InvalidHost CodeserverURI deriving stock (Show, Eq) deriving anyclass (Exception) @@ -127,14 +127,8 @@ instance Aeson.FromJSON DiscoveryDoc where type ProfileName = Text --- | The hostname of a server we may authenticate with, --- e.g. @Host "enlil.unison-lang.org"@ -newtype Host = Host Text - deriving stock (Eq, Ord, Show) - deriving newtype (ToJSON, FromJSON, ToJSONKey, FromJSONKey) - data Credentials = Credentials - { credentials :: Map ProfileName (Map Host Tokens), + { credentials :: Map ProfileName (Map CodeserverId Tokens), activeProfile :: ProfileName } deriving (Eq) @@ -142,12 +136,12 @@ data Credentials = Credentials emptyCredentials :: Credentials emptyCredentials = Credentials mempty defaultProfileName -getActiveTokens :: Host -> Credentials -> Either CredentialFailure Tokens +getActiveTokens :: CodeserverId -> Credentials -> Either CredentialFailure Tokens getActiveTokens host (Credentials {credentials, activeProfile}) = maybeToEither (ReauthRequired host) $ credentials ^? ix activeProfile . ix host -setActiveTokens :: Host -> Tokens -> Credentials -> Credentials +setActiveTokens :: CodeserverId -> Tokens -> Credentials -> Credentials setActiveTokens host tokens creds@(Credentials {credentials, activeProfile}) = let newCredMap = credentials diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index aa5853c961..f44213d447 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -29,7 +29,6 @@ import Data.Tuple.Extra (uncurry3) import qualified Text.Megaparsec as P import U.Util.Timing (unsafeTime) import qualified Unison.ABT as ABT -import Unison.Auth.Types (Host (Host)) import qualified Unison.Builtin as Builtin import qualified Unison.Builtin.Decls as DD import qualified Unison.Builtin.Terms as Builtin @@ -1638,14 +1637,7 @@ loop = do UpdateBuiltinsI -> notImplemented QuitI -> empty GistI input -> handleGist input - AuthLoginI mayCodebaseServer -> do - case mayCodebaseServer of - Nothing -> authLogin Nothing - Just codeServer -> do - mayHost <- eval $ ConfigLookup ("CodeServers." <> codeServer) - case mayHost of - Nothing -> respond (UnknownCodeServer codeServer) - Just host -> authLogin (Just $ Host host) + AuthLoginI -> authLogin VersionI -> do ucmVersion <- eval UCMVersion respond $ PrintVersion ucmVersion diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs index bfb4448653..e54e488abb 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs @@ -1,28 +1,37 @@ module Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin) where import Control.Monad.Reader -import qualified Data.Text as Text +import Network.URI (URIAuth (..), parseURI) import System.IO.Unsafe (unsafePerformIO) -import Unison.Auth.OAuth -import Unison.Auth.Types (Host (..)) +import Unison.Auth.OAuth (authenticateCodeserver) import Unison.Codebase.Editor.HandleInput.LoopState import Unison.Codebase.Editor.Output (Output (CredentialFailureMsg, Success)) import Unison.Prelude +import Unison.Share.Types import qualified UnliftIO import UnliftIO.Environment (lookupEnv) -defaultShareHost :: Host -defaultShareHost = unsafePerformIO $ do +-- | This is the URI where the share API is based. +defaultShareURI :: CodeserverURI +defaultShareURI = unsafePerformIO $ do lookupEnv "UNISON_SHARE_HOST" <&> \case -- TODO: swap to production share before release. - Nothing -> Host "share-next.us-west-2.unison-lang.org" - Just shareHost -> Host (Text.pack shareHost) -{-# NOINLINE defaultShareHost #-} + Nothing -> + CodeserverURI + { codeserverScheme = "https:", + codeserverAuthority = URIAuth {uriUserInfo = "", uriRegName = "share-next.us-west-2.unison-lang.org", uriPort = ""}, + codeserverPath = "/api" + } + Just shareHost -> + fromMaybe (error $ "Share Host is not a valid URI: " <> shareHost) $ do + uri <- parseURI shareHost + codeserverFromURI uri +{-# NOINLINE defaultShareURI #-} -authLogin :: UnliftIO.MonadUnliftIO m => Maybe Host -> Action m i v () -authLogin mayHost = do - let host = fromMaybe defaultShareHost mayHost +authLogin :: UnliftIO.MonadUnliftIO m => Action m i v () +authLogin = do + let host = defaultShareURI credsMan <- asks credentialManager - (Action . lift . lift . lift $ authenticateHost credsMan host) >>= \case + (Action . lift . lift . lift $ authenticateCodeserver credsMan host) >>= \case Left err -> respond (CredentialFailureMsg err) Right () -> respond Success diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index b586ee6130..5c91ea715d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -44,8 +44,6 @@ type SourceName = Text -- "foo.u" or "buffer 7" type PatchPath = Path.Split' -type CodebaseServerName = Text - data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath deriving (Eq, Ord, Show) @@ -186,7 +184,7 @@ data Input | UiI | DocsToHtmlI Path' FilePath | GistI GistInput - | AuthLoginI (Maybe CodebaseServerName) + | AuthLoginI | VersionI deriving (Eq, Show) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 68fd8efd8e..3d790fcf71 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -294,23 +294,23 @@ patch = I.Visible [(Required, patchArg), (Optional, namespaceArg)] ( P.lines - [ P.wrap $ - makeExample' patch - <> "rewrites any definitions that depend on " - <> "definitions with type-preserving edits to use the updated versions of" - <> "these dependencies.", - "", - P.wrapColumn2 - [ ( makeExample patch ["", "[path]"], - "applies the given patch" - <> "to the given namespace" - ), - ( makeExample patch [""], - "applies the given patch" - <> "to the current namespace" - ) + [ P.wrap $ + makeExample' patch + <> "rewrites any definitions that depend on " + <> "definitions with type-preserving edits to use the updated versions of" + <> "these dependencies.", + "", + P.wrapColumn2 + [ ( makeExample patch ["", "[path]"], + "applies the given patch" + <> "to the given namespace" + ), + ( makeExample patch [""], + "applies the given patch" + <> "to the current namespace" + ) + ] ] - ] ) ( \case patchStr : ws -> first fromString $ do @@ -2040,20 +2040,15 @@ authLogin = "auth.login" [] I.Hidden - [(Optional, noCompletions)] + [] ( P.lines - [ P.wrap "Obtain an authentication session with Unison Share or a specified codeserver host.", + [ P.wrap "Obtain an authentication session with Unison Share.", makeExample authLogin [] - <> "authenticates ucm with Unison Share.", - makeExample authLogin ["mycodeserver"] - <> "authenticates ucm with the host configured at" - <> P.backticked "CodeServers.mycodeserver" - <> "in your .unisonConfig" + <> "authenticates ucm with Unison Share." ] ) ( \case - [] -> Right $ Input.AuthLoginI Nothing - [codebaseServerName] -> Right . Input.AuthLoginI $ Just (Text.pack codebaseServerName) + [] -> Right $ Input.AuthLoginI _ -> Left (showPatternHelp authLogin) ) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 083c317f4f..b730b820d0 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1547,9 +1547,9 @@ notifyUser dir o = case o of "You can configure code server hosts in your .unisonConfig file." ] CredentialFailureMsg err -> pure $ case err of - Auth.ReauthRequired (Auth.Host host) -> + Auth.ReauthRequired host -> P.lines - [ "Authentication for host " <> P.red (P.text host) <> " is required.", + [ "Authentication for host " <> P.red (P.shown host) <> " is required.", "Run " <> IP.makeExample IP.help [IP.patternName IP.authLogin] <> " to learn how." ] @@ -1575,9 +1575,9 @@ notifyUser dir o = case o of [ "Failed to parse token response from authentication server: " <> prettyURI uri, "The error was: " <> P.text txt ] - Auth.InvalidHost (Auth.Host host) -> + Auth.InvalidHost host -> P.lines - [ "Failed to parse a URI from the hostname: " <> P.text host <> ".", + [ "Failed to parse a URI from the hostname: " <> P.shown host <> ".", "Host names should NOT include a schema or path." ] PrintVersion ucmVersion -> pure (P.text ucmVersion) diff --git a/unison-cli/src/Unison/Share/Types.hs b/unison-cli/src/Unison/Share/Types.hs new file mode 100644 index 0000000000..0436a90b04 --- /dev/null +++ b/unison-cli/src/Unison/Share/Types.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} + +module Unison.Share.Types + ( CodeserverURI (..), + CodeserverId (..), + codeserverFromURI, + codeserverIdFromURI, + codeserverToURI, + codeserverIdFromCodeserverURI, + ) +where + +import Data.Aeson +import Data.Text +import qualified Data.Text as Text +import Network.URI +import Unison.Prelude + +data CodeserverURI = CodeserverURI + { codeserverScheme :: String, + codeserverAuthority :: URIAuth, + codeserverPath :: String + } + deriving stock (Show, Eq, Ord) + +codeserverToURI :: CodeserverURI -> URI +codeserverToURI (CodeserverURI {..}) = + URI + { uriScheme = codeserverScheme, + uriAuthority = Just codeserverAuthority, + uriPath = codeserverPath, + uriQuery = "", + uriFragment = "" + } + +codeserverFromURI :: URI -> Maybe CodeserverURI +codeserverFromURI URI {..} = do + uriAuth <- uriAuthority + pure $ + CodeserverURI + { codeserverScheme = uriScheme, + codeserverAuthority = uriAuth, + codeserverPath = uriPath + } + +-- | This is distinct from the codeserver URI in that we store credentials by a normalized ID, since it's +-- much easier to look up that way than from an arbitrary path. +-- We may wish to use explicitly named configurations in the future. +-- This currently uses a stringified uriAuthority. +newtype CodeserverId = CodeserverId {codeserverId :: Text} + deriving newtype (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey) + +-- | Gets the part of the CodeserverURI that we use for identifying that codeserver in +-- credentials files. +-- +-- >>> import Data.Maybe (fromJust) +-- >>> import Network.URI (parseURI) +-- >>> codeserverIdFromURI (CodeserverURI . fromJust $ parseURI "http://localhost:5424/api") +-- >>> codeserverIdFromURI (CodeserverURI . fromJust $ parseURI "https://share.unison-lang.org/api") +-- Right "localhost" +-- Right "share.unison-lang.org" +codeserverIdFromURI :: URI -> Either Text CodeserverId +codeserverIdFromURI uri = + case uriAuthority uri of + Nothing -> Left $ "No URI Authority for URI " <> tShow uri + Just ua -> pure $ codeserverIdFromURIAuth ua + +codeserverIdFromURIAuth :: URIAuth -> CodeserverId +codeserverIdFromURIAuth ua = + (CodeserverId (Text.pack $ uriUserInfo ua <> uriRegName ua <> uriPort ua)) + +codeserverIdFromCodeserverURI :: CodeserverURI -> CodeserverId +codeserverIdFromCodeserverURI = + codeserverIdFromURIAuth . codeserverAuthority diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 50d4ba2e96..9dd47d58ce 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -59,6 +59,7 @@ library Unison.CommandLine.Main Unison.CommandLine.OutputMessages Unison.CommandLine.Welcome + Unison.Share.Types Unison.Sync.HTTP Unison.Util.HTTP other-modules: From bd312a74d4dd279257ee175316f01746660250ac Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 31 May 2022 15:23:33 -0400 Subject: [PATCH 260/529] fixing up some sync bugs --- .../U/Codebase/Sqlite/Queries.hs | 26 +++++++++++++++---- unison-share-api/src/Unison/Sync/Types.hs | 16 ++++++------ 2 files changed, 29 insertions(+), 13 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 7716b81057..24251e2ec7 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -502,10 +502,26 @@ expectPatchObjectIdForHash32 = fmap PatchObjectId . expectObjectIdForHash32 expectBranchHashIdForHash32 :: Base32Hex -> Transaction BranchHashId -expectBranchHashIdForHash32 = undefined +expectBranchHashIdForHash32 = queryOneCol sql . Only + where + sql = + [here| + SELECT hash.id FROM object + INNER JOIN hash_object ON hash_object.object_id = object.id + INNER JOIN hash ON hash_object.hash_id = hash.id + WHERE object.type_id = 2 + AND hash.base32 = ? + |] expectCausalHashIdForHash32 :: Base32Hex -> Transaction CausalHashId -expectCausalHashIdForHash32 = undefined +expectCausalHashIdForHash32 = queryOneCol sql . Only + where + sql = + [here| + SELECT self_hash_id + FROM causal INNER JOIN hash ON hash.id = self_hash_id + WHERE base32 = ? + |] loadPatchObjectIdForPrimaryHash :: PatchHash -> Transaction (Maybe PatchObjectId) loadPatchObjectIdForPrimaryHash = @@ -695,7 +711,7 @@ expectTempEntity b32 = do TempEntityType.PatchType -> Entity.P <$> decodeTempPatchFormat blob TempEntityType.CausalType -> Entity.C <$> decodeTempCausalFormat blob where sql = [here| - SELECT (blob, type_id) + SELECT blob, type_id FROM temp_entity WHERE hash = ? |] @@ -1459,14 +1475,14 @@ insertTempEntity :: Base32Hex -> TempEntity -> NESet (Base32Hex, Text) -> Transa insertTempEntity entityHash entity missingDependencies = do execute [here| - INSERT INTO temp_entity (hash, blob, typeId) + INSERT INTO temp_entity (hash, blob, type_id) VALUES (?, ?, ?) |] (entityHash, entityBlob, entityType) executeMany [here| - INSERT INTO temp_entity_missing_dependencies (dependent, dependency, dependencyJwt) + INSERT INTO temp_entity_missing_dependency (dependent, dependency, dependencyJwt) VALUES (?, ?, ?) |] (map (\(depHash, depHashJwt) -> (entityHash, depHash, depHashJwt)) (Foldable.toList missingDependencies)) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index c2edd7a79d..86136dc681 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -278,7 +278,7 @@ entityDependencies = \case Set.fromList patchLookup, foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup ] - C Causal {parents} -> parents + C Causal {namespaceHash, parents} -> Set.insert namespaceHash parents data TermComponent text hash = TermComponent [(LocalIds text hash, ByteString)] deriving stock (Show, Eq, Ord) @@ -299,6 +299,12 @@ instance (ToJSON text, ToJSON hash) => ToJSON (TermComponent text hash) where [ "terms" .= (encodeComponentPiece <$> components) ] +instance (FromJSON text, FromJSON hash) => FromJSON (TermComponent text hash) where + parseJSON = Aeson.withObject "TermComponent" \obj -> do + pieces <- obj .: "terms" + terms <- traverse decodeComponentPiece pieces + pure (TermComponent terms) + bitraverseComponents :: Applicative f => (a -> f a') -> @@ -320,15 +326,9 @@ encodeComponentPiece (localIDs, bytes) = decodeComponentPiece :: (FromJSON text, FromJSON hash) => Value -> Aeson.Parser (LocalIds text hash, ByteString) decodeComponentPiece = Aeson.withObject "Component Piece" \obj -> do localIDs <- obj .: "local_ids" - Base64Bytes bytes <- obj .: "local_ids" + Base64Bytes bytes <- obj .: "bytes" pure (localIDs, bytes) -instance (FromJSON text, FromJSON hash) => FromJSON (TermComponent text hash) where - parseJSON = Aeson.withObject "TermComponent" \obj -> do - pieces <- obj .: "terms" - terms <- traverse decodeComponentPiece pieces - pure (TermComponent terms) - data DeclComponent text hash = DeclComponent [(LocalIds text hash, ByteString)] deriving stock (Show, Eq, Ord) From 8adb6fde3d3f5b28ef82269611daed674cca4814 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 31 May 2022 17:00:11 -0400 Subject: [PATCH 261/529] update tryMoveTempEntityDependents --- .../U/Codebase/Sqlite/Queries.hs | 24 +++++++------------ 1 file changed, 9 insertions(+), 15 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 24251e2ec7..577e3826a4 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -621,30 +621,24 @@ flushCausalDependents chId = do -- Note: beef up insert_entity procedure to flush temp_entity table --- | flushTempEntity does this: --- 1. When inserting object #foo, --- look up all dependents of #foo in --- temp_entity_missing_dependency table (say #bar, #baz). --- 2. Delete (#bar, #foo) and (#baz, #foo) from temp_entity_missing_dependency. +-- | tryMoveTempEntityDependents does this: +-- 0. Precondition: We just inserted object #foo. +-- 1. Delete #foo as dependency from temp_entity_missing_dependency. e.g. (#bar, #foo), (#baz, #foo) -- 3. Delete #foo from temp_entity (if it's there) -- 4. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, -- insert_entity them. --- --- Precondition: Must have inserted the entity with hash b32 already. tryMoveTempEntityDependents :: Base32Hex -> Transaction () tryMoveTempEntityDependents dependencyBase32 = do - dependents <- getMissingDependentsForTempEntity dependencyBase32 - executeMany deleteTempDependents (dependents <&> (,dependencyBase32)) + + execute deleteMissingDependency (Only dependencyBase32) deleteTempEntity dependencyBase32 traverse_ moveTempEntityToMain =<< tempEntitiesWithNoMissingDependencies where - deleteTempDependents :: Sql - deleteTempDependents = [here| + deleteMissingDependency :: Sql + deleteMissingDependency = [here| DELETE FROM temp_entity_missing_dependency - WHERE dependent = ? - AND dependency = ? + WHERE dependency = ? |] - tempEntitiesWithNoMissingDependencies :: Transaction [Base32Hex] tempEntitiesWithNoMissingDependencies = queryListCol_ [here| SELECT hash @@ -698,7 +692,7 @@ moveTempEntityToMain b32 = do t <- expectTempEntity b32 r <- tempToSyncEntity t _ <- saveSyncEntity b32 r - pure () + deleteTempEntity b32 -- | Read an entity out of temp storage. expectTempEntity :: Base32Hex -> Transaction TempEntity From 54f5b0b8a812669bc866b5552737231663bd8c05 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 31 May 2022 17:55:27 -0400 Subject: [PATCH 262/529] fix tryMoveTempEntityDependents differently --- .../U/Codebase/Sqlite/Queries.hs | 31 ++++++++++--------- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 4 ++- 2 files changed, 20 insertions(+), 15 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 577e3826a4..4aa2d48c61 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -619,36 +619,39 @@ flushCausalDependents chId = do hash <- expectHash32 (unCausalHashId chId) tryMoveTempEntityDependents hash --- Note: beef up insert_entity procedure to flush temp_entity table - -- | tryMoveTempEntityDependents does this: -- 0. Precondition: We just inserted object #foo. -- 1. Delete #foo as dependency from temp_entity_missing_dependency. e.g. (#bar, #foo), (#baz, #foo) --- 3. Delete #foo from temp_entity (if it's there) --- 4. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, +-- 2. Delete #foo from temp_entity (if it's there) +-- 3. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, -- insert_entity them. tryMoveTempEntityDependents :: Base32Hex -> Transaction () tryMoveTempEntityDependents dependencyBase32 = do - + dependents <- getMissingDependentsForTempEntity dependencyBase32 execute deleteMissingDependency (Only dependencyBase32) deleteTempEntity dependencyBase32 - traverse_ moveTempEntityToMain =<< tempEntitiesWithNoMissingDependencies + traverse_ moveIfNoDependencies dependents where deleteMissingDependency :: Sql deleteMissingDependency = [here| DELETE FROM temp_entity_missing_dependency WHERE dependency = ? |] - tempEntitiesWithNoMissingDependencies :: Transaction [Base32Hex] - tempEntitiesWithNoMissingDependencies = queryListCol_ [here| - SELECT hash - FROM temp_entity - WHERE NOT EXISTS( + + moveIfNoDependencies :: Base32Hex -> Transaction () + moveIfNoDependencies dependent = do + hasMissingDependencies dependent >>= \case + True -> pure () + False -> moveTempEntityToMain dependent + + hasMissingDependencies :: Base32Hex -> Transaction Bool + hasMissingDependencies = queryOneCol [here| + SELECT EXISTS ( SELECT 1 - FROM temp_entity_missing_dependency dep - WHERE dep.dependent = temp_entity.hash + FROM temp_entity_missing_dependency + WHERE dependent = ? ) - |] + |] . Only expectCausal :: CausalHashId -> Transaction Causal.SyncCausalFormat expectCausal hashId = do diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 4eeed6055b..d7e6fe5c9a 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -25,7 +25,9 @@ data ShareRepo = ShareRepo deriving (Eq, Show) shareRepoToBaseUrl :: ShareRepo -> Servant.BaseUrl -shareRepoToBaseUrl ShareRepo = Servant.BaseUrl Servant.Https "share.unison.cloud" 443 "" +shareRepoToBaseUrl ShareRepo = + Servant.BaseUrl Servant.Http "localhost" 5424 "sync" + data WriteRepo = WriteRepoGit WriteGitRepo From 12630958b49d85801e41f7b055c7bd7f3ea01408 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 31 May 2022 19:29:15 -0400 Subject: [PATCH 263/529] wrap a couple output messages (for spaces) --- unison-cli/src/Unison/CommandLine/OutputMessages.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index a5df238d36..6f5d961e43 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1657,9 +1657,9 @@ notifyUser dir o = case o of _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" expectedNonEmptyPushDest writeRemotePath = P.lines - [ "The remote namespace" <> prettyWriteRemotePath writeRemotePath <> "is empty.", + [ P.wrap ("The remote namespace" <> prettyWriteRemotePath writeRemotePath <> "is empty."), "", - "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" + P.wrap ("Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?") ] sharePathToWriteRemotePathShare sharePath = -- Recover the original WriteRemotePath from the information in the error, which is thrown from generic share From f1a6cfb0c000045ca055b9450f7eb14f35ce5771 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 31 May 2022 19:50:25 -0400 Subject: [PATCH 264/529] flushIfReadyToFlush --- .../U/Codebase/Sqlite/Queries.hs | 22 +++++++++++-------- 1 file changed, 13 insertions(+), 9 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 4aa2d48c61..2a2a84b62f 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -630,7 +630,7 @@ tryMoveTempEntityDependents dependencyBase32 = do dependents <- getMissingDependentsForTempEntity dependencyBase32 execute deleteMissingDependency (Only dependencyBase32) deleteTempEntity dependencyBase32 - traverse_ moveIfNoDependencies dependents + traverse_ flushIfReadyToFlush dependents where deleteMissingDependency :: Sql deleteMissingDependency = [here| @@ -638,20 +638,24 @@ tryMoveTempEntityDependents dependencyBase32 = do WHERE dependency = ? |] - moveIfNoDependencies :: Base32Hex -> Transaction () - moveIfNoDependencies dependent = do - hasMissingDependencies dependent >>= \case - True -> pure () - False -> moveTempEntityToMain dependent + flushIfReadyToFlush :: Base32Hex -> Transaction () + flushIfReadyToFlush dependent = do + readyToFlush dependent >>= \case + True -> moveTempEntityToMain dependent + False -> pure () - hasMissingDependencies :: Base32Hex -> Transaction Bool - hasMissingDependencies = queryOneCol [here| + readyToFlush :: Base32Hex -> Transaction Bool + readyToFlush b32 = queryOneCol [here| SELECT EXISTS ( + SELECT 1 + FROM temp_entity + WHERE hash = ? + ) AND NOT EXISTS ( SELECT 1 FROM temp_entity_missing_dependency WHERE dependent = ? ) - |] . Only + |] (b32, b32) expectCausal :: CausalHashId -> Transaction Causal.SyncCausalFormat expectCausal hashId = do From 51677b9a3d9819aed386d53e4e3a3f0fb597de75 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 1 Jun 2022 15:04:03 -0600 Subject: [PATCH 265/529] Fix incorrect ToJWT/FromJWT instances for HashJWT --- unison-share-api/package.yaml | 1 + unison-share-api/src/Unison/Sync/Types.hs | 15 +++++++++++++-- unison-share-api/unison-share-api.cabal | 1 + 3 files changed, 15 insertions(+), 2 deletions(-) diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 6ea021cc31..0e5418e93e 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -19,6 +19,7 @@ dependencies: - fuzzyfind - http-media - http-types + - jose - jwt - lens - lucid diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 86136dc681..a5a636695b 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -71,7 +71,8 @@ module Unison.Sync.Types ) where -import Control.Lens (both, traverseOf) +import Control.Lens (both, ix, traverseOf, (^?)) +import qualified Crypto.JWT as Jose import Data.Aeson import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson @@ -158,7 +159,17 @@ data HashJWTClaims = HashJWTClaims -- entityType :: EntityType } deriving stock (Show, Eq, Ord) - deriving anyclass (ToJWT, FromJWT) -- uses JSON instances + +instance ToJWT HashJWTClaims where + encodeJWT (HashJWTClaims h) = + Jose.addClaim "h" (toJSON h) Jose.emptyClaimsSet + +instance FromJWT HashJWTClaims where + decodeJWT claims = case claims ^? Jose.unregisteredClaims . ix "h" of + Nothing -> Left "Missing 'h' claim on HashJWT" + Just v + | Success hash <- fromJSON v -> Right $ HashJWTClaims hash + | otherwise -> Left "Invalid hash at 'h' claim in HashJWT" instance ToJSON HashJWTClaims where toJSON (HashJWTClaims hash) = diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index b668ab4a27..c03c125951 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -81,6 +81,7 @@ library , fuzzyfind , http-media , http-types + , jose , jwt , lens , lucid From 4e7b4c2a4237d10add7c5cb265503374113e4423 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Wed, 1 Jun 2022 18:23:14 -0400 Subject: [PATCH 266/529] tweak fixes --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 3 ++- unison-cli/src/Unison/CommandLine/OutputMessages.hs | 4 ++-- 2 files changed, 4 insertions(+), 3 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 2a2a84b62f..4ef6278942 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -697,9 +697,10 @@ expectEntity hash = do moveTempEntityToMain :: Base32Hex -> Transaction () moveTempEntityToMain b32 = do t <- expectTempEntity b32 + deleteTempEntity b32 r <- tempToSyncEntity t _ <- saveSyncEntity b32 r - deleteTempEntity b32 + pure () -- | Read an entity out of temp storage. expectTempEntity :: Base32Hex -> Transaction TempEntity diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 6f5d961e43..771a4e8d4e 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1647,9 +1647,9 @@ notifyUser dir o = case o of handleGetCausalHashByPathError = \case Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermission sharePath noReadPermission sharePath = - P.wrap $ P.text "The server said you don't have permission to read" <> prettySharePath sharePath + P.wrap $ P.text "The server said you don't have permission to read" <> P.group (prettySharePath sharePath <> ".") noWritePermission sharePath = - P.wrap $ P.text "The server said you don't have permission to write" <> prettySharePath sharePath + P.wrap $ P.text "The server said you don't have permission to write" <> P.group (prettySharePath sharePath <> ".") IntegrityCheck result -> pure $ case result of NoIntegrityErrors -> "๐ŸŽ‰ No issues detected ๐ŸŽ‰" IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns From 785e71359e24b95b833dd1c0e9666cf38db214e3 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 1 Jun 2022 16:42:54 -0600 Subject: [PATCH 267/529] Extract update names index logic for easier use with sync algorithms --- .../src/Unison/Sqlite/Transaction.hs | 4 +++ .../src/Unison/Codebase/SqliteCodebase.hs | 13 ++------- .../Codebase/SqliteCodebase/Operations.hs | 27 +++++++++++++++++-- 3 files changed, 31 insertions(+), 13 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 6c316385f9..8fbcebb97e 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -7,6 +7,7 @@ module Unison.Sqlite.Transaction unsafeUnTransaction, savepoint, unsafeIO, + unsafeGetConnection, -- * Executing queries @@ -80,6 +81,9 @@ newtype Transaction a -- Omit MonadThrow instance so we always throw SqliteException (via *Check) with lots of context deriving (Applicative, Functor, Monad) via (ReaderT Connection IO) +unsafeGetConnection :: Transaction Connection +unsafeGetConnection = Transaction pure + -- | Run a transaction on the given connection. runTransaction :: MonadIO m => Connection -> Transaction a -> m a runTransaction conn (Transaction f) = liftIO do diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index f995afd29a..38bd6ea72d 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -29,7 +29,6 @@ import qualified System.FilePath as FilePath import qualified System.FilePath.Posix as FilePath.Posix import qualified U.Codebase.Branch as V2Branch import U.Codebase.HashTags (CausalHash (CausalHash)) -import qualified U.Codebase.Reference as C.Reference import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Q import qualified U.Codebase.Sqlite.Sync22 as Sync22 @@ -41,7 +40,6 @@ import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase1 import Unison.Codebase.Branch (Branch (..)) import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Codebase.Branch.Names as Branch import qualified Unison.Codebase.Causal.Type as Causal import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo) import qualified Unison.Codebase.Editor.Git as Git @@ -69,7 +67,6 @@ import qualified Unison.Codebase.SqliteCodebase.SyncEphemeral as SyncEphemeral import Unison.Codebase.SyncMode (SyncMode) import Unison.Codebase.Type (LocalOrRemote (..), PushGitBranchOpts (..)) import qualified Unison.Codebase.Type as C -import qualified Unison.ConstructorType as CT import Unison.DataDeclaration (Decl) import Unison.Hash (Hash) import Unison.Parser.Ann (Ann) @@ -204,20 +201,16 @@ sqliteCodebase debugName root localOrRemote action = do typeOfTermCache <- Cache.semispaceCache 8192 declCache <- Cache.semispaceCache 1024 rootBranchCache <- newTVarIO Nothing + getDeclType <- CodebaseOps.mkGetDeclType -- The v1 codebase interface has operations to read and write individual definitions -- whereas the v2 codebase writes them as complete components. These two fields buffer -- the individual definitions until a complete component has been written. termBuffer :: TVar (Map Hash CodebaseOps.TermBufferEntry) <- newTVarIO Map.empty declBuffer :: TVar (Map Hash CodebaseOps.DeclBufferEntry) <- newTVarIO Map.empty - declTypeCache <- Cache.semispaceCache 2048 let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann)) getTerm id = Sqlite.runTransaction conn (CodebaseOps.getTerm getDeclType id) - getDeclType :: C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType - getDeclType = - Sqlite.unsafeIO . Cache.apply declTypeCache (\ref -> Sqlite.unsafeUnTransaction (CodebaseOps.getDeclType ref) conn) - getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann)) getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined getTypeOfTermImpl id = @@ -496,9 +489,7 @@ sqliteCodebase debugName root localOrRemote action = do beforeImpl = (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r), namesAtPath = \path -> Sqlite.runReadOnlyTransaction conn \runTx -> runTx (CodebaseOps.namesAtPath path), - updateNameLookup = Sqlite.runTransaction conn $ do - root <- (CodebaseOps.getRootBranch getDeclType rootBranchCache) - CodebaseOps.saveRootNamesIndex (Branch.toNames . Branch.head $ root), + updateNameLookup = Sqlite.runTransaction conn $ CodebaseOps.updateNameLookupIndex getDeclType, connection = conn } let finalizer :: MonadIO m => m () diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 31d0d335f3..8e4e20f3b1 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -23,10 +23,12 @@ import qualified U.Codebase.Sqlite.NamedRef as S import qualified U.Codebase.Sqlite.ObjectType as OT import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Q +import qualified U.Util.Cache as Cache import qualified U.Util.Hash as H2 import qualified Unison.Builtin as Builtins import Unison.Codebase.Branch (Branch (..)) import qualified Unison.Codebase.Branch as Branch +import qualified Unison.Codebase.Branch.Names as Branch import qualified Unison.Codebase.Causal.Type as Causal import Unison.Codebase.Patch (Patch) import Unison.Codebase.Path (Path) @@ -55,6 +57,7 @@ import qualified Unison.ShortHash as SH import qualified Unison.ShortHash as ShortHash import Unison.Sqlite (Transaction) import qualified Unison.Sqlite as Sqlite +import qualified Unison.Sqlite.Transaction as Sqlite import Unison.Symbol (Symbol) import Unison.Term (Term) import qualified Unison.Term as Term @@ -359,12 +362,18 @@ getRootBranch doGetDeclType rootBranchCache = where forceReload :: Transaction (Branch Transaction) forceReload = do - causal2 <- Ops.expectRootCausal - branch1 <- Cv.causalbranch2to1 doGetDeclType causal2 + branch1 <- uncachedLoadRootBranch doGetDeclType ver <- Sqlite.getDataVersion Sqlite.unsafeIO (atomically (writeTVar rootBranchCache (Just (ver, branch1)))) pure branch1 +uncachedLoadRootBranch :: + (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> + Transaction (Branch Transaction) +uncachedLoadRootBranch getDeclType = do + causal2 <- Ops.expectRootCausal + Cv.causalbranch2to1 getDeclType causal2 + getRootBranchExists :: Transaction Bool getRootBranchExists = isJust <$> Ops.loadRootCausalHash @@ -602,3 +611,17 @@ saveRootNamesIndex Names {Names.terms, Names.types} = do splitReferent referent = case referent of Referent.Ref {} -> (Cv.referent1to2 referent, Nothing) Referent.Con _ref ct -> (Cv.referent1to2 referent, Just (Cv.constructorType1to2 ct)) + +mkGetDeclType :: MonadIO m => m (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) +mkGetDeclType = do + declTypeCache <- Cache.semispaceCache 2048 + pure $ \ref -> do + conn <- Sqlite.unsafeGetConnection + Sqlite.unsafeIO $ Cache.apply declTypeCache (\ref -> Sqlite.unsafeUnTransaction (getDeclType ref) conn) ref + +-- | Update the root namespace names index which is used by the share server for serving api +-- requests. +updateNameLookupIndex :: (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> Sqlite.Transaction () +updateNameLookupIndex getDeclType = do + root <- uncachedLoadRootBranch getDeclType + saveRootNamesIndex (Branch.toNames . Branch.head $ root) From 4d7a9452ae793fd07d105f22d7559a8c72eca63f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 2 Jun 2022 14:22:40 -0600 Subject: [PATCH 268/529] Set journal mode on create rather than open. --- parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 8a57a57a71..8ff6d62484 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -131,7 +131,8 @@ createCodebaseOrError debugName path action = do (pure $ Left Codebase1.CreateCodebaseAlreadyExists) do createDirectoryIfMissing True (makeCodebaseDirPath path) - withConnection (debugName ++ ".createSchema") path \conn -> + withConnection (debugName ++ ".createSchema") path \conn -> do + liftIO $ Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL Sqlite.runTransaction conn do Q.createSchema void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty @@ -178,9 +179,7 @@ withConnection :: (Sqlite.Connection -> m a) -> m a withConnection name root action = - Sqlite.withConnection name (makeCodebasePath root) \conn -> do - liftIO (Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL) - action conn + Sqlite.withConnection name (makeCodebasePath root) action sqliteCodebase :: forall m r. From 548e84b31a33ec9f85fb0205a20f8fa7adae2757 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 2 Jun 2022 14:34:22 -0600 Subject: [PATCH 269/529] Set WAL mode when viewing remote branches. --- lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs | 6 +++--- parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs | 8 ++++++-- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs b/lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs index f0a164131c..7c4afdcf5c 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs @@ -8,9 +8,9 @@ where import qualified Data.Text as Text import qualified Database.SQLite.Simple as Sqlite import Unison.Prelude +import Unison.Sqlite.Connection import Unison.Sqlite.Exception (SqliteExceptionReason) import Unison.Sqlite.Sql -import Unison.Sqlite.Connection -- | https://www.sqlite.org/pragma.html#pragma_journal_mode data JournalMode @@ -45,8 +45,8 @@ journalModeToText = \case JournalMode'WAL -> "wal" JournalMode'OFF -> "off" -trySetJournalMode :: Connection -> JournalMode -> IO () -trySetJournalMode conn mode0 = do +trySetJournalMode :: MonadIO m => Connection -> JournalMode -> m () +trySetJournalMode conn mode0 = liftIO $ do queryOneRowCheck_ conn (Sql ("PRAGMA journal_mode = " <> journalModeToText mode0)) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 8ff6d62484..e03b73efe4 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -132,7 +132,7 @@ createCodebaseOrError debugName path action = do do createDirectoryIfMissing True (makeCodebaseDirPath path) withConnection (debugName ++ ".createSchema") path \conn -> do - liftIO $ Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL + Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL Sqlite.runTransaction conn do Q.createSchema void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty @@ -687,6 +687,10 @@ viewRemoteBranch' (repo, sbh, path) gitBranchBehavior action = UnliftIO.try $ do time "Git fetch" $ throwEitherMWith C.GitProtocolError . withRepo repo gitBranchBehavior $ \remoteRepo -> do let remotePath = Git.gitDirToPath remoteRepo + -- In modern UCM all new codebases are created in WAL mode, but it's possible old + -- codebases were pushed to git in DELETE mode, so when pulling remote branches we + -- ensure we're in WAL mode just to be safe. + ensureWALMode conn = Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL -- Tickle the database before calling into `sqliteCodebase`; this covers the case that the database file either -- doesn't exist at all or isn't a SQLite database file, but does not cover the case that the database file itself -- is somehow corrupt, or not even a Unison database. @@ -694,7 +698,7 @@ viewRemoteBranch' (repo, sbh, path) gitBranchBehavior action = UnliftIO.try $ do -- FIXME it would probably make more sense to define some proper preconditions on `sqliteCodebase`, and perhaps -- update its output type, which currently indicates the only way it can fail is with an `UnknownSchemaVersion` -- error. - (withConnection "codebase exists check" remotePath \_ -> pure ()) `catch` \exception -> + (withConnection "codebase exists check" remotePath ensureWALMode) `catch` \exception -> if Sqlite.isCantOpenException exception then throwIO (C.GitSqliteCodebaseError (GitError.NoDatabaseFile repo remotePath)) else throwIO exception From de62ee01d2246a19299cafaca96afec207bdc15f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 2 Jun 2022 15:10:09 -0600 Subject: [PATCH 270/529] Update lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs Co-authored-by: Mitchell Rosen --- lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs b/lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs index 7c4afdcf5c..67537eff6e 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/JournalMode.hs @@ -46,7 +46,7 @@ journalModeToText = \case JournalMode'OFF -> "off" trySetJournalMode :: MonadIO m => Connection -> JournalMode -> m () -trySetJournalMode conn mode0 = liftIO $ do +trySetJournalMode conn mode0 = liftIO do queryOneRowCheck_ conn (Sql ("PRAGMA journal_mode = " <> journalModeToText mode0)) From df33c1e25748e7487400b03750503531a751e090 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 2 Jun 2022 17:10:59 -0400 Subject: [PATCH 271/529] add when/Paths_ stuff to every package.yaml target didn't put it into another PR, I'm sorry. But we can cherry-pick this out in a separate PR --- codebase2/codebase-sqlite/package.yaml | 3 +++ .../codebase-sqlite/unison-codebase-sqlite.cabal | 2 -- codebase2/codebase-sync/package.yaml | 3 +++ codebase2/codebase-sync/unison-codebase-sync.cabal | 4 +--- codebase2/codebase/package.yaml | 3 +++ codebase2/codebase/unison-codebase.cabal | 2 -- codebase2/core/package.yaml | 3 +++ codebase2/core/unison-core.cabal | 4 +--- codebase2/util-serialization/package.yaml | 3 +++ .../unison-util-serialization.cabal | 4 +--- codebase2/util-term/package.yaml | 3 +++ codebase2/util-term/unison-util-term.cabal | 4 +--- codebase2/util/package.yaml | 7 +++++++ codebase2/util/unison-util.cabal | 5 +---- lib/unison-prelude/package.yaml | 3 +++ lib/unison-prelude/unison-prelude.cabal | 2 -- lib/unison-pretty-printer/package.yaml | 10 ++++++++++ .../unison-pretty-printer.cabal | 5 ----- lib/unison-sqlite/package.yaml | 4 ++++ lib/unison-util-base32hex/package.yaml | 3 +++ .../unison-util-base32hex.cabal | 2 -- lib/unison-util-relation/package.yaml | 9 +++++++++ .../unison-util-relation.cabal | 4 ---- parser-typechecker/package.yaml | 6 ++++++ parser-typechecker/unison-parser-typechecker.cabal | 3 --- unison-cli/package.yaml | 14 ++++++++++++++ unison-cli/unison-cli.cabal | 7 ------- unison-core/package.yaml | 3 +++ unison-core/unison-core1.cabal | 2 -- unison-share-api/package.yaml | 3 +++ unison-share-api/unison-share-api.cabal | 2 -- 31 files changed, 85 insertions(+), 47 deletions(-) diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index 412cffd051..fa1481fd09 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -2,6 +2,9 @@ name: unison-codebase-sqlite github: unisonweb/unison library: + when: + - condition: false + other-modules: Paths_unison_codebase_sqlite source-dirs: . extra-source-files: diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 13c2371ccd..5dd57b42b4 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -47,8 +47,6 @@ library U.Codebase.Sqlite.TempEntity U.Codebase.Sqlite.TempEntityType U.Codebase.Sqlite.Term.Format - other-modules: - Paths_unison_codebase_sqlite hs-source-dirs: ./ default-extensions: diff --git a/codebase2/codebase-sync/package.yaml b/codebase2/codebase-sync/package.yaml index be5d9b4d9f..88a368d166 100644 --- a/codebase2/codebase-sync/package.yaml +++ b/codebase2/codebase-sync/package.yaml @@ -3,6 +3,9 @@ github: unisonweb/unison library: source-dirs: . + when: + - condition: false + other-modules: Paths_unison_codebase_sync dependencies: - base diff --git a/codebase2/codebase-sync/unison-codebase-sync.cabal b/codebase2/codebase-sync/unison-codebase-sync.cabal index 793918dca4..7878ee41e9 100644 --- a/codebase2/codebase-sync/unison-codebase-sync.cabal +++ b/codebase2/codebase-sync/unison-codebase-sync.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: a62b0e8dbabe51c01ebc0871290e2427a734c0fbf9e78aee138b2bdad34d2704 +-- hash: e3307c66c00f5bf45548b61cb0aa78f2006c2df8b9ad9172c645f944688d6263 name: unison-codebase-sync version: 0.0.0 @@ -19,8 +19,6 @@ source-repository head library exposed-modules: U.Codebase.Sync - other-modules: - Paths_unison_codebase_sync hs-source-dirs: ./ build-depends: diff --git a/codebase2/codebase/package.yaml b/codebase2/codebase/package.yaml index e0c9a35cfe..c5154d7a24 100644 --- a/codebase2/codebase/package.yaml +++ b/codebase2/codebase/package.yaml @@ -20,6 +20,9 @@ default-extensions: library: source-dirs: . + when: + - condition: false + other-modules: Paths_unison_codebase dependencies: - base diff --git a/codebase2/codebase/unison-codebase.cabal b/codebase2/codebase/unison-codebase.cabal index 652782ee95..8dcc4ebe3e 100644 --- a/codebase2/codebase/unison-codebase.cabal +++ b/codebase2/codebase/unison-codebase.cabal @@ -30,8 +30,6 @@ library U.Codebase.Type U.Codebase.TypeEdit U.Codebase.WatchKind - other-modules: - Paths_unison_codebase hs-source-dirs: ./ default-extensions: diff --git a/codebase2/core/package.yaml b/codebase2/core/package.yaml index b98a6a6dff..db979d9664 100644 --- a/codebase2/core/package.yaml +++ b/codebase2/core/package.yaml @@ -3,6 +3,9 @@ github: unisonweb/unison library: source-dirs: . + when: + - condition: false + other-modules: Paths_unison_core dependencies: - base diff --git a/codebase2/core/unison-core.cabal b/codebase2/core/unison-core.cabal index 8436916748..82ba9672db 100644 --- a/codebase2/core/unison-core.cabal +++ b/codebase2/core/unison-core.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: f696d0f997ab3afba6494f5932ac232d27e77073a331ab64d3c8b7929d1deb3a +-- hash: 7b810bbd4d380ccd76c363eac447c7233c7b0e9d968960547c00d20ac3edeb08 name: unison-core version: 0.0.0 @@ -20,8 +20,6 @@ library exposed-modules: U.Core.ABT U.Core.ABT.Var - other-modules: - Paths_unison_core hs-source-dirs: ./ build-depends: diff --git a/codebase2/util-serialization/package.yaml b/codebase2/util-serialization/package.yaml index 51b20adb52..2f836d75cc 100644 --- a/codebase2/util-serialization/package.yaml +++ b/codebase2/util-serialization/package.yaml @@ -2,6 +2,9 @@ name: unison-util-serialization library: source-dirs: . + when: + - condition: false + other-modules: Paths_unison_util_serialization dependencies: - base diff --git a/codebase2/util-serialization/unison-util-serialization.cabal b/codebase2/util-serialization/unison-util-serialization.cabal index be2566b468..62a66f6d88 100644 --- a/codebase2/util-serialization/unison-util-serialization.cabal +++ b/codebase2/util-serialization/unison-util-serialization.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 0dd31d457a6c3bc41017d163374947c1c31752279ce7ce77bc5772150101afe1 +-- hash: 065e98437c72cce9c4cc6102d3eb0b3c8be444a95c3c71ab65a9d17f29e95eae name: unison-util-serialization version: 0.0.0 @@ -13,8 +13,6 @@ build-type: Simple library exposed-modules: U.Util.Serialization - other-modules: - Paths_unison_util_serialization hs-source-dirs: ./ build-depends: diff --git a/codebase2/util-term/package.yaml b/codebase2/util-term/package.yaml index b3ca704347..b1dd314885 100644 --- a/codebase2/util-term/package.yaml +++ b/codebase2/util-term/package.yaml @@ -3,6 +3,9 @@ github: unisonweb/unison library: source-dirs: . + when: + - condition: false + other-modules: Paths_unison_util_term dependencies: - base diff --git a/codebase2/util-term/unison-util-term.cabal b/codebase2/util-term/unison-util-term.cabal index 01a735ee49..1e95a37ce2 100644 --- a/codebase2/util-term/unison-util-term.cabal +++ b/codebase2/util-term/unison-util-term.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 655ca1a695b9a272d6b440b74fe2b6717f710a543d7ddb7639366d4233961bf8 +-- hash: 6b08707c87592d47677b3f2db15c17c94a23c13544f339227e43ac19f7ee7947 name: unison-util-term version: 0.0.0 @@ -20,8 +20,6 @@ library exposed-modules: U.Util.Term U.Util.Type - other-modules: - Paths_unison_util_term hs-source-dirs: ./ build-depends: diff --git a/codebase2/util/package.yaml b/codebase2/util/package.yaml index 96d664f085..da6bdb3a3b 100644 --- a/codebase2/util/package.yaml +++ b/codebase2/util/package.yaml @@ -3,13 +3,20 @@ github: unisonweb/unison library: source-dirs: src + when: + - condition: false + other-modules: Paths_unison_util benchmarks: bench: + when: + - condition: false + other-modules: Paths_unison_util dependencies: - criterion - sandi - unison-util + - unison-util-base32hex main: Main.hs source-dirs: bench diff --git a/codebase2/util/unison-util.cabal b/codebase2/util/unison-util.cabal index dc31d530a0..8758b1250b 100644 --- a/codebase2/util/unison-util.cabal +++ b/codebase2/util/unison-util.cabal @@ -24,8 +24,6 @@ library U.Util.String U.Util.Text U.Util.Timing - other-modules: - Paths_unison_util hs-source-dirs: src default-extensions: @@ -64,8 +62,6 @@ library benchmark bench type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: - Paths_unison_util hs-source-dirs: bench default-extensions: @@ -99,6 +95,7 @@ benchmark bench , text , time , unison-util + , unison-util-base32hex , unison-util-relation , unliftio , vector diff --git a/lib/unison-prelude/package.yaml b/lib/unison-prelude/package.yaml index e999a79ddd..83ba73773b 100644 --- a/lib/unison-prelude/package.yaml +++ b/lib/unison-prelude/package.yaml @@ -4,6 +4,9 @@ copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors library: source-dirs: src + when: + - condition: false + other-modules: Paths_unison_prelude dependencies: - base diff --git a/lib/unison-prelude/unison-prelude.cabal b/lib/unison-prelude/unison-prelude.cabal index 48053ebb4f..dc6b7d04df 100644 --- a/lib/unison-prelude/unison-prelude.cabal +++ b/lib/unison-prelude/unison-prelude.cabal @@ -22,8 +22,6 @@ library Unison.Util.Map Unison.Util.Monoid Unison.Util.Set - other-modules: - Paths_unison_prelude hs-source-dirs: src default-extensions: diff --git a/lib/unison-pretty-printer/package.yaml b/lib/unison-pretty-printer/package.yaml index c2b77be01b..1f63dfd222 100644 --- a/lib/unison-pretty-printer/package.yaml +++ b/lib/unison-pretty-printer/package.yaml @@ -36,6 +36,10 @@ when: ghc-options: -funbox-strict-fields -O2 library: + when: + - condition: false + other-modules: Paths_unison_pretty_printer + source-dirs: src dependencies: - base @@ -53,6 +57,9 @@ library: executables: prettyprintdemo: + when: + - condition: false + other-modules: Paths_unison_pretty_printer source-dirs: prettyprintdemo main: Main.hs dependencies: @@ -64,6 +71,9 @@ executables: tests: pretty-printer-tests: + when: + - condition: false + other-modules: Paths_unison_pretty_printer source-dirs: tests main: Suite.hs ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 diff --git a/lib/unison-pretty-printer/unison-pretty-printer.cabal b/lib/unison-pretty-printer/unison-pretty-printer.cabal index 9a6186f05a..a5968ec87d 100644 --- a/lib/unison-pretty-printer/unison-pretty-printer.cabal +++ b/lib/unison-pretty-printer/unison-pretty-printer.cabal @@ -31,8 +31,6 @@ library Unison.Util.Pretty Unison.Util.Range Unison.Util.SyntaxText - other-modules: - Paths_unison_pretty_printer hs-source-dirs: src default-extensions: @@ -76,8 +74,6 @@ library executable prettyprintdemo main-is: Main.hs - other-modules: - Paths_unison_pretty_printer hs-source-dirs: prettyprintdemo default-extensions: @@ -118,7 +114,6 @@ test-suite pretty-printer-tests Unison.Test.ColorText Unison.Test.Range Unison.Test.Util.Pretty - Paths_unison_pretty_printer hs-source-dirs: tests default-extensions: diff --git a/lib/unison-sqlite/package.yaml b/lib/unison-sqlite/package.yaml index bd2c6917c1..5ee014e0ac 100644 --- a/lib/unison-sqlite/package.yaml +++ b/lib/unison-sqlite/package.yaml @@ -3,6 +3,10 @@ github: unisonweb/unison copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors library: + when: + - condition: false + other-modules: Paths_unison_sqlite + source-dirs: src other-modules: - Unison.Sqlite.DataVersion diff --git a/lib/unison-util-base32hex/package.yaml b/lib/unison-util-base32hex/package.yaml index ad8647beaf..324692eec8 100644 --- a/lib/unison-util-base32hex/package.yaml +++ b/lib/unison-util-base32hex/package.yaml @@ -3,6 +3,9 @@ github: unisonweb/unison copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors library: + when: + - condition: false + other-modules: Paths_unison_util_base32hex source-dirs: src dependencies: diff --git a/lib/unison-util-base32hex/unison-util-base32hex.cabal b/lib/unison-util-base32hex/unison-util-base32hex.cabal index 4c13522ead..27d50df2cb 100644 --- a/lib/unison-util-base32hex/unison-util-base32hex.cabal +++ b/lib/unison-util-base32hex/unison-util-base32hex.cabal @@ -19,8 +19,6 @@ library exposed-modules: U.Util.Base32Hex U.Util.Hash - other-modules: - Paths_unison_util_base32hex hs-source-dirs: src default-extensions: diff --git a/lib/unison-util-relation/package.yaml b/lib/unison-util-relation/package.yaml index 678c2bf123..25705bf517 100644 --- a/lib/unison-util-relation/package.yaml +++ b/lib/unison-util-relation/package.yaml @@ -4,9 +4,15 @@ copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors library: source-dirs: src + when: + - condition: false + other-modules: Paths_unison_util_relation tests: util-relation-tests: + when: + - condition: false + other-modules: Paths_unison_util_relation dependencies: - code-page - easytest @@ -17,6 +23,9 @@ tests: benchmarks: relation: + when: + - condition: false + other-modules: Paths_unison_util_relation source-dirs: benchmarks/relation main: Main.hs dependencies: diff --git a/lib/unison-util-relation/unison-util-relation.cabal b/lib/unison-util-relation/unison-util-relation.cabal index 99530e8ccd..826f88e5b7 100644 --- a/lib/unison-util-relation/unison-util-relation.cabal +++ b/lib/unison-util-relation/unison-util-relation.cabal @@ -51,8 +51,6 @@ library test-suite util-relation-tests type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: - Paths_unison_util_relation hs-source-dirs: test default-extensions: @@ -86,8 +84,6 @@ test-suite util-relation-tests benchmark relation type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: - Paths_unison_util_relation hs-source-dirs: benchmarks/relation default-extensions: diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 9f840fd0c8..3090f85262 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -125,6 +125,9 @@ dependencies: library: source-dirs: src + when: + - condition: false + other-modules: Paths_unison_parser_typechecker tests: parser-typechecker-tests: @@ -137,6 +140,9 @@ tests: - filemanip - split - unison-parser-typechecker + when: + - condition: false + other-modules: Paths_unison_parser_typechecker default-extensions: - ApplicativeDo diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index d06c5487f7..91acd0a2b4 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -166,8 +166,6 @@ library Unison.Util.Text Unison.Util.TQueue Unison.Util.TransitiveClosure - other-modules: - Paths_unison_parser_typechecker hs-source-dirs: src default-extensions: @@ -343,7 +341,6 @@ test-suite parser-typechecker-tests Unison.Test.Util.Relation Unison.Test.Util.Text Unison.Test.Var - Paths_unison_parser_typechecker hs-source-dirs: tests default-extensions: diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index b232904b50..21b4bff000 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -72,9 +72,14 @@ library: when: - condition: '!os(windows)' dependencies: unix + - condition: false + other-modules: Paths_unison_cli tests: cli-tests: + when: + - condition: false + other-modules: Paths_unison_cli dependencies: - code-page - easytest @@ -87,6 +92,9 @@ tests: executables: unison: + when: + - condition: false + other-modules: Paths_unison_cli source-dirs: unison main: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-I0 -optP-Wno-nonportable-include-path @@ -99,6 +107,9 @@ executables: - unison-cli transcripts: + when: + - condition: false + other-modules: Paths_unison_cli source-dirs: transcripts main: Transcripts.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N -v0 @@ -110,6 +121,9 @@ executables: - unison-cli cli-integration-tests: + when: + - condition: false + other-modules: Paths_unison_cli source-dirs: integration-tests main: Suite.hs ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 4db74a8856..20e4b8f773 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -63,8 +63,6 @@ library Unison.Share.Sync Unison.Share.Types Unison.Util.HTTP - other-modules: - Paths_unison_cli hs-source-dirs: src default-extensions: @@ -160,7 +158,6 @@ executable cli-integration-tests main-is: Suite.hs other-modules: IntegrationTests.ArgumentParsing - Paths_unison_cli hs-source-dirs: integration-tests default-extensions: @@ -257,8 +254,6 @@ executable cli-integration-tests executable transcripts main-is: Transcripts.hs - other-modules: - Paths_unison_cli hs-source-dirs: transcripts default-extensions: @@ -358,7 +353,6 @@ executable unison ArgParse System.Path Version - Paths_unison_cli hs-source-dirs: unison default-extensions: @@ -463,7 +457,6 @@ test-suite cli-tests Unison.Test.Ucm Unison.Test.UriParser Unison.Test.VersionParser - Paths_unison_cli hs-source-dirs: tests default-extensions: diff --git a/unison-core/package.yaml b/unison-core/package.yaml index 3ae9322bb1..1fd7ca73b6 100644 --- a/unison-core/package.yaml +++ b/unison-core/package.yaml @@ -3,6 +3,9 @@ github: unisonweb/unison copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors library: + when: + - condition: false + other-modules: Paths_unison_core1 source-dirs: src ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -funbox-strict-fields dependencies: diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index 3b9c2ed72b..564994ec63 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -60,8 +60,6 @@ library Unison.Var Unison.Var.RefNamed Unison.WatchKind - other-modules: - Paths_unison_core1 hs-source-dirs: src default-extensions: diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 0e5418e93e..78b7b2f193 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -4,6 +4,9 @@ copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors library: source-dirs: src + when: + - condition: false + other-modules: Paths_unison_share_api dependencies: - NanoID diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index c03c125951..71a9fa24e8 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -37,8 +37,6 @@ library Unison.Sync.Common Unison.Sync.Types Unison.Util.Find - other-modules: - Paths_unison_share_api hs-source-dirs: src default-extensions: From 3ff57e3a26fc7dc77a923436f4acdd8e8f8647c9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 2 Jun 2022 15:44:38 -0600 Subject: [PATCH 272/529] Allow passing an access token explicitly This lets us use transcripts for testing codeservers --- unison-cli/src/Unison/Auth/HTTPClient.hs | 14 ++--- .../Codebase/Editor/HandleInput/LoopState.hs | 4 +- .../src/Unison/Codebase/TranscriptParser.hs | 16 +++++- unison-cli/src/Unison/CommandLine/Main.hs | 6 +- unison-cli/src/Unison/Share/Sync.hs | 28 +++++----- unison-cli/src/Unison/Sync/HTTP.hs | 55 +++++++++++++++++++ unison-cli/unison-cli.cabal | 1 + 7 files changed, 97 insertions(+), 27 deletions(-) create mode 100644 unison-cli/src/Unison/Sync/HTTP.hs diff --git a/unison-cli/src/Unison/Auth/HTTPClient.hs b/unison-cli/src/Unison/Auth/HTTPClient.hs index 52b9131b24..659d76cf26 100644 --- a/unison-cli/src/Unison/Auth/HTTPClient.hs +++ b/unison-cli/src/Unison/Auth/HTTPClient.hs @@ -1,29 +1,27 @@ -module Unison.Auth.HTTPClient (newAuthorizedHTTPClient, AuthorizedHttpClient (..)) where +module Unison.Auth.HTTPClient (newAuthenticatedHTTPClient, AuthenticatedHttpClient (..)) where import qualified Data.Text.Encoding as Text import Network.HTTP.Client (Request) import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTP -import Unison.Auth.CredentialManager (CredentialManager) -import Unison.Auth.Tokens (TokenProvider, newTokenProvider) +import Unison.Auth.Tokens (TokenProvider) import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Prelude import Unison.Share.Types (codeserverIdFromURI) import qualified Unison.Util.HTTP as HTTP -- | Newtype to delineate HTTP Managers with access-token logic. -newtype AuthorizedHttpClient = AuthorizedHttpClient HTTP.Manager +newtype AuthenticatedHttpClient = AuthenticatedHttpClient HTTP.Manager -- | Returns a new http manager which applies the appropriate Authorization header to -- any hosts our UCM is authenticated with. -newAuthorizedHTTPClient :: MonadIO m => CredentialManager -> UCMVersion -> m AuthorizedHttpClient -newAuthorizedHTTPClient credsMan ucmVersion = liftIO $ do - let tokenProvider = newTokenProvider credsMan +newAuthenticatedHTTPClient :: MonadIO m => TokenProvider -> UCMVersion -> m AuthenticatedHttpClient +newAuthenticatedHTTPClient tokenProvider ucmVersion = liftIO $ do let managerSettings = HTTP.tlsManagerSettings & HTTP.addRequestMiddleware (authMiddleware tokenProvider) & HTTP.setUserAgent (HTTP.ucmUserAgent ucmVersion) - AuthorizedHttpClient <$> HTTP.newTlsManagerWith managerSettings + AuthenticatedHttpClient <$> HTTP.newTlsManagerWith managerSettings -- | Adds Bearer tokens to requests according to their host. -- If a CredentialFailure occurs (failure to refresh a token), auth is simply omitted, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs index 372b8bbb42..9e310c1bb9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs @@ -12,7 +12,7 @@ import Data.Configurator () import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel import Unison.Auth.CredentialManager (CredentialManager) -import Unison.Auth.HTTPClient (AuthorizedHttpClient) +import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Codebase (Codebase) import Unison.Codebase.Branch ( Branch (..), @@ -30,7 +30,7 @@ import qualified Unison.Util.Free as Free type F m i v = Free (Command m i v) data Env m v = Env - { authHTTPClient :: AuthorizedHttpClient, + { authHTTPClient :: AuthenticatedHttpClient, codebase :: Codebase m v Ann, credentialManager :: CredentialManager } diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 54edbba95a..f619047f5f 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -33,10 +33,14 @@ import qualified Data.Map as Map import qualified Data.Text as Text import qualified Network.HTTP.Client as HTTP import System.Directory (doesFileExist) +import System.Environment (lookupEnv) import System.Exit (die) import qualified System.IO as IO import System.IO.Error (catchIOError) import qualified Text.Megaparsec as P +import qualified Unison.Auth.HTTPClient as AuthN +import qualified Unison.Auth.Tokens as AuthN +import qualified Unison.Auth.Types as AuthN import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch @@ -71,6 +75,9 @@ import Prelude hiding (readFile, writeFile) terminalWidth :: Pretty.Width terminalWidth = 65 +accessTokenEnvVarKey :: String +accessTokenEnvVarKey = "UNISON_SHARE_ACCESS_TOKEN" + type ExpectingError = Bool type ScratchFileName = Text @@ -219,6 +226,13 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do ] root <- Codebase.getRootBranch codebase do + mayShareAccessToken <- fmap Text.pack <$> lookupEnv accessTokenEnvVarKey + let tokenProvider :: AuthN.TokenProvider + tokenProvider = + case mayShareAccessToken of + Nothing -> \_codeserverID -> pure (Left . AuthN.InvalidJWT $ "Unable to access codebase servers in transcripts unless an access token is provided with via the " <> Text.pack accessTokenEnvVarKey <> " environment variable.") + Just accessToken -> \_codeserverID -> pure $ Right accessToken + authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion pathRef <- newIORef initialPath rootBranchRef <- newIORef root numberedArgsRef <- newIORef [] @@ -424,7 +438,7 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do writeIORef pathRef (view LoopState.currentPath state) let env = LoopState.Env - { LoopState.authHTTPClient = error "Error: No access to authorized requests from transcripts.", + { LoopState.authHTTPClient = authenticatedHTTPClient, LoopState.codebase = codebase, LoopState.credentialManager = error "Error: No access to credentials from transcripts." } diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index be44430ac3..bcfc55a5bd 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -23,7 +23,8 @@ import System.IO (hPutStrLn, stderr) import System.IO.Error (isDoesNotExistError) import Text.Pretty.Simple (pShow) import Unison.Auth.CredentialManager (newCredentialManager) -import qualified Unison.Auth.HTTPClient as HTTP +import qualified Unison.Auth.HTTPClient as AuthN +import qualified Unison.Auth.Tokens as AuthN import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Unison.Codebase.Branch (Branch) @@ -193,7 +194,8 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba loop state = do writeIORef pathRef (view LoopState.currentPath state) credMan <- newCredentialManager - authorizedHTTPClient <- HTTP.newAuthorizedHTTPClient credMan ucmVersion + let tokenProvider = AuthN.newTokenProvider credMan + authorizedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion let env = LoopState.Env { LoopState.authHTTPClient = authorizedHTTPClient, diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index a203634a34..9589a47882 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -45,7 +45,7 @@ import U.Codebase.HashTags (CausalHash (..)) import qualified U.Codebase.Sqlite.Queries as Q import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Hash as Hash -import Unison.Auth.HTTPClient (AuthorizedHttpClient) +import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import qualified Unison.Auth.HTTPClient as Auth import Unison.Prelude import qualified Unison.Sqlite as Sqlite @@ -68,7 +68,7 @@ data CheckAndSetPushError -- FIXME reword this checkAndSetPush :: -- | The HTTP client to use for Unison Share requests. - AuthorizedHttpClient -> + AuthenticatedHttpClient -> -- | The Unison Share URL. BaseUrl -> -- | SQLite connection, for reading entities to push. @@ -131,7 +131,7 @@ data FastForwardPushError -- FIXME reword this fastForwardPush :: -- | The HTTP client to use for Unison Share requests. - AuthorizedHttpClient -> + AuthenticatedHttpClient -> -- | The Unison Share URL. BaseUrl -> -- | SQLite connection, for reading entities to push. @@ -314,7 +314,7 @@ data PullError pull :: -- | The HTTP client to use for Unison Share requests. - AuthorizedHttpClient -> + AuthenticatedHttpClient -> -- | The Unison Share URL. BaseUrl -> -- | SQLite connection, for writing entities we pull. @@ -350,7 +350,7 @@ data GetCausalHashByPathError -- | Get the causal hash of a path hosted on Unison Share. getCausalHashByPath :: -- | The HTTP client to use for Unison Share requests. - AuthorizedHttpClient -> + AuthenticatedHttpClient -> -- | The Unison Share URL. BaseUrl -> Share.Path -> @@ -365,7 +365,7 @@ getCausalHashByPath httpClient unisonShareUrl repoPath = -- | Download a set of entities from Unison Share. downloadEntities :: - AuthorizedHttpClient -> + AuthenticatedHttpClient -> BaseUrl -> Sqlite.Connection -> Share.RepoName -> @@ -406,7 +406,7 @@ downloadEntities httpClient unisonShareUrl conn repoName = -- -- Returns true on success, false on failure (because the user does not have write permission). uploadEntities :: - AuthorizedHttpClient -> + AuthenticatedHttpClient -> BaseUrl -> Sqlite.Connection -> Share.RepoName -> @@ -534,11 +534,11 @@ insertTempEntity hash entity missingDependencies = ------------------------------------------------------------------------------------------------------------------------ -- HTTP calls -httpGetCausalHashByPath :: Auth.AuthorizedHttpClient -> BaseUrl -> Share.GetCausalHashByPathRequest -> IO Share.GetCausalHashByPathResponse -httpFastForwardPath :: Auth.AuthorizedHttpClient -> BaseUrl -> Share.FastForwardPathRequest -> IO Share.FastForwardPathResponse -httpUpdatePath :: Auth.AuthorizedHttpClient -> BaseUrl -> Share.UpdatePathRequest -> IO Share.UpdatePathResponse -httpDownloadEntities :: Auth.AuthorizedHttpClient -> BaseUrl -> Share.DownloadEntitiesRequest -> IO Share.DownloadEntitiesResponse -httpUploadEntities :: Auth.AuthorizedHttpClient -> BaseUrl -> Share.UploadEntitiesRequest -> IO Share.UploadEntitiesResponse +httpGetCausalHashByPath :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.GetCausalHashByPathRequest -> IO Share.GetCausalHashByPathResponse +httpFastForwardPath :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.FastForwardPathRequest -> IO Share.FastForwardPathResponse +httpUpdatePath :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UpdatePathRequest -> IO Share.UpdatePathResponse +httpDownloadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.DownloadEntitiesRequest -> IO Share.DownloadEntitiesResponse +httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEntitiesRequest -> IO Share.UploadEntitiesResponse ( httpGetCausalHashByPath, httpFastForwardPath, httpUpdatePath, @@ -565,9 +565,9 @@ httpUploadEntities :: Auth.AuthorizedHttpClient -> BaseUrl -> Share.UploadEntiti go :: (req -> ReaderT Servant.ClientEnv IO resp) -> - Auth.AuthorizedHttpClient -> + Auth.AuthenticatedHttpClient -> BaseUrl -> req -> IO resp - go f (Auth.AuthorizedHttpClient httpClient) unisonShareUrl req = + go f (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req = runReaderT (f req) (Servant.mkClientEnv httpClient unisonShareUrl) diff --git a/unison-cli/src/Unison/Sync/HTTP.hs b/unison-cli/src/Unison/Sync/HTTP.hs new file mode 100644 index 0000000000..46e497af12 --- /dev/null +++ b/unison-cli/src/Unison/Sync/HTTP.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} + +module Unison.Sync.HTTP + ( getPathHandler, + updatePathHandler, + downloadEntitiesHandler, + uploadEntitiesHandler, + ) +where + +import Control.Monad.Reader +import Servant.API +import Servant.Client +import qualified Unison.Auth.HTTPClient as Auth +import Unison.Prelude +import qualified Unison.Sync.API as Sync +import Unison.Sync.Types + +data SyncError + = ClientErr ClientError + deriving stock (Show) + deriving anyclass (Exception) + +getPathHandler :: Auth.AuthenticatedHttpClient -> BaseUrl -> GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse +updatePathHandler :: Auth.AuthenticatedHttpClient -> BaseUrl -> UpdatePathRequest -> IO UpdatePathResponse +downloadEntitiesHandler :: Auth.AuthenticatedHttpClient -> BaseUrl -> DownloadEntitiesRequest -> IO DownloadEntitiesResponse +uploadEntitiesHandler :: Auth.AuthenticatedHttpClient -> BaseUrl -> UploadEntitiesRequest -> IO UploadEntitiesResponse +( getPathHandler, + updatePathHandler, + downloadEntitiesHandler, + uploadEntitiesHandler + ) = + let ( getPathHandler + :<|> updatePathHandler + :<|> downloadEntitiesHandler + :<|> uploadEntitiesHandler + ) = hoistClient Sync.api hoist (client Sync.api) + in (uncurryReaderT getPathHandler, uncurryReaderT updatePathHandler, uncurryReaderT downloadEntitiesHandler, uncurryReaderT uploadEntitiesHandler) + where + hoist :: forall a. ClientM a -> ReaderT (Auth.AuthenticatedHttpClient, BaseUrl) IO a + hoist m = do + (Auth.AuthenticatedHttpClient manager, baseUrl) <- ask + let clientEnv = mkClientEnv manager baseUrl + resp <- liftIO . throwEitherMWith ClientErr $ (runClientM m clientEnv) + pure resp + + uncurryReaderT :: forall req resp. (req -> ReaderT (Auth.AuthenticatedHttpClient, BaseUrl) IO resp) -> Auth.AuthenticatedHttpClient -> BaseUrl -> req -> IO resp + uncurryReaderT f httpClient baseURL req = + runReaderT (f req) (httpClient, baseURL) diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 20e4b8f773..6248de48c0 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -62,6 +62,7 @@ library Unison.CommandLine.Welcome Unison.Share.Sync Unison.Share.Types + Unison.Sync.HTTP Unison.Util.HTTP hs-source-dirs: src From 83d9bfb419af667272688b91bf709ab573363354 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 2 Jun 2022 15:59:17 -0600 Subject: [PATCH 273/529] Remove unused sync http module --- .../unison-util-relation.cabal | 2 - unison-cli/src/Unison/Sync/HTTP.hs | 55 ------------------- unison-cli/unison-cli.cabal | 1 - 3 files changed, 58 deletions(-) delete mode 100644 unison-cli/src/Unison/Sync/HTTP.hs diff --git a/lib/unison-util-relation/unison-util-relation.cabal b/lib/unison-util-relation/unison-util-relation.cabal index 826f88e5b7..d92dc66a37 100644 --- a/lib/unison-util-relation/unison-util-relation.cabal +++ b/lib/unison-util-relation/unison-util-relation.cabal @@ -20,8 +20,6 @@ library Unison.Util.Relation Unison.Util.Relation3 Unison.Util.Relation4 - other-modules: - Paths_unison_util_relation hs-source-dirs: src default-extensions: diff --git a/unison-cli/src/Unison/Sync/HTTP.hs b/unison-cli/src/Unison/Sync/HTTP.hs deleted file mode 100644 index 46e497af12..0000000000 --- a/unison-cli/src/Unison/Sync/HTTP.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Sync.HTTP - ( getPathHandler, - updatePathHandler, - downloadEntitiesHandler, - uploadEntitiesHandler, - ) -where - -import Control.Monad.Reader -import Servant.API -import Servant.Client -import qualified Unison.Auth.HTTPClient as Auth -import Unison.Prelude -import qualified Unison.Sync.API as Sync -import Unison.Sync.Types - -data SyncError - = ClientErr ClientError - deriving stock (Show) - deriving anyclass (Exception) - -getPathHandler :: Auth.AuthenticatedHttpClient -> BaseUrl -> GetCausalHashByPathRequest -> IO GetCausalHashByPathResponse -updatePathHandler :: Auth.AuthenticatedHttpClient -> BaseUrl -> UpdatePathRequest -> IO UpdatePathResponse -downloadEntitiesHandler :: Auth.AuthenticatedHttpClient -> BaseUrl -> DownloadEntitiesRequest -> IO DownloadEntitiesResponse -uploadEntitiesHandler :: Auth.AuthenticatedHttpClient -> BaseUrl -> UploadEntitiesRequest -> IO UploadEntitiesResponse -( getPathHandler, - updatePathHandler, - downloadEntitiesHandler, - uploadEntitiesHandler - ) = - let ( getPathHandler - :<|> updatePathHandler - :<|> downloadEntitiesHandler - :<|> uploadEntitiesHandler - ) = hoistClient Sync.api hoist (client Sync.api) - in (uncurryReaderT getPathHandler, uncurryReaderT updatePathHandler, uncurryReaderT downloadEntitiesHandler, uncurryReaderT uploadEntitiesHandler) - where - hoist :: forall a. ClientM a -> ReaderT (Auth.AuthenticatedHttpClient, BaseUrl) IO a - hoist m = do - (Auth.AuthenticatedHttpClient manager, baseUrl) <- ask - let clientEnv = mkClientEnv manager baseUrl - resp <- liftIO . throwEitherMWith ClientErr $ (runClientM m clientEnv) - pure resp - - uncurryReaderT :: forall req resp. (req -> ReaderT (Auth.AuthenticatedHttpClient, BaseUrl) IO resp) -> Auth.AuthenticatedHttpClient -> BaseUrl -> req -> IO resp - uncurryReaderT f httpClient baseURL req = - runReaderT (f req) (httpClient, baseURL) diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 6248de48c0..20e4b8f773 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -62,7 +62,6 @@ library Unison.CommandLine.Welcome Unison.Share.Sync Unison.Share.Types - Unison.Sync.HTTP Unison.Util.HTTP hs-source-dirs: src From 428f40849f6c0dcc3fa934e832f89fa0c058937e Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 2 Jun 2022 20:55:58 -0600 Subject: [PATCH 274/529] Provide credential manager and Authenticated client in transcripts Can't think of a good reason not to allow it --- unison-cli/src/Unison/Codebase/TranscriptParser.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index f619047f5f..2d7afa20e3 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -38,9 +38,9 @@ import System.Exit (die) import qualified System.IO as IO import System.IO.Error (catchIOError) import qualified Text.Megaparsec as P +import qualified Unison.Auth.CredentialManager as AuthN import qualified Unison.Auth.HTTPClient as AuthN import qualified Unison.Auth.Tokens as AuthN -import qualified Unison.Auth.Types as AuthN import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch @@ -227,11 +227,14 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do root <- Codebase.getRootBranch codebase do mayShareAccessToken <- fmap Text.pack <$> lookupEnv accessTokenEnvVarKey + credMan <- AuthN.newCredentialManager let tokenProvider :: AuthN.TokenProvider tokenProvider = case mayShareAccessToken of - Nothing -> \_codeserverID -> pure (Left . AuthN.InvalidJWT $ "Unable to access codebase servers in transcripts unless an access token is provided with via the " <> Text.pack accessTokenEnvVarKey <> " environment variable.") - Just accessToken -> \_codeserverID -> pure $ Right accessToken + Nothing -> do + AuthN.newTokenProvider credMan + Just accessToken -> + \_codeserverID -> pure $ Right accessToken authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion pathRef <- newIORef initialPath rootBranchRef <- newIORef root @@ -440,7 +443,7 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do LoopState.Env { LoopState.authHTTPClient = authenticatedHTTPClient, LoopState.codebase = codebase, - LoopState.credentialManager = error "Error: No access to credentials from transcripts." + LoopState.credentialManager = credMan } let free = LoopState.runAction env state $ HandleInput.loop rng i = pure $ Random.drgNewSeed (Random.seedFromInteger (fromIntegral i)) From dd0e6fb67964980cea31db6118e75419a2aedc0c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 2 Jun 2022 22:17:49 -0600 Subject: [PATCH 275/529] docs --- unison-cli/src/Unison/Codebase/TranscriptParser.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 2d7afa20e3..d5a606823a 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -75,6 +75,10 @@ import Prelude hiding (readFile, writeFile) terminalWidth :: Pretty.Width terminalWidth = 65 +-- | If provided, this access token will be used on all +-- requests which use the Authenticated HTTP Client; i.e. all codeserver interactions. +-- +-- It's useful in scripted contexts or when running transcripts against a codeserver. accessTokenEnvVarKey :: String accessTokenEnvVarKey = "UNISON_SHARE_ACCESS_TOKEN" From 784a524432b67ee44cf5ed38896b7f9bd1cb7749 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Wed, 1 Jun 2022 14:16:53 -0400 Subject: [PATCH 276/529] Bump megaparsec dependency --- CONTRIBUTORS.markdown | 1 + parser-typechecker/src/Unison/Lexer.hs | 102 +++++++++++------- parser-typechecker/src/Unison/Parser.hs | 62 ++--------- parser-typechecker/src/Unison/PrintError.hs | 8 +- .../tests/Unison/Test/Common.hs | 3 +- .../unison-parser-typechecker.cabal | 2 +- stack.yaml | 2 - stack.yaml.lock | 77 ++++++------- .../src/Unison/Codebase/Editor/UriParser.hs | 6 +- .../Unison/Codebase/Editor/VersionParser.hs | 2 +- .../src/Unison/CommandLine/InputPatterns.hs | 61 +++++++---- 11 files changed, 159 insertions(+), 167 deletions(-) diff --git a/CONTRIBUTORS.markdown b/CONTRIBUTORS.markdown index 93b97e9d01..cff5437fb0 100644 --- a/CONTRIBUTORS.markdown +++ b/CONTRIBUTORS.markdown @@ -67,3 +67,4 @@ The format for this list: name, GitHub handle * Nicole Prindle (@nprindle) * Harald Gliebe (@hagl) * Phil de Joux (@philderbeast) +* Travis Staton (@tstat) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index a683bce06c..12c9e66ebc 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -49,7 +49,6 @@ import qualified Text.Megaparsec as P import Text.Megaparsec.Char (char) import qualified Text.Megaparsec.Char as CP import qualified Text.Megaparsec.Char.Lexer as LP -import Text.Megaparsec.Error (ShowToken (..)) import qualified Text.Megaparsec.Error as EP import qualified Text.Megaparsec.Internal as PI import Unison.Lexer.Pos (Column, Line, Pos (Pos), column, line) @@ -68,7 +67,7 @@ data Token a = Token start :: !Pos, end :: !Pos } - deriving (Eq, Ord, Show, Functor) + deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) data ParsingEnv = ParsingEnv { layout :: !Layout, -- layout stack @@ -92,7 +91,7 @@ local f p = do Left e -> parseFailure e Right a -> pure a -parseFailure :: EP.ParseError Char (Token Err) -> P a +parseFailure :: EP.ParseError [Char] (Token Err) -> P a parseFailure e = PI.ParsecT $ \s _ _ _ eerr -> eerr e s data Err @@ -160,7 +159,7 @@ token = token' (\a start end -> [Token a start end]) pos :: P Pos pos = do - p <- P.getPosition + p <- P.getSourcePos pure $ Pos (P.unPos (P.sourceLine p)) (P.unPos (P.sourceColumn p)) -- Token parser: strips trailing whitespace and comments after a @@ -175,7 +174,7 @@ err start t = do stop <- pos -- This consumes a character and therefore produces committed failure, -- so `err s t <|> p2` won't try `p2` - _ <- void CP.anyChar <|> P.eof + _ <- void P.anySingle <|> P.eof P.customFailure (Token t start stop) {- @@ -249,17 +248,40 @@ token'' tok p = do topHasClosePair ((name, _) : _) = name `elem` ["{", "(", "[", "handle", "match", "if", "then"] +showErrorFancy :: P.ShowErrorComponent e => P.ErrorFancy e -> String +showErrorFancy (P.ErrorFail msg) = msg +showErrorFancy (P.ErrorIndentation ord ref actual) = + "incorrect indentation (got " <> show (P.unPos actual) + <> ", should be " + <> p + <> show (P.unPos ref) + <> ")" + where + p = case ord of + LT -> "less than " + EQ -> "equal to " + GT -> "greater than " +showErrorFancy (P.ErrorCustom a) = P.showErrorComponent a + lexer0' :: String -> String -> [Token Lexeme] lexer0' scope rem = case flip S.evalState env0 $ P.runParserT lexemes scope rem of - Left e -> case e of - P.FancyError _ (customErrs -> es) | not (null es) -> es - P.FancyError (top Nel.:| _) es -> - let msg = intercalateMap "\n" P.showErrorComponent es - in [Token (Err (Opaque msg)) (toPos top) (toPos top)] - P.TrivialError (top Nel.:| _) _ _ -> - let msg = Opaque $ EP.parseErrorPretty e - in [Token (Err msg) (toPos top) (toPos top)] + Left e -> + let errsWithSourcePos = + fst $ + P.attachSourcePos + P.errorOffset + (toList (P.bundleErrors e)) + (P.bundlePosState e) + errorToTokens (err, top) = case err of + P.FancyError _ (customErrs -> es) | not (null es) -> es + P.FancyError _errOffset es -> + let msg = intercalateMap "\n" showErrorFancy es + in [Token (Err (Opaque msg)) (toPos top) (toPos top)] + P.TrivialError _errOffset _ _ -> + let msg = Opaque $ EP.parseErrorPretty err + in [Token (Err msg) (toPos top) (toPos top)] + in errsWithSourcePos >>= errorToTokens Right ts -> Token (Open scope) topLeftCorner topLeftCorner : tweak ts where customErrs es = [Err <$> e | P.ErrorCustom e <- toList es] @@ -387,9 +409,9 @@ lexemes' eof = P.lookAhead $ void docClose <|> void docOpen - <|> void (CP.satisfy isSpace) + <|> void (P.satisfy isSpace) <|> void closing - word <- P.manyTill (CP.satisfy (\ch -> not (isSpace ch))) end + word <- P.manyTill (P.satisfy (\ch -> not (isSpace ch))) end guard (not $ reserved word || null word) pure word @@ -471,8 +493,8 @@ lexemes' eof = verbatim = P.label "code (examples: ''**unformatted**'', '''_words_''')" $ do (start, txt, stop) <- positioned $ do - quotes <- lit "''" <+> many (CP.satisfy (== '\'')) - P.someTill CP.anyChar (lit quotes) + quotes <- lit "''" <+> many (P.satisfy (== '\'')) + P.someTill P.anySingle (lit quotes) if all isSpace $ takeWhile (/= '\n') txt then wrap "syntax.docVerbatim" $ @@ -523,7 +545,7 @@ lexemes' eof = evalUnison = wrap "syntax.docEval" $ do -- commit after seeing that ``` is on its own line fence <- P.try $ do - fence <- lit "```" <+> P.many (CP.satisfy (== '`')) + fence <- lit "```" <+> P.many (P.satisfy (== '`')) b <- all isSpace <$> P.lookAhead (P.takeWhileP Nothing (/= '\n')) fence <$ guard b CP.space @@ -533,7 +555,7 @@ lexemes' eof = exampleBlock = wrap "syntax.docExampleBlock" $ do void $ lit "@typecheck" <* CP.space - fence <- lit "```" <+> P.many (CP.satisfy (== '`')) + fence <- lit "```" <+> P.many (P.satisfy (== '`')) local (\env -> env {inLayout = True, opening = Just "docExampleBlock"}) (restoreStack "docExampleBlock" $ lexemes' ([] <$ lit fence)) @@ -550,31 +572,31 @@ lexemes' eof = other = wrap "syntax.docCodeBlock" $ do column <- (\x -> x - 1) . toInteger . P.unPos <$> LP.indentLevel - tabWidth <- toInteger . P.unPos <$> P.getTabWidth - fence <- lit "```" <+> P.many (CP.satisfy (== '`')) + let tabWidth = toInteger . P.unPos $ P.defaultTabWidth + fence <- lit "```" <+> P.many (P.satisfy (== '`')) name <- - P.many (CP.satisfy nonNewlineSpace) + P.many (P.satisfy nonNewlineSpace) *> tok (Textual <$> P.takeWhile1P Nothing (not . isSpace)) - <* P.many (CP.satisfy nonNewlineSpace) + <* P.many (P.satisfy nonNewlineSpace) _ <- void CP.eol verbatim <- tok $ Textual . uncolumn column tabWidth . trim - <$> P.someTill CP.anyChar ([] <$ lit fence) + <$> P.someTill P.anySingle ([] <$ lit fence) pure (name <> verbatim) boldOrItalicOrStrikethrough closing = do let start = - some (CP.satisfy (== '*')) <|> some (CP.satisfy (== '_')) + some (P.satisfy (== '*')) <|> some (P.satisfy (== '_')) <|> some - (CP.satisfy (== '~')) + (P.satisfy (== '~')) name s = if take 1 s == "~" then "syntax.docStrikethrough" else if take 1 s == "*" then "syntax.docBold" else "syntax.docItalic" end <- P.try $ do end <- start - P.lookAhead (CP.satisfy (not . isSpace)) + P.lookAhead (P.satisfy (not . isSpace)) pure end wrap (name end) . wrap "syntax.docParagraph" $ join @@ -618,8 +640,8 @@ lexemes' eof = listSep = P.try $ newline *> nonNewlineSpaces *> P.lookAhead (bulletedStart <|> numberedStart) bulletedStart = P.try $ do - r <- listItemStart' $ [] <$ CP.satisfy bulletChar - P.lookAhead (CP.satisfy isSpace) + r <- listItemStart' $ [] <$ P.satisfy bulletChar + P.lookAhead (P.satisfy isSpace) pure r where bulletChar ch = ch == '*' || ch == '-' || ch == '+' @@ -733,14 +755,14 @@ lexemes' eof = body :: P [Token Lexeme] body = txt <+> (atk <|> pure []) where - ch = (":]" <$ lit "\\:]") <|> ("@" <$ lit "\\@") <|> (pure <$> CP.anyChar) + ch = (":]" <$ lit "\\:]") <|> ("@" <$ lit "\\@") <|> (pure <$> P.anySingle) txt = tok (Textual . join <$> P.manyTill ch (P.lookAhead sep)) sep = void at <|> void close ref = at *> (tok wordyId <|> tok symbolyId <|> docTyp) atk = (ref <|> docTyp) <+> body docTyp = do _ <- lit "[" - typ <- tok (P.manyTill CP.anyChar (P.lookAhead (lit "]"))) + typ <- tok (P.manyTill P.anySingle (P.lookAhead (lit "]"))) _ <- lit "]" *> CP.space t <- tok wordyId <|> tok symbolyId pure $ (fmap Reserved <$> typ) <> t @@ -760,7 +782,7 @@ lexemes' eof = wordyId :: P Lexeme wordyId = P.label wordyMsg . P.try $ do dot <- P.optional (lit ".") - segs <- P.sepBy1 wordyIdSeg (P.try (char '.' <* P.lookAhead (CP.satisfy wordyIdChar))) + segs <- P.sepBy1 wordyIdSeg (P.try (char '.' <* P.lookAhead (P.satisfy wordyIdChar))) shorthash <- P.optional shorthash pure $ WordyId (fromMaybe "" dot <> intercalate "." segs) shorthash where @@ -794,8 +816,8 @@ lexemes' eof = -- wordyIdSeg = litSeg <|> (P.try do -- todo wordyIdSeg = P.try $ do start <- pos - ch <- CP.satisfy wordyIdStartChar - rest <- P.many (CP.satisfy wordyIdChar) + ch <- P.satisfy wordyIdStartChar + rest <- P.many (P.satisfy wordyIdChar) let word = ch : rest when (Set.member word keywords) $ do stop <- pos @@ -824,7 +846,7 @@ lexemes' eof = Just sh -> pure sh separated :: (Char -> Bool) -> P a -> P a - separated ok p = P.try $ p <* P.lookAhead (void (CP.satisfy ok) <|> P.eof) + separated ok p = P.try $ p <* P.lookAhead (void (P.satisfy ok) <|> P.eof) numeric = bytes <|> otherbase <|> float <|> intOrNat where @@ -973,7 +995,7 @@ lexemes' eof = -- if we're within an existing {{ }} block, inLayout will be false -- so we can actually allow }} to appear in normal code inLayout <- S.gets inLayout - when (not inLayout) $ void $ P.lookAhead (CP.satisfy (/= '}')) + when (not inLayout) $ void $ P.lookAhead (P.satisfy (/= '}')) pure l matchWithBlocks = ["match-with", "cases"] parens = open "(" <|> close ["("] (lit ")") @@ -992,12 +1014,12 @@ lexemes' eof = _ -> fail "this comma is a pattern separator" delim = P.try $ do - ch <- CP.satisfy (\ch -> ch /= ';' && Set.member ch delimiters) + ch <- P.satisfy (\ch -> ch /= ';' && Set.member ch delimiters) pos <- pos pure [Token (Reserved [ch]) pos (inc pos)] delayOrForce = separated ok $ do - (start, op, end) <- positioned $ CP.satisfy isDelayOrForce + (start, op, end) <- positioned $ P.satisfy isDelayOrForce pure [Token (Reserved [op]) start end] where ok c = isDelayOrForce c || isSpace c || isAlphaNum c || Set.member c delimiters || c == '\"' @@ -1333,8 +1355,8 @@ instance EP.ShowErrorComponent (Token Err) where e -> show e excerpt s = if length s < 15 then s else take 15 s <> "..." -instance ShowToken (Token Lexeme) where - showTokens xs = +instance P.VisualStream [Token Lexeme] where + showTokens _ xs = join . Nel.toList . S.evalState (traverse go xs) . end $ Nel.head xs where go :: Token Lexeme -> S.State Pos String diff --git a/parser-typechecker/src/Unison/Parser.hs b/parser-typechecker/src/Unison/Parser.hs index 9307b25499..76decce2ef 100644 --- a/parser-typechecker/src/Unison/Parser.hs +++ b/parser-typechecker/src/Unison/Parser.hs @@ -1,24 +1,23 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} module Unison.Parser where import Control.Monad.Reader.Class (asks) import qualified Crypto.Random as Random -import Data.Bifunctor (bimap) import Data.Bytes.Put (runPutS) import Data.Bytes.Serial (serialize) import Data.Bytes.VarInt (VarInt (..)) import qualified Data.Char as Char -import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as Nel import qualified Data.Set as Set import qualified Data.Text as Text import Data.Typeable (Proxy (..)) import Text.Megaparsec (runParserT) import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Char as P import Text.Megaparsec.Error (ShowErrorComponent) import qualified U.Util.Base32Hex as Base32Hex import qualified Unison.ABT as ABT @@ -41,9 +40,6 @@ import Unison.Prelude foldl', fromMaybe, isJust, - join, - lastMay, - listToMaybe, optional, trace, void, @@ -64,7 +60,7 @@ type P v = P.ParsecT (Error v) Input ((->) ParsingEnv) type Token s = P.Token s -type Err v = P.ParseError (Token Input) (Error v) +type Err v = P.ParseError Input (Error v) data ParsingEnv = ParsingEnv { uniqueNames :: UniqueName, @@ -137,43 +133,8 @@ tokenToPair :: L.Token a -> (Ann, a) tokenToPair t = (ann t, L.payload t) newtype Input = Input {inputStream :: [L.Token L.Lexeme]} - deriving (Eq, Ord, Show) - -instance P.Stream Input where - type Token Input = L.Token L.Lexeme - type Tokens Input = Input - - tokenToChunk pxy = P.tokensToChunk pxy . pure - - tokensToChunk _ = Input - - chunkToTokens _ = inputStream - - chunkLength pxy = length . P.chunkToTokens pxy - - chunkEmpty pxy = null . P.chunkToTokens pxy - - positionAt1 _ sp t = setPos sp (L.start t) - - positionAtN pxy sp = - maybe sp (setPos sp . L.start) . listToMaybe . P.chunkToTokens pxy - - advance1 _ _ cp = setPos cp . L.end - - advanceN _ _ cp = maybe cp (setPos cp . L.end) . lastMay . inputStream - - take1_ (P.chunkToTokens proxy -> []) = Nothing - take1_ (P.chunkToTokens proxy -> t : ts) = Just (t, P.tokensToChunk proxy ts) - take1_ _ = error "Unpossible" - - takeN_ n (P.chunkToTokens proxy -> []) | n > 0 = Nothing - takeN_ n ts = - Just - . join bimap (P.tokensToChunk proxy) - . splitAt n - $ P.chunkToTokens proxy ts - - takeWhile_ p = join bimap (P.tokensToChunk proxy) . span p . inputStream + deriving stock (Eq, Ord, Show) + deriving newtype (P.Stream, P.VisualStream) setPos :: P.SourcePos -> L.Pos -> P.SourcePos setPos sp lp = @@ -220,13 +181,13 @@ tok :: (Ann -> a -> b) -> L.Token a -> b tok f (L.Token a start end) = f (Ann start end) a peekAny :: Ord v => P v (L.Token L.Lexeme) -peekAny = P.lookAhead P.anyChar +peekAny = P.lookAhead P.anySingle lookAhead :: Ord v => P v a -> P v a lookAhead = P.lookAhead anyToken :: Ord v => P v (L.Token L.Lexeme) -anyToken = P.anyChar +anyToken = P.anySingle failCommitted :: Ord v => Error v -> P v x failCommitted e = do @@ -249,17 +210,16 @@ run' p s name env = then L.lexer name (trace (L.debugLex''' "lexer receives" s) s) else L.lexer name s pTraced = traceRemainingTokens "parser receives" *> p - in runParserT pTraced name (Input lex) env + in case runParserT pTraced name (Input lex) env of + Left err -> Left (Nel.head (P.bundleErrors err)) + Right x -> Right x run :: Ord v => P v a -> String -> ParsingEnv -> Either (Err v) a run p s = run' p s "" -- Virtual pattern match on a lexeme. queryToken :: Ord v => (L.Lexeme -> Maybe a) -> P v (L.Token a) -queryToken f = P.token go Nothing - where - go t@(f . L.payload -> Just s) = Right $ fmap (const s) t - go x = Left (pure (P.Tokens (x :| [])), Set.empty) +queryToken f = P.token (traverse f) Set.empty -- Consume a block opening and return the string that opens the block. openBlock :: Ord v => P v (L.Token String) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 0578b01fe0..9e94d8a911 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -11,12 +11,12 @@ import Data.List (find, intersperse) import Data.List.Extra (nubOrd) import qualified Data.List.NonEmpty as Nel import qualified Data.Map as Map +import Data.Proxy import Data.Sequence (Seq (..)) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NES import qualified Data.Text as Text -import Data.Void (Void) import qualified Text.Megaparsec as P import qualified Unison.ABT as ABT import Unison.Builtin.Decls (pattern TupleType') @@ -1230,9 +1230,9 @@ prettyParseError s = \case excerpt ] L.Opaque msg -> style ErrorSite msg - P.TrivialError sp unexpected expected -> + te@(P.TrivialError _errOffset unexpected _expected) -> fromString - (P.parseErrorPretty @_ @Void (P.TrivialError sp unexpected expected)) + (P.parseErrorPretty te) <> ( case unexpected of Just (P.Tokens (toList -> ts)) -> case ts of [] -> mempty @@ -1418,7 +1418,7 @@ prettyParseError s = \case "\n" ] where - t = style Code (fromString (P.showTokens (pure tok))) + t = style Code (fromString (P.showTokens (Proxy @[L.Token L.Lexeme]) (pure tok))) go (Parser.ExpectedBlockOpen blockName tok@(L.payload -> L.Close)) = mconcat [ "I was expecting an indented block following the " diff --git a/parser-typechecker/tests/Unison/Test/Common.hs b/parser-typechecker/tests/Unison/Test/Common.hs index 60450f0d9f..3fe83cd3b4 100644 --- a/parser-typechecker/tests/Unison/Test/Common.hs +++ b/parser-typechecker/tests/Unison/Test/Common.hs @@ -15,7 +15,6 @@ import qualified Text.Megaparsec.Error as MPE import qualified Unison.ABT as ABT import qualified Unison.Builtin as B import qualified Unison.FileParsers as FP -import qualified Unison.Lexer as L import Unison.Names (Names) import qualified Unison.Parser as Parser import Unison.Parser.Ann (Ann (..)) @@ -58,7 +57,7 @@ tm s = showParseError :: Var v => String -> - MPE.ParseError (L.Token L.Lexeme) (Parser.Error v) -> + MPE.ParseError Parser.Input (Parser.Error v) -> String showParseError s = Pr.toANSI 60 . prettyParseError s diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 79cc7e7dc0..e908589c56 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack diff --git a/stack.yaml b/stack.yaml index 777895939e..c27a459300 100644 --- a/stack.yaml +++ b/stack.yaml @@ -35,8 +35,6 @@ extra-deps: commit: e47e9e9fe1f576f8c835183b9def52d73c01327a - github: unisonweb/haskeline commit: 2944b11d19ee034c48276edc991736105c9d6143 -- github: unisonweb/megaparsec - commit: c4463124c578e8d1074c04518779b5ce5957af6b - github: unisonweb/shellmet commit: 2fd348592c8f51bb4c0ca6ba4bc8e38668913746 - guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 diff --git a/stack.yaml.lock b/stack.yaml.lock index 07ed778d63..99b4efacbb 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,122 +5,111 @@ packages: - completed: - sha256: d4fd87fb7bfc5d8e9fbc3e4ee7302c6b1500cdc00fdb9b659d0f4849b6ebe2d5 - name: configurator size: 15989 url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz + name: configurator + version: 0.3.0.0 + sha256: d4fd87fb7bfc5d8e9fbc3e4ee7302c6b1500cdc00fdb9b659d0f4849b6ebe2d5 pantry-tree: - sha256: 90547cd983fd15ebdc803e057d3ef8735fe93a75e29a00f8a74eadc13ee0f6e9 size: 955 - version: 0.3.0.0 + sha256: 90547cd983fd15ebdc803e057d3ef8735fe93a75e29a00f8a74eadc13ee0f6e9 original: url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz - completed: - sha256: 6d44207a4e94a16bc99d13dccbbb79bf676190c0476436b03235eeeaf6c72f9d - name: haskeline size: 75098 url: https://github.com/unisonweb/haskeline/archive/2944b11d19ee034c48276edc991736105c9d6143.tar.gz + name: haskeline + version: 0.7.5.0 + sha256: 6d44207a4e94a16bc99d13dccbbb79bf676190c0476436b03235eeeaf6c72f9d pantry-tree: - sha256: 878c7fb5801ec7418761a49b529ca3fdab274f22707c7d2759f2b3a2df06c3ea size: 3717 - version: 0.7.5.0 + sha256: 878c7fb5801ec7418761a49b529ca3fdab274f22707c7d2759f2b3a2df06c3ea original: url: https://github.com/unisonweb/haskeline/archive/2944b11d19ee034c48276edc991736105c9d6143.tar.gz - completed: - sha256: 94f9573735fefda868371ff735a6b1f52bea22b9e52289abeb8114c99bbf8832 - name: megaparsec - size: 92490 - url: https://github.com/unisonweb/megaparsec/archive/c4463124c578e8d1074c04518779b5ce5957af6b.tar.gz - pantry-tree: - sha256: 7d3f8b23c862d878b4adce628caaf7bc337f0ac10b2556e1cdf0913c28a45929 - size: 2635 - version: 6.5.0 - original: - url: https://github.com/unisonweb/megaparsec/archive/c4463124c578e8d1074c04518779b5ce5957af6b.tar.gz -- completed: - sha256: 6e642163070a217cc3363bdbefde571ff6c1878f4fc3d92e9c910db7fa88eaf2 - name: shellmet size: 10460 url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz + name: shellmet + version: 0.0.4.0 + sha256: 6e642163070a217cc3363bdbefde571ff6c1878f4fc3d92e9c910db7fa88eaf2 pantry-tree: - sha256: 05a169a7a6b68100630e885054dc1821d31cd06571b0317ec90c75ac2c41aeb7 size: 654 - version: 0.0.4.0 + sha256: 05a169a7a6b68100630e885054dc1821d31cd06571b0317ec90c75ac2c41aeb7 original: url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz - completed: + hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 pantry-tree: - sha256: a33838b7b1c54f6ac3e1b436b25674948713a4189658e4d82e639b9a689bc90d size: 364 - hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 + sha256: a33838b7b1c54f6ac3e1b436b25674948713a4189658e4d82e639b9a689bc90d original: hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 - completed: + hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 pantry-tree: - sha256: a03f60a1250c9d0daaf208ba58ccf24e05e0807f2e3dc7892fad3f2f3a196f7f size: 476 - hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 + sha256: a03f60a1250c9d0daaf208ba58ccf24e05e0807f2e3dc7892fad3f2f3a196f7f original: hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 - completed: + hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 pantry-tree: - sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350 size: 3455 - hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 + sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350 original: hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 - completed: + hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 pantry-tree: - sha256: 876e5a679244143e2a7e74357427c7522a8d61f68a4cc3ae265fe4960b75a2e2 size: 212 - hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 + sha256: 876e5a679244143e2a7e74357427c7522a8d61f68a4cc3ae265fe4960b75a2e2 original: hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 - completed: + hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 pantry-tree: - sha256: 0e6c6d4f89083c8385de5adc4f36ad01b2b0ff45261b47f7d90d919969c8b5ed size: 542 - hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 + sha256: 0e6c6d4f89083c8385de5adc4f36ad01b2b0ff45261b47f7d90d919969c8b5ed original: hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 - completed: + hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 pantry-tree: - sha256: 8e049bd12ce2bd470909578f2ee8eb80b89d5ff88860afa30e29dd4eafecfa3e size: 713 - hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 + sha256: 8e049bd12ce2bd470909578f2ee8eb80b89d5ff88860afa30e29dd4eafecfa3e original: hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 - completed: + hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 pantry-tree: - sha256: d33d603a2f0d1a220ff0d5e7edb6273def89120e6bb958c2d836cae89e788334 size: 363 - hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 + sha256: d33d603a2f0d1a220ff0d5e7edb6273def89120e6bb958c2d836cae89e788334 original: hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 - completed: + hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 pantry-tree: - sha256: d87d84c3f760c1b2540f74e4a301cd4e8294df891e8e4262e8bdd313bc8e0bfd size: 2410 - hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 + sha256: d87d84c3f760c1b2540f74e4a301cd4e8294df891e8e4262e8bdd313bc8e0bfd original: hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 - completed: + hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 pantry-tree: - sha256: 3634593ce191e82793ea0e060598ab3cf67f2ef2fe1d65345dc9335ad529d25f size: 718 - hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 + sha256: 3634593ce191e82793ea0e060598ab3cf67f2ef2fe1d65345dc9335ad529d25f original: hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 - completed: + hackage: http-client-0.7.11@sha256:3f59ac8ffe2a3768846cdda040a0d1df2a413960529ba61c839861c948871967,5756 pantry-tree: - sha256: 8372e84e9c710097f4f80f2016ca15a5a0cd7884b8ac5ce70f26b3110f4401bd size: 2547 - hackage: http-client-0.7.11@sha256:3f59ac8ffe2a3768846cdda040a0d1df2a413960529ba61c839861c948871967,5756 + sha256: 8372e84e9c710097f4f80f2016ca15a5a0cd7884b8ac5ce70f26b3110f4401bd original: hackage: http-client-0.7.11 snapshots: - completed: - sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 size: 590100 url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml + sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 original: lts-18.28 diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 0dde3d6671..11fbffaa68 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -176,15 +176,15 @@ absolutePath = do void $ C.char '.' Path . Seq.fromList . fmap (NameSegment . Text.pack) <$> P.sepBy1 - ( (:) <$> C.satisfy Unison.Lexer.wordyIdStartChar - <*> P.many (C.satisfy Unison.Lexer.wordyIdChar) + ( (:) <$> P.satisfy Unison.Lexer.wordyIdStartChar + <*> P.many (P.satisfy Unison.Lexer.wordyIdChar) ) (C.char '.') treeishSuffix :: P Text treeishSuffix = P.label "git treeish" . P.try $ do void $ C.char ':' - notdothash <- C.noneOf @[] ".#:" + notdothash <- P.noneOf @[] ".#:" rest <- P.takeWhileP (Just "not colon") (/= ':') pure $ Text.cons notdothash rest diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index fb4a5939e3..4488b5357b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -19,7 +19,7 @@ defaultBaseLib :: Parsec Void Text ReadRemoteNamespace defaultBaseLib = fmap makeNS $ latest <|> release where latest, release, version :: Parsec Void Text Text - latest = "latest-" *> many anyChar *> eof $> "trunk" + latest = "latest-" *> many anySingle *> eof $> "trunk" release = fmap ("releases._" <>) $ "release/" *> version <* eof version = do Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 3d790fcf71..0653499a5c 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -9,6 +9,7 @@ import Data.List (intercalate, isPrefixOf) import Data.List.Extra (nubOrdOn) import qualified Data.List.NonEmpty as NE import qualified Data.Map as Map +import Data.Proxy (Proxy (..)) import qualified Data.Set as Set import qualified Data.Text as Text import Data.Void (Void) @@ -1243,25 +1244,27 @@ parseUri label input = let printError err = P.lines [P.string "I couldn't parse the repository address given above.", prettyPrintParseError input err] in first printError (P.parse UriParser.repoPath label (Text.pack input)) -prettyPrintParseError :: String -> P.ParseError Char Void -> P.Pretty P.ColorText -prettyPrintParseError input = \case - P.TrivialError sp ue ee -> - P.lines - [ printLocation sp, - P.newline, - printTrivial ue ee - ] - P.FancyError sp ee -> - let errors = foldMap (P.string . mappend "\n" . P.showErrorComponent) ee - in P.lines - [ printLocation sp, - errors - ] +prettyPrintParseError :: String -> P.ParseErrorBundle Text Void -> P.Pretty P.ColorText +prettyPrintParseError input errBundle = + let (firstError, sp) = NE.head . fst $ P.attachSourcePos P.errorOffset (P.bundleErrors errBundle) (P.bundlePosState errBundle) + in case firstError of + P.TrivialError _errorOffset ue ee -> + P.lines + [ printLocation sp, + P.newline, + printTrivial ue ee + ] + P.FancyError _errorOffset ee -> + let errors = foldMap (P.string . mappend "\n" . showErrorFancy) ee + in P.lines + [ printLocation sp, + errors + ] where - printLocation :: NE.NonEmpty P.SourcePos -> P.Pretty P.ColorText + printLocation :: P.SourcePos -> P.Pretty P.ColorText printLocation sp = - let col = (P.unPos $ P.sourceColumn $ NE.head sp) - 1 - row = (P.unPos $ P.sourceLine $ NE.head sp) - 1 + let col = (P.unPos $ P.sourceColumn sp) - 1 + row = (P.unPos $ P.sourceLine sp) - 1 errorLine = lines input !! row in P.lines [ P.newline, @@ -1271,8 +1274,8 @@ prettyPrintParseError input = \case printTrivial :: (Maybe (P.ErrorItem Char)) -> (Set (P.ErrorItem Char)) -> P.Pretty P.ColorText printTrivial ue ee = - let expected = "I expected " <> foldMap (P.singleQuoted . P.string . P.showErrorComponent) ee - found = P.string . mappend "I found " . P.showErrorComponent <$> ue + let expected = "I expected " <> foldMap (P.singleQuoted . P.string . showErrorItem) ee + found = P.string . mappend "I found " . showErrorItem <$> ue message = [expected] <> catMaybes [found] in P.oxfordCommasWith "." message @@ -2367,3 +2370,23 @@ explainRemote = P.backticked "https://github.com/org/repo:some-branch" ] ] + +showErrorFancy :: P.ShowErrorComponent e => P.ErrorFancy e -> String +showErrorFancy (P.ErrorFail msg) = msg +showErrorFancy (P.ErrorIndentation ord ref actual) = + "incorrect indentation (got " <> show (P.unPos actual) + <> ", should be " + <> p + <> show (P.unPos ref) + <> ")" + where + p = case ord of + LT -> "less than " + EQ -> "equal to " + GT -> "greater than " +showErrorFancy (P.ErrorCustom a) = P.showErrorComponent a + +showErrorItem :: P.ErrorItem (P.Token Text) -> String +showErrorItem (P.Tokens ts) = P.showTokens (Proxy @Text) ts +showErrorItem (P.Label label) = NE.toList label +showErrorItem P.EndOfInput = "end of input" From da18e47b2eea1df54df01884b169132bf04cb5de Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 2 Jun 2022 17:10:59 -0400 Subject: [PATCH 277/529] Add package.yaml workaround to stack rebuild issue --- codebase2/codebase-sqlite/package.yaml | 3 +++ .../codebase-sqlite/unison-codebase-sqlite.cabal | 2 -- codebase2/codebase-sync/package.yaml | 3 +++ codebase2/codebase-sync/unison-codebase-sync.cabal | 4 +--- codebase2/codebase/package.yaml | 3 +++ codebase2/codebase/unison-codebase.cabal | 2 -- codebase2/core/package.yaml | 3 +++ codebase2/core/unison-core.cabal | 4 +--- codebase2/util-serialization/package.yaml | 3 +++ .../unison-util-serialization.cabal | 4 +--- codebase2/util-term/package.yaml | 3 +++ codebase2/util-term/unison-util-term.cabal | 4 +--- codebase2/util/package.yaml | 7 +++++++ codebase2/util/unison-util.cabal | 5 +---- lib/unison-prelude/package.yaml | 3 +++ lib/unison-prelude/unison-prelude.cabal | 2 -- lib/unison-pretty-printer/package.yaml | 10 ++++++++++ .../unison-pretty-printer.cabal | 5 ----- lib/unison-sqlite/package.yaml | 4 ++++ lib/unison-util-relation/package.yaml | 9 +++++++++ .../unison-util-relation.cabal | 6 ------ parser-typechecker/package.yaml | 6 ++++++ parser-typechecker/unison-parser-typechecker.cabal | 3 --- unison-cli/package.yaml | 14 ++++++++++++++ unison-cli/unison-cli.cabal | 7 ------- unison-core/package.yaml | 3 +++ unison-core/unison-core1.cabal | 2 -- unison-share-api/package.yaml | 3 +++ unison-share-api/unison-share-api.cabal | 2 -- 29 files changed, 82 insertions(+), 47 deletions(-) diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index 91f633de87..6afc601b30 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -2,6 +2,9 @@ name: unison-codebase-sqlite github: unisonweb/unison library: + when: + - condition: false + other-modules: Paths_unison_codebase_sqlite source-dirs: . extra-source-files: diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 1fba325b10..5df6f75866 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -42,8 +42,6 @@ library U.Codebase.Sqlite.Symbol U.Codebase.Sqlite.Sync22 U.Codebase.Sqlite.Term.Format - other-modules: - Paths_unison_codebase_sqlite hs-source-dirs: ./ default-extensions: diff --git a/codebase2/codebase-sync/package.yaml b/codebase2/codebase-sync/package.yaml index be5d9b4d9f..88a368d166 100644 --- a/codebase2/codebase-sync/package.yaml +++ b/codebase2/codebase-sync/package.yaml @@ -3,6 +3,9 @@ github: unisonweb/unison library: source-dirs: . + when: + - condition: false + other-modules: Paths_unison_codebase_sync dependencies: - base diff --git a/codebase2/codebase-sync/unison-codebase-sync.cabal b/codebase2/codebase-sync/unison-codebase-sync.cabal index 793918dca4..7878ee41e9 100644 --- a/codebase2/codebase-sync/unison-codebase-sync.cabal +++ b/codebase2/codebase-sync/unison-codebase-sync.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: a62b0e8dbabe51c01ebc0871290e2427a734c0fbf9e78aee138b2bdad34d2704 +-- hash: e3307c66c00f5bf45548b61cb0aa78f2006c2df8b9ad9172c645f944688d6263 name: unison-codebase-sync version: 0.0.0 @@ -19,8 +19,6 @@ source-repository head library exposed-modules: U.Codebase.Sync - other-modules: - Paths_unison_codebase_sync hs-source-dirs: ./ build-depends: diff --git a/codebase2/codebase/package.yaml b/codebase2/codebase/package.yaml index 5cd83cb575..5e14f3d90e 100644 --- a/codebase2/codebase/package.yaml +++ b/codebase2/codebase/package.yaml @@ -20,6 +20,9 @@ default-extensions: library: source-dirs: . + when: + - condition: false + other-modules: Paths_unison_codebase dependencies: - base diff --git a/codebase2/codebase/unison-codebase.cabal b/codebase2/codebase/unison-codebase.cabal index d0f15314e2..62c44af0d1 100644 --- a/codebase2/codebase/unison-codebase.cabal +++ b/codebase2/codebase/unison-codebase.cabal @@ -32,8 +32,6 @@ library U.Codebase.Type U.Codebase.TypeEdit U.Codebase.WatchKind - other-modules: - Paths_unison_codebase hs-source-dirs: ./ default-extensions: diff --git a/codebase2/core/package.yaml b/codebase2/core/package.yaml index b98a6a6dff..db979d9664 100644 --- a/codebase2/core/package.yaml +++ b/codebase2/core/package.yaml @@ -3,6 +3,9 @@ github: unisonweb/unison library: source-dirs: . + when: + - condition: false + other-modules: Paths_unison_core dependencies: - base diff --git a/codebase2/core/unison-core.cabal b/codebase2/core/unison-core.cabal index 8436916748..82ba9672db 100644 --- a/codebase2/core/unison-core.cabal +++ b/codebase2/core/unison-core.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: f696d0f997ab3afba6494f5932ac232d27e77073a331ab64d3c8b7929d1deb3a +-- hash: 7b810bbd4d380ccd76c363eac447c7233c7b0e9d968960547c00d20ac3edeb08 name: unison-core version: 0.0.0 @@ -20,8 +20,6 @@ library exposed-modules: U.Core.ABT U.Core.ABT.Var - other-modules: - Paths_unison_core hs-source-dirs: ./ build-depends: diff --git a/codebase2/util-serialization/package.yaml b/codebase2/util-serialization/package.yaml index 51b20adb52..2f836d75cc 100644 --- a/codebase2/util-serialization/package.yaml +++ b/codebase2/util-serialization/package.yaml @@ -2,6 +2,9 @@ name: unison-util-serialization library: source-dirs: . + when: + - condition: false + other-modules: Paths_unison_util_serialization dependencies: - base diff --git a/codebase2/util-serialization/unison-util-serialization.cabal b/codebase2/util-serialization/unison-util-serialization.cabal index be2566b468..62a66f6d88 100644 --- a/codebase2/util-serialization/unison-util-serialization.cabal +++ b/codebase2/util-serialization/unison-util-serialization.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 0dd31d457a6c3bc41017d163374947c1c31752279ce7ce77bc5772150101afe1 +-- hash: 065e98437c72cce9c4cc6102d3eb0b3c8be444a95c3c71ab65a9d17f29e95eae name: unison-util-serialization version: 0.0.0 @@ -13,8 +13,6 @@ build-type: Simple library exposed-modules: U.Util.Serialization - other-modules: - Paths_unison_util_serialization hs-source-dirs: ./ build-depends: diff --git a/codebase2/util-term/package.yaml b/codebase2/util-term/package.yaml index b3ca704347..b1dd314885 100644 --- a/codebase2/util-term/package.yaml +++ b/codebase2/util-term/package.yaml @@ -3,6 +3,9 @@ github: unisonweb/unison library: source-dirs: . + when: + - condition: false + other-modules: Paths_unison_util_term dependencies: - base diff --git a/codebase2/util-term/unison-util-term.cabal b/codebase2/util-term/unison-util-term.cabal index 01a735ee49..1e95a37ce2 100644 --- a/codebase2/util-term/unison-util-term.cabal +++ b/codebase2/util-term/unison-util-term.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 655ca1a695b9a272d6b440b74fe2b6717f710a543d7ddb7639366d4233961bf8 +-- hash: 6b08707c87592d47677b3f2db15c17c94a23c13544f339227e43ac19f7ee7947 name: unison-util-term version: 0.0.0 @@ -20,8 +20,6 @@ library exposed-modules: U.Util.Term U.Util.Type - other-modules: - Paths_unison_util_term hs-source-dirs: ./ build-depends: diff --git a/codebase2/util/package.yaml b/codebase2/util/package.yaml index 96d664f085..da6bdb3a3b 100644 --- a/codebase2/util/package.yaml +++ b/codebase2/util/package.yaml @@ -3,13 +3,20 @@ github: unisonweb/unison library: source-dirs: src + when: + - condition: false + other-modules: Paths_unison_util benchmarks: bench: + when: + - condition: false + other-modules: Paths_unison_util dependencies: - criterion - sandi - unison-util + - unison-util-base32hex main: Main.hs source-dirs: bench diff --git a/codebase2/util/unison-util.cabal b/codebase2/util/unison-util.cabal index 9bfd2cf91d..aea5e09be7 100644 --- a/codebase2/util/unison-util.cabal +++ b/codebase2/util/unison-util.cabal @@ -26,8 +26,6 @@ library U.Util.String U.Util.Text U.Util.Timing - other-modules: - Paths_unison_util hs-source-dirs: src default-extensions: @@ -66,8 +64,6 @@ library benchmark bench type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: - Paths_unison_util hs-source-dirs: bench default-extensions: @@ -101,6 +97,7 @@ benchmark bench , text , time , unison-util + , unison-util-base32hex , unison-util-relation , unliftio , vector diff --git a/lib/unison-prelude/package.yaml b/lib/unison-prelude/package.yaml index e999a79ddd..83ba73773b 100644 --- a/lib/unison-prelude/package.yaml +++ b/lib/unison-prelude/package.yaml @@ -4,6 +4,9 @@ copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors library: source-dirs: src + when: + - condition: false + other-modules: Paths_unison_prelude dependencies: - base diff --git a/lib/unison-prelude/unison-prelude.cabal b/lib/unison-prelude/unison-prelude.cabal index 8bb82595b2..7549ef7462 100644 --- a/lib/unison-prelude/unison-prelude.cabal +++ b/lib/unison-prelude/unison-prelude.cabal @@ -21,8 +21,6 @@ library Unison.Prelude Unison.Util.Map Unison.Util.Set - other-modules: - Paths_unison_prelude hs-source-dirs: src default-extensions: diff --git a/lib/unison-pretty-printer/package.yaml b/lib/unison-pretty-printer/package.yaml index c2b77be01b..1f63dfd222 100644 --- a/lib/unison-pretty-printer/package.yaml +++ b/lib/unison-pretty-printer/package.yaml @@ -36,6 +36,10 @@ when: ghc-options: -funbox-strict-fields -O2 library: + when: + - condition: false + other-modules: Paths_unison_pretty_printer + source-dirs: src dependencies: - base @@ -53,6 +57,9 @@ library: executables: prettyprintdemo: + when: + - condition: false + other-modules: Paths_unison_pretty_printer source-dirs: prettyprintdemo main: Main.hs dependencies: @@ -64,6 +71,9 @@ executables: tests: pretty-printer-tests: + when: + - condition: false + other-modules: Paths_unison_pretty_printer source-dirs: tests main: Suite.hs ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 diff --git a/lib/unison-pretty-printer/unison-pretty-printer.cabal b/lib/unison-pretty-printer/unison-pretty-printer.cabal index 9a6186f05a..a5968ec87d 100644 --- a/lib/unison-pretty-printer/unison-pretty-printer.cabal +++ b/lib/unison-pretty-printer/unison-pretty-printer.cabal @@ -31,8 +31,6 @@ library Unison.Util.Pretty Unison.Util.Range Unison.Util.SyntaxText - other-modules: - Paths_unison_pretty_printer hs-source-dirs: src default-extensions: @@ -76,8 +74,6 @@ library executable prettyprintdemo main-is: Main.hs - other-modules: - Paths_unison_pretty_printer hs-source-dirs: prettyprintdemo default-extensions: @@ -118,7 +114,6 @@ test-suite pretty-printer-tests Unison.Test.ColorText Unison.Test.Range Unison.Test.Util.Pretty - Paths_unison_pretty_printer hs-source-dirs: tests default-extensions: diff --git a/lib/unison-sqlite/package.yaml b/lib/unison-sqlite/package.yaml index bd2c6917c1..5ee014e0ac 100644 --- a/lib/unison-sqlite/package.yaml +++ b/lib/unison-sqlite/package.yaml @@ -3,6 +3,10 @@ github: unisonweb/unison copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors library: + when: + - condition: false + other-modules: Paths_unison_sqlite + source-dirs: src other-modules: - Unison.Sqlite.DataVersion diff --git a/lib/unison-util-relation/package.yaml b/lib/unison-util-relation/package.yaml index 678c2bf123..25705bf517 100644 --- a/lib/unison-util-relation/package.yaml +++ b/lib/unison-util-relation/package.yaml @@ -4,9 +4,15 @@ copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors library: source-dirs: src + when: + - condition: false + other-modules: Paths_unison_util_relation tests: util-relation-tests: + when: + - condition: false + other-modules: Paths_unison_util_relation dependencies: - code-page - easytest @@ -17,6 +23,9 @@ tests: benchmarks: relation: + when: + - condition: false + other-modules: Paths_unison_util_relation source-dirs: benchmarks/relation main: Main.hs dependencies: diff --git a/lib/unison-util-relation/unison-util-relation.cabal b/lib/unison-util-relation/unison-util-relation.cabal index 99530e8ccd..d92dc66a37 100644 --- a/lib/unison-util-relation/unison-util-relation.cabal +++ b/lib/unison-util-relation/unison-util-relation.cabal @@ -20,8 +20,6 @@ library Unison.Util.Relation Unison.Util.Relation3 Unison.Util.Relation4 - other-modules: - Paths_unison_util_relation hs-source-dirs: src default-extensions: @@ -51,8 +49,6 @@ library test-suite util-relation-tests type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: - Paths_unison_util_relation hs-source-dirs: test default-extensions: @@ -86,8 +82,6 @@ test-suite util-relation-tests benchmark relation type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: - Paths_unison_util_relation hs-source-dirs: benchmarks/relation default-extensions: diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 389581d619..37150eba13 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -125,6 +125,9 @@ library: - open-browser - uri-encode - generic-lens + when: + - condition: false + other-modules: Paths_unison_parser_typechecker tests: parser-typechecker-tests: @@ -163,6 +166,9 @@ tests: - unison-util - unison-util-relation - unison-pretty-printer + when: + - condition: false + other-modules: Paths_unison_parser_typechecker default-extensions: - ApplicativeDo diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 79cc7e7dc0..819f1257bc 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -165,8 +165,6 @@ library Unison.Util.Text Unison.Util.TQueue Unison.Util.TransitiveClosure - other-modules: - Paths_unison_parser_typechecker hs-source-dirs: src default-extensions: @@ -339,7 +337,6 @@ test-suite parser-typechecker-tests Unison.Test.Util.Relation Unison.Test.Util.Text Unison.Test.Var - Paths_unison_parser_typechecker hs-source-dirs: tests default-extensions: diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 7b62d539a6..96cec9a8fd 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -66,9 +66,14 @@ library: when: - condition: '!os(windows)' dependencies: unix + - condition: false + other-modules: Paths_unison_cli tests: cli-tests: + when: + - condition: false + other-modules: Paths_unison_cli dependencies: - code-page - easytest @@ -81,6 +86,9 @@ tests: executables: unison: + when: + - condition: false + other-modules: Paths_unison_cli source-dirs: unison main: Main.hs ghc-options: -threaded -rtsopts -with-rtsopts=-I0 -optP-Wno-nonportable-include-path @@ -93,6 +101,9 @@ executables: - unison-cli transcripts: + when: + - condition: false + other-modules: Paths_unison_cli source-dirs: transcripts main: Transcripts.hs ghc-options: -threaded -rtsopts -with-rtsopts=-N -v0 @@ -104,6 +115,9 @@ executables: - unison-cli cli-integration-tests: + when: + - condition: false + other-modules: Paths_unison_cli source-dirs: integration-tests main: Suite.hs ghc-options: -W -threaded -rtsopts "-with-rtsopts=-N -T" -v0 diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 9dd47d58ce..17392b3bb7 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -62,8 +62,6 @@ library Unison.Share.Types Unison.Sync.HTTP Unison.Util.HTTP - other-modules: - Paths_unison_cli hs-source-dirs: src default-extensions: @@ -152,7 +150,6 @@ executable cli-integration-tests main-is: Suite.hs other-modules: IntegrationTests.ArgumentParsing - Paths_unison_cli hs-source-dirs: integration-tests default-extensions: @@ -242,8 +239,6 @@ executable cli-integration-tests executable transcripts main-is: Transcripts.hs - other-modules: - Paths_unison_cli hs-source-dirs: transcripts default-extensions: @@ -336,7 +331,6 @@ executable unison ArgParse System.Path Version - Paths_unison_cli hs-source-dirs: unison default-extensions: @@ -434,7 +428,6 @@ test-suite cli-tests Unison.Test.Ucm Unison.Test.UriParser Unison.Test.VersionParser - Paths_unison_cli hs-source-dirs: tests default-extensions: diff --git a/unison-core/package.yaml b/unison-core/package.yaml index 77738de834..bd59e25667 100644 --- a/unison-core/package.yaml +++ b/unison-core/package.yaml @@ -3,6 +3,9 @@ github: unisonweb/unison copyright: Copyright (C) 2013-2018 Unison Computing, PBC and contributors library: + when: + - condition: false + other-modules: Paths_unison_core1 source-dirs: src ghc-options: -Wall -fno-warn-name-shadowing -fno-warn-missing-pattern-synonym-signatures -funbox-strict-fields dependencies: diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index dbebb68187..0281f19dae 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -61,8 +61,6 @@ library Unison.Var Unison.Var.RefNamed Unison.WatchKind - other-modules: - Paths_unison_core1 hs-source-dirs: src default-extensions: diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index b7a1aa120a..d9198a892c 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -4,6 +4,9 @@ copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors library: source-dirs: src + when: + - condition: false + other-modules: Paths_unison_share_api dependencies: - base diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index 49bc8a9c38..79989aa72f 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -36,8 +36,6 @@ library Unison.Sync.API Unison.Sync.Types Unison.Util.Find - other-modules: - Paths_unison_share_api hs-source-dirs: src default-extensions: From 8495d22c25a7255ab8f5ca8f9def7b749ddabfae Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 3 Jun 2022 15:32:52 -0400 Subject: [PATCH 278/529] remove package that doesn't exist yet --- codebase2/util/package.yaml | 1 - codebase2/util/unison-util.cabal | 1 - 2 files changed, 2 deletions(-) diff --git a/codebase2/util/package.yaml b/codebase2/util/package.yaml index da6bdb3a3b..9b2bbb74f3 100644 --- a/codebase2/util/package.yaml +++ b/codebase2/util/package.yaml @@ -16,7 +16,6 @@ benchmarks: - criterion - sandi - unison-util - - unison-util-base32hex main: Main.hs source-dirs: bench diff --git a/codebase2/util/unison-util.cabal b/codebase2/util/unison-util.cabal index aea5e09be7..deaf94e03c 100644 --- a/codebase2/util/unison-util.cabal +++ b/codebase2/util/unison-util.cabal @@ -97,7 +97,6 @@ benchmark bench , text , time , unison-util - , unison-util-base32hex , unison-util-relation , unliftio , vector From 8558dacb36ce34e99083fe109ea55a616ab344c9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 3 Jun 2022 14:56:11 -0600 Subject: [PATCH 279/529] Maybe fix windows failures? --- unison-cli/tests/Unison/Test/GitSync.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-cli/tests/Unison/Test/GitSync.hs b/unison-cli/tests/Unison/Test/GitSync.hs index 0036c4b9c1..647b926ff6 100644 --- a/unison-cli/tests/Unison/Test/GitSync.hs +++ b/unison-cli/tests/Unison/Test/GitSync.hs @@ -109,7 +109,7 @@ test = Note that this only tests that the pull succeeds, since (at time of writing) we don't track/test transcript output for these tests in the unison repo. ```ucm - .> pull.without-history ${repo}:.child .child + .> pull.without-history git(${repo}):.child .child .> history .child ``` |] @@ -335,7 +335,7 @@ test = ( \repo -> [i| ```ucm - .> pull ${repo} + .> pull git(${repo}) .> history .> reset-root #l43v9nr16v .> history From 91ff128a62d406f1b4ff1e2ca1d1b9d3f3392ff6 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 3 Jun 2022 17:12:55 -0400 Subject: [PATCH 280/529] add comments and delete dead code --- .../U/Codebase/Sqlite/Queries.hs | 17 +++-------------- 1 file changed, 3 insertions(+), 14 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 4ef6278942..2f6571ecab 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -141,7 +141,6 @@ module U.Codebase.Sqlite.Queries syncToTempEntity, insertTempEntity, saveSyncEntity, - deleteTempDependencies, -- * db misc createSchema, @@ -619,8 +618,9 @@ flushCausalDependents chId = do hash <- expectHash32 (unCausalHashId chId) tryMoveTempEntityDependents hash --- | tryMoveTempEntityDependents does this: +-- | `tryMoveTempEntityDependents #foo` does this: -- 0. Precondition: We just inserted object #foo. +-- 0.5. look up the dependents of #foo -- 1. Delete #foo as dependency from temp_entity_missing_dependency. e.g. (#bar, #foo), (#baz, #foo) -- 2. Delete #foo from temp_entity (if it's there) -- 3. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, @@ -718,6 +718,7 @@ expectTempEntity b32 = do WHERE hash = ? |] +-- | look up all of the input entity's dependencies in the main table, to convert it to a sync entity tempToSyncEntity :: TempEntity -> Transaction SyncEntity tempToSyncEntity = \case Entity.TC term -> Entity.TC <$> tempToSyncTermComponent term @@ -1507,15 +1508,3 @@ deleteTempEntity hash = WHERE hash = ? |] (Only hash) - --- | takes a dependent's hash and multiple dependency hashes -deleteTempDependencies :: Foldable f => Base32Hex -> f Base32Hex -> Transaction () -deleteTempDependencies dependent (Foldable.toList -> dependencies) = - executeMany sql (map (dependent,) dependencies) - where - sql = - [here| - DELETE FROM temp_entity_missing_dependencies - WHERE dependent = ? - AND dependency = ? - |] From fed78f2afa27f91a86523b64b224f0a877fd1eef Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 3 Jun 2022 17:13:29 -0400 Subject: [PATCH 281/529] fix branch TempEntity serialization mismatch --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index 87aa6f04cd..a049a96265 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -771,7 +771,7 @@ putTempEntity = \case putFramedByteString bytes putSyncFullNamespace lids bytes = do putNamespaceLocalIds lids - putByteString bytes + putFramedByteString bytes putSyncDiffNamespace parent lids bytes = do putBase32Hex parent putNamespaceLocalIds lids From 3961c43c8d659faa0ba73271f7f3d4bb5e9bad24 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 3 Jun 2022 17:13:44 -0400 Subject: [PATCH 282/529] delete dead utility functions --- .../codebase-sqlite/U/Codebase/Sqlite/Serialization.hs | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index a049a96265..00b0239e84 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -791,16 +791,6 @@ putTempEntity = \case getBase32Hex :: MonadGet m => m Base32Hex getBase32Hex = Base32Hex.UnsafeFromText <$> getText -putFramedBytes :: MonadPut m => BS.ByteString -> m () -putFramedBytes bs = do - putVarInt (BS.length bs) - putByteString bs - -getFramedBytes :: MonadGet m => m BS.ByteString -getFramedBytes = do - length <- getVarInt - getByteString length - getTempTermFormat :: MonadGet m => m TempEntity.TempTermFormat getTempTermFormat = getWord8 >>= \case From ad29dd53555fdb9a68dd19924de58b9c67eee9e3 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 3 Jun 2022 17:13:52 -0400 Subject: [PATCH 283/529] ormolu --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index 00b0239e84..c93b495f09 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -32,6 +32,7 @@ import qualified U.Codebase.Sqlite.Branch.Format as BranchFormat import qualified U.Codebase.Sqlite.Branch.Full as BranchFull import qualified U.Codebase.Sqlite.Causal as Causal import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat +import qualified U.Codebase.Sqlite.Entity as Entity import U.Codebase.Sqlite.LocalIds (LocalIds, LocalIds' (..), LocalTextId, WatchLocalIds) import qualified U.Codebase.Sqlite.Patch.Diff as PatchDiff import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat @@ -40,7 +41,6 @@ import qualified U.Codebase.Sqlite.Patch.TermEdit as TermEdit import qualified U.Codebase.Sqlite.Patch.TypeEdit as TypeEdit import U.Codebase.Sqlite.Symbol (Symbol (..)) import U.Codebase.Sqlite.TempEntity (TempEntity) -import qualified U.Codebase.Sqlite.Entity as Entity import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat import qualified U.Codebase.Term as Term From 00cce77240d2557f77258db687b603e012dc068f Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 3 Jun 2022 17:14:11 -0400 Subject: [PATCH 284/529] hpack --- lib/unison-util-relation/unison-util-relation.cabal | 2 -- 1 file changed, 2 deletions(-) diff --git a/lib/unison-util-relation/unison-util-relation.cabal b/lib/unison-util-relation/unison-util-relation.cabal index 826f88e5b7..d92dc66a37 100644 --- a/lib/unison-util-relation/unison-util-relation.cabal +++ b/lib/unison-util-relation/unison-util-relation.cabal @@ -20,8 +20,6 @@ library Unison.Util.Relation Unison.Util.Relation3 Unison.Util.Relation4 - other-modules: - Paths_unison_util_relation hs-source-dirs: src default-extensions: From 18266a13a876faf90df62b0331cf30076c9b3fc4 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 3 Jun 2022 15:31:43 -0600 Subject: [PATCH 285/529] Update input patterns and unisonConfig for Share paths. (#3080) * Clean up docs and parsers for read/write remote namespaces for share * Revive deprecated git parser so old unisonConfig's still work * Don't hide git errors * Fix CodeserverURI -> URI conversion * Reflect the provided port in CodeserverURI * Focus messaging around primary action --- lib/unison-prelude/src/Unison/Debug.hs | 1 + parser-typechecker/package.yaml | 1 + .../src/Unison/Codebase/Editor/Git.hs | 10 +- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 59 ++++--- .../src/Unison/Codebase/Path.hs | 9 ++ .../src/Unison/Codebase/SqliteCodebase.hs | 2 +- parser-typechecker/src/Unison/Share/Types.hs | 146 ++++++++++++++++++ .../unison-parser-typechecker.cabal | 3 + unison-cli/src/Unison/Auth/HTTPClient.hs | 10 +- unison-cli/src/Unison/Auth/Types.hs | 2 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 77 +++++---- .../Codebase/Editor/HandleInput/AuthLogin.hs | 26 +--- .../src/Unison/Codebase/Editor/Output.hs | 8 +- .../src/Unison/Codebase/Editor/UriParser.hs | 61 +++++++- .../src/Unison/CommandLine/InputPatterns.hs | 80 ++++++---- .../src/Unison/CommandLine/OutputMessages.hs | 25 +-- unison-cli/src/Unison/Share/Codeserver.hs | 33 ++++ unison-cli/src/Unison/Share/Types.hs | 75 --------- unison-cli/tests/Unison/Test/UriParser.hs | 4 +- unison-cli/unison-cli.cabal | 2 +- 20 files changed, 415 insertions(+), 219 deletions(-) create mode 100644 parser-typechecker/src/Unison/Share/Types.hs create mode 100644 unison-cli/src/Unison/Share/Codeserver.hs delete mode 100644 unison-cli/src/Unison/Share/Types.hs diff --git a/lib/unison-prelude/src/Unison/Debug.hs b/lib/unison-prelude/src/Unison/Debug.hs index 475a81fbce..abd947ddda 100644 --- a/lib/unison-prelude/src/Unison/Debug.hs +++ b/lib/unison-prelude/src/Unison/Debug.hs @@ -6,6 +6,7 @@ module Unison.Debug whenDebug, debugLog, debugLogM, + shouldDebug, DebugFlag (..), ) where diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 3090f85262..3dc759e84f 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -64,6 +64,7 @@ dependencies: - NanoID - natural-transformation - network + - network-uri - network-simple - nonempty-containers - open-browser diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs index 1fabb1cbdb..da6089a46a 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs @@ -11,6 +11,7 @@ module Unison.Codebase.Editor.Git withIsolatedRepo, debugGit, gitDirToPath, + gitVerbosity, GitBranchBehavior (..), GitRepo (..), @@ -27,21 +28,18 @@ import qualified Data.Text as Text import Shellmet (($?), ($^), ($|)) import System.Exit (ExitCode (ExitSuccess)) import System.FilePath (()) -import System.IO.Unsafe (unsafePerformIO) -import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo(..)) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..)) import Unison.Codebase.GitError (GitProtocolError) import qualified Unison.Codebase.GitError as GitError +import qualified Unison.Debug as Debug import Unison.Prelude import qualified UnliftIO import UnliftIO.Directory (XdgDirectory (XdgCache), doesDirectoryExist, findExecutable, getXdgDirectory) -import UnliftIO.Environment (lookupEnv) import UnliftIO.IO (hFlush, stdout) import qualified UnliftIO.Process as UnliftIO debugGit :: Bool -debugGit = - isJust (unsafePerformIO (lookupEnv "UNISON_DEBUG_GIT")) -{-# NOINLINE debugGit #-} +debugGit = Debug.shouldDebug Debug.Git gitVerbosity :: [Text] gitVerbosity = diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index d7e6fe5c9a..973a6f298a 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -4,38 +4,51 @@ module Unison.Codebase.Editor.RemoteRepo where import qualified Data.Text as Text -import qualified Servant.Client as Servant import qualified U.Util.Monoid as Monoid import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Path as Path import Unison.Codebase.ShortBranchHash (ShortBranchHash) import qualified Unison.Codebase.ShortBranchHash as SBH import Unison.Prelude +import Unison.Share.Types data ReadRepo = ReadRepoGit ReadGitRepo - | ReadRepoShare ShareRepo - deriving (Eq, Show) + | ReadRepoShare ShareCodeserver + deriving stock (Eq, Ord, Show) + +data ShareCodeserver + = DefaultCodeserver + | CustomCodeserver CodeserverURI + deriving stock (Eq, Ord, Show) + +-- | +-- >>> :set -XOverloadedLists +-- >>> import Data.Maybe (fromJust) +-- >>> import Network.URI +-- >>> displayShareCodeserver DefaultCodeserver "share" ["base", "List"] +-- "share.base.List" +-- >>> displayShareCodeserver DefaultCodeserver "share" [] +-- "share" +-- >>> displayShareCodeserver (CustomCodeserver . fromJust $ parseURI "https://share-next.unison-lang.org/api" >>= codeserverFromURI ) "unison" ["base", "List"] +-- "share(https://share-next.unison-lang.org:443/api).unison.base.List" +displayShareCodeserver :: ShareCodeserver -> Text -> Path -> Text +displayShareCodeserver cs repo path = + let shareServer = case cs of + DefaultCodeserver -> "" + CustomCodeserver cu -> "share(" <> tShow cu <> ")." + in shareServer <> repo <> maybePrintPath path data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} - deriving (Eq, Show) - --- FIXME rename to ShareServer -data ShareRepo = ShareRepo - deriving (Eq, Show) - -shareRepoToBaseUrl :: ShareRepo -> Servant.BaseUrl -shareRepoToBaseUrl ShareRepo = - Servant.BaseUrl Servant.Http "localhost" 5424 "sync" - + deriving stock (Eq, Ord, Show) data WriteRepo = WriteRepoGit WriteGitRepo - | WriteRepoShare ShareRepo - deriving (Eq, Show) + | WriteRepoShare ShareCodeserver + deriving stock (Eq, Ord, Show) data WriteGitRepo = WriteGitRepo {url :: Text, branch :: Maybe Text} - deriving (Eq, Show) + deriving stock (Eq, Ord, Show) writeToRead :: WriteRepo -> ReadRepo writeToRead = \case @@ -69,16 +82,16 @@ printNamespace = \case maybePrintSBH = \case Nothing -> mempty Just sbh -> "#" <> SBH.toText sbh - ReadRemoteNamespaceShare ReadShareRemoteNamespace {server = ShareRepo, repo, path} -> - repo <> maybePrintPath path + ReadRemoteNamespaceShare ReadShareRemoteNamespace {server, repo, path} -> + displayShareCodeserver server repo path -- | Render a 'WriteRemotePath' as text. printWriteRemotePath :: WriteRemotePath -> Text printWriteRemotePath = \case - WriteRemotePathGit WriteGitRemotePath {repo, path} -> + WriteRemotePathGit (WriteGitRemotePath {repo, path}) -> printWriteGitRepo repo <> maybePrintPath path - WriteRemotePathShare WriteShareRemotePath {server = ShareRepo, repo, path} -> - repo <> maybePrintPath path + WriteRemotePathShare (WriteShareRemotePath {server, repo, path}) -> + displayShareCodeserver server repo path maybePrintPath :: Path -> Text maybePrintPath path = @@ -99,7 +112,7 @@ data ReadGitRemoteNamespace = ReadGitRemoteNamespace deriving stock (Eq, Show) data ReadShareRemoteNamespace = ReadShareRemoteNamespace - { server :: ShareRepo, + { server :: ShareCodeserver, repo :: Text, -- sbh :: Maybe ShortBranchHash, -- maybe later path :: Path @@ -118,7 +131,7 @@ data WriteGitRemotePath = WriteGitRemotePath deriving stock (Eq, Show) data WriteShareRemotePath = WriteShareRemotePath - { server :: ShareRepo, + { server :: ShareCodeserver, repo :: Text, path :: Path } diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index ce94277688..7463dcedb0 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -4,6 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} module Unison.Codebase.Path @@ -79,6 +80,7 @@ import qualified Data.List.NonEmpty as List.NonEmpty import Data.Sequence (Seq ((:<|), (:|>))) import qualified Data.Sequence as Seq import qualified Data.Text as Text +import qualified GHC.Exts as GHC import qualified Unison.HashQualified' as HQ' import Unison.Name (Convert (..), Name, Parse) import qualified Unison.Name as Name @@ -92,6 +94,13 @@ newtype Path = Path {toSeq :: Seq NameSegment} deriving stock (Eq, Ord) deriving newtype (Semigroup, Monoid) +-- | Meant for use mostly in doc-tests where it's +-- sometimes convenient to specify paths as lists. +instance GHC.IsList Path where + type Item Path = NameSegment + toList (Path segs) = Foldable.toList segs + fromList = Path . Seq.fromList + newtype Absolute = Absolute {unabsolute :: Path} deriving (Eq, Ord) newtype Relative = Relative {unrelative :: Path} deriving (Eq, Ord) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 38bd6ea72d..3b0d34516e 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -885,6 +885,6 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift -- Push our changes to the repo, silencing all output. -- Even with quiet, the remote (Github) can still send output through, -- so we capture stdout and stderr. - (successful, _stdout, stderr) <- gitInCaptured remotePath $ ["push", "--quiet", url] ++ maybe [] (pure @[]) mayGitBranch + (successful, _stdout, stderr) <- gitInCaptured remotePath $ ["push", url] ++ Git.gitVerbosity ++ maybe [] (pure @[]) mayGitBranch when (not successful) . throwIO $ GitError.PushException repo (Text.unpack stderr) pure True diff --git a/parser-typechecker/src/Unison/Share/Types.hs b/parser-typechecker/src/Unison/Share/Types.hs new file mode 100644 index 0000000000..4b27b437e9 --- /dev/null +++ b/parser-typechecker/src/Unison/Share/Types.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Types related to Share and Codeservers. +module Unison.Share.Types + ( CodeserverURI (..), + CodeserverId (..), + Scheme (..), + codeserverFromURI, + codeserverIdFromURI, + codeserverToURI, + codeserverIdFromCodeserverURI, + codeserverBaseURL, + ) +where + +import Data.Aeson +import qualified Data.List as List +import qualified Data.List.Extra as List +import Data.Text +import qualified Data.Text as Text +import Network.URI +import qualified Servant.Client as Servant +import Unison.Prelude + +data Scheme = Http | Https + deriving (Eq, Ord, Show) + +-- | This type is expanded out into all of its fields because we require certain pieces +-- which are optional in a URI, and also to make it more typesafe to eventually convert into a +-- BaseURL for servant clients. +data CodeserverURI = CodeserverURI + { codeserverScheme :: Scheme, + codeserverUserInfo :: String, + codeserverRegName :: String, + -- A custom port, if one was specified. + codeserverPort :: Maybe Int, + codeserverPath :: [String] + } + deriving stock (Eq, Ord) + +instance Show CodeserverURI where + show = show . codeserverToURI + +codeserverToURI :: CodeserverURI -> URI +codeserverToURI cs@(CodeserverURI {..}) = + let scheme = case codeserverScheme of + Http -> "http:" + Https -> "https:" + authority = codeserverAuthority cs + in URI + { uriScheme = scheme, + uriAuthority = Just authority, + uriPath = case codeserverPath of + [] -> "" + segs -> "/" <> List.intercalate "/" segs, + uriQuery = "", + uriFragment = "" + } + +codeserverAuthority :: CodeserverURI -> URIAuth +codeserverAuthority (CodeserverURI {..}) = + URIAuth + { uriUserInfo = codeserverUserInfo, + uriPort = case codeserverPort of + Nothing -> "" + Just p -> ":" <> show p, + uriRegName = codeserverRegName + } + +-- | +-- >>> import Data.Maybe (fromJust) +-- >>> codeserverFromURI . fromJust $ parseURI "http://localhost:8080" +-- Just http://localhost:8080 +-- >>> codeserverFromURI . fromJust $ parseURI "http://localhost:80" +-- Just http://localhost:80 +-- >>> codeserverFromURI . fromJust $ parseURI "https://share.unison-lang.org/api" +-- Just https://share.unison-lang.org/api +-- >>> codeserverFromURI . fromJust $ parseURI "http://share.unison-lang.org/api" +-- Just http://share.unison-lang.org/api +codeserverFromURI :: URI -> Maybe CodeserverURI +codeserverFromURI URI {..} = do + URIAuth {uriUserInfo, uriRegName, uriPort} <- uriAuthority + scheme <- case uriScheme of + "http:" -> Just Http + "https:" -> Just Https + _ -> Nothing + let port = case uriPort of + (':' : p) -> readMaybe p + _ -> Nothing + pure $ + CodeserverURI + { codeserverScheme = scheme, + codeserverUserInfo = uriUserInfo, + codeserverRegName = uriRegName, + codeserverPort = port, + codeserverPath = + let unprefixed = + case uriPath of + ('/' : path) -> path + path -> path + in case List.splitOn "/" unprefixed of + [""] -> [] + p -> p + } + +-- | This is distinct from the codeserver URI in that we store credentials by a normalized ID, since it's +-- much easier to look up that way than from an arbitrary path. +-- We may wish to use explicitly named configurations in the future. +-- This currently uses a stringified uriAuthority. +newtype CodeserverId = CodeserverId {codeserverId :: Text} + deriving newtype (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey) + +-- | Gets the part of the CodeserverURI that we use for identifying that codeserver in +-- credentials files. +-- +-- >>> import Data.Maybe (fromJust) +-- >>> import Network.URI (parseURI) +-- >>> codeserverIdFromURI (CodeserverURI . fromJust $ parseURI "http://localhost:5424/api") +-- >>> codeserverIdFromURI (CodeserverURI . fromJust $ parseURI "https://share.unison-lang.org/api") +-- Right "localhost" +-- Right "share.unison-lang.org" +codeserverIdFromURI :: URI -> Either Text CodeserverId +codeserverIdFromURI uri = + case uriAuthority uri of + Nothing -> Left $ "No URI Authority for URI " <> tShow uri + Just ua -> pure $ codeserverIdFromURIAuth ua + +-- | Builds a CodeserverId from a URIAuth +codeserverIdFromURIAuth :: URIAuth -> CodeserverId +codeserverIdFromURIAuth ua = + (CodeserverId (Text.pack $ uriUserInfo ua <> uriRegName ua <> uriPort ua)) + +-- | Gets the CodeserverId for a given CodeserverURI +codeserverIdFromCodeserverURI :: CodeserverURI -> CodeserverId +codeserverIdFromCodeserverURI = + codeserverIdFromURIAuth . codeserverAuthority + +-- | Builds a servant-compatible BaseUrl for a given CodeserverURI. +codeserverBaseURL :: CodeserverURI -> Servant.BaseUrl +codeserverBaseURL (CodeserverURI {..}) = + let (scheme, defaultPort) = case codeserverScheme of + Https -> (Servant.Https, 443) + Http -> (Servant.Http, 80) + host = codeserverUserInfo <> codeserverRegName + in Servant.BaseUrl scheme host (fromMaybe defaultPort codeserverPort) (List.intercalate "/" codeserverPath) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 91acd0a2b4..05229db71a 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -135,6 +135,7 @@ library Unison.Runtime.SparseVector Unison.Runtime.Stack Unison.Runtime.Vector + Unison.Share.Types Unison.TermParser Unison.TermPrinter Unison.Typechecker @@ -246,6 +247,7 @@ library , natural-transformation , network , network-simple + , network-uri , nonempty-containers , open-browser , openapi3 @@ -424,6 +426,7 @@ test-suite parser-typechecker-tests , natural-transformation , network , network-simple + , network-uri , nonempty-containers , open-browser , openapi3 diff --git a/unison-cli/src/Unison/Auth/HTTPClient.hs b/unison-cli/src/Unison/Auth/HTTPClient.hs index 52b9131b24..4b16205bcf 100644 --- a/unison-cli/src/Unison/Auth/HTTPClient.hs +++ b/unison-cli/src/Unison/Auth/HTTPClient.hs @@ -32,10 +32,10 @@ newAuthorizedHTTPClient credsMan ucmVersion = liftIO $ do -- If a host isn't associated with any credentials auth is omitted. authMiddleware :: TokenProvider -> (Request -> IO Request) authMiddleware tokenProvider req = do - case (codeserverIdFromURI $ (HTTP.getUri req)) of + case codeserverIdFromURI $ (HTTP.getUri req) of + -- If we can't identify an appropriate codeserver we pass it through without any auth. Left _ -> pure req Right codeserverHost -> do - result <- tokenProvider codeserverHost - case result of - Right token -> pure $ HTTP.applyBearerAuth (Text.encodeUtf8 token) req - Left _ -> pure req + tokenProvider codeserverHost <&> \case + Right token -> HTTP.applyBearerAuth (Text.encodeUtf8 token) req + Left _ -> req diff --git a/unison-cli/src/Unison/Auth/Types.hs b/unison-cli/src/Unison/Auth/Types.hs index 13b745568b..67b6eb66fd 100644 --- a/unison-cli/src/Unison/Auth/Types.hs +++ b/unison-cli/src/Unison/Auth/Types.hs @@ -29,7 +29,7 @@ import Data.Time (NominalDiffTime) import Network.URI import qualified Network.URI as URI import Unison.Prelude -import Unison.Share.Types (CodeserverId, CodeserverURI) +import Unison.Share.Types defaultProfileName :: ProfileName defaultProfileName = "default" diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index efb30e8624..169496ce58 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -67,10 +67,10 @@ import Unison.Codebase.Editor.RemoteRepo WriteRemotePath (..), WriteShareRemotePath (..), printNamespace, - shareRepoToBaseUrl, writePathToRead, writeToReadGit, ) +import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -142,6 +142,7 @@ import Unison.Server.SearchResult (SearchResult) import qualified Unison.Server.SearchResult as SR import qualified Unison.Server.SearchResult' as SR' import qualified Unison.Share.Sync as Share +import Unison.Share.Types (codeserverBaseURL) import qualified Unison.ShortHash as SH import qualified Unison.Sqlite as Sqlite import Unison.Symbol (Symbol) @@ -169,6 +170,7 @@ import Unison.Util.TransitiveClosure (transitiveClosure) import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.WatchKind as WK +import qualified Unison.Share.Codeserver as Codeserver defaultPatchNameSegment :: NameSegment defaultPatchNameSegment = "patch" @@ -715,8 +717,8 @@ loop = do case getAtSplit' dest of Just existingDest | not (Branch.isEmpty0 (Branch.head existingDest)) -> do - -- Branch exists and isn't empty, print an error - throwError (BranchAlreadyExists (Path.unsplit' dest)) + -- Branch exists and isn't empty, print an error + throwError (BranchAlreadyExists (Path.unsplit' dest)) _ -> pure () -- allow rewriting history to ensure we move the branch's history too. lift $ @@ -1409,11 +1411,11 @@ loop = do case filtered of [(Referent.Ref ref, ty)] | Typechecker.isSubtype ty mainType -> - eval (MakeStandalone ppe ref output) >>= \case - Just err -> respond $ EvaluationFailure err - Nothing -> pure () + eval (MakeStandalone ppe ref output) >>= \case + Just err -> respond $ EvaluationFailure err + Nothing -> pure () | otherwise -> - respond $ BadMainFunction smain ty ppe [mainType] + respond $ BadMainFunction smain ty ppe [mainType] _ -> respond $ NoMainFunction smain ppe [mainType] IOTestI main -> do -- todo - allow this to run tests from scratch file, using addRunMain @@ -1653,7 +1655,7 @@ loop = do UpdateBuiltinsI -> notImplemented QuitI -> empty GistI input -> handleGist input - AuthLoginI -> authLogin + AuthLoginI -> authLogin (Codeserver.resolveCodeserver RemoteRepo.DefaultCodeserver) VersionI -> do ucmVersion <- eval UCMVersion respond $ PrintVersion ucmVersion @@ -1823,7 +1825,8 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do let opts = PushGitBranchOpts {setRoot = True, syncMode} runExceptT (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case Left gitErr -> respond (Output.GitError gitErr) - Right _branch -> respond Success + Right (Left errOutput) -> respond errOutput + Right (Right _branch) -> respond Success NormalPush (WriteRemotePathShare sharePath) pushBehavior -> handlePushToUnisonShare sharePath localPath pushBehavior GistyPush repo -> do @@ -1831,6 +1834,7 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do let opts = PushGitBranchOpts {setRoot = False, syncMode} runExceptT (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))) >>= \case Left gitErr -> respond (Output.GitError gitErr) + Right (Left errOutput) -> respond errOutput Right _result -> do sbhLength <- eval BranchHashLength respond $ @@ -1855,6 +1859,8 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do handlePushToUnisonShare :: MonadIO m => WriteShareRemotePath -> Path.Absolute -> PushBehavior -> Action' m v () handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} localPath behavior = do + let codeserver = Codeserver.resolveCodeserver server + let baseURL = codeserverBaseURL codeserver let sharePath = Share.Path (repo Nel.:| pathToSegments remotePath) LoopState.Env {authHTTPClient, codebase = Codebase {connection}} <- ask @@ -1870,7 +1876,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l push = Share.checkAndSetPush authHTTPClient - (shareRepoToBaseUrl server) + baseURL connection sharePath Nothing @@ -1881,7 +1887,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l PushBehavior.RequireNonEmpty -> do let push :: IO (Either Share.FastForwardPushError ()) push = - Share.fastForwardPush authHTTPClient (shareRepoToBaseUrl server) connection sharePath localCausalHash + Share.fastForwardPush authHTTPClient baseURL connection sharePath localCausalHash liftIO push >>= \case Left err -> respond (Output.ShareError (ShareErrorFastForwardPush err)) Right () -> pure () @@ -2223,20 +2229,33 @@ resolveConfiguredUrl :: resolveConfiguredUrl pushPull destPath' = ExceptT do currentPath' <- use LoopState.currentPath let destPath = Path.resolve currentPath' destPath' - let configKey = gitUrlKey destPath - (eval . ConfigLookup) configKey >>= \case - Just url -> - case P.parse UriParser.writeRemotePath (Text.unpack configKey) url of + let remoteMappingConfigKey = remoteMappingKey destPath + (eval . ConfigLookup) remoteMappingConfigKey >>= \case + Nothing -> do + let gitUrlConfigKey = gitUrlKey destPath + -- Fall back to deprecated GitUrl key + (eval . ConfigLookup) gitUrlConfigKey >>= \case + Just url -> + case WriteRemotePathGit <$> P.parse UriParser.deprecatedWriteGitRemotePath (Text.unpack gitUrlConfigKey) url of + Left e -> + pure . Left $ + ConfiguredRemoteMappingParseError pushPull destPath url (show e) + Right ns -> + pure . Right $ ns + Nothing -> + pure . Left $ NoConfiguredRemoteMapping pushPull destPath + Just url -> do + case P.parse UriParser.writeRemotePath (Text.unpack remoteMappingConfigKey) url of Left e -> pure . Left $ - ConfiguredGitUrlParseError pushPull destPath' url (show e) + ConfiguredRemoteMappingParseError pushPull destPath url (show e) Right ns -> pure . Right $ ns - Nothing -> - pure . Left $ NoConfiguredGitUrl pushPull destPath' - -gitUrlKey :: Path.Absolute -> Text -gitUrlKey = configKey "GitUrl" + where + gitUrlKey :: Path.Absolute -> Text + gitUrlKey = configKey "GitUrl" + remoteMappingKey :: Path.Absolute -> Text + remoteMappingKey = configKey "RemoteMapping" configKey :: Text -> Path.Absolute -> Text configKey k p = @@ -2256,11 +2275,13 @@ viewRemoteGitBranch ns gitBranchBehavior action = do eval $ ViewRemoteGitBranch ns gitBranchBehavior action importRemoteShareBranch :: MonadIO m => ReadShareRemoteNamespace -> Action' m v (Either (Output v) (Branch m)) -importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = +importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do + let codeserver = Codeserver.resolveCodeserver server + let baseURL = codeserverBaseURL codeserver mapLeft Output.ShareError <$> do let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask - liftIO (Share.pull authHTTPClient (shareRepoToBaseUrl server) connection shareFlavoredPath) >>= \case + liftIO (Share.pull authHTTPClient baseURL connection shareFlavoredPath) >>= \case Left e -> pure (Left (Output.ShareErrorPull e)) Right causalHash -> do (eval . Eval) (Codebase.getBranchForHash codebase (Cv.causalHash2to1 causalHash)) >>= \case @@ -2556,10 +2577,10 @@ searchBranchScored names0 score queries = pair qn HQ.HashQualified qn h | h `SH.isPrefixOf` Referent.toShortHash ref -> - pair qn + pair qn HQ.HashOnly h | h `SH.isPrefixOf` Referent.toShortHash ref -> - Set.singleton (Nothing, result) + Set.singleton (Nothing, result) _ -> mempty where result = SR.termSearchResult names0 name ref @@ -2576,10 +2597,10 @@ searchBranchScored names0 score queries = pair qn HQ.HashQualified qn h | h `SH.isPrefixOf` Reference.toShortHash ref -> - pair qn + pair qn HQ.HashOnly h | h `SH.isPrefixOf` Reference.toShortHash ref -> - Set.singleton (Nothing, result) + Set.singleton (Nothing, result) _ -> mempty where result = SR.typeSearchResult names0 name ref @@ -2972,7 +2993,7 @@ docsI srcLoc prettyPrintNames src = do | Set.size s == 1 -> displayI prettyPrintNames ConsoleLocation dotDoc | Set.size s == 0 -> respond $ ListOfLinks mempty [] | otherwise -> -- todo: return a list of links here too - respond $ ListOfLinks mempty [] + respond $ ListOfLinks mempty [] filterBySlurpResult :: Ord v => diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs index e54e488abb..0b100261a2 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs @@ -1,36 +1,14 @@ module Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin) where import Control.Monad.Reader -import Network.URI (URIAuth (..), parseURI) -import System.IO.Unsafe (unsafePerformIO) import Unison.Auth.OAuth (authenticateCodeserver) import Unison.Codebase.Editor.HandleInput.LoopState import Unison.Codebase.Editor.Output (Output (CredentialFailureMsg, Success)) -import Unison.Prelude import Unison.Share.Types import qualified UnliftIO -import UnliftIO.Environment (lookupEnv) --- | This is the URI where the share API is based. -defaultShareURI :: CodeserverURI -defaultShareURI = unsafePerformIO $ do - lookupEnv "UNISON_SHARE_HOST" <&> \case - -- TODO: swap to production share before release. - Nothing -> - CodeserverURI - { codeserverScheme = "https:", - codeserverAuthority = URIAuth {uriUserInfo = "", uriRegName = "share-next.us-west-2.unison-lang.org", uriPort = ""}, - codeserverPath = "/api" - } - Just shareHost -> - fromMaybe (error $ "Share Host is not a valid URI: " <> shareHost) $ do - uri <- parseURI shareHost - codeserverFromURI uri -{-# NOINLINE defaultShareURI #-} - -authLogin :: UnliftIO.MonadUnliftIO m => Action m i v () -authLogin = do - let host = defaultShareURI +authLogin :: UnliftIO.MonadUnliftIO m => CodeserverURI -> Action m i v () +authLogin host = do credsMan <- asks credentialManager (Action . lift . lift . lift $ authenticateCodeserver credsMan host) >>= \case Left err -> respond (CredentialFailureMsg err) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 74b4793453..b5498df726 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -211,8 +211,8 @@ data Output v | GitError GitError | ShareError ShareError | ConfiguredMetadataParseError Path' String (P.Pretty P.ColorText) - | NoConfiguredGitUrl PushPull Path' - | ConfiguredGitUrlParseError PushPull Path' Text String + | NoConfiguredRemoteMapping PushPull Path.Absolute + | ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String | MetadataMissingType PPE.PrettyPrintEnv Referent | TermMissingType Reference | MetadataAmbiguous (HQ.HashQualified Name) PPE.PrettyPrintEnv [Referent] @@ -354,8 +354,8 @@ isFailure o = case o of GitError {} -> True BustedBuiltins {} -> True ConfiguredMetadataParseError {} -> True - NoConfiguredGitUrl {} -> True - ConfiguredGitUrlParseError {} -> True + NoConfiguredRemoteMapping {} -> True + ConfiguredRemoteMappingParseError {} -> True MetadataMissingType {} -> True MetadataAmbiguous {} -> True PatchNeedsToBeConflictFree {} -> True diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index f24e18ed1e..544b6804e1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -3,6 +3,7 @@ module Unison.Codebase.Editor.UriParser ( repoPath, writeGitRepo, + deprecatedWriteGitRemotePath, writeRemotePath, ) where @@ -19,7 +20,7 @@ import Unison.Codebase.Editor.RemoteRepo ReadGitRepo (..), ReadRemoteNamespace (..), ReadShareRemoteNamespace (..), - ShareRepo (..), + ShareCodeserver (DefaultCodeserver), WriteGitRemotePath (..), WriteGitRepo (..), WriteRemotePath (..), @@ -75,7 +76,7 @@ writeShareRemotePath :: P WriteShareRemotePath writeShareRemotePath = P.label "write share remote path" $ WriteShareRemotePath - <$> pure ShareRepo + <$> pure DefaultCodeserver <*> (NameSegment.toText <$> nameSegment) <*> (Path.fromList <$> P.many (C.char '.' *> nameSegment)) @@ -87,21 +88,21 @@ readShareRemoteNamespace :: P ReadShareRemoteNamespace readShareRemoteNamespace = do P.label "read share remote namespace" $ ReadShareRemoteNamespace - <$> pure ShareRepo + <$> pure DefaultCodeserver -- <*> sbh <- P.optional shortBranchHash <*> (NameSegment.toText <$> nameSegment) <*> (Path.fromList <$> P.many (C.char '.' *> nameSegment)) --- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf.foo.bar" -- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf" -- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf." -- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)" -- >>> P.parseMaybe readGitRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3" --- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = foo.bar}) +-- >>> P.parseMaybe readGitRemoteNamespace "git( user@server:project.git:branch )#asdf.foo.bar" -- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = }) -- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = }) -- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Nothing, path = }) -- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "git@github.com:unisonweb/base", ref = Just "v3"}, sbh = Nothing, path = _releases.M3}) +-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = foo.bar}) readGitRemoteNamespace :: P ReadGitRemoteNamespace readGitRemoteNamespace = P.label "generic git repo" $ do P.string "git(" @@ -150,6 +151,56 @@ writeGitRepo = P.label "repo root for writing" $ do P.string ")" pure WriteGitRepo {url = printProtocol uri, branch = treeish} +-- | A parser for the deprecated format of git URLs, which may still exist in old GitURL +-- unisonConfigs. +-- +-- >>> P.parseMaybe deprecatedWriteGitRemotePath "/srv/git/project.git:.namespace" +-- >>> P.parseMaybe deprecatedWriteGitRemotePath "/srv/git/project.git:branch:.namespace" +-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "/srv/git/project.git", branch = Nothing}, path = namespace}) +-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"}, path = namespace}) +-- +-- >>> P.parseMaybe deprecatedWriteGitRemotePath "file:///srv/git/project.git" +-- >>> P.parseMaybe deprecatedWriteGitRemotePath "file:///srv/git/project.git:branch" +-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing}, path = }) +-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"}, path = }) +-- +-- >>> P.parseMaybe deprecatedWriteGitRemotePath "https://example.com/gitproject.git" +-- >>> P.parseMaybe deprecatedWriteGitRemotePath "https://example.com/gitproject.git:base" +-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing}, path = }) +-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"}, path = }) +-- +-- >>> P.parseMaybe deprecatedWriteGitRemotePath "ssh://user@server/project.git" +-- >>> P.parseMaybe deprecatedWriteGitRemotePath "ssh://user@server/project.git:branch" +-- >>> P.parseMaybe deprecatedWriteGitRemotePath "ssh://server/project.git" +-- >>> P.parseMaybe deprecatedWriteGitRemotePath "ssh://server/project.git:branch" +-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing}, path = }) +-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"}, path = }) +-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "ssh://server/project.git", branch = Nothing}, path = }) +-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"}, path = }) +-- +-- >>> P.parseMaybe deprecatedWriteGitRemotePath "server:project" +-- >>> P.parseMaybe deprecatedWriteGitRemotePath "user@server:project.git:branch" +-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "server:project", branch = Nothing}, path = }) +-- Just (WriteGitRemotePath {repo = WriteGitRepo {url = "user@server:project.git", branch = Just "branch"}, path = }) +deprecatedWriteGitRemotePath :: P WriteGitRemotePath +deprecatedWriteGitRemotePath = P.label "generic write repo" $ do + repo <- deprecatedWriteGitRepo + path <- P.optional (C.char ':' *> absolutePath) + pure WriteGitRemotePath {repo, path = fromMaybe Path.empty path} + where + deprecatedWriteGitRepo :: P WriteGitRepo + deprecatedWriteGitRepo = do + P.label "repo root for writing" $ do + uri <- parseGitProtocol + treeish <- P.optional deprecatedTreeishSuffix + pure WriteGitRepo {url = printProtocol uri, branch = treeish} + deprecatedTreeishSuffix :: P Text + deprecatedTreeishSuffix = P.label "git treeish" . P.try $ do + void $ C.char ':' + notdothash <- C.noneOf @[] ".#:" + rest <- P.takeWhileP (Just "not colon") (/= ':') + pure $ Text.cons notdothash rest + -- git(myrepo@git.com).foo.bar writeGitRemotePath :: P WriteGitRemotePath writeGitRemotePath = P.label "generic write repo" $ do diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index fc60b6745e..3269053384 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -997,7 +997,7 @@ pullImpl name verbosity pullMode addendum = do name [] I.Visible - [(Optional, gitUrlArg), (Optional, namespaceArg)] + [(Optional, remoteNamespaceArg), (Optional, namespaceArg)] ( P.lines [ P.wrap "The" @@ -1016,8 +1016,7 @@ pullImpl name verbosity pullMode addendum = do ), ( makeExample' self, "merges the remote namespace configured in `.unisonConfig`" - <> "with the key `GitUrl.ns` where `ns` is the current namespace," - <> "into the current namespace" + <> "at the key `RemoteMappings.` where `` is the current namespace," ) ], "", @@ -1028,10 +1027,10 @@ pullImpl name verbosity pullMode addendum = do [] -> Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.ShortCircuit pullMode verbosity [url] -> do - ns <- parseUri "url" url + ns <- parseReadRemoteNamespace "remote-namespace" url Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.ShortCircuit pullMode verbosity [url, path] -> do - ns <- parseUri "url" url + ns <- parseReadRemoteNamespace "remote-namespace" url p <- first fromString $ Path.parsePath' path Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.ShortCircuit pullMode verbosity _ -> Left (I.help self) @@ -1043,7 +1042,7 @@ pullExhaustive = "debug.pull-exhaustive" [] I.Visible - [(Required, gitUrlArg), (Optional, namespaceArg)] + [(Required, remoteNamespaceArg), (Optional, namespaceArg)] ( P.lines [ P.wrap $ "The " <> makeExample' pullExhaustive <> "command can be used in place of" @@ -1057,10 +1056,10 @@ pullExhaustive = [] -> Right $ Input.PullRemoteBranchI Nothing Path.relativeEmpty' SyncMode.Complete Input.PullWithHistory Verbosity.Default [url] -> do - ns <- parseUri "url" url + ns <- parseReadRemoteNamespace "remote-namespace" url Right $ Input.PullRemoteBranchI (Just ns) Path.relativeEmpty' SyncMode.Complete Input.PullWithHistory Verbosity.Default [url, path] -> do - ns <- parseUri "url" url + ns <- parseReadRemoteNamespace "remote-namespace" url p <- first fromString $ Path.parsePath' path Right $ Input.PullRemoteBranchI (Just ns) p SyncMode.Complete Input.PullWithHistory Verbosity.Default _ -> Left (I.help pull) @@ -1072,7 +1071,7 @@ push = "push" [] I.Visible - [(Required, gitUrlArg), (Optional, namespaceArg)] + [(Required, remoteNamespaceArg), (Optional, namespaceArg)] ( P.lines [ P.wrap "The `push` command merges a local namespace into a remote namespace.", @@ -1086,9 +1085,8 @@ push = "publishes the current namespace into the remote namespace `remote`" ), ( "`push`", - "publishes the current namespace" - <> "into the remote namespace configured in `.unisonConfig`" - <> "with the key `GitUrl.ns` where `ns` is the current namespace" + "publishes the current namespace into the remote namespace configured in your `.unisonConfig`" + <> "at the key `RemoteMappings.` where `` is the current namespace." ) ], "", @@ -1099,7 +1097,7 @@ push = [] -> Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireNonEmpty SyncMode.ShortCircuit url : rest -> do - pushPath <- parsePushPath "url" url + pushPath <- parseWriteRemotePath "remote-path" url p <- case rest of [] -> Right Path.relativeEmpty' [path] -> first fromString $ Path.parsePath' path @@ -1113,7 +1111,7 @@ pushCreate = "push.create" [] I.Visible - [(Required, gitUrlArg), (Optional, namespaceArg)] + [(Required, remoteNamespaceArg), (Optional, namespaceArg)] ( P.lines [ P.wrap "The `push.create` command pushes a local namespace to an empty remote namespace.", @@ -1127,9 +1125,9 @@ pushCreate = "publishes the current namespace into the empty remote namespace `remote`" ), ( "`push`", - "publishes the current namespace" - <> "into the empty remote namespace configured in `.unisonConfig`" - <> "with the key `GitUrl.ns` where `ns` is the current namespace" + "publishes the current namespace into the remote namespace configured in your `.unisonConfig`" + <> "at the key `RemoteMappings.` where `` is the current namespace," + <> "then publishes the current namespace to that location." ) ], "", @@ -1140,7 +1138,7 @@ pushCreate = [] -> Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireEmpty SyncMode.ShortCircuit url : rest -> do - pushPath <- parsePushPath "url" url + pushPath <- parseWriteRemotePath "remote-path" url p <- case rest of [] -> Right Path.relativeEmpty' [path] -> first fromString $ Path.parsePath' path @@ -1154,7 +1152,7 @@ pushExhaustive = "debug.push-exhaustive" [] I.Visible - [(Required, gitUrlArg), (Optional, namespaceArg)] + [(Required, remoteNamespaceArg), (Optional, namespaceArg)] ( P.lines [ P.wrap $ "The " <> makeExample' pushExhaustive <> "command can be used in place of" @@ -1168,7 +1166,7 @@ pushExhaustive = [] -> Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireNonEmpty SyncMode.Complete url : rest -> do - pushPath <- parsePushPath "url" url + pushPath <- parseWriteRemotePath "remote-path" url p <- case rest of [] -> Right Path.relativeEmpty' [path] -> first fromString $ Path.parsePath' path @@ -1182,7 +1180,7 @@ createPullRequest = "pull-request.create" ["pr.create"] I.Visible - [(Required, gitUrlArg), (Required, gitUrlArg), (Optional, namespaceArg)] + [(Required, remoteNamespaceArg), (Required, remoteNamespaceArg), (Optional, namespaceArg)] ( P.group $ P.lines [ P.wrap $ @@ -1200,8 +1198,8 @@ createPullRequest = ) ( \case [baseUrl, headUrl] -> do - baseRepo <- parseUri "baseRepo" baseUrl - headRepo <- parseUri "headRepo" headUrl + baseRepo <- parseReadRemoteNamespace "base-remote-namespace" baseUrl + headRepo <- parseReadRemoteNamespace "head-remote-namespace" headUrl pure $ Input.CreatePullRequestI baseRepo headRepo _ -> Left (I.help createPullRequest) ) @@ -1212,7 +1210,7 @@ loadPullRequest = "pull-request.load" ["pr.load"] I.Visible - [(Required, gitUrlArg), (Required, gitUrlArg), (Optional, namespaceArg)] + [(Required, remoteNamespaceArg), (Required, remoteNamespaceArg), (Optional, namespaceArg)] ( P.lines [ P.wrap $ makeExample loadPullRequest ["base", "head"] @@ -1227,19 +1225,19 @@ loadPullRequest = ) ( \case [baseUrl, headUrl] -> do - baseRepo <- parseUri "baseRepo" baseUrl - headRepo <- parseUri "topicRepo" headUrl + baseRepo <- parseReadRemoteNamespace "base-remote-namespace" baseUrl + headRepo <- parseReadRemoteNamespace "head-remote-namespace" headUrl pure $ Input.LoadPullRequestI baseRepo headRepo Path.relativeEmpty' [baseUrl, headUrl, dest] -> do - baseRepo <- parseUri "baseRepo" baseUrl - headRepo <- parseUri "topicRepo" headUrl + baseRepo <- parseReadRemoteNamespace "base-remote-namespace" baseUrl + headRepo <- parseReadRemoteNamespace "head-remote-namespace" headUrl destPath <- first fromString $ Path.parsePath' dest pure $ Input.LoadPullRequestI baseRepo headRepo destPath _ -> Left (I.help loadPullRequest) ) -parseUri :: String -> String -> Either (P.Pretty P.ColorText) ReadRemoteNamespace -parseUri label input = +parseReadRemoteNamespace :: String -> String -> Either (P.Pretty P.ColorText) ReadRemoteNamespace +parseReadRemoteNamespace label input = let printError err = P.lines [P.string "I couldn't parse the repository address given above.", prettyPrintParseError input err] in first printError (P.parse UriParser.repoPath label (Text.pack input)) @@ -1282,8 +1280,8 @@ parseWriteGitRepo label input = do (fromString . show) -- turn any parsing errors into a Pretty. (P.parse UriParser.writeGitRepo label (Text.pack input)) -parsePushPath :: String -> String -> Either (P.Pretty P.ColorText) WriteRemotePath -parsePushPath label input = do +parseWriteRemotePath :: String -> String -> Either (P.Pretty P.ColorText) WriteRemotePath +parseWriteRemotePath label input = do first (fromString . show) -- turn any parsing errors into a Pretty. (P.parse UriParser.writeRemotePath label (Text.pack input)) @@ -2352,6 +2350,24 @@ gitUrlArg = globTargets = mempty } +-- | Refers to a namespace on some remote code host. +remoteNamespaceArg :: ArgumentType +remoteNamespaceArg = + ArgumentType + { typeName = "remote-namespace", + suggestions = + let complete s = pure [Completion s s False] + in \input _ _ _ -> case input of + "gh" -> complete "git(https://github.com/" + "gl" -> complete "git(https://gitlab.com/" + "bb" -> complete "git(https://bitbucket.com/" + "ghs" -> complete "git(git@github.com:" + "gls" -> complete "git(git@gitlab.com:" + "bbs" -> complete "git(git@bitbucket.com:" + _ -> pure [], + globTargets = mempty + } + collectNothings :: (a -> Maybe b) -> [a] -> [a] collectNothings f as = [a | (Nothing, a) <- map f as `zip` as] diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 771a4e8d4e..f02961efa9 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1229,25 +1229,25 @@ notifyUser dir o = case o of "", err ] - NoConfiguredGitUrl pp p -> + NoConfiguredRemoteMapping pp p -> pure . P.fatalCallout . P.wrap $ "I don't know where to " <> pushPull "push to!" "pull from!" pp - <> ( if Path.isRoot' p + <> ( if Path.isRoot p then "" else - "Add a line like `GitUrl." <> P.shown p - <> " = ' to .unisonConfig. " + "Add a line like `RemoteMapping." <> P.shown p + <> " = namespace.path' to .unisonConfig. " ) <> "Type `help " <> pushPull "push" "pull" pp <> "` for more information." -- | ConfiguredGitUrlParseError PushPull Path' Text String - ConfiguredGitUrlParseError pp p url err -> + ConfiguredRemoteMappingParseError pp p url err -> pure . P.fatalCallout . P.lines $ [ P.wrap $ - "I couldn't understand the GitUrl that's set for" - <> prettyPath' p + "I couldn't understand the RemoteMapping that's set for" + <> prettyAbsolute p <> "in .unisonConfig", P.wrap $ "The value I found was" <> (P.backticked . P.blue . P.text) url @@ -1599,9 +1599,10 @@ notifyUser dir o = case o of (Share.FastForwardPushErrorNoReadPermission sharePath) -> noReadPermission sharePath (Share.FastForwardPushInvalidParentage parent child) -> P.fatalCallout - ( P.lines ["The server detected an error in the history being pushed, please report this as a bug in ucm." - , "The history in question is the hash: " <> prettyShareHash child <> " with the ancestor: " <> prettyShareHash parent - ] + ( P.lines + [ "The server detected an error in the history being pushed, please report this as a bug in ucm.", + "The history in question is the hash: " <> prettyShareHash child <> " with the ancestor: " <> prettyShareHash parent + ] ) Share.FastForwardPushErrorNotFastForward sharePath -> P.lines $ @@ -1657,7 +1658,7 @@ notifyUser dir o = case o of _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" expectedNonEmptyPushDest writeRemotePath = P.lines - [ P.wrap ("The remote namespace" <> prettyWriteRemotePath writeRemotePath <> "is empty."), + [ P.wrap ("The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is empty."), "", P.wrap ("Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?") ] @@ -1666,7 +1667,7 @@ notifyUser dir o = case o of -- client code that doesn't know about WriteRemotePath ( WriteRemotePathShare WriteShareRemotePath - { server = RemoteRepo.ShareRepo, + { server = RemoteRepo.DefaultCodeserver, repo = Share.unRepoName (Share.pathRepoName sharePath), path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath)) } diff --git a/unison-cli/src/Unison/Share/Codeserver.hs b/unison-cli/src/Unison/Share/Codeserver.hs new file mode 100644 index 0000000000..9e2b710e5d --- /dev/null +++ b/unison-cli/src/Unison/Share/Codeserver.hs @@ -0,0 +1,33 @@ +module Unison.Share.Codeserver where + +import Network.URI (parseURI) +import System.IO.Unsafe (unsafePerformIO) +import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo +import Unison.Prelude +import Unison.Share.Types +import qualified Unison.Share.Types as Share +import UnliftIO.Environment (lookupEnv) + +-- | This is the URI where the share API is based. +defaultCodeserver :: CodeserverURI +defaultCodeserver = unsafePerformIO $ do + lookupEnv "UNISON_SHARE_HOST" <&> \case + -- TODO: swap to production share before release. + Nothing -> + CodeserverURI + { codeserverScheme = Share.Https, + codeserverUserInfo = "", + codeserverRegName = "share-next.us-west-2.unison-lang.org", + codeserverPort = Just 443, + codeserverPath = ["api"] + } + Just shareHost -> + fromMaybe (error $ "Share Host is not a valid URI: " <> shareHost) $ do + uri <- parseURI shareHost + codeserverFromURI uri +{-# NOINLINE defaultCodeserver #-} + +resolveCodeserver :: RemoteRepo.ShareCodeserver -> CodeserverURI +resolveCodeserver = \case + RemoteRepo.DefaultCodeserver -> defaultCodeserver + RemoteRepo.CustomCodeserver cs -> cs diff --git a/unison-cli/src/Unison/Share/Types.hs b/unison-cli/src/Unison/Share/Types.hs deleted file mode 100644 index 0436a90b04..0000000000 --- a/unison-cli/src/Unison/Share/Types.hs +++ /dev/null @@ -1,75 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE RecordWildCards #-} - -module Unison.Share.Types - ( CodeserverURI (..), - CodeserverId (..), - codeserverFromURI, - codeserverIdFromURI, - codeserverToURI, - codeserverIdFromCodeserverURI, - ) -where - -import Data.Aeson -import Data.Text -import qualified Data.Text as Text -import Network.URI -import Unison.Prelude - -data CodeserverURI = CodeserverURI - { codeserverScheme :: String, - codeserverAuthority :: URIAuth, - codeserverPath :: String - } - deriving stock (Show, Eq, Ord) - -codeserverToURI :: CodeserverURI -> URI -codeserverToURI (CodeserverURI {..}) = - URI - { uriScheme = codeserverScheme, - uriAuthority = Just codeserverAuthority, - uriPath = codeserverPath, - uriQuery = "", - uriFragment = "" - } - -codeserverFromURI :: URI -> Maybe CodeserverURI -codeserverFromURI URI {..} = do - uriAuth <- uriAuthority - pure $ - CodeserverURI - { codeserverScheme = uriScheme, - codeserverAuthority = uriAuth, - codeserverPath = uriPath - } - --- | This is distinct from the codeserver URI in that we store credentials by a normalized ID, since it's --- much easier to look up that way than from an arbitrary path. --- We may wish to use explicitly named configurations in the future. --- This currently uses a stringified uriAuthority. -newtype CodeserverId = CodeserverId {codeserverId :: Text} - deriving newtype (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey) - --- | Gets the part of the CodeserverURI that we use for identifying that codeserver in --- credentials files. --- --- >>> import Data.Maybe (fromJust) --- >>> import Network.URI (parseURI) --- >>> codeserverIdFromURI (CodeserverURI . fromJust $ parseURI "http://localhost:5424/api") --- >>> codeserverIdFromURI (CodeserverURI . fromJust $ parseURI "https://share.unison-lang.org/api") --- Right "localhost" --- Right "share.unison-lang.org" -codeserverIdFromURI :: URI -> Either Text CodeserverId -codeserverIdFromURI uri = - case uriAuthority uri of - Nothing -> Left $ "No URI Authority for URI " <> tShow uri - Just ua -> pure $ codeserverIdFromURIAuth ua - -codeserverIdFromURIAuth :: URIAuth -> CodeserverId -codeserverIdFromURIAuth ua = - (CodeserverId (Text.pack $ uriUserInfo ua <> uriRegName ua <> uriPort ua)) - -codeserverIdFromCodeserverURI :: CodeserverURI -> CodeserverId -codeserverIdFromCodeserverURI = - codeserverIdFromURIAuth . codeserverAuthority diff --git a/unison-cli/tests/Unison/Test/UriParser.hs b/unison-cli/tests/Unison/Test/UriParser.hs index 850c951909..305b337877 100644 --- a/unison-cli/tests/Unison/Test/UriParser.hs +++ b/unison-cli/tests/Unison/Test/UriParser.hs @@ -12,7 +12,7 @@ import qualified Text.Megaparsec as P import Unison.Codebase.Editor.RemoteRepo ( ReadGitRepo (..), ReadRemoteNamespace (..), - ShareRepo (..), + ShareCodeserver(..), pattern ReadGitRemoteNamespace, pattern ReadShareRemoteNamespace, ) @@ -33,7 +33,7 @@ testShare = scope "share" . tests $ [ parseAugmented ( "unisonweb.base._releases.M4", - ReadRemoteNamespaceShare (ReadShareRemoteNamespace ShareRepo "unisonweb" (path ["base", "_releases", "M4"])) + ReadRemoteNamespaceShare (ReadShareRemoteNamespace DefaultCodeserver "unisonweb" (path ["base", "_releases", "M4"])) ), expectParseFailure ".unisonweb.base" ] diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 20e4b8f773..310cc6882f 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -60,8 +60,8 @@ library Unison.CommandLine.Main Unison.CommandLine.OutputMessages Unison.CommandLine.Welcome + Unison.Share.Codeserver Unison.Share.Sync - Unison.Share.Types Unison.Util.HTTP hs-source-dirs: src From 6eddc5681834deb6922f9aababec68fc693c57a9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 3 Jun 2022 15:49:48 -0600 Subject: [PATCH 286/529] Commit cabal changes --- lib/unison-util-relation/unison-util-relation.cabal | 2 -- 1 file changed, 2 deletions(-) diff --git a/lib/unison-util-relation/unison-util-relation.cabal b/lib/unison-util-relation/unison-util-relation.cabal index 826f88e5b7..d92dc66a37 100644 --- a/lib/unison-util-relation/unison-util-relation.cabal +++ b/lib/unison-util-relation/unison-util-relation.cabal @@ -20,8 +20,6 @@ library Unison.Util.Relation Unison.Util.Relation3 Unison.Util.Relation4 - other-modules: - Paths_unison_util_relation hs-source-dirs: src default-extensions: From 8f4cbd92e5ea61fb34492acdbe2d338fe3e943b1 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 3 Jun 2022 20:35:28 -0400 Subject: [PATCH 287/529] delete hie.yaml --- hie.yaml | 85 -------------------------------------------------------- 1 file changed, 85 deletions(-) delete mode 100644 hie.yaml diff --git a/hie.yaml b/hie.yaml deleted file mode 100644 index 182444fff6..0000000000 --- a/hie.yaml +++ /dev/null @@ -1,85 +0,0 @@ -cradle: - stack: - - path: "codebase2/codebase/" - component: "unison-codebase:lib" - - - path: "codebase2/codebase-sqlite" - component: "unison-codebase-sqlite:lib" - - - path: "codebase2/codebase-sync" - component: "unison-codebase-sync:lib" - - - path: "codebase2/core" - component: "unison-core:lib" - - - path: "codebase2/util/src" - component: "unison-util:lib" - - - path: "codebase2/util/bench" - component: "unison-util:bench:bench" - - - path: "codebase2/util-serialization" - component: "unison-util-serialization:lib" - - - path: "codebase2/util-term" - component: "unison-util-term:lib" - - - path: "lib/unison-prelude/src" - component: "unison-prelude:lib" - - - path: "lib/unison-pretty-printer/src" - component: "unison-pretty-printer:lib" - - - path: "lib/unison-pretty-printer/prettyprintdemo" - component: "unison-pretty-printer:exe:prettyprintdemo" - - - path: "lib/unison-pretty-printer/tests" - component: "unison-pretty-printer:test:pretty-printer-tests" - - - path: "lib/unison-sqlite/src" - component: "unison-sqlite:lib" - - - path: "lib/unison-util-base32hex/src" - component: "unison-util-base32hex:lib" - - - path: "lib/unison-util-relation/src" - component: "unison-util-relation:lib" - - - path: "lib/unison-util-relation/test" - component: "unison-util-relation:test:util-relation-tests" - - - path: "lib/unison-util-relation/benchmarks/relation" - component: "unison-util-relation:bench:relation" - - - path: "parser-typechecker/src" - component: "unison-parser-typechecker:lib" - - - path: "parser-typechecker/tests" - component: "unison-parser-typechecker:test:parser-typechecker-tests" - - - path: "unison-cli/src" - component: "unison-cli:lib" - - - path: "unison-cli/integration-tests" - component: "unison-cli:exe:cli-integration-tests" - - - path: "unison-cli/transcripts" - component: "unison-cli:exe:transcripts" - - - path: "unison-cli/unison" - component: "unison-cli:exe:unison" - - - path: "unison-cli/tests" - component: "unison-cli:test:cli-tests" - - - path: "unison-core/src" - component: "unison-core1:lib" - - - path: "unison-share-api/src" - component: "unison-share-api:lib" - - - path: "yaks/easytest/src" - component: "easytest:lib" - - - path: "yaks/easytest/tests" - component: "easytest:exe:runtests" From 0ad12af4016e19512858b86911e571e52900c813 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 3 Jun 2022 21:06:51 -0400 Subject: [PATCH 288/529] begin implementing push/pull progress reporting --- lib/unison-prelude/src/Unison/Prelude/Text.hs | 14 ++++ lib/unison-prelude/unison-prelude.cabal | 1 + unison-cli/package.yaml | 1 + .../src/Unison/Codebase/Editor/HandleInput.hs | 77 +++++++++++++------ unison-cli/src/Unison/Share/Sync.hs | 46 +++++++---- unison-cli/unison-cli.cabal | 5 ++ 6 files changed, 106 insertions(+), 38 deletions(-) create mode 100644 lib/unison-prelude/src/Unison/Prelude/Text.hs diff --git a/lib/unison-prelude/src/Unison/Prelude/Text.hs b/lib/unison-prelude/src/Unison/Prelude/Text.hs new file mode 100644 index 0000000000..9b44413ceb --- /dev/null +++ b/lib/unison-prelude/src/Unison/Prelude/Text.hs @@ -0,0 +1,14 @@ +module Unison.Prelude.Text + ( fromInt, + ) +where + +import Data.Text (Text) +import qualified Data.Text.Lazy as LazyText +import qualified Data.Text.Lazy.Builder as LazyText.Builder +import qualified Data.Text.Lazy.Builder.Int as LazyText.Builder + +-- | Render an Int as Text. +fromInt :: Int -> Text +fromInt = + LazyText.toStrict . LazyText.Builder.toLazyText . LazyText.Builder.decimal diff --git a/lib/unison-prelude/unison-prelude.cabal b/lib/unison-prelude/unison-prelude.cabal index dc6b7d04df..c5878a03b1 100644 --- a/lib/unison-prelude/unison-prelude.cabal +++ b/lib/unison-prelude/unison-prelude.cabal @@ -19,6 +19,7 @@ library exposed-modules: Unison.Debug Unison.Prelude + Unison.Prelude.Text Unison.Util.Map Unison.Util.Monoid Unison.Util.Set diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 21b4bff000..3e33e68ea7 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -17,6 +17,7 @@ dependencies: - base - bytes - bytestring + - concurrent-output - configurator - containers >= 0.6.3 - cryptonite diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 169496ce58..0422f0fbd3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -27,7 +27,9 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) +import qualified System.Console.Regions as Console.Regions import qualified Text.Megaparsec as P +import U.Codebase.HashTags (CausalHash) import qualified U.Codebase.Sqlite.Operations as Ops import U.Util.Timing (unsafeTime) import qualified Unison.ABT as ABT @@ -122,6 +124,7 @@ import qualified Unison.NamesWithHistory as NamesWithHistory import Unison.Parser.Ann (Ann (..)) import Unison.Position (Position (..)) import Unison.Prelude +import qualified Unison.Prelude.Text as Text import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.PrettyPrintEnv.Names as PPE import qualified Unison.PrettyPrintEnvDecl as PPE @@ -141,6 +144,7 @@ import Unison.Server.QueryResult import Unison.Server.SearchResult (SearchResult) import qualified Unison.Server.SearchResult as SR import qualified Unison.Server.SearchResult' as SR' +import qualified Unison.Share.Codeserver as Codeserver import qualified Unison.Share.Sync as Share import Unison.Share.Types (codeserverBaseURL) import qualified Unison.ShortHash as SH @@ -170,7 +174,6 @@ import Unison.Util.TransitiveClosure (transitiveClosure) import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.WatchKind as WK -import qualified Unison.Share.Codeserver as Codeserver defaultPatchNameSegment :: NameSegment defaultPatchNameSegment = "patch" @@ -717,8 +720,8 @@ loop = do case getAtSplit' dest of Just existingDest | not (Branch.isEmpty0 (Branch.head existingDest)) -> do - -- Branch exists and isn't empty, print an error - throwError (BranchAlreadyExists (Path.unsplit' dest)) + -- Branch exists and isn't empty, print an error + throwError (BranchAlreadyExists (Path.unsplit' dest)) _ -> pure () -- allow rewriting history to ensure we move the branch's history too. lift $ @@ -1411,11 +1414,11 @@ loop = do case filtered of [(Referent.Ref ref, ty)] | Typechecker.isSubtype ty mainType -> - eval (MakeStandalone ppe ref output) >>= \case - Just err -> respond $ EvaluationFailure err - Nothing -> pure () + eval (MakeStandalone ppe ref output) >>= \case + Just err -> respond $ EvaluationFailure err + Nothing -> pure () | otherwise -> - respond $ BadMainFunction smain ty ppe [mainType] + respond $ BadMainFunction smain ty ppe [mainType] _ -> respond $ NoMainFunction smain ppe [mainType] IOTestI main -> do -- todo - allow this to run tests from scratch file, using addRunMain @@ -1874,20 +1877,29 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l PushBehavior.RequireEmpty -> do let push :: IO (Either Share.CheckAndSetPushError ()) push = - Share.checkAndSetPush - authHTTPClient - baseURL - connection - sharePath - Nothing - localCausalHash + withEntitiesUploadedProgressCallback \entitiesUploadedProgressCallback -> + Share.checkAndSetPush + authHTTPClient + baseURL + connection + sharePath + Nothing + localCausalHash + entitiesUploadedProgressCallback liftIO push >>= \case Left err -> respond (Output.ShareError (ShareErrorCheckAndSetPush err)) Right () -> pure () PushBehavior.RequireNonEmpty -> do let push :: IO (Either Share.FastForwardPushError ()) push = - Share.fastForwardPush authHTTPClient baseURL connection sharePath localCausalHash + withEntitiesUploadedProgressCallback \entitiesUploadedProgressCallback -> + Share.fastForwardPush + authHTTPClient + baseURL + connection + sharePath + localCausalHash + entitiesUploadedProgressCallback liftIO push >>= \case Left err -> respond (Output.ShareError (ShareErrorFastForwardPush err)) Right () -> pure () @@ -1896,6 +1908,14 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l pathToSegments = coerce Path.toList + withEntitiesUploadedProgressCallback :: ((Int -> IO ()) -> IO a) -> IO a + withEntitiesUploadedProgressCallback action = + Console.Regions.displayConsoleRegions do + Console.Regions.withConsoleRegion Console.Regions.Linear \region -> + action \entitiesUploaded -> + Console.Regions.setConsoleRegion region $ + "\n Uploaded " <> Text.fromInt entitiesUploaded <> " entities...\n\n" + -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: forall m v. @@ -2281,8 +2301,21 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do mapLeft Output.ShareError <$> do let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask - liftIO (Share.pull authHTTPClient baseURL connection shareFlavoredPath) >>= \case - Left e -> pure (Left (Output.ShareErrorPull e)) + let pull :: IO (Either Share.PullError CausalHash) + pull = + Console.Regions.displayConsoleRegions do + Console.Regions.withConsoleRegion Console.Regions.Linear \region -> + Share.pull + authHTTPClient + baseURL + connection + shareFlavoredPath + ( \entitiesDownloaded -> + Console.Regions.setConsoleRegion region $ + "\n Downloaded " <> Text.fromInt entitiesDownloaded <> " entities...\n\n" + ) + liftIO pull >>= \case + Left err -> pure (Left (Output.ShareErrorPull err)) Right causalHash -> do (eval . Eval) (Codebase.getBranchForHash codebase (Cv.causalHash2to1 causalHash)) >>= \case Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" @@ -2577,10 +2610,10 @@ searchBranchScored names0 score queries = pair qn HQ.HashQualified qn h | h `SH.isPrefixOf` Referent.toShortHash ref -> - pair qn + pair qn HQ.HashOnly h | h `SH.isPrefixOf` Referent.toShortHash ref -> - Set.singleton (Nothing, result) + Set.singleton (Nothing, result) _ -> mempty where result = SR.termSearchResult names0 name ref @@ -2597,10 +2630,10 @@ searchBranchScored names0 score queries = pair qn HQ.HashQualified qn h | h `SH.isPrefixOf` Reference.toShortHash ref -> - pair qn + pair qn HQ.HashOnly h | h `SH.isPrefixOf` Reference.toShortHash ref -> - Set.singleton (Nothing, result) + Set.singleton (Nothing, result) _ -> mempty where result = SR.typeSearchResult names0 name ref @@ -2993,7 +3026,7 @@ docsI srcLoc prettyPrintNames src = do | Set.size s == 1 -> displayI prettyPrintNames ConsoleLocation dotDoc | Set.size s == 0 -> respond $ ListOfLinks mempty [] | otherwise -> -- todo: return a list of links here too - respond $ ListOfLinks mempty [] + respond $ ListOfLinks mempty [] filterBySlurpResult :: Ord v => diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index a203634a34..7e4558e888 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -80,8 +80,10 @@ checkAndSetPush :: Maybe Share.Hash -> -- | The hash of our local causal to push. CausalHash -> + -- | Callback that is given the total number of entities uploaded. + (Int -> IO ()) -> IO (Either CheckAndSetPushError ()) -checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash = do +checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash uploadCountCallback = do -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs -- this causal (UpdatePathMissingDependencies). updatePath >>= \case @@ -89,7 +91,7 @@ checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash = do Share.UpdatePathHashMismatch mismatch -> pure (Left (CheckAndSetPushErrorHashMismatch mismatch)) Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do -- Upload the causal and all of its dependencies. - uploadEntities httpClient unisonShareUrl conn (Share.pathRepoName path) dependencies >>= \case + uploadEntities httpClient unisonShareUrl conn (Share.pathRepoName path) dependencies uploadCountCallback >>= \case False -> pure (Left (CheckAndSetPushErrorNoWritePermission path)) True -> -- After uploading the causal and all of its dependencies, try setting the remote path again. @@ -140,8 +142,10 @@ fastForwardPush :: Share.Path -> -- | The hash of our local causal to push. CausalHash -> + -- | Callback that is given the total number of entities uploaded. + (Int -> IO ()) -> IO (Either FastForwardPushError ()) -fastForwardPush httpClient unisonShareUrl conn path localHeadHash = +fastForwardPush httpClient unisonShareUrl conn path localHeadHash uploadCountCallback = getCausalHashByPath httpClient unisonShareUrl path >>= \case Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path)) Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path)) @@ -186,6 +190,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = conn (Share.pathRepoName path) (NESet.singleton (causalHashToShareHash headHash)) + uploadCountCallback -- Return a list from oldest to newst of the ancestors between (excluding) the latest local and the current remote -- hash. @@ -321,8 +326,10 @@ pull :: Sqlite.Connection -> -- | The repo+path to pull from. Share.Path -> + -- | Callback that is given the total number of entities downloaded. + (Int -> IO ()) -> IO (Either PullError CausalHash) -pull httpClient unisonShareUrl conn repoPath = do +pull httpClient unisonShareUrl conn repoPath downloadCountCallback = do getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case Left err -> pure (Left (PullErrorGetCausalHashByPath err)) -- There's nothing at the remote path, so there's no causal to pull. @@ -336,8 +343,8 @@ pull httpClient unisonShareUrl conn repoPath = do pure (Right (CausalHash (Hash.fromBase32Hex (Share.toBase32Hex hash)))) where doDownload :: NESet Share.HashJWT -> IO () - doDownload = - downloadEntities httpClient unisonShareUrl conn (Share.pathRepoName repoPath) + doDownload hashes = + downloadEntities httpClient unisonShareUrl conn (Share.pathRepoName repoPath) hashes downloadCountCallback ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path @@ -370,14 +377,17 @@ downloadEntities :: Sqlite.Connection -> Share.RepoName -> NESet Share.HashJWT -> + (Int -> IO ()) -> IO () -downloadEntities httpClient unisonShareUrl conn repoName = - loop . NESet.map Share.decodeHashJWT +downloadEntities httpClient unisonShareUrl conn repoName hashes_ downloadCountCallback = + loop 0 (NESet.map Share.decodeHashJWT hashes_) where - loop :: NESet Share.DecodedHashJWT -> IO () - loop hashes0 = + loop :: Int -> NESet Share.DecodedHashJWT -> IO () + loop downloadCount hashes0 = whenJustM (Sqlite.runTransaction conn (elaborateHashes hashes0)) \hashes1 -> do entities <- doDownload hashes1 + let newDownloadCount = downloadCount + NEMap.size entities + downloadCountCallback newDownloadCount missingDependencies0 <- Sqlite.runTransaction conn do @@ -386,7 +396,7 @@ downloadEntities httpClient unisonShareUrl conn repoName = EntityInMainStorage -> Set.empty EntityInTempStorage missingDependencies -> Set.map Share.decodeHashJWT (NESet.toSet missingDependencies) - whenJust (NESet.nonEmptySet missingDependencies0) loop + whenJust (NESet.nonEmptySet missingDependencies0) (loop newDownloadCount) doDownload :: NESet Share.HashJWT -> IO (NEMap Share.Hash (Share.Entity Text Share.Hash Share.HashJWT)) doDownload hashes = do @@ -411,14 +421,18 @@ uploadEntities :: Sqlite.Connection -> Share.RepoName -> NESet Share.Hash -> + (Int -> IO ()) -> IO Bool -uploadEntities httpClient unisonShareUrl conn repoName = - loop +uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadCountCallback = + loop 0 hashes0 where - loop :: NESet Share.Hash -> IO Bool - loop (NESet.toAscList -> hashes) = do + loop :: Int -> NESet Share.Hash -> IO Bool + loop uploadCount hashesSet = do + let hashes = NESet.toAscList hashesSet -- Get each entity that the server is missing out of the database. entities <- Sqlite.runTransaction conn (traverse expectEntity hashes) + let newUploadCount = uploadCount + NESet.size hashesSet + uploadCountCallback newUploadCount let uploadEntities :: IO Share.UploadEntitiesResponse uploadEntities = @@ -433,7 +447,7 @@ uploadEntities httpClient unisonShareUrl conn repoName = -- Upload all of the entities we know the server needs, and if the server responds that it needs yet more, loop to -- upload those too. uploadEntities >>= \case - Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> loop moreHashes + Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> loop newUploadCount moreHashes Share.UploadEntitiesNoWritePermission _ -> pure False Share.UploadEntitiesHashMismatchForEntity {} -> pure False Share.UploadEntitiesSuccess -> pure True diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 310cc6882f..1a466c67a8 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -99,6 +99,7 @@ library , base , bytes , bytestring + , concurrent-output , configurator , containers >=0.6.3 , cryptonite @@ -197,6 +198,7 @@ executable cli-integration-tests , bytes , bytestring , code-page + , concurrent-output , configurator , containers >=0.6.3 , cryptonite @@ -291,6 +293,7 @@ executable transcripts , bytes , bytestring , code-page + , concurrent-output , configurator , containers >=0.6.3 , cryptonite @@ -390,6 +393,7 @@ executable unison , bytes , bytestring , code-page + , concurrent-output , configurator , containers >=0.6.3 , cryptonite @@ -494,6 +498,7 @@ test-suite cli-tests , bytes , bytestring , code-page + , concurrent-output , configurator , containers >=0.6.3 , cryptonite From a18998be6e5e3677c8be23b39054bdf132d242ad Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 3 Jun 2022 21:35:18 -0400 Subject: [PATCH 289/529] leave upload/download counts up after push/pull are complete --- .../src/Unison/Codebase/Editor/HandleInput.hs | 47 ++++++++++++------- 1 file changed, 30 insertions(+), 17 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 0422f0fbd3..34e2eb308e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -24,6 +24,7 @@ import qualified Data.Map as Map import Data.Sequence (Seq (..)) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) +import Control.Concurrent.STM (atomically, newTVarIO, readTVar, readTVarIO, writeTVar) import qualified Data.Set.NonEmpty as NESet import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) @@ -1891,7 +1892,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l Right () -> pure () PushBehavior.RequireNonEmpty -> do let push :: IO (Either Share.FastForwardPushError ()) - push = + push = do withEntitiesUploadedProgressCallback \entitiesUploadedProgressCallback -> Share.fastForwardPush authHTTPClient @@ -1909,12 +1910,18 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l coerce Path.toList withEntitiesUploadedProgressCallback :: ((Int -> IO ()) -> IO a) -> IO a - withEntitiesUploadedProgressCallback action = + withEntitiesUploadedProgressCallback action = do + entitiesUploadedVar <- newTVarIO 0 Console.Regions.displayConsoleRegions do - Console.Regions.withConsoleRegion Console.Regions.Linear \region -> - action \entitiesUploaded -> - Console.Regions.setConsoleRegion region $ - "\n Uploaded " <> Text.fromInt entitiesUploaded <> " entities...\n\n" + Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do + Console.Regions.setConsoleRegion region do + entitiesUploaded <- readTVar entitiesUploadedVar + pure ("\n Uploaded " <> Text.fromInt entitiesUploaded <> " entities...\n\n") + result <- action \entitiesUploaded -> atomically (writeTVar entitiesUploadedVar entitiesUploaded) + entitiesUploaded <- readTVarIO entitiesUploadedVar + Console.Regions.finishConsoleRegion region $ + "\n Uploaded " <> Text.fromInt entitiesUploaded <> " entities.\n" + pure result -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: @@ -2302,18 +2309,24 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask let pull :: IO (Either Share.PullError CausalHash) - pull = + pull = do + entitiesDownloadedVar <- newTVarIO 0 Console.Regions.displayConsoleRegions do - Console.Regions.withConsoleRegion Console.Regions.Linear \region -> - Share.pull - authHTTPClient - baseURL - connection - shareFlavoredPath - ( \entitiesDownloaded -> - Console.Regions.setConsoleRegion region $ - "\n Downloaded " <> Text.fromInt entitiesDownloaded <> " entities...\n\n" - ) + Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do + Console.Regions.setConsoleRegion region do + entitiesDownloaded <- readTVar entitiesDownloadedVar + pure ("\n Downloaded " <> Text.fromInt entitiesDownloaded <> " entities...\n\n") + result <- + Share.pull + authHTTPClient + baseURL + connection + shareFlavoredPath + (\entitiesDownloaded -> atomically (writeTVar entitiesDownloadedVar entitiesDownloaded)) + entitiesDownloaded <- readTVarIO entitiesDownloadedVar + Console.Regions.finishConsoleRegion region $ + "\n Downloaded " <> Text.fromInt entitiesDownloaded <> " entities.\n" + pure result liftIO pull >>= \case Left err -> pure (Left (Output.ShareErrorPull err)) Right causalHash -> do From 32e5b1a6e61f8722d75784cc24c76e8a643d2c73 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 3 Jun 2022 21:48:24 -0400 Subject: [PATCH 290/529] remove optimized Int->Text conversion since it wasn't impressively faster --- lib/unison-prelude/src/Unison/Prelude/Text.hs | 14 -------------- lib/unison-prelude/unison-prelude.cabal | 1 - .../src/Unison/Codebase/Editor/HandleInput.hs | 9 ++++----- 3 files changed, 4 insertions(+), 20 deletions(-) delete mode 100644 lib/unison-prelude/src/Unison/Prelude/Text.hs diff --git a/lib/unison-prelude/src/Unison/Prelude/Text.hs b/lib/unison-prelude/src/Unison/Prelude/Text.hs deleted file mode 100644 index 9b44413ceb..0000000000 --- a/lib/unison-prelude/src/Unison/Prelude/Text.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Unison.Prelude.Text - ( fromInt, - ) -where - -import Data.Text (Text) -import qualified Data.Text.Lazy as LazyText -import qualified Data.Text.Lazy.Builder as LazyText.Builder -import qualified Data.Text.Lazy.Builder.Int as LazyText.Builder - --- | Render an Int as Text. -fromInt :: Int -> Text -fromInt = - LazyText.toStrict . LazyText.Builder.toLazyText . LazyText.Builder.decimal diff --git a/lib/unison-prelude/unison-prelude.cabal b/lib/unison-prelude/unison-prelude.cabal index c5878a03b1..dc6b7d04df 100644 --- a/lib/unison-prelude/unison-prelude.cabal +++ b/lib/unison-prelude/unison-prelude.cabal @@ -19,7 +19,6 @@ library exposed-modules: Unison.Debug Unison.Prelude - Unison.Prelude.Text Unison.Util.Map Unison.Util.Monoid Unison.Util.Set diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 34e2eb308e..cea08c41bd 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -125,7 +125,6 @@ import qualified Unison.NamesWithHistory as NamesWithHistory import Unison.Parser.Ann (Ann (..)) import Unison.Position (Position (..)) import Unison.Prelude -import qualified Unison.Prelude.Text as Text import qualified Unison.PrettyPrintEnv as PPE import qualified Unison.PrettyPrintEnv.Names as PPE import qualified Unison.PrettyPrintEnvDecl as PPE @@ -1916,11 +1915,11 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do Console.Regions.setConsoleRegion region do entitiesUploaded <- readTVar entitiesUploadedVar - pure ("\n Uploaded " <> Text.fromInt entitiesUploaded <> " entities...\n\n") + pure ("\n Uploaded " <> tShow entitiesUploaded <> " entities...\n\n") result <- action \entitiesUploaded -> atomically (writeTVar entitiesUploadedVar entitiesUploaded) entitiesUploaded <- readTVarIO entitiesUploadedVar Console.Regions.finishConsoleRegion region $ - "\n Uploaded " <> Text.fromInt entitiesUploaded <> " entities.\n" + "\n Uploaded " <> tShow entitiesUploaded <> " entities.\n" pure result -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. @@ -2315,7 +2314,7 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do Console.Regions.setConsoleRegion region do entitiesDownloaded <- readTVar entitiesDownloadedVar - pure ("\n Downloaded " <> Text.fromInt entitiesDownloaded <> " entities...\n\n") + pure ("\n Downloaded " <> tShow entitiesDownloaded <> " entities...\n\n") result <- Share.pull authHTTPClient @@ -2325,7 +2324,7 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do (\entitiesDownloaded -> atomically (writeTVar entitiesDownloadedVar entitiesDownloaded)) entitiesDownloaded <- readTVarIO entitiesDownloadedVar Console.Regions.finishConsoleRegion region $ - "\n Downloaded " <> Text.fromInt entitiesDownloaded <> " entities.\n" + "\n Downloaded " <> tShow entitiesDownloaded <> " entities.\n" pure result liftIO pull >>= \case Left err -> pure (Left (Output.ShareErrorPull err)) From f0489468dd691481ea164506045cc9c95d2df531 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 4 Jun 2022 11:45:20 -0400 Subject: [PATCH 291/529] adjust contrib/cabal.project --- contrib/cabal.project | 1 + 1 file changed, 1 insertion(+) diff --git a/contrib/cabal.project b/contrib/cabal.project index f66dd97297..eab844c6a7 100644 --- a/contrib/cabal.project +++ b/contrib/cabal.project @@ -15,6 +15,7 @@ packages: lib/unison-prelude lib/unison-sqlite + lib/unison-util-base32hex lib/unison-util-relation lib/unison-pretty-printer From d02ce4bc0f369ce3198c11555a8973a8031b8530 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 4 Jun 2022 12:06:10 -0400 Subject: [PATCH 292/529] add back hie.yaml --- hie.yaml | 100 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 100 insertions(+) create mode 100644 hie.yaml diff --git a/hie.yaml b/hie.yaml new file mode 100644 index 0000000000..7c6ac739a1 --- /dev/null +++ b/hie.yaml @@ -0,0 +1,100 @@ +cradle: + stack: + - path: "codebase2/codebase/./" + component: "unison-codebase:lib" + + - path: "codebase2/codebase-sqlite/./" + component: "unison-codebase-sqlite:lib" + + - path: "codebase2/codebase-sync/./" + component: "unison-codebase-sync:lib" + + - path: "codebase2/core/./" + component: "unison-core:lib" + + - path: "codebase2/util/src" + component: "unison-util:lib" + + - path: "codebase2/util/bench/Main.hs" + component: "unison-util:bench:bench" + + - path: "codebase2/util-serialization/./" + component: "unison-util-serialization:lib" + + - path: "codebase2/util-term/./" + component: "unison-util-term:lib" + + - path: "lib/unison-prelude/src" + component: "unison-prelude:lib" + + - path: "lib/unison-pretty-printer/src" + component: "unison-pretty-printer:lib" + + - path: "lib/unison-pretty-printer/prettyprintdemo/Main.hs" + component: "unison-pretty-printer:exe:prettyprintdemo" + + - path: "lib/unison-pretty-printer/tests" + component: "unison-pretty-printer:test:pretty-printer-tests" + + - path: "lib/unison-sqlite/src" + component: "unison-sqlite:lib" + + - path: "lib/unison-util-base32hex/src" + component: "unison-util-base32hex:lib" + + - path: "lib/unison-util-relation/src" + component: "unison-util-relation:lib" + + - path: "lib/unison-util-relation/test" + component: "unison-util-relation:test:util-relation-tests" + + - path: "lib/unison-util-relation/benchmarks/relation/Main.hs" + component: "unison-util-relation:bench:relation" + + - path: "parser-typechecker/src" + component: "unison-parser-typechecker:lib" + + - path: "parser-typechecker/tests" + component: "unison-parser-typechecker:test:parser-typechecker-tests" + + - path: "unison-cli/src" + component: "unison-cli:lib" + + - path: "unison-cli/integration-tests/Suite.hs" + component: "unison-cli:exe:cli-integration-tests" + + - path: "unison-cli/integration-tests/IntegrationTests/ArgumentParsing.hs" + component: "unison-cli:exe:cli-integration-tests" + + - path: "unison-cli/transcripts/Transcripts.hs" + component: "unison-cli:exe:transcripts" + + - path: "unison-cli/unison/Main.hs" + component: "unison-cli:exe:unison" + + - path: "unison-cli/unison/ArgParse.hs" + component: "unison-cli:exe:unison" + + - path: "unison-cli/unison/System/Path.hs" + component: "unison-cli:exe:unison" + + - path: "unison-cli/unison/Version.hs" + component: "unison-cli:exe:unison" + + - path: "unison-cli/tests" + component: "unison-cli:test:cli-tests" + + - path: "unison-core/src" + component: "unison-core1:lib" + + - path: "unison-share-api/src" + component: "unison-share-api:lib" + + - path: "yaks/easytest/src" + component: "easytest:lib" + + - path: "yaks/easytest/tests/Suite.hs" + component: "easytest:exe:runtests" + + - path: "yaks/easytest/tests" + component: "easytest:test:tests" From 7e7b9112267416998950683bb79ee442587c3d3d Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 4 Jun 2022 12:12:44 -0400 Subject: [PATCH 293/529] Add U.Util.Hash32 --- .../src/U/Util/Hash32.hs | 40 +++++++++++++++++++ .../unison-util-base32hex.cabal | 1 + 2 files changed, 41 insertions(+) create mode 100644 lib/unison-util-base32hex/src/U/Util/Hash32.hs diff --git a/lib/unison-util-base32hex/src/U/Util/Hash32.hs b/lib/unison-util-base32hex/src/U/Util/Hash32.hs new file mode 100644 index 0000000000..bc1f6ab29d --- /dev/null +++ b/lib/unison-util-base32hex/src/U/Util/Hash32.hs @@ -0,0 +1,40 @@ +-- | A 512-bit hash, internally represented as base32hex. +module U.Util.Hash32 + ( -- * Hash32 type + Hash32, + + -- * Conversions + + -- ** Base32Hex + fromBase32Hex, + toBase32Hex, + + -- ** The other Hash :) + fromHash, + toHash, + ) +where + +import U.Util.Base32Hex (Base32Hex) +import U.Util.Hash (Hash) +import qualified U.Util.Hash as Hash +import Unison.Prelude + +-- | A 512-bit hash, internally represented as base32hex. +newtype Hash32 = Hash32 Base32Hex + +fromBase32Hex :: Base32Hex -> Hash32 +fromBase32Hex = + Hash32 + +toBase32Hex :: Hash32 -> Base32Hex +toBase32Hex = + coerce + +fromHash :: Hash -> Hash32 +fromHash = + fromBase32Hex . Hash.toBase32Hex + +toHash :: Hash32 -> Hash +toHash = + Hash.fromBase32Hex . toBase32Hex diff --git a/lib/unison-util-base32hex/unison-util-base32hex.cabal b/lib/unison-util-base32hex/unison-util-base32hex.cabal index 27d50df2cb..57b7d69cb3 100644 --- a/lib/unison-util-base32hex/unison-util-base32hex.cabal +++ b/lib/unison-util-base32hex/unison-util-base32hex.cabal @@ -19,6 +19,7 @@ library exposed-modules: U.Util.Base32Hex U.Util.Hash + U.Util.Hash32 hs-source-dirs: src default-extensions: From 8aa9805f9a4ccfba381cd69aa947ddbf2175f4e3 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 4 Jun 2022 13:31:37 -0400 Subject: [PATCH 294/529] replace Share.Hash with U.Util.Hash32 --- .../U/Codebase/Sqlite/Operations.hs | 3 +- .../U/Codebase/Sqlite/Queries.hs | 98 ++++++++++--------- .../U/Codebase/Sqlite/Serialization.hs | 57 ++++++----- .../U/Codebase/Sqlite/TempEntity.hs | 20 ++-- codebase2/codebase-sqlite/package.yaml | 1 + .../unison-codebase-sqlite.cabal | 1 + hie.yaml | 3 + .../package.yaml | 44 +++++++++ .../src/U/Util/Hash32/Orphans/Aeson.hs | 14 +++ .../unison-util-base32hex-orphans-aeson.cabal | 53 ++++++++++ .../package.yaml | 44 +++++++++ .../src/U/Util/Hash32/Orphans/Sqlite.hs | 11 +++ ...unison-util-base32hex-orphans-sqlite.cabal | 53 ++++++++++ .../src/U/Util/Hash32.hs | 47 ++++++--- stack.yaml | 2 + .../src/Unison/CommandLine/OutputMessages.hs | 18 ++-- unison-cli/src/Unison/Share/Sync.hs | 65 ++++++------ unison-share-api/package.yaml | 1 + unison-share-api/src/Unison/Sync/Common.hs | 88 +++++++++-------- unison-share-api/src/Unison/Sync/Types.hs | 39 ++++---- unison-share-api/unison-share-api.cabal | 1 + 21 files changed, 454 insertions(+), 209 deletions(-) create mode 100644 lib/unison-util-base32hex-orphans-aeson/package.yaml create mode 100644 lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs create mode 100644 lib/unison-util-base32hex-orphans-aeson/unison-util-base32hex-orphans-aeson.cabal create mode 100644 lib/unison-util-base32hex-orphans-sqlite/package.yaml create mode 100644 lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs create mode 100644 lib/unison-util-base32hex-orphans-sqlite/unison-util-base32hex-orphans-sqlite.cabal diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index b688b89095..4a37c108e2 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -163,6 +163,7 @@ import U.Codebase.WatchKind (WatchKind) import qualified U.Core.ABT as ABT import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as H +import qualified U.Util.Hash32 as Hash32 import qualified U.Util.Lens as Lens import qualified U.Util.Serialization as S import qualified U.Util.Term as TermUtil @@ -186,7 +187,7 @@ newtype NeedTypeForBuiltinMetadata objectExistsForHash :: H.Hash -> Transaction Bool objectExistsForHash h = isJust <$> runMaybeT do - id <- MaybeT . Q.loadHashId . H.toBase32Hex $ h + id <- MaybeT . Q.loadHashId . Hash32.fromHash $ h MaybeT $ Q.loadObjectIdForAnyHashId id expectValueHashByCausalHashId :: Db.CausalHashId -> Transaction BranchHash diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 2f6571ecab..067b3c0d9b 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -200,9 +200,11 @@ import qualified U.Codebase.Sqlite.TempEntityType as TempEntityType import qualified U.Codebase.Sqlite.Term.Format as TermFormat import U.Codebase.WatchKind (WatchKind) import qualified U.Util.Alternative as Alternative -import U.Util.Base32Hex (Base32Hex (..)) import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash +import U.Util.Hash32 (Hash32) +import qualified U.Util.Hash32 as Hash32 +import U.Util.Hash32.Orphans.Sqlite () import Unison.Prelude import Unison.Sqlite @@ -259,28 +261,28 @@ countCausals = queryOneCol_ [here| SELECT COUNT(*) FROM causal |] countWatches :: Transaction Int countWatches = queryOneCol_ [here| SELECT COUNT(*) FROM watch |] -saveHash :: Base32Hex -> Transaction HashId -saveHash base32 = execute sql (Only base32) >> expectHashId base32 +saveHash :: Hash32 -> Transaction HashId +saveHash hash = execute sql (Only hash) >> expectHashId hash where sql = [here| INSERT INTO hash (base32) VALUES (?) ON CONFLICT DO NOTHING |] saveHashHash :: Hash -> Transaction HashId -saveHashHash = saveHash . Hash.toBase32Hex +saveHashHash = saveHash . Hash32.fromHash -loadHashId :: Base32Hex -> Transaction (Maybe HashId) -loadHashId base32 = queryMaybeCol loadHashIdSql (Only base32) +loadHashId :: Hash32 -> Transaction (Maybe HashId) +loadHashId hash = queryMaybeCol loadHashIdSql (Only hash) -expectHashId :: Base32Hex -> Transaction HashId -expectHashId base32 = queryOneCol loadHashIdSql (Only base32) +expectHashId :: Hash32 -> Transaction HashId +expectHashId hash = queryOneCol loadHashIdSql (Only hash) loadHashIdSql :: Sql loadHashIdSql = [here| SELECT id FROM hash WHERE base32 = ? |] loadHashIdByHash :: Hash -> Transaction (Maybe HashId) -loadHashIdByHash = loadHashId . Hash.toBase32Hex +loadHashIdByHash = loadHashId . Hash32.fromHash saveCausalHash :: CausalHash -> Transaction CausalHashId saveCausalHash = fmap CausalHashId . saveHashHash . unCausalHash @@ -311,12 +313,12 @@ expectCausalByCausalHash ch = do pure (hId, bhId) expectHashIdByHash :: Hash -> Transaction HashId -expectHashIdByHash = expectHashId . Hash.toBase32Hex +expectHashIdByHash = expectHashId . Hash32.fromHash expectHash :: HashId -> Transaction Hash -expectHash h = Hash.fromBase32Hex <$> expectHash32 h +expectHash h = Hash32.toHash <$> expectHash32 h -expectHash32 :: HashId -> Transaction Base32Hex +expectHash32 :: HashId -> Transaction Hash32 expectHash32 h = queryOneCol sql (Only h) where sql = [here|ย SELECT base32 FROM hash WHERE id = ? |] @@ -485,22 +487,22 @@ loadObjectIdForPrimaryHash h = expectObjectIdForPrimaryHash :: Hash -> Transaction ObjectId expectObjectIdForPrimaryHash = - expectObjectIdForHash32 . Hash.toBase32Hex + expectObjectIdForHash32 . Hash32.fromHash -expectObjectIdForHash32 :: Base32Hex -> Transaction ObjectId +expectObjectIdForHash32 :: Hash32 -> Transaction ObjectId expectObjectIdForHash32 hash = do hashId <- expectHashId hash expectObjectIdForPrimaryHashId hashId -expectBranchObjectIdForHash32 :: Base32Hex -> Transaction BranchObjectId +expectBranchObjectIdForHash32 :: Hash32 -> Transaction BranchObjectId expectBranchObjectIdForHash32 = fmap BranchObjectId . expectObjectIdForHash32 -expectPatchObjectIdForHash32 :: Base32Hex -> Transaction PatchObjectId +expectPatchObjectIdForHash32 :: Hash32 -> Transaction PatchObjectId expectPatchObjectIdForHash32 = fmap PatchObjectId . expectObjectIdForHash32 -expectBranchHashIdForHash32 :: Base32Hex -> Transaction BranchHashId +expectBranchHashIdForHash32 :: Hash32 -> Transaction BranchHashId expectBranchHashIdForHash32 = queryOneCol sql . Only where sql = @@ -512,7 +514,7 @@ expectBranchHashIdForHash32 = queryOneCol sql . Only AND hash.base32 = ? |] -expectCausalHashIdForHash32 :: Base32Hex -> Transaction CausalHashId +expectCausalHashIdForHash32 :: Hash32 -> Transaction CausalHashId expectCausalHashIdForHash32 = queryOneCol sql . Only where sql = @@ -556,9 +558,9 @@ isObjectHash h = -- | All objects have corresponding hashes. expectPrimaryHashByObjectId :: ObjectId -> Transaction Hash expectPrimaryHashByObjectId = - fmap Hash.fromBase32Hex . expectPrimaryHash32ByObjectId + fmap Hash32.toHash . expectPrimaryHash32ByObjectId -expectPrimaryHash32ByObjectId :: ObjectId -> Transaction Base32Hex +expectPrimaryHash32ByObjectId :: ObjectId -> Transaction Hash32 expectPrimaryHash32ByObjectId oId = queryOneCol sql (Only oId) where sql = [here| SELECT hash.base32 @@ -625,11 +627,11 @@ flushCausalDependents chId = do -- 2. Delete #foo from temp_entity (if it's there) -- 3. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, -- insert_entity them. -tryMoveTempEntityDependents :: Base32Hex -> Transaction () -tryMoveTempEntityDependents dependencyBase32 = do - dependents <- getMissingDependentsForTempEntity dependencyBase32 - execute deleteMissingDependency (Only dependencyBase32) - deleteTempEntity dependencyBase32 +tryMoveTempEntityDependents :: Hash32 -> Transaction () +tryMoveTempEntityDependents dependency = do + dependents <- getMissingDependentsForTempEntity dependency + execute deleteMissingDependency (Only dependency) + deleteTempEntity dependency traverse_ flushIfReadyToFlush dependents where deleteMissingDependency :: Sql @@ -638,14 +640,14 @@ tryMoveTempEntityDependents dependencyBase32 = do WHERE dependency = ? |] - flushIfReadyToFlush :: Base32Hex -> Transaction () + flushIfReadyToFlush :: Hash32 -> Transaction () flushIfReadyToFlush dependent = do readyToFlush dependent >>= \case True -> moveTempEntityToMain dependent False -> pure () - readyToFlush :: Base32Hex -> Transaction Bool - readyToFlush b32 = queryOneCol [here| + readyToFlush :: Hash32 -> Transaction Bool + readyToFlush hash = queryOneCol [here| SELECT EXISTS ( SELECT 1 FROM temp_entity @@ -655,7 +657,7 @@ tryMoveTempEntityDependents dependencyBase32 = do FROM temp_entity_missing_dependency WHERE dependent = ? ) - |] (b32, b32) + |] (hash, hash) expectCausal :: CausalHashId -> Transaction Causal.SyncCausalFormat expectCausal hashId = do @@ -680,7 +682,7 @@ expectCausal hashId = do pure Causal.SyncCausalFormat {parents, valueHash} -- | Read an entity out of main storage. -expectEntity :: Base32Hex -> Transaction SyncEntity +expectEntity :: Hash32 -> Transaction SyncEntity expectEntity hash = do hashId <- expectHashId hash -- We don't know if this is an object or a causal, so just try one, then the other. @@ -694,18 +696,18 @@ expectEntity hash = do Namespace -> Entity.N <$> decodeSyncNamespaceFormat bytes Patch -> Entity.P <$> decodeSyncPatchFormat bytes -moveTempEntityToMain :: Base32Hex -> Transaction () -moveTempEntityToMain b32 = do - t <- expectTempEntity b32 - deleteTempEntity b32 - r <- tempToSyncEntity t - _ <- saveSyncEntity b32 r +moveTempEntityToMain :: Hash32 -> Transaction () +moveTempEntityToMain hash = do + entity <- expectTempEntity hash + deleteTempEntity hash + entity' <- tempToSyncEntity entity + _ <- saveSyncEntity hash entity' pure () -- | Read an entity out of temp storage. -expectTempEntity :: Base32Hex -> Transaction TempEntity -expectTempEntity b32 = do - queryOneRowCheck sql (Only b32) \(blob, typeId) -> +expectTempEntity :: Hash32 -> Transaction TempEntity +expectTempEntity hash = do + queryOneRowCheck sql (Only hash) \(blob, typeId) -> case typeId of TempEntityType.TermComponentType -> Entity.TC <$> decodeTempTermFormat blob TempEntityType.DeclComponentType -> Entity.DC <$> decodeTempDeclFormat blob @@ -851,9 +853,9 @@ syncToTempEntity = \case TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent <$> Lens.traverseOf (traverse . Lens._1) (bitraverse expectText expectPrimaryHash32ByObjectId) terms -saveSyncEntity :: Base32Hex -> SyncEntity -> Transaction (Either CausalHashId ObjectId) -saveSyncEntity b32Hex entity = do - hashId <- saveHash b32Hex +saveSyncEntity :: Hash32 -> SyncEntity -> Transaction (Either CausalHashId ObjectId) +saveSyncEntity hash entity = do + hashId <- saveHash hash case entity of Entity.TC stf -> do let bytes = runPutS (Serialization.recomposeTermFormat stf) @@ -932,7 +934,7 @@ loadCausalParents h = queryListCol sql (Only h) where sql = [here| |] -- | Like 'loadCausalParents', but the input and outputs are hashes, not hash ids. -loadCausalParentsByHash :: Base32Hex -> Transaction [Base32Hex] +loadCausalParentsByHash :: Hash32 -> Transaction [Hash32] loadCausalParentsByHash hash = queryListCol [here| @@ -1440,7 +1442,7 @@ ancestorSql = -- * share sync / temp entities -- | Does this entity already exist in the database, i.e. in the `object` or `causal` table? -entityExists :: Base32Hex -> Transaction Bool +entityExists :: Hash32 -> Transaction Bool entityExists hash = do -- first get hashId if exists loadHashId hash >>= \case @@ -1448,7 +1450,7 @@ entityExists hash = do -- then check if is causal hash or if object exists for hash id Just hashId -> isCausalHash hashId ||^ isObjectHash hashId -getMissingDependencyJwtsForTempEntity :: Base32Hex -> Transaction (Maybe (NESet Text)) +getMissingDependencyJwtsForTempEntity :: Hash32 -> Transaction (Maybe (NESet Text)) getMissingDependencyJwtsForTempEntity h = do jwts <- queryListCol @@ -1459,7 +1461,7 @@ getMissingDependencyJwtsForTempEntity h = do (Only h) pure (NESet.nonEmptySet (Set.fromList jwts)) -getMissingDependentsForTempEntity :: Base32Hex -> Transaction [Base32Hex] +getMissingDependentsForTempEntity :: Hash32 -> Transaction [Hash32] getMissingDependentsForTempEntity h = queryListCol [here| @@ -1474,7 +1476,7 @@ getMissingDependentsForTempEntity h = -- Preconditions: -- 1. The entity does not already exist in "main" storage (`object` / `causal`) -- 2. The entity does not already exist in `temp_entity`. -insertTempEntity :: Base32Hex -> TempEntity -> NESet (Base32Hex, Text) -> Transaction () +insertTempEntity :: Hash32 -> TempEntity -> NESet (Hash32, Text) -> Transaction () insertTempEntity entityHash entity missingDependencies = do execute [here| @@ -1499,7 +1501,7 @@ insertTempEntity entityHash entity missingDependencies = do Entity.entityType entity -- | Delete a row from the `temp_entity` table, if it exists. -deleteTempEntity :: Base32Hex -> Transaction () +deleteTempEntity :: Hash32 -> Transaction () deleteTempEntity hash = execute [here| diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index c93b495f09..6880913567 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -14,12 +14,9 @@ import Data.Bytes.Get (MonadGet, getByteString, getWord8, runGetS) import Data.Bytes.Put (MonadPut, putByteString, putWord8) import Data.Bytes.Serial (SerialEndian (serializeBE), deserialize, deserializeBE, serialize) import Data.Bytes.VarInt (VarInt (VarInt), unVarInt) -import Data.Int (Int64) import Data.List (elemIndex) import qualified Data.Set as Set import Data.Vector (Vector) -import Data.Word (Word64) -import Debug.Trace (trace) import qualified U.Codebase.Decl as Decl import U.Codebase.Kind (Kind) import qualified U.Codebase.Kind as Kind @@ -46,10 +43,12 @@ import qualified U.Codebase.Sqlite.Term.Format as TermFormat import qualified U.Codebase.Term as Term import qualified U.Codebase.Type as Type import qualified U.Core.ABT as ABT -import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Base32Hex as Base32Hex +import U.Util.Hash32 (Hash32) +import qualified U.Util.Hash32 as Hash32 import qualified U.Util.Monoid as Monoid import U.Util.Serialization hiding (debug) +import Unison.Prelude import Prelude hiding (getChar, putChar) debug :: Bool @@ -749,31 +748,31 @@ putTempEntity = \case Entity.C gdc -> putSyncCausal gdc where - putBase32Hex = putText . Base32Hex.toText + putHash32 = putText . Hash32.toText putPatchLocalIds PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} = do putFoldable putText patchTextLookup - putFoldable putBase32Hex patchHashLookup - putFoldable putBase32Hex patchDefnLookup + putFoldable putHash32 patchHashLookup + putFoldable putHash32 patchDefnLookup putNamespaceLocalIds BranchFormat.LocalIds {branchTextLookup, branchDefnLookup, branchPatchLookup, branchChildLookup} = do putFoldable putText branchTextLookup - putFoldable putBase32Hex branchDefnLookup - putFoldable putBase32Hex branchPatchLookup - putFoldable (putPair putBase32Hex putBase32Hex) branchChildLookup + putFoldable putHash32 branchDefnLookup + putFoldable putHash32 branchPatchLookup + putFoldable (putPair putHash32 putHash32) branchChildLookup putSyncCausal Causal.SyncCausalFormat {valueHash, parents} = do - putBase32Hex valueHash - putFoldable putBase32Hex parents + putHash32 valueHash + putFoldable putHash32 parents putSyncFullPatch lids bytes = do putPatchLocalIds lids putFramedByteString bytes putSyncDiffPatch parent lids bytes = do - putBase32Hex parent + putHash32 parent putPatchLocalIds lids putFramedByteString bytes putSyncFullNamespace lids bytes = do putNamespaceLocalIds lids putFramedByteString bytes putSyncDiffNamespace parent lids bytes = do - putBase32Hex parent + putHash32 parent putNamespaceLocalIds lids putFramedByteString bytes putSyncTerm (TermFormat.SyncLocallyIndexedComponent vec) = @@ -781,15 +780,15 @@ putTempEntity = \case -- when deserializing, because we don't think we need to (and it adds a -- little overhead.) flip putFoldable vec \(localIds, bytes) -> do - putLocalIdsWith putText putBase32Hex localIds + putLocalIdsWith putText putHash32 localIds putFramedByteString bytes putSyncDecl (DeclFormat.SyncLocallyIndexedComponent vec) = flip putFoldable vec \(localIds, bytes) -> do - putLocalIdsWith putText putBase32Hex localIds + putLocalIdsWith putText putHash32 localIds putFramedByteString bytes -getBase32Hex :: MonadGet m => m Base32Hex -getBase32Hex = Base32Hex.UnsafeFromText <$> getText +getHash32 :: MonadGet m => m Hash32 +getHash32 = Hash32.UnsafeFromBase32Hex . Base32Hex.UnsafeFromText <$> getText getTempTermFormat :: MonadGet m => m TempEntity.TempTermFormat getTempTermFormat = @@ -798,7 +797,7 @@ getTempTermFormat = TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent <$> getVector ( getPair - (getLocalIdsWith getText getBase32Hex) + (getLocalIdsWith getText getHash32) getFramedByteString ) tag -> unknownTag "getTempTermFormat" tag @@ -810,7 +809,7 @@ getTempDeclFormat = DeclFormat.SyncDecl . DeclFormat.SyncLocallyIndexedComponent <$> getVector ( getPair - (getLocalIdsWith getText getBase32Hex) + (getLocalIdsWith getText getHash32) getFramedByteString ) tag -> unknownTag "getTempDeclFormat" tag @@ -819,34 +818,34 @@ getTempPatchFormat :: MonadGet m => m TempEntity.TempPatchFormat getTempPatchFormat = getWord8 >>= \case 0 -> PatchFormat.SyncFull <$> getPatchLocalIds <*> getFramedByteString - 1 -> PatchFormat.SyncDiff <$> getBase32Hex <*> getPatchLocalIds <*> getFramedByteString + 1 -> PatchFormat.SyncDiff <$> getHash32 <*> getPatchLocalIds <*> getFramedByteString tag -> unknownTag "getTempPatchFormat" tag where getPatchLocalIds = PatchFormat.LocalIds <$> getVector getText - <*> getVector getBase32Hex - <*> getVector getBase32Hex + <*> getVector getHash32 + <*> getVector getHash32 getTempNamespaceFormat :: MonadGet m => m TempEntity.TempNamespaceFormat getTempNamespaceFormat = getWord8 >>= \case 0 -> BranchFormat.SyncFull <$> getBranchLocalIds <*> getFramedByteString - 1 -> BranchFormat.SyncDiff <$> getBase32Hex <*> getBranchLocalIds <*> getFramedByteString + 1 -> BranchFormat.SyncDiff <$> getHash32 <*> getBranchLocalIds <*> getFramedByteString tag -> unknownTag "getTempNamespaceFormat" tag where getBranchLocalIds = BranchFormat.LocalIds <$> getVector getText - <*> getVector getBase32Hex - <*> getVector getBase32Hex - <*> getVector (getPair getBase32Hex getBase32Hex) + <*> getVector getHash32 + <*> getVector getHash32 + <*> getVector (getPair getHash32 getHash32) getTempCausalFormat :: MonadGet m => m TempEntity.TempCausalFormat getTempCausalFormat = Causal.SyncCausalFormat - <$> getBase32Hex - <*> getVector getBase32Hex + <$> getHash32 + <*> getVector getHash32 getSymbol :: MonadGet m => m Symbol getSymbol = Symbol <$> getVarInt <*> getText diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs index aff0e5df8e..be966233b6 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/TempEntity.hs @@ -7,7 +7,7 @@ import qualified U.Codebase.Sqlite.Entity as Entity import U.Codebase.Sqlite.LocalIds (LocalIds') import qualified U.Codebase.Sqlite.Patch.Format as Patch import qualified U.Codebase.Sqlite.Term.Format as Term -import U.Util.Base32Hex (Base32Hex) +import U.Util.Hash32 (Hash32) import Unison.Prelude -- | @@ -18,20 +18,20 @@ import Unison.Prelude -- | P TempPatchFormat -- | C TempCausalFormat type TempEntity = - Entity.SyncEntity' Text Base32Hex Base32Hex Base32Hex Base32Hex Base32Hex Base32Hex + Entity.SyncEntity' Text Hash32 Hash32 Hash32 Hash32 Hash32 Hash32 -type TempLocalIds = LocalIds' Text Base32Hex +type TempLocalIds = LocalIds' Text Hash32 -type TempTermFormat = Term.SyncTermFormat' Text Base32Hex +type TempTermFormat = Term.SyncTermFormat' Text Hash32 -type TempDeclFormat = Decl.SyncDeclFormat' Text Base32Hex +type TempDeclFormat = Decl.SyncDeclFormat' Text Hash32 -type TempPatchFormat = Patch.SyncPatchFormat' Base32Hex Text Base32Hex Base32Hex +type TempPatchFormat = Patch.SyncPatchFormat' Hash32 Text Hash32 Hash32 -type TempPatchLocalIds = Patch.PatchLocalIds' Text Base32Hex Base32Hex +type TempPatchLocalIds = Patch.PatchLocalIds' Text Hash32 Hash32 -type TempNamespaceFormat = Namespace.SyncBranchFormat' Base32Hex Text Base32Hex Base32Hex (Base32Hex, Base32Hex) +type TempNamespaceFormat = Namespace.SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32) -type TempNamespaceLocalIds = Namespace.BranchLocalIds' Text Base32Hex Base32Hex (Base32Hex, Base32Hex) +type TempNamespaceLocalIds = Namespace.BranchLocalIds' Text Hash32 Hash32 (Hash32, Hash32) -type TempCausalFormat = Causal.SyncCausalFormat' Base32Hex Base32Hex +type TempCausalFormat = Causal.SyncCausalFormat' Hash32 Hash32 diff --git a/codebase2/codebase-sqlite/package.yaml b/codebase2/codebase-sqlite/package.yaml index fa1481fd09..f0331c2199 100644 --- a/codebase2/codebase-sqlite/package.yaml +++ b/codebase2/codebase-sqlite/package.yaml @@ -33,6 +33,7 @@ dependencies: - unison-sqlite - unison-util - unison-util-base32hex + - unison-util-base32hex-orphans-sqlite - unison-util-serialization - unison-util-term - unliftio diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 5dd57b42b4..3f827edf02 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -106,6 +106,7 @@ library , unison-sqlite , unison-util , unison-util-base32hex + , unison-util-base32hex-orphans-sqlite , unison-util-serialization , unison-util-term , unliftio diff --git a/hie.yaml b/hie.yaml index 7c6ac739a1..91cc9aebad 100644 --- a/hie.yaml +++ b/hie.yaml @@ -42,6 +42,9 @@ cradle: - path: "lib/unison-util-base32hex/src" component: "unison-util-base32hex:lib" + - path: "lib/unison-util-base32hex-orphans-aeson/src" + component: "unison-util-base32hex-orphans-aeson:lib" + - path: "lib/unison-util-relation/src" component: "unison-util-relation:lib" diff --git a/lib/unison-util-base32hex-orphans-aeson/package.yaml b/lib/unison-util-base32hex-orphans-aeson/package.yaml new file mode 100644 index 0000000000..da2b27afc8 --- /dev/null +++ b/lib/unison-util-base32hex-orphans-aeson/package.yaml @@ -0,0 +1,44 @@ +name: unison-util-base32hex-orphans-aeson +github: unisonweb/unison +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors + +library: + when: + - condition: false + other-modules: Paths_unison_util_base32hex_orphans_aeson + source-dirs: src + +dependencies: + - aeson + - base + - text + - unison-util-base32hex + +ghc-options: + -Wall + -fno-warn-orphans + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeApplications + - ViewPatterns diff --git a/lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs b/lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs new file mode 100644 index 0000000000..10ce032d17 --- /dev/null +++ b/lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs @@ -0,0 +1,14 @@ +module U.Util.Hash32.Orphans.Aeson () where + +import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) +import Data.Text (Text) +import U.Util.Base32Hex (Base32Hex (..)) +import U.Util.Hash32 (Hash32 (..)) + +deriving via Text instance FromJSON Hash32 + +deriving via Text instance FromJSONKey Hash32 + +deriving via Text instance ToJSON Hash32 + +deriving via Text instance ToJSONKey Hash32 diff --git a/lib/unison-util-base32hex-orphans-aeson/unison-util-base32hex-orphans-aeson.cabal b/lib/unison-util-base32hex-orphans-aeson/unison-util-base32hex-orphans-aeson.cabal new file mode 100644 index 0000000000..b77f6d5be8 --- /dev/null +++ b/lib/unison-util-base32hex-orphans-aeson/unison-util-base32hex-orphans-aeson.cabal @@ -0,0 +1,53 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: unison-util-base32hex-orphans-aeson +version: 0.0.0 +homepage: https://github.com/unisonweb/unison#readme +bug-reports: https://github.com/unisonweb/unison/issues +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors +build-type: Simple + +source-repository head + type: git + location: https://github.com/unisonweb/unison + +library + exposed-modules: + U.Util.Hash32.Orphans.Aeson + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall -fno-warn-orphans + build-depends: + aeson + , base + , text + , unison-util-base32hex + default-language: Haskell2010 diff --git a/lib/unison-util-base32hex-orphans-sqlite/package.yaml b/lib/unison-util-base32hex-orphans-sqlite/package.yaml new file mode 100644 index 0000000000..7ed1fbaa83 --- /dev/null +++ b/lib/unison-util-base32hex-orphans-sqlite/package.yaml @@ -0,0 +1,44 @@ +name: unison-util-base32hex-orphans-sqlite +github: unisonweb/unison +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors + +library: + when: + - condition: false + other-modules: Paths_unison_util_base32hex_orphans_sqlite + source-dirs: src + +dependencies: + - base + - sqlite-simple + - text + - unison-util-base32hex + +ghc-options: + -Wall + -fno-warn-orphans + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeApplications + - ViewPatterns diff --git a/lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs b/lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs new file mode 100644 index 0000000000..2b5aaaa797 --- /dev/null +++ b/lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs @@ -0,0 +1,11 @@ +module U.Util.Hash32.Orphans.Sqlite () where + +import Data.Text (Text) +import Database.SQLite.Simple.FromField (FromField) +import Database.SQLite.Simple.ToField (ToField) +import U.Util.Base32Hex (Base32Hex (..)) +import U.Util.Hash32 (Hash32 (..)) + +deriving via Text instance ToField Hash32 + +deriving via Text instance FromField Hash32 diff --git a/lib/unison-util-base32hex-orphans-sqlite/unison-util-base32hex-orphans-sqlite.cabal b/lib/unison-util-base32hex-orphans-sqlite/unison-util-base32hex-orphans-sqlite.cabal new file mode 100644 index 0000000000..f78c9eca9d --- /dev/null +++ b/lib/unison-util-base32hex-orphans-sqlite/unison-util-base32hex-orphans-sqlite.cabal @@ -0,0 +1,53 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: unison-util-base32hex-orphans-sqlite +version: 0.0.0 +homepage: https://github.com/unisonweb/unison#readme +bug-reports: https://github.com/unisonweb/unison/issues +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors +build-type: Simple + +source-repository head + type: git + location: https://github.com/unisonweb/unison + +library + exposed-modules: + U.Util.Hash32.Orphans.Sqlite + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall -fno-warn-orphans + build-depends: + base + , sqlite-simple + , text + , unison-util-base32hex + default-language: Haskell2010 diff --git a/lib/unison-util-base32hex/src/U/Util/Hash32.hs b/lib/unison-util-base32hex/src/U/Util/Hash32.hs index bc1f6ab29d..39f4205e02 100644 --- a/lib/unison-util-base32hex/src/U/Util/Hash32.hs +++ b/lib/unison-util-base32hex/src/U/Util/Hash32.hs @@ -1,40 +1,55 @@ -- | A 512-bit hash, internally represented as base32hex. module U.Util.Hash32 ( -- * Hash32 type - Hash32, + Hash32 (..), -- * Conversions - -- ** Base32Hex - fromBase32Hex, - toBase32Hex, - -- ** The other Hash :) fromHash, toHash, + + -- ** Base32Hex + unsafeFromBase32Hex, + toBase32Hex, + + -- ** Text + toText, ) where -import U.Util.Base32Hex (Base32Hex) +import U.Util.Base32Hex (Base32Hex (..)) import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash import Unison.Prelude -- | A 512-bit hash, internally represented as base32hex. -newtype Hash32 = Hash32 Base32Hex - -fromBase32Hex :: Base32Hex -> Hash32 -fromBase32Hex = - Hash32 - -toBase32Hex :: Hash32 -> Base32Hex -toBase32Hex = - coerce +-- +-- Some orphan instances provided in: +-- +-- * @unison-util-base32hex-orphans-aeson@ +-- * @unison-util-base32hex-orphans-sqlite@ +newtype Hash32 = UnsafeFromBase32Hex Base32Hex + deriving (Eq, Ord, Show) via (Text) fromHash :: Hash -> Hash32 fromHash = - fromBase32Hex . Hash.toBase32Hex + unsafeFromBase32Hex . Hash.toBase32Hex toHash :: Hash32 -> Hash toHash = Hash.fromBase32Hex . toBase32Hex + +-- | Convert base32hex to a hash32 (asserting that it is a 512-bit hash). +unsafeFromBase32Hex :: Base32Hex -> Hash32 +unsafeFromBase32Hex = + coerce + +-- | Convert a hash32 to base32hex. +toBase32Hex :: Hash32 -> Base32Hex +toBase32Hex = + coerce + +toText :: Hash32 -> Text +toText = + coerce diff --git a/stack.yaml b/stack.yaml index 313e93b8d1..adbe564c4d 100644 --- a/stack.yaml +++ b/stack.yaml @@ -25,6 +25,8 @@ packages: - lib/unison-prelude - lib/unison-sqlite - lib/unison-util-base32hex +- lib/unison-util-base32hex-orphans-aeson +- lib/unison-util-base32hex-orphans-sqlite - lib/unison-util-relation - lib/unison-pretty-printer diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index f02961efa9..36c8ed4eb2 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -32,6 +32,8 @@ import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) import U.Util.Base32Hex (Base32Hex) import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as Hash +import U.Util.Hash32 (Hash32) +import qualified U.Util.Hash32 as Hash32 import qualified U.Util.Monoid as Monoid import qualified Unison.ABT as ABT import qualified Unison.Auth.Types as Auth @@ -129,7 +131,6 @@ import qualified Unison.Share.Sync as Share import qualified Unison.ShortHash as SH import qualified Unison.ShortHash as ShortHash import qualified Unison.Sync.Types as Share -import qualified Unison.Sync.Types as Share.Hash (toBase32Hex) import Unison.Term (Term) import qualified Unison.Term as Term import qualified Unison.TermPrinter as TermPrinter @@ -637,8 +638,8 @@ notifyUser dir o = case o of CachedTests 0 _ -> pure . P.callout "๐Ÿ˜ถ" $ "No tests to run." CachedTests n n' | n == n' -> - pure $ - P.lines [cache, "", displayTestResults True ppe oks fails] + pure $ + P.lines [cache, "", displayTestResults True ppe oks fails] CachedTests _n m -> pure $ if m == 0 @@ -647,6 +648,7 @@ notifyUser dir o = case o of P.indentN 2 $ P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "โœ… "] where + NewlyComputed -> do clearCurrentLine pure $ @@ -1601,7 +1603,7 @@ notifyUser dir o = case o of P.fatalCallout ( P.lines [ "The server detected an error in the history being pushed, please report this as a bug in ucm.", - "The history in question is the hash: " <> prettyShareHash child <> " with the ancestor: " <> prettyShareHash parent + "The history in question is the hash: " <> prettyHash32 child <> " with the ancestor: " <> prettyHash32 parent ] ) Share.FastForwardPushErrorNotFastForward sharePath -> @@ -1643,7 +1645,7 @@ notifyUser dir o = case o of ), P.text "", P.text "The hashes it expected are:\n" - <> P.indentN 2 (P.lines (map prettyShareHash (toList hashes))) + <> P.indentN 2 (P.lines (map prettyHash32 (toList hashes))) ] handleGetCausalHashByPathError = \case Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermission sharePath @@ -1736,8 +1738,8 @@ prettyBase32Hex# b = P.group $ "#" <> prettyBase32Hex b prettyHash :: IsString s => Hash.Hash -> P.Pretty s prettyHash = prettyBase32Hex# . Hash.toBase32Hex -prettyShareHash :: IsString s => Share.Hash -> P.Pretty s -prettyShareHash = prettyBase32Hex# . Share.Hash.toBase32Hex +prettyHash32 :: IsString s => Hash32 -> P.Pretty s +prettyHash32 = prettyBase32Hex# . Hash32.toBase32Hex formatMissingStuff :: (Show tm, Show typ) => @@ -2269,7 +2271,7 @@ showDiffNamespace :: (Pretty, NumberedArgs) showDiffNamespace _ _ _ _ diffOutput | OBD.isEmpty diffOutput = - ("The namespaces are identical.", mempty) + ("The namespaces are identical.", mempty) showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = (P.sepNonEmpty "\n\n" p, toList args) where diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index a203634a34..f35b23a5af 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -41,16 +41,15 @@ import qualified Data.Set.NonEmpty as NESet import qualified Servant.API as Servant ((:<|>) (..)) import Servant.Client (BaseUrl) import qualified Servant.Client as Servant (ClientEnv, ClientM, client, hoistClient, mkClientEnv, runClientM) -import U.Codebase.HashTags (CausalHash (..)) +import U.Codebase.HashTags (CausalHash) import qualified U.Codebase.Sqlite.Queries as Q -import U.Util.Base32Hex (Base32Hex) -import qualified U.Util.Hash as Hash +import U.Util.Hash32 (Hash32) import Unison.Auth.HTTPClient (AuthorizedHttpClient) import qualified Unison.Auth.HTTPClient as Auth import Unison.Prelude import qualified Unison.Sqlite as Sqlite import qualified Unison.Sync.API as Share (api) -import Unison.Sync.Common +import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash) import qualified Unison.Sync.Types as Share import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set @@ -62,7 +61,7 @@ import qualified Unison.Util.Set as Set data CheckAndSetPushError = CheckAndSetPushErrorHashMismatch Share.HashMismatch | CheckAndSetPushErrorNoWritePermission Share.Path - | CheckAndSetPushErrorServerMissingDependencies (NESet Share.Hash) + | CheckAndSetPushErrorServerMissingDependencies (NESet Hash32) -- | Push a causal to Unison Share. -- FIXME reword this @@ -77,7 +76,7 @@ checkAndSetPush :: Share.Path -> -- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error. -- This prevents accidentally pushing over data that we didn't know was there. - Maybe Share.Hash -> + Maybe Hash32 -> -- | The hash of our local causal to push. CausalHash -> IO (Either CheckAndSetPushError ()) @@ -114,7 +113,7 @@ checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash = do Share.UpdatePathRequest { path, expectedHash, - newHash = causalHashToShareHash causalHash + newHash = causalHashToHash32 causalHash } -- | An error occurred while fast-forward pushing code to Unison Share. @@ -123,9 +122,9 @@ data FastForwardPushError | FastForwardPushErrorNoReadPermission Share.Path | FastForwardPushErrorNotFastForward Share.Path | FastForwardPushErrorNoWritePermission Share.Path - | FastForwardPushErrorServerMissingDependencies (NESet Share.Hash) - | -- Parent Child - FastForwardPushInvalidParentage Share.Hash Share.Hash + | FastForwardPushErrorServerMissingDependencies (NESet Hash32) + | -- Parent Child + FastForwardPushInvalidParentage Hash32 Hash32 -- | Push a causal to Unison Share. -- FIXME reword this @@ -161,7 +160,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = Share.FastForwardPathRequest { expectedHash = remoteHeadHash, hashes = - causalHashToShareHash <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), + causalHashToHash32 <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), path } doFastForwardPath <&> \case @@ -185,14 +184,14 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = unisonShareUrl conn (Share.pathRepoName path) - (NESet.singleton (causalHashToShareHash headHash)) + (NESet.singleton (causalHashToHash32 headHash)) -- Return a list from oldest to newst of the ancestors between (excluding) the latest local and the current remote -- hash. -- note: seems like we /should/ cut this short, with another command to go longer? :grimace: - fancyBfs :: CausalHash -> Share.Hash -> Sqlite.Transaction (Maybe [CausalHash]) + fancyBfs :: CausalHash -> Hash32 -> Sqlite.Transaction (Maybe [CausalHash]) fancyBfs h0 h1 = - tweak <$> dagbfs (== Share.toBase32Hex h1) Q.loadCausalParentsByHash (Hash.toBase32Hex (unCausalHash h0)) + tweak <$> dagbfs (== h1) Q.loadCausalParentsByHash (causalHashToHash32 h0) where -- Drop 1 (under a Maybe, and twddling hash types): -- @@ -202,9 +201,9 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = -- -- The drop 1 is because dagbfs returns the goal at the head of the returned list, but we know what the goal is -- already (the remote head hash). - tweak :: Maybe [Base32Hex] -> Maybe [CausalHash] + tweak :: Maybe [Hash32] -> Maybe [CausalHash] tweak = - fmap (map (CausalHash . Hash.fromBase32Hex) . drop 1) + fmap (map hash32ToCausalHash . drop 1) data Step a = DeadEnd @@ -333,7 +332,7 @@ pull httpClient unisonShareUrl conn repoPath = do Just EntityInMainStorage -> pure () Just (EntityInTempStorage missingDependencies) -> doDownload missingDependencies Nothing -> doDownload (NESet.singleton hashJwt) - pure (Right (CausalHash (Hash.fromBase32Hex (Share.toBase32Hex hash)))) + pure (Right (hash32ToCausalHash hash)) where doDownload :: NESet Share.HashJWT -> IO () doDownload = @@ -388,7 +387,7 @@ downloadEntities httpClient unisonShareUrl conn repoName = whenJust (NESet.nonEmptySet missingDependencies0) loop - doDownload :: NESet Share.HashJWT -> IO (NEMap Share.Hash (Share.Entity Text Share.Hash Share.HashJWT)) + doDownload :: NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) doDownload hashes = do Share.DownloadEntitiesSuccess entities <- httpDownloadEntities @@ -410,12 +409,12 @@ uploadEntities :: BaseUrl -> Sqlite.Connection -> Share.RepoName -> - NESet Share.Hash -> + NESet Hash32 -> IO Bool uploadEntities httpClient unisonShareUrl conn repoName = loop where - loop :: NESet Share.Hash -> IO Bool + loop :: NESet Hash32 -> IO Bool loop (NESet.toAscList -> hashes) = do -- Get each entity that the server is missing out of the database. entities <- Sqlite.runTransaction conn (traverse expectEntity hashes) @@ -449,8 +448,8 @@ data EntityLocation EntityInTempStorage (NESet Share.HashJWT) -- | Where is an entity stored? -entityLocation :: Share.Hash -> Sqlite.Transaction (Maybe EntityLocation) -entityLocation (Share.Hash hash) = +entityLocation :: Hash32 -> Sqlite.Transaction (Maybe EntityLocation) +entityLocation hash = Q.entityExists hash >>= \case True -> pure (Just EntityInMainStorage) False -> @@ -487,8 +486,8 @@ elaborateHashes = -- 2. In main storage if we already have all of its dependencies in main storage. -- 3. In temp storage otherwise. upsertEntitySomewhere :: - Share.Hash -> - Share.Entity Text Share.Hash Share.HashJWT -> + Hash32 -> + Share.Entity Text Hash32 Share.HashJWT -> Sqlite.Transaction EntityLocation upsertEntitySomewhere hash entity = entityLocation hash >>= \case @@ -496,7 +495,7 @@ upsertEntitySomewhere hash entity = Nothing -> do missingDependencies0 <- Set.filterM - (fmap not . Q.entityExists . Share.toBase32Hex . Share.hashJWTHash) + (fmap not . Q.entityExists . Share.hashJWTHash) (Share.entityDependencies entity) case NESet.nonEmptySet missingDependencies0 of Nothing -> do @@ -507,26 +506,26 @@ upsertEntitySomewhere hash entity = pure (EntityInTempStorage missingDependencies) -- | Insert an entity that doesn't have any missing dependencies. -insertEntity :: Share.Hash -> Share.Entity Text Share.Hash Share.HashJWT -> Sqlite.Transaction () +insertEntity :: Hash32 -> Share.Entity Text Hash32 Share.HashJWT -> Sqlite.Transaction () insertEntity hash entity = do - syncEntity <- Q.tempToSyncEntity (entityToTempEntity (Share.toBase32Hex . Share.hashJWTHash) entity) - _id <- Q.saveSyncEntity (Share.toBase32Hex hash) syncEntity + syncEntity <- Q.tempToSyncEntity (entityToTempEntity Share.hashJWTHash entity) + _id <- Q.saveSyncEntity hash syncEntity pure () -- | Insert an entity and its missing dependencies. insertTempEntity :: - Share.Hash -> - Share.Entity Text Share.Hash Share.HashJWT -> + Hash32 -> + Share.Entity Text Hash32 Share.HashJWT -> NESet Share.HashJWT -> Sqlite.Transaction () insertTempEntity hash entity missingDependencies = Q.insertTempEntity - (Share.toBase32Hex hash) - (entityToTempEntity (Share.toBase32Hex . Share.hashJWTHash) entity) + hash + (entityToTempEntity Share.hashJWTHash entity) ( NESet.map ( \hashJwt -> let Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}} = Share.decodeHashJWT hashJwt - in (Share.toBase32Hex hash, Share.unHashJWT hashJwt) + in (hash, Share.unHashJWT hashJwt) ) missingDependencies ) diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 78b7b2f193..779210a011 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -47,6 +47,7 @@ dependencies: - unison-pretty-printer - unison-util - unison-util-base32hex + - unison-util-base32hex-orphans-aeson - unison-util-relation - unison-sqlite - unliftio diff --git a/unison-share-api/src/Unison/Sync/Common.hs b/unison-share-api/src/Unison/Sync/Common.hs index af7fb4f370..8bad96a97f 100644 --- a/unison-share-api/src/Unison/Sync/Common.hs +++ b/unison-share-api/src/Unison/Sync/Common.hs @@ -3,7 +3,8 @@ module Unison.Sync.Common ( expectEntity, -- * Type conversions - causalHashToShareHash, + causalHashToHash32, + hash32ToCausalHash, entityToTempEntity, tempEntityToEntity, ) @@ -11,7 +12,6 @@ where import qualified Control.Lens as Lens import qualified Data.Set as Set -import Data.Vector (Vector) import qualified Data.Vector as Vector import U.Codebase.HashTags (CausalHash (..)) import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat @@ -25,27 +25,33 @@ import U.Codebase.Sqlite.TempEntity (TempEntity) import qualified U.Codebase.Sqlite.TempEntity as Sqlite import qualified U.Codebase.Sqlite.TempEntity as TempEntity import qualified U.Codebase.Sqlite.Term.Format as TermFormat -import U.Util.Base32Hex (Base32Hex) -import qualified U.Util.Hash as Hash +import U.Util.Hash32 (Hash32) +import qualified U.Util.Hash32 as Hash32 import Unison.Prelude import qualified Unison.Sqlite as Sqlite import qualified Unison.Sync.Types as Share -- | Read an entity out of the database that we know is in main storage. -expectEntity :: Share.Hash -> Sqlite.Transaction (Share.Entity Text Share.Hash Share.Hash) +expectEntity :: Hash32 -> Sqlite.Transaction (Share.Entity Text Hash32 Hash32) expectEntity hash = do - syncEntity <- Q.expectEntity (Share.toBase32Hex hash) + syncEntity <- Q.expectEntity hash tempEntity <- Q.syncToTempEntity syncEntity pure (tempEntityToEntity tempEntity) -causalHashToShareHash :: CausalHash -> Share.Hash -causalHashToShareHash = - Share.Hash . Hash.toBase32Hex . unCausalHash +-- FIXME this isn't the right module for this conversion +causalHashToHash32 :: CausalHash -> Hash32 +causalHashToHash32 = + Hash32.fromHash . unCausalHash + +-- FIXME this isn't the right module for this conversion +hash32ToCausalHash :: Hash32 -> CausalHash +hash32ToCausalHash = + CausalHash . Hash32.toHash -- | Convert an entity that came over the wire from Unison Share into an equivalent type that we can store in the -- `temp_entity` table. -entityToTempEntity :: forall hash. (hash -> Base32Hex) -> Share.Entity Text Share.Hash hash -> TempEntity -entityToTempEntity toBase32Hex = \case +entityToTempEntity :: forall hash. (hash -> Hash32) -> Share.Entity Text Hash32 hash -> TempEntity +entityToTempEntity toHash32 = \case Share.TC (Share.TermComponent terms) -> terms & Vector.fromList @@ -65,7 +71,7 @@ entityToTempEntity toBase32Hex = \case Share.PD Share.PatchDiff {parent, textLookup, oldHashLookup, newHashLookup, bytes} -> Entity.P ( PatchFormat.SyncDiff - (toBase32Hex parent) + (toHash32 parent) (mungePatchLocalIds textLookup oldHashLookup newHashLookup) bytes ) @@ -74,22 +80,22 @@ entityToTempEntity toBase32Hex = \case Share.ND Share.NamespaceDiff {parent, textLookup, defnLookup, patchLookup, childLookup, bytes} -> Entity.N ( NamespaceFormat.SyncDiff - (toBase32Hex parent) + (toHash32 parent) (mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup) bytes ) Share.C Share.Causal {namespaceHash, parents} -> Entity.C Causal.SyncCausalFormat - { valueHash = toBase32Hex namespaceHash, - parents = Vector.fromList (map toBase32Hex (Set.toList parents)) + { valueHash = toHash32 namespaceHash, + parents = Vector.fromList (map toHash32 (Set.toList parents)) } where mungeLocalIds :: Share.LocalIds Text hash -> TempEntity.TempLocalIds mungeLocalIds Share.LocalIds {texts, hashes} = LocalIds { textLookup = Vector.fromList texts, - defnLookup = Vector.map toBase32Hex (Vector.fromList hashes) + defnLookup = Vector.map toHash32 (Vector.fromList hashes) } mungeNamespaceLocalIds :: @@ -101,20 +107,20 @@ entityToTempEntity toBase32Hex = \case mungeNamespaceLocalIds textLookup defnLookup patchLookup childLookup = NamespaceFormat.LocalIds { branchTextLookup = Vector.fromList textLookup, - branchDefnLookup = Vector.fromList (map toBase32Hex defnLookup), - branchPatchLookup = Vector.fromList (map toBase32Hex patchLookup), - branchChildLookup = Vector.fromList (map (\(x, y) -> (toBase32Hex x, toBase32Hex y)) childLookup) + branchDefnLookup = Vector.fromList (map toHash32 defnLookup), + branchPatchLookup = Vector.fromList (map toHash32 patchLookup), + branchChildLookup = Vector.fromList (map (\(x, y) -> (toHash32 x, toHash32 y)) childLookup) } - mungePatchLocalIds :: [Text] -> [Share.Hash] -> [hash] -> TempEntity.TempPatchLocalIds + mungePatchLocalIds :: [Text] -> [Hash32] -> [hash] -> TempEntity.TempPatchLocalIds mungePatchLocalIds textLookup oldHashLookup newHashLookup = PatchFormat.LocalIds { patchTextLookup = Vector.fromList textLookup, - patchHashLookup = Vector.fromList (coerce @[Share.Hash] @[Base32Hex] oldHashLookup), - patchDefnLookup = Vector.fromList (map toBase32Hex newHashLookup) + patchHashLookup = Vector.fromList oldHashLookup, + patchDefnLookup = Vector.fromList (map toHash32 newHashLookup) } -tempEntityToEntity :: Sqlite.TempEntity -> Share.Entity Text Share.Hash Share.Hash +tempEntityToEntity :: Sqlite.TempEntity -> Share.Entity Text Hash32 Hash32 tempEntityToEntity = \case Entity.TC (TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent terms)) -> terms @@ -134,17 +140,17 @@ tempEntityToEntity = \case Share.P Share.Patch { textLookup = Vector.toList patchTextLookup, - oldHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchHashLookup), - newHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchDefnLookup), + oldHashLookup = Vector.toList patchHashLookup, + newHashLookup = Vector.toList patchDefnLookup, bytes } PatchFormat.SyncDiff parent PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} bytes -> Share.PD Share.PatchDiff - { parent = Share.Hash parent, + { parent, textLookup = Vector.toList patchTextLookup, - oldHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchHashLookup), - newHashLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) patchDefnLookup), + oldHashLookup = Vector.toList patchHashLookup, + newHashLookup = Vector.toList patchDefnLookup, bytes } Entity.N format -> @@ -160,11 +166,9 @@ tempEntityToEntity = \case Share.N Share.Namespace { textLookup = Vector.toList branchTextLookup, - defnLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchDefnLookup), - patchLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchPatchLookup), - childLookup = - Vector.toList - (coerce @(Vector (Base32Hex, Base32Hex)) @(Vector (Share.Hash, Share.Hash)) branchChildLookup), + defnLookup = Vector.toList branchDefnLookup, + patchLookup = Vector.toList branchPatchLookup, + childLookup = Vector.toList branchChildLookup, bytes } NamespaceFormat.SyncDiff @@ -178,25 +182,23 @@ tempEntityToEntity = \case bytes -> Share.ND Share.NamespaceDiff - { parent = Share.Hash parent, + { parent, textLookup = Vector.toList branchTextLookup, - defnLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchDefnLookup), - patchLookup = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) branchPatchLookup), - childLookup = - Vector.toList - (coerce @(Vector (Base32Hex, Base32Hex)) @(Vector (Share.Hash, Share.Hash)) branchChildLookup), + defnLookup = Vector.toList branchDefnLookup, + patchLookup = Vector.toList branchPatchLookup, + childLookup = Vector.toList branchChildLookup, bytes } Entity.C Causal.SyncCausalFormat {valueHash, parents} -> Share.C Share.Causal - { namespaceHash = Share.Hash valueHash, - parents = Set.fromList (coerce @[Base32Hex] @[Share.Hash] (Vector.toList parents)) + { namespaceHash = valueHash, + parents = Set.fromList (Vector.toList parents) } where - mungeLocalIds :: LocalIds' Text Base32Hex -> Share.LocalIds Text Share.Hash + mungeLocalIds :: LocalIds' Text Hash32 -> Share.LocalIds Text Hash32 mungeLocalIds LocalIds {textLookup, defnLookup} = Share.LocalIds { texts = Vector.toList textLookup, - hashes = Vector.toList (coerce @(Vector Base32Hex) @(Vector Share.Hash) defnLookup) + hashes = Vector.toList defnLookup } diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index a5a636695b..6e842cc77a 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -12,7 +12,6 @@ module Unison.Sync.Types pathCodebasePath, -- ** Hash types - Hash (..), HashJWT (..), hashJWTHash, HashJWTClaims (..), @@ -89,7 +88,8 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Servant.Auth.JWT -import U.Util.Base32Hex (Base32Hex (..)) +import U.Util.Hash32 (Hash32) +import U.Util.Hash32.Orphans.Aeson () import Unison.Prelude import qualified Unison.Util.Set as Set import qualified Web.JWT as JWT @@ -140,21 +140,18 @@ instance FromJSON Path where ------------------------------------------------------------------------------------------------------------------------ -- Hash types -newtype Hash = Hash {toBase32Hex :: Base32Hex} - deriving (Show, Eq, Ord, ToJSON, FromJSON, ToJSONKey, FromJSONKey) via (Text) - newtype HashJWT = HashJWT {unHashJWT :: Text} deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) -- | Grab the hash out of a hash JWT. -- -- This decodes the whole JWT, then throws away the claims; use it if you really only need the hash! -hashJWTHash :: HashJWT -> Hash +hashJWTHash :: HashJWT -> Hash32 hashJWTHash = decodedHashJWTHash . decodeHashJWT data HashJWTClaims = HashJWTClaims - { hash :: Hash + { hash :: Hash32 -- Currently unused -- entityType :: EntityType } @@ -216,7 +213,7 @@ decodeHashJWTClaims (HashJWT text) = Aeson.Success claims -> claims -- | Grab the hash out of a decoded hash JWT. -decodedHashJWTHash :: DecodedHashJWT -> Hash +decodedHashJWTHash :: DecodedHashJWT -> Hash32 decodedHashJWTHash DecodedHashJWT {claims = HashJWTClaims {hash}} = hash @@ -661,7 +658,7 @@ instance FromJSON DownloadEntitiesRequest where pure DownloadEntitiesRequest {..} data DownloadEntitiesResponse - = DownloadEntitiesSuccess (NEMap Hash (Entity Text Hash HashJWT)) + = DownloadEntitiesSuccess (NEMap Hash32 (Entity Text Hash32 HashJWT)) | DownloadEntitiesNoReadPermission RepoName -- data DownloadEntities = DownloadEntities @@ -696,7 +693,7 @@ instance FromJSON DownloadEntitiesResponse where data UploadEntitiesRequest = UploadEntitiesRequest { repoName :: RepoName, - entities :: NEMap Hash (Entity Text Hash Hash) + entities :: NEMap Hash32 (Entity Text Hash32 Hash32) } deriving stock (Show, Eq, Ord) @@ -715,12 +712,12 @@ instance FromJSON UploadEntitiesRequest where data UploadEntitiesResponse = UploadEntitiesSuccess - | UploadEntitiesNeedDependencies (NeedDependencies Hash) + | UploadEntitiesNeedDependencies (NeedDependencies Hash32) | UploadEntitiesNoWritePermission RepoName | UploadEntitiesHashMismatchForEntity HashMismatchForEntity deriving stock (Show, Eq, Ord) -data HashMismatchForEntity = HashMismatchForEntity {supplied :: Hash, computed :: Hash} +data HashMismatchForEntity = HashMismatchForEntity {supplied :: Hash32, computed :: Hash32} deriving stock (Show, Eq, Ord) instance ToJSON UploadEntitiesResponse where @@ -775,9 +772,9 @@ instance FromJSON HashMismatchForEntity where -- instead. data FastForwardPathRequest = FastForwardPathRequest { -- | The causal that the client believes exists at `path` - expectedHash :: Hash, + expectedHash :: Hash32, -- | The sequence of causals to fast-forward with, starting from the oldest new causal to the newest new causal - hashes :: NonEmpty Hash, + hashes :: NonEmpty Hash32, -- | The path to fast-forward path :: Path } @@ -801,7 +798,7 @@ instance FromJSON FastForwardPathRequest where data FastForwardPathResponse = FastForwardPathSuccess - | FastForwardPathMissingDependencies (NeedDependencies Hash) + | FastForwardPathMissingDependencies (NeedDependencies Hash32) | FastForwardPathNoWritePermission Path | -- | This wasn't a fast-forward. Here's a JWT to download the causal head, if you want it. FastForwardPathNotFastForward HashJWT @@ -811,7 +808,7 @@ data FastForwardPathResponse FastForwardPathInvalidParentage InvalidParentage deriving stock (Show) -data InvalidParentage = InvalidParentage {parent :: Hash, child :: Hash} +data InvalidParentage = InvalidParentage {parent :: Hash32, child :: Hash32} deriving stock (Show) instance ToJSON FastForwardPathResponse where @@ -847,8 +844,8 @@ instance FromJSON InvalidParentage where data UpdatePathRequest = UpdatePathRequest { path :: Path, - expectedHash :: Maybe Hash, -- Nothing requires empty history at destination - newHash :: Hash + expectedHash :: Maybe Hash32, -- Nothing requires empty history at destination + newHash :: Hash32 } deriving stock (Show, Eq, Ord) @@ -870,7 +867,7 @@ instance FromJSON UpdatePathRequest where data UpdatePathResponse = UpdatePathSuccess | UpdatePathHashMismatch HashMismatch - | UpdatePathMissingDependencies (NeedDependencies Hash) + | UpdatePathMissingDependencies (NeedDependencies Hash32) | UpdatePathNoWritePermission Path deriving stock (Show, Eq, Ord) @@ -893,8 +890,8 @@ instance FromJSON UpdatePathResponse where data HashMismatch = HashMismatch { path :: Path, - expectedHash :: Maybe Hash, - actualHash :: Maybe Hash + expectedHash :: Maybe Hash32, + actualHash :: Maybe Hash32 } deriving stock (Show, Eq, Ord) diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index 71a9fa24e8..a9e3e75d7d 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -105,6 +105,7 @@ library , unison-sqlite , unison-util , unison-util-base32hex + , unison-util-base32hex-orphans-aeson , unison-util-relation , unliftio , unordered-containers From 4f69bbd5034cf687b1b8d9e15f57f9f4fe88607a Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 4 Jun 2022 19:59:52 -0400 Subject: [PATCH 295/529] -fno-warn-orphans in orphans modules --- .../src/U/Util/Hash32/Orphans/Aeson.hs | 2 ++ .../src/U/Util/Hash32/Orphans/Sqlite.hs | 2 ++ 2 files changed, 4 insertions(+) diff --git a/lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs b/lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs index 10ce032d17..4cc9efbbea 100644 --- a/lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs +++ b/lib/unison-util-base32hex-orphans-aeson/src/U/Util/Hash32/Orphans/Aeson.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module U.Util.Hash32.Orphans.Aeson () where import Data.Aeson (FromJSON, FromJSONKey, ToJSON, ToJSONKey) diff --git a/lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs b/lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs index 2b5aaaa797..4602e87375 100644 --- a/lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs +++ b/lib/unison-util-base32hex-orphans-sqlite/src/U/Util/Hash32/Orphans/Sqlite.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + module U.Util.Hash32.Orphans.Sqlite () where import Data.Text (Text) From 97a33fc536c42529728abc01271422ddbb434391 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sun, 5 Jun 2022 11:11:10 -0400 Subject: [PATCH 296/529] turn on some timing stuff temporarily --- codebase2/util/src/U/Util/Timing.hs | 2 +- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 3 ++- unison-cli/src/Unison/Share/Sync.hs | 3 ++- 3 files changed, 5 insertions(+), 3 deletions(-) diff --git a/codebase2/util/src/U/Util/Timing.hs b/codebase2/util/src/U/Util/Timing.hs index 797759b495..7bb9c45da1 100644 --- a/codebase2/util/src/U/Util/Timing.hs +++ b/codebase2/util/src/U/Util/Timing.hs @@ -10,7 +10,7 @@ import System.IO.Unsafe (unsafePerformIO) import UnliftIO (MonadIO, liftIO) enabled :: Bool -enabled = False +enabled = True time :: MonadIO m => String -> m a -> m a time _ ma | not enabled = ma diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 169496ce58..2f92702087 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -29,7 +29,7 @@ import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) import qualified Text.Megaparsec as P import qualified U.Codebase.Sqlite.Operations as Ops -import U.Util.Timing (unsafeTime) +import U.Util.Timing (time, unsafeTime) import qualified Unison.ABT as ABT import qualified Unison.Builtin as Builtin import qualified Unison.Builtin.Decls as DD @@ -1780,6 +1780,7 @@ handlePushRemoteBranch :: SyncMode.SyncMode -> Action' m v () handlePushRemoteBranch mayRepo path pushBehavior syncMode = + time "handlePushRemoteBranch" case mayRepo of Nothing -> runExceptT (resolveConfiguredUrl Push path) >>= \case diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index f35b23a5af..5af9b338bf 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -44,6 +44,7 @@ import qualified Servant.Client as Servant (ClientEnv, ClientM, client, hoistCli import U.Codebase.HashTags (CausalHash) import qualified U.Codebase.Sqlite.Queries as Q import U.Util.Hash32 (Hash32) +import qualified U.Util.Timing as Timing import Unison.Auth.HTTPClient (AuthorizedHttpClient) import qualified Unison.Auth.HTTPClient as Auth import Unison.Prelude @@ -420,7 +421,7 @@ uploadEntities httpClient unisonShareUrl conn repoName = entities <- Sqlite.runTransaction conn (traverse expectEntity hashes) let uploadEntities :: IO Share.UploadEntitiesResponse - uploadEntities = + uploadEntities = Timing.time ("uploadEntities with " <> show (length hashes) <> " hashes.") do httpUploadEntities httpClient unisonShareUrl From c1489998f4ae0695799f43797f376acf96187b93 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sun, 5 Jun 2022 11:11:50 -0400 Subject: [PATCH 297/529] add `seen` check to elaborateHashes --- unison-cli/src/Unison/Share/Sync.hs | 21 ++++++++++++++------- 1 file changed, 14 insertions(+), 7 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 5af9b338bf..0cf791ba64 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -51,6 +51,7 @@ import Unison.Prelude import qualified Unison.Sqlite as Sqlite import qualified Unison.Sync.API as Share (api) import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash) +import Unison.Sync.Types (DecodedHashJWT, HashJWT) import qualified Unison.Sync.Types as Share import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set @@ -470,16 +471,22 @@ entityLocation hash = -- In the end, we return a set of hashes that correspond to entities we actually need to download. elaborateHashes :: NESet Share.DecodedHashJWT -> Sqlite.Transaction (Maybe (NESet Share.HashJWT)) elaborateHashes = - let loop hashes outputs = + let loop :: Set DecodedHashJWT -> Set HashJWT -> Set HashJWT -> Sqlite.Transaction (Maybe (NESet HashJWT)) + loop hashes seen outputs = do case Set.minView hashes of Nothing -> pure (NESet.nonEmptySet outputs) Just (Share.DecodedHashJWT (Share.HashJWTClaims {hash}) jwt, hashes') -> - entityLocation hash >>= \case - Nothing -> loop hashes' (Set.insert jwt outputs) - Just (EntityInTempStorage missingDependencies) -> - loop (Set.union (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) hashes') outputs - Just EntityInMainStorage -> loop hashes' outputs - in \hashes -> loop (NESet.toSet hashes) Set.empty + let seen' = Set.insert jwt seen + in if Set.member jwt outputs || Set.member jwt seen + then -- skip โ€” if it's in outputs, it's already fully elaborated + loop hashes' seen' outputs + else + entityLocation hash >>= \case + Nothing -> loop hashes' seen' (Set.insert jwt outputs) + Just (EntityInTempStorage missingDependencies) -> do + loop (Set.union (Set.map Share.decodeHashJWT missingDependencies) hashes') seen' outputs + Just EntityInMainStorage -> loop hashes' seen' outputs + in \hashes -> loop (NESet.toSet hashes) Set.empty Set.empty -- | Upsert a downloaded entity "somewhere" - -- From abf17cdc162ac1db8d6ce77c00f19bbce43ab6c3 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sun, 5 Jun 2022 11:12:09 -0400 Subject: [PATCH 298/529] prepare to be a submodule called `unison` --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 4 ++-- codebase2/codebase-sqlite/unison | 1 + 2 files changed, 3 insertions(+), 2 deletions(-) create mode 120000 codebase2/codebase-sqlite/unison diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 067b3c0d9b..46fbc4da15 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -212,12 +212,12 @@ import Unison.Sqlite createSchema :: Transaction () createSchema = do - executeFile [hereFile|sql/create.sql|] + executeFile [hereFile|unison/sql/create.sql|] addTempEntityTables addTempEntityTables :: Transaction () addTempEntityTables = - executeFile [hereFile|sql/001-temp-entity-tables.sql|] + executeFile [hereFile|unison/sql/001-temp-entity-tables.sql|] executeFile :: String -> Transaction () executeFile = diff --git a/codebase2/codebase-sqlite/unison b/codebase2/codebase-sqlite/unison new file mode 120000 index 0000000000..945c9b46d6 --- /dev/null +++ b/codebase2/codebase-sqlite/unison @@ -0,0 +1 @@ +. \ No newline at end of file From 44a086e968f6f5c2f93b110b78277af2c0225f7e Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sun, 5 Jun 2022 11:28:07 -0400 Subject: [PATCH 299/529] fix sloppy checkin c1489998 --- unison-cli/src/Unison/Share/Sync.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 0cf791ba64..fb43b82711 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -484,7 +484,7 @@ elaborateHashes = entityLocation hash >>= \case Nothing -> loop hashes' seen' (Set.insert jwt outputs) Just (EntityInTempStorage missingDependencies) -> do - loop (Set.union (Set.map Share.decodeHashJWT missingDependencies) hashes') seen' outputs + loop (Set.union (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) hashes') seen' outputs Just EntityInMainStorage -> loop hashes' seen' outputs in \hashes -> loop (NESet.toSet hashes) Set.empty Set.empty From 79ef3a4005bd553c1ba04cd2b25e8a7f4fc75012 Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Mon, 6 Jun 2022 10:56:09 -0400 Subject: [PATCH 300/529] Update development.markdown --- development.markdown | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/development.markdown b/development.markdown index 3ccf07ef72..a4d1ff3189 100644 --- a/development.markdown +++ b/development.markdown @@ -11,7 +11,7 @@ To get cracking with Unison: 1. [Install `stack`](https://docs.haskellstack.org/en/stable/README/#how-to-install). 2. Build the project with `stack build`. This builds all executables. 3. (Optional) Run `./dev-ui-install.hs` to fetch the latest release of the codebase UI. If you don't care about running the codebase UI locally you can ignore this step. -4. After building do `stack exec unison -- init` will initialize a codebase in your home directory (in `~/.unison`). This only needs to be done once. +4. After building do `stack exec unison` to will initialize a codebase in your home directory (in `~/.unison`). This only needs to be done once. (Alternatively, you can use `stack exec -- unison -C to create a codebase in ` 5. `stack exec unison` starts Unison and watches for `.u` file changes in the current directory. If you want to run it in a different directory, just add `unison` to your `PATH`, after finding it with `stack exec which unison`. On startup, Unison prints a url for the codebase UI. If you did step 3 above, then visiting that URL in a browser will give you a nice interface to your codebase. @@ -31,12 +31,16 @@ Some tests are executables instead: * `stack exec integration-tests` runs the additional integration tests for cli. These tests are not triggered by `tests` or `trancscripts`. * `stack exec unison -- transcript unison-src/transcripts-round-trip/main.md` runs the pretty-printing round trip tests +### Building everything at once, including tests and benchmarks, but without running them: +Do: + + stack build --fast --test --bench --no-run-tests --no-run-benchmarks ### What if you want a profiled build? Do: - stack build --executable-profiling --library-profiling --ghc-options="-fprof-auto -rtsopts" unison-parser-typechecker + stack build --profile unison-parser-typechecker Again you can leave off the flag. To run an executable with profiling enabled, do: From 5cd33965b59ebf65b1a62d849b209fac74da0e9d Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 6 Jun 2022 12:09:49 -0400 Subject: [PATCH 301/529] pull some console printing out to a helper --- .../src/Unison/Codebase/Editor/HandleInput.hs | 42 +++++++++++-------- 1 file changed, 24 insertions(+), 18 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index cea08c41bd..3884a25feb 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1908,6 +1908,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l pathToSegments = coerce Path.toList + -- Provide the given action a callback that prints out the number of entities uploaded. withEntitiesUploadedProgressCallback :: ((Int -> IO ()) -> IO a) -> IO a withEntitiesUploadedProgressCallback action = do entitiesUploadedVar <- newTVarIO 0 @@ -2308,30 +2309,35 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask let pull :: IO (Either Share.PullError CausalHash) - pull = do - entitiesDownloadedVar <- newTVarIO 0 - Console.Regions.displayConsoleRegions do - Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do - Console.Regions.setConsoleRegion region do - entitiesDownloaded <- readTVar entitiesDownloadedVar - pure ("\n Downloaded " <> tShow entitiesDownloaded <> " entities...\n\n") - result <- - Share.pull - authHTTPClient - baseURL - connection - shareFlavoredPath - (\entitiesDownloaded -> atomically (writeTVar entitiesDownloadedVar entitiesDownloaded)) - entitiesDownloaded <- readTVarIO entitiesDownloadedVar - Console.Regions.finishConsoleRegion region $ - "\n Downloaded " <> tShow entitiesDownloaded <> " entities.\n" - pure result + pull = + withEntitiesDownloadedProgressCallback \entitiesDownloadedProgressCallback -> + Share.pull + authHTTPClient + baseURL + connection + shareFlavoredPath + entitiesDownloadedProgressCallback liftIO pull >>= \case Left err -> pure (Left (Output.ShareErrorPull err)) Right causalHash -> do (eval . Eval) (Codebase.getBranchForHash codebase (Cv.causalHash2to1 causalHash)) >>= \case Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" Just branch -> pure (Right branch) + where + -- Provide the given action a callback that prints out the number of entities downloaded. + withEntitiesDownloadedProgressCallback :: ((Int -> IO ()) -> IO a) -> IO a + withEntitiesDownloadedProgressCallback action = do + entitiesDownloadedVar <- newTVarIO 0 + Console.Regions.displayConsoleRegions do + Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do + Console.Regions.setConsoleRegion region do + entitiesDownloaded <- readTVar entitiesDownloadedVar + pure ("\n Downloaded " <> tShow entitiesDownloaded <> " entities...\n\n") + result <- action \entitiesDownloaded -> atomically (writeTVar entitiesDownloadedVar entitiesDownloaded) + entitiesDownloaded <- readTVarIO entitiesDownloadedVar + Console.Regions.finishConsoleRegion region $ + "\n Downloaded " <> tShow entitiesDownloaded <> " entities.\n" + pure result -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) From fcf3a3212bbe8529ce6f7a30487885898dc09a6f Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Mon, 6 Jun 2022 13:54:47 -0400 Subject: [PATCH 302/529] don't show diff when deleting a namespace --- .../src/Unison/Codebase/Editor/HandleInput.hs | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 8e00808285..f42f81ebba 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -760,25 +760,20 @@ loop = do Just (Branch.head -> b0) -> do endangerments <- computeEndangerments b0 if null endangerments - then doDelete b0 + then doDelete else case insistence of Force -> do ppeDecl <- currentPrettyPrintEnvDecl Backend.Within - doDelete b0 + doDelete respondNumbered $ DeletedDespiteDependents ppeDecl endangerments Try -> do ppeDecl <- currentPrettyPrintEnvDecl Backend.Within respondNumbered $ CantDeleteNamespace ppeDecl endangerments where - doDelete b0 = do + doDelete = do stepAt Branch.CompressHistory $ BranchUtil.makeDeleteBranch (resolveSplit' p) + respond Success -- Looks similar to the 'toDelete' above... investigate me! ;) - diffHelper b0 Branch.empty0 - >>= respondNumbered - . uncurry - ( ShowDiffAfterDeleteBranch $ - resolveToAbsolute (Path.unsplit' p) - ) computeEndangerments :: Branch0 m1 -> Action' m v (Map LabeledDependency (NESet LabeledDependency)) computeEndangerments b0 = do let rootNames = Branch.toNames root0 From 5ed0e34656bb7a25c140d97072bc0687657c6de7 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Mon, 6 Jun 2022 13:59:53 -0400 Subject: [PATCH 303/529] refresh transcripts --- unison-src/transcripts/delete-namespace.output.md | 13 ++----------- unison-src/transcripts/empty-namespaces.output.md | 6 +----- unison-src/transcripts/merge.output.md | 12 ++---------- unison-src/transcripts/merges.output.md | 6 +----- unison-src/transcripts/propagate.output.md | 13 +------------ unison-src/transcripts/unitnamespace.output.md | 6 +----- 6 files changed, 8 insertions(+), 48 deletions(-) diff --git a/unison-src/transcripts/delete-namespace.output.md b/unison-src/transcripts/delete-namespace.output.md index 37586d09e6..0acdacbbb0 100644 --- a/unison-src/transcripts/delete-namespace.output.md +++ b/unison-src/transcripts/delete-namespace.output.md @@ -15,11 +15,7 @@ Deleting a namespace with no external dependencies should succeed. ```ucm .> delete.namespace no_dependencies - Removed definitions: - - 1. thing : Text - - Tip: You can use `undo` or `reflog` to undo this change. + Done. ``` Deleting a namespace with external dependencies should fail and list all dependents. @@ -48,12 +44,7 @@ Deleting a namespace with external dependencies should succeed when using `delet ```ucm .> delete.namespace.force dependencies - Removed definitions: - - 1. term1 : Nat - 2. term2 : Nat - - Tip: You can use `undo` or `reflog` to undo this change. + Done. โš ๏ธ diff --git a/unison-src/transcripts/empty-namespaces.output.md b/unison-src/transcripts/empty-namespaces.output.md index 82da1fd157..306ee11e48 100644 --- a/unison-src/transcripts/empty-namespaces.output.md +++ b/unison-src/transcripts/empty-namespaces.output.md @@ -133,11 +133,7 @@ The history should be that of the moved namespace. ```ucm .> delete.namespace moveoverme - Removed definitions: - - 1. x : ##Nat - - Tip: You can use `undo` or `reflog` to undo this change. + Done. .> history moveme diff --git a/unison-src/transcripts/merge.output.md b/unison-src/transcripts/merge.output.md index 9767d4ca2a..c252eb88d9 100644 --- a/unison-src/transcripts/merge.output.md +++ b/unison-src/transcripts/merge.output.md @@ -99,19 +99,11 @@ foo.z = +28348 .P2> delete.namespace baz - Removed definitions: - - 1. x : Nat - - Tip: You can use `undo` or `reflog` to undo this change. + Done. .P2> delete.namespace quux - Removed definitions: - - 1. x : Nat - - Tip: You can use `undo` or `reflog` to undo this change. + Done. .P2> find diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 27937ad325..09685e42b8 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -101,11 +101,7 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t ```ucm .> delete.namespace .feature1 - Removed definitions: - - 1. y : Text - - Tip: You can use `undo` or `reflog` to undo this change. + Done. .> history .feature1 diff --git a/unison-src/transcripts/propagate.output.md b/unison-src/transcripts/propagate.output.md index 475f75c08e..c359fbf898 100644 --- a/unison-src/transcripts/propagate.output.md +++ b/unison-src/transcripts/propagate.output.md @@ -189,18 +189,7 @@ Cleaning up a bit... ```ucm .> delete.namespace subpath - Removed definitions: - - 1. unique type Foo - 2. Foo.Bar : #isd1untaal - 3. Foo.Foo : #isd1untaal - 4. fooToInt : #isd1untaal -> Int - 5. preserve.otherTerm : Optional baz -> Optional baz - 6. preserve.someTerm : Optional x -> Optional x - 7. patch patch - 8. patch preserve.patch - - Tip: You can use `undo` or `reflog` to undo this change. + Done. ``` Now, we make two terms, where one depends on the other. diff --git a/unison-src/transcripts/unitnamespace.output.md b/unison-src/transcripts/unitnamespace.output.md index 1e3a726877..011c2f8ac4 100644 --- a/unison-src/transcripts/unitnamespace.output.md +++ b/unison-src/transcripts/unitnamespace.output.md @@ -26,10 +26,6 @@ foo = "bar" .> delete.namespace () - Removed definitions: - - 1. foo : ##Text - - Tip: You can use `undo` or `reflog` to undo this change. + Done. ``` From b7b4de89e97f88dac60f8052817e4970b1d97262 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 6 Jun 2022 15:55:31 -0400 Subject: [PATCH 304/529] recursive query for server-side elaborateHashes --- .../U/Codebase/Sqlite/Queries.hs | 24 +++++++++++++++++++ 1 file changed, 24 insertions(+) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 46fbc4da15..586eb09305 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -142,6 +142,9 @@ module U.Codebase.Sqlite.Queries insertTempEntity, saveSyncEntity, + -- * elaborate hashes + elaborateHashesServer, + -- * db misc createSchema, addTempEntityTables, @@ -1510,3 +1513,24 @@ deleteTempEntity hash = WHERE hash = ? |] (Only hash) + +elaborateHashesServer :: Foldable f => f Hash32 -> Transaction [Hash32] +elaborateHashesServer hashes = do + execute_ [here|CREATE TABLE unelaborated_dependency (hash text)|] + executeMany [here|INSERT INTO unelaborated_dependency (hash) VALUES (?)|] (Only <$> toList hashes) + result <- + queryListCol_ + [here| + WITH RECURSIVE elaborated_dependency (hash) AS ( + SELECT hash FROM unelaborated_dependency + UNION + SELECT dependency + FROM temp_entity_missing_dependency + JOIN elaborated_dependency + ON temp_entity_missing_dependency.dependent = elaborated_dependency.hash + ) + SELECT hash FROM elaborated_dependency + EXCEPT SELECT hash FROM temp_entity; + |] + execute_ [here|DROP TABLE unelaborated_dependency|] + pure result From a92be4f8509c847e73ee024654f8b38d532cfd67 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 6 Jun 2022 16:05:39 -0400 Subject: [PATCH 305/529] slightly adjust placement of upload callback in push to be more correct --- unison-cli/src/Unison/Share/Sync.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index b5f60cc5fa..48e48c06f8 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -432,8 +432,6 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadCountCallba let hashes = NESet.toAscList hashesSet -- Get each entity that the server is missing out of the database. entities <- Sqlite.runTransaction conn (traverse expectEntity hashes) - let newUploadCount = uploadCount + NESet.size hashesSet - uploadCountCallback newUploadCount let uploadEntities :: IO Share.UploadEntitiesResponse uploadEntities = Timing.time ("uploadEntities with " <> show (length hashes) <> " hashes.") do @@ -448,10 +446,15 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadCountCallba -- Upload all of the entities we know the server needs, and if the server responds that it needs yet more, loop to -- upload those too. uploadEntities >>= \case - Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> loop newUploadCount moreHashes + Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> do + let newUploadCount = uploadCount + NESet.size hashesSet + uploadCountCallback newUploadCount + loop newUploadCount moreHashes Share.UploadEntitiesNoWritePermission _ -> pure False Share.UploadEntitiesHashMismatchForEntity {} -> pure False - Share.UploadEntitiesSuccess -> pure True + Share.UploadEntitiesSuccess -> do + uploadCountCallback (uploadCount + NESet.size hashesSet) + pure True ------------------------------------------------------------------------------------------------------------------------ -- Database operations From cc34c0db2c306c983704b768b79aa50278152c06 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 6 Jun 2022 16:31:24 -0400 Subject: [PATCH 306/529] chunk share uploads (currently 500 entities / request) --- unison-cli/src/Unison/Share/Sync.hs | 36 ++++++++++++++++++++--------- 1 file changed, 25 insertions(+), 11 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 48e48c06f8..63d247bc62 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -38,6 +38,7 @@ import qualified Data.Sequence.NonEmpty as NESeq (fromList, nonEmptySeq, (><|)) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet +import Data.These (These (..)) import qualified Servant.API as Servant ((:<|>) (..)) import Servant.Client (BaseUrl) import qualified Servant.Client as Servant (ClientEnv, ClientM, client, hoistClient, mkClientEnv, runClientM) @@ -428,33 +429,46 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadCountCallba loop 0 hashes0 where loop :: Int -> NESet Hash32 -> IO Bool - loop uploadCount hashesSet = do - let hashes = NESet.toAscList hashesSet + loop uploadCount allHashesSet = do + -- Each request only contains a certain maximum number of entities; split the set of hashes we need to upload into + -- those we will upload right now, and those we will begin uploading + let (hashesSet, nextHashes) = + case NESet.splitAt 500 allHashesSet of + This hs1 -> (hs1, Set.empty) + That hs2 -> (hs2, Set.empty) -- impossible, this only happens if we split at 0 + These hs1 hs2 -> (hs1, NESet.toSet hs2) + + let hashesList = NESet.toAscList hashesSet -- Get each entity that the server is missing out of the database. - entities <- Sqlite.runTransaction conn (traverse expectEntity hashes) + entities <- Sqlite.runTransaction conn (traverse expectEntity hashesList) let uploadEntities :: IO Share.UploadEntitiesResponse - uploadEntities = Timing.time ("uploadEntities with " <> show (length hashes) <> " hashes.") do + uploadEntities = Timing.time ("uploadEntities with " <> show (NESet.size hashesSet) <> " hashes.") do httpUploadEntities httpClient unisonShareUrl Share.UploadEntitiesRequest - { entities = NEMap.fromAscList (List.NonEmpty.zip hashes entities), + { entities = NEMap.fromAscList (List.NonEmpty.zip hashesList entities), repoName } - -- Upload all of the entities we know the server needs, and if the server responds that it needs yet more, loop to - -- upload those too. + -- The new upload count *if* we make a successful upload. + let newUploadCount = uploadCount + NESet.size hashesSet + uploadEntities >>= \case Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> do - let newUploadCount = uploadCount + NESet.size hashesSet uploadCountCallback newUploadCount - loop newUploadCount moreHashes + loop newUploadCount $ + case NESet.nonEmptySet nextHashes of + Nothing -> moreHashes + Just nextHashes1 -> NESet.union moreHashes nextHashes1 Share.UploadEntitiesNoWritePermission _ -> pure False Share.UploadEntitiesHashMismatchForEntity {} -> pure False Share.UploadEntitiesSuccess -> do - uploadCountCallback (uploadCount + NESet.size hashesSet) - pure True + uploadCountCallback newUploadCount + case NESet.nonEmptySet nextHashes of + Nothing -> pure True + Just nextHashes1 -> loop newUploadCount nextHashes1 ------------------------------------------------------------------------------------------------------------------------ -- Database operations From 3dbe8bbbcb0a35133d2aa698ad2070601422c7fb Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 6 Jun 2022 18:06:09 -0400 Subject: [PATCH 307/529] recursive query for client-side elaborateHashes (not yet testable) --- .../U/Codebase/Sqlite/Queries.hs | 42 ++++++++++++++++++- unison-cli/src/Unison/Share/Sync.hs | 15 +++++-- 2 files changed, 52 insertions(+), 5 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 586eb09305..e10d4625ca 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -143,6 +143,7 @@ module U.Codebase.Sqlite.Queries saveSyncEntity, -- * elaborate hashes + elaborateHashesClient, elaborateHashesServer, -- * db misc @@ -1514,10 +1515,10 @@ deleteTempEntity hash = |] (Only hash) -elaborateHashesServer :: Foldable f => f Hash32 -> Transaction [Hash32] +elaborateHashesServer :: [Hash32] -> Transaction [Hash32] elaborateHashesServer hashes = do execute_ [here|CREATE TABLE unelaborated_dependency (hash text)|] - executeMany [here|INSERT INTO unelaborated_dependency (hash) VALUES (?)|] (Only <$> toList hashes) + executeMany [here|INSERT INTO unelaborated_dependency (hash) VALUES (?)|] (Only <$> hashes) result <- queryListCol_ [here| @@ -1534,3 +1535,40 @@ elaborateHashesServer hashes = do |] execute_ [here|DROP TABLE unelaborated_dependency|] pure result + +-- | where Text = HashJWT +elaborateHashesClient :: [(Hash32, Text)] -> Transaction [Text] +elaborateHashesClient hashes = do + execute_ + [here| + CREATE TABLE unelaborated_dependency ( + hash text, + hashJwt text + ) + |] + executeMany + [here| + INSERT INTO unelaborated_dependency + (hash, hashJwt) + VALUES (?,?) + |] + hashes + result <- + queryListCol_ + [here| + WITH RECURSIVE elaborated_dependency (hash, hashJwt) AS ( + SELECT (hash, hashJwt) FROM unelaborated_dependency + UNION + SELECT (dependency, dependencyJwt) + FROM temp_entity_missing_dependency + JOIN elaborated_dependency + ON temp_entity_missing_dependency.dependent = elaborated_dependency.hash + ) + SELECT hashJwt FROM elaborated_dependency + WHERE NOT EXISTS ( + SELECT FROM temp_entity + WHERE temp_entity.hash = elaborated_depdenency.hash + ) + |] + execute_ [here|DROP TABLE unelaborated_dependency|] + pure result diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index fb43b82711..494d9a7df4 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -51,7 +51,6 @@ import Unison.Prelude import qualified Unison.Sqlite as Sqlite import qualified Unison.Sync.API as Share (api) import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash) -import Unison.Sync.Types (DecodedHashJWT, HashJWT) import qualified Unison.Sync.Types as Share import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set @@ -470,8 +469,18 @@ entityLocation hash = -- -- In the end, we return a set of hashes that correspond to entities we actually need to download. elaborateHashes :: NESet Share.DecodedHashJWT -> Sqlite.Transaction (Maybe (NESet Share.HashJWT)) -elaborateHashes = - let loop :: Set DecodedHashJWT -> Set HashJWT -> Set HashJWT -> Sqlite.Transaction (Maybe (NESet HashJWT)) +elaborateHashes hashes = do + let input :: [(Hash32, Share.HashJWT)] + input = + toList hashes + <&> \(Share.DecodedHashJWT (Share.HashJWTClaims {hash}) jwt) -> + (hash, jwt) + result <- Q.elaborateHashesClient (coerce @[(Hash32, Share.HashJWT)] @[(Hash32, Text)] input) + pure $ (NESet.nonEmptySet . Set.fromList) (coerce @[Text] @[Share.HashJWT] result) + +_elaborateHashes1 :: NESet Share.DecodedHashJWT -> Sqlite.Transaction (Maybe (NESet Share.HashJWT)) +_elaborateHashes1 = + let loop :: Set Share.DecodedHashJWT -> Set Share.HashJWT -> Set Share.HashJWT -> Sqlite.Transaction (Maybe (NESet Share.HashJWT)) loop hashes seen outputs = do case Set.minView hashes of Nothing -> pure (NESet.nonEmptySet outputs) From eca50efd4d8a84360c5395d2c80bf732a8463ed0 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 6 Jun 2022 17:40:55 -0600 Subject: [PATCH 308/529] Implement token refresh (#3095) --- .../src/Unison/Auth/CredentialManager.hs | 16 ++--- unison-cli/src/Unison/Auth/Discovery.hs | 17 ++--- unison-cli/src/Unison/Auth/OAuth.hs | 15 +++-- unison-cli/src/Unison/Auth/Tokens.hs | 52 ++++++++++++--- unison-cli/src/Unison/Auth/Types.hs | 65 ++++++++++++++----- 5 files changed, 117 insertions(+), 48 deletions(-) diff --git a/unison-cli/src/Unison/Auth/CredentialManager.hs b/unison-cli/src/Unison/Auth/CredentialManager.hs index 07ac0847fb..98780efef8 100644 --- a/unison-cli/src/Unison/Auth/CredentialManager.hs +++ b/unison-cli/src/Unison/Auth/CredentialManager.hs @@ -1,10 +1,10 @@ {-# LANGUAGE DeriveAnyClass #-} module Unison.Auth.CredentialManager - ( saveTokens, + ( saveCredentials, CredentialManager, newCredentialManager, - getTokens, + getCredentials, ) where @@ -22,9 +22,9 @@ import qualified UnliftIO newtype CredentialManager = CredentialManager (UnliftIO.MVar Credentials) -- | Saves credentials to the active profile. -saveTokens :: UnliftIO.MonadUnliftIO m => CredentialManager -> CodeserverId -> Tokens -> m () -saveTokens credManager aud tokens = do - void . modifyCredentials credManager $ setActiveTokens aud tokens +saveCredentials :: UnliftIO.MonadUnliftIO m => CredentialManager -> CodeserverId -> CodeserverCredentials -> m () +saveCredentials credManager aud creds = do + void . modifyCredentials credManager $ setCodeserverCredentials aud creds -- | Atomically update the credential storage file, and update the in-memory cache. modifyCredentials :: UnliftIO.MonadUnliftIO m => CredentialManager -> (Credentials -> Credentials) -> m Credentials @@ -33,10 +33,10 @@ modifyCredentials (CredentialManager credsVar) f = do newCreds <- atomicallyModifyCredentialsFile f pure (newCreds, newCreds) -getTokens :: MonadIO m => CredentialManager -> CodeserverId -> m (Either CredentialFailure Tokens) -getTokens (CredentialManager credsVar) aud = do +getCredentials :: MonadIO m => CredentialManager -> CodeserverId -> m (Either CredentialFailure CodeserverCredentials) +getCredentials (CredentialManager credsVar) aud = do creds <- UnliftIO.readMVar credsVar - pure $ getActiveTokens aud creds + pure $ getCodeserverCredentials aud creds newCredentialManager :: MonadIO m => m CredentialManager newCredentialManager = do diff --git a/unison-cli/src/Unison/Auth/Discovery.hs b/unison-cli/src/Unison/Auth/Discovery.hs index f95a7d828b..4c2c07d4ba 100644 --- a/unison-cli/src/Unison/Auth/Discovery.hs +++ b/unison-cli/src/Unison/Auth/Discovery.hs @@ -3,22 +3,23 @@ module Unison.Auth.Discovery where import qualified Data.Aeson as Aeson import qualified Data.Text as Text import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.TLS as HTTP import Network.URI import Unison.Auth.Types import Unison.Prelude import Unison.Share.Types (CodeserverURI (..), codeserverToURI) import qualified UnliftIO -discoveryURI :: CodeserverURI -> URI -discoveryURI cs = +discoveryURIForCodeserver :: CodeserverURI -> URI +discoveryURIForCodeserver cs = let uri = codeserverToURI cs in uri {uriPath = uriPath uri <> "/.well-known/openid-configuration"} -discoveryForCodeserver :: MonadIO m => HTTP.Manager -> CodeserverURI -> m (Either CredentialFailure DiscoveryDoc) -discoveryForCodeserver httpClient host = liftIO . UnliftIO.try @_ @CredentialFailure $ do - let uri = discoveryURI host - req <- HTTP.requestFromURI uri - resp <- HTTP.httpLbs req httpClient +fetchDiscoveryDoc :: MonadIO m => URI -> m (Either CredentialFailure DiscoveryDoc) +fetchDiscoveryDoc discoveryURI = liftIO . UnliftIO.try @_ @CredentialFailure $ do + unauthenticatedHttpClient <- HTTP.getGlobalManager + req <- HTTP.requestFromURI discoveryURI + resp <- HTTP.httpLbs req unauthenticatedHttpClient case Aeson.eitherDecode (HTTP.responseBody $ resp) of - Left err -> UnliftIO.throwIO $ InvalidDiscoveryDocument uri (Text.pack err) + Left err -> UnliftIO.throwIO $ InvalidDiscoveryDocument discoveryURI (Text.pack err) Right doc -> pure doc diff --git a/unison-cli/src/Unison/Auth/OAuth.hs b/unison-cli/src/Unison/Auth/OAuth.hs index 0a0d8c46cf..b31c40c76f 100644 --- a/unison-cli/src/Unison/Auth/OAuth.hs +++ b/unison-cli/src/Unison/Auth/OAuth.hs @@ -1,6 +1,9 @@ {-# LANGUAGE RecordWildCards #-} -module Unison.Auth.OAuth (authenticateCodeserver) where +module Unison.Auth.OAuth + ( authenticateCodeserver, + ) +where import qualified Crypto.Hash as Crypto import Crypto.Random (getRandomBytes) @@ -17,8 +20,8 @@ import Network.URI import Network.Wai import qualified Network.Wai as Wai import qualified Network.Wai.Handler.Warp as Warp -import Unison.Auth.CredentialManager (CredentialManager, saveTokens) -import Unison.Auth.Discovery (discoveryForCodeserver) +import Unison.Auth.CredentialManager (CredentialManager, saveCredentials) +import Unison.Auth.Discovery (discoveryURIForCodeserver, fetchDiscoveryDoc) import Unison.Auth.Types import Unison.Codebase.Editor.HandleInput.LoopState (MonadCommand, respond) import qualified Unison.Codebase.Editor.Output as Output @@ -50,7 +53,8 @@ authTransferServer callback req respond = authenticateCodeserver :: forall m n i v. (UnliftIO.MonadUnliftIO m, MonadCommand m n i v) => CredentialManager -> CodeserverURI -> m (Either CredentialFailure ()) authenticateCodeserver credsManager codeserverURI = UnliftIO.try @_ @CredentialFailure $ do httpClient <- liftIO HTTP.getGlobalManager - doc@(DiscoveryDoc {authorizationEndpoint, tokenEndpoint}) <- throwCredFailure $ discoveryForCodeserver httpClient codeserverURI + let discoveryURI = discoveryURIForCodeserver codeserverURI + doc@(DiscoveryDoc {authorizationEndpoint, tokenEndpoint}) <- throwCredFailure $ fetchDiscoveryDoc discoveryURI debugM Auth "Discovery Doc" doc authResultVar <- UnliftIO.newEmptyMVar @_ @(Either CredentialFailure Tokens) -- The redirect_uri depends on the port, so we need to spin up the server first, but @@ -78,7 +82,8 @@ authenticateCodeserver credsManager codeserverURI = UnliftIO.try @_ @CredentialF respond . Output.InitiateAuthFlow $ authorizationKickoff tokens <- throwCredFailure $ UnliftIO.readMVar authResultVar let codeserverId = codeserverIdFromCodeserverURI codeserverURI - saveTokens credsManager codeserverId tokens + let creds = codeserverCredentials discoveryURI tokens + saveCredentials credsManager codeserverId creds where throwCredFailure :: m (Either CredentialFailure a) -> m a throwCredFailure = throwEitherM diff --git a/unison-cli/src/Unison/Auth/Tokens.hs b/unison-cli/src/Unison/Auth/Tokens.hs index 05d375197e..40b5d36e52 100644 --- a/unison-cli/src/Unison/Auth/Tokens.hs +++ b/unison-cli/src/Unison/Auth/Tokens.hs @@ -1,8 +1,16 @@ module Unison.Auth.Tokens where +import Control.Monad.Except +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Char8 as BSC import qualified Data.Text as Text import Data.Time.Clock.POSIX (getPOSIXTime) +import qualified Network.HTTP.Client as HTTP +import qualified Network.HTTP.Client.TLS as HTTP +import qualified Network.HTTP.Types as Network +import Network.URI (URI) import Unison.Auth.CredentialManager +import Unison.Auth.Discovery (fetchDiscoveryDoc) import Unison.Auth.Types import Unison.CommandLine.InputPattern (patternName) import qualified Unison.CommandLine.InputPatterns as IP @@ -29,17 +37,43 @@ type TokenProvider = CodeserverId -> IO (Either CredentialFailure AccessToken) -- | Creates a 'TokenProvider' using the given 'CredentialManager' newTokenProvider :: CredentialManager -> TokenProvider newTokenProvider manager host = UnliftIO.try @_ @CredentialFailure $ do - tokens@(Tokens {accessToken}) <- throwEitherM $ getTokens manager host - expired <- isExpired accessToken + CodeserverCredentials {tokens, discoveryURI} <- throwEitherM $ getCredentials manager host + let Tokens {accessToken = currentAccessToken} = tokens + expired <- isExpired currentAccessToken if expired then do - newTokens@(Tokens {accessToken = newAccessToken}) <- throwEitherM $ refreshTokens manager host tokens - saveTokens manager host newTokens + newTokens@(Tokens {accessToken = newAccessToken}) <- throwEitherM $ performTokenRefresh discoveryURI tokens + saveCredentials manager host (codeserverCredentials discoveryURI newTokens) pure $ newAccessToken - else pure accessToken + else pure currentAccessToken -- | Don't yet support automatically refreshing tokens. -refreshTokens :: MonadIO m => CredentialManager -> CodeserverId -> Tokens -> m (Either CredentialFailure Tokens) -refreshTokens _manager _host _tokens = - -- Refreshing tokens is currently unsupported. - pure (Left (RefreshFailure . Text.pack $ "Unable to refresh authentication, please run " <> patternName IP.authLogin <> " and try again.")) +-- +-- Specification: https://datatracker.ietf.org/doc/html/rfc6749#section-6 +performTokenRefresh :: MonadIO m => URI -> Tokens -> m (Either CredentialFailure Tokens) +performTokenRefresh discoveryURI (Tokens {refreshToken = currentRefreshToken}) = runExceptT $ + case currentRefreshToken of + Nothing -> + throwError $ (RefreshFailure . Text.pack $ "Unable to refresh authentication, please run " <> patternName IP.authLogin <> " and try again.") + Just rt -> do + DiscoveryDoc {tokenEndpoint} <- ExceptT $ fetchDiscoveryDoc discoveryURI + req <- liftIO $ HTTP.requestFromURI tokenEndpoint + let addFormData = + HTTP.urlEncodedBody + [ ("grant_type", "refresh_token"), + ("refresh_token", BSC.pack . Text.unpack $ rt) + ] + let fullReq = addFormData $ req {HTTP.method = "POST", HTTP.requestHeaders = [("Accept", "application/json")]} + unauthenticatedHttpClient <- liftIO $ HTTP.getGlobalManager + resp <- liftIO $ HTTP.httpLbs fullReq unauthenticatedHttpClient + newTokens <- case HTTP.responseStatus resp of + status + | status < Network.status300 -> do + let respBytes = HTTP.responseBody resp + case Aeson.eitherDecode @Tokens respBytes of + Left err -> throwError (InvalidTokenResponse tokenEndpoint (Text.pack err)) + Right a -> pure a + | otherwise -> throwError $ (InvalidTokenResponse tokenEndpoint $ "Received " <> tShow status <> " response from token endpoint") + -- According to the spec, servers may or may not update the refresh token itself. + -- If updated we need to replace it, if not updated we keep the existing one. + pure $ newTokens {refreshToken = refreshToken newTokens <|> currentRefreshToken} diff --git a/unison-cli/src/Unison/Auth/Types.hs b/unison-cli/src/Unison/Auth/Types.hs index 67b6eb66fd..0b07dbbe49 100644 --- a/unison-cli/src/Unison/Auth/Types.hs +++ b/unison-cli/src/Unison/Auth/Types.hs @@ -14,8 +14,10 @@ module Unison.Auth.Types PKCEChallenge, ProfileName, CredentialFailure (..), - getActiveTokens, - setActiveTokens, + CodeserverCredentials (..), + getCodeserverCredentials, + setCodeserverCredentials, + codeserverCredentials, emptyCredentials, ) where @@ -128,26 +130,11 @@ instance Aeson.FromJSON DiscoveryDoc where type ProfileName = Text data Credentials = Credentials - { credentials :: Map ProfileName (Map CodeserverId Tokens), + { credentials :: Map ProfileName (Map CodeserverId CodeserverCredentials), activeProfile :: ProfileName } deriving (Eq) -emptyCredentials :: Credentials -emptyCredentials = Credentials mempty defaultProfileName - -getActiveTokens :: CodeserverId -> Credentials -> Either CredentialFailure Tokens -getActiveTokens host (Credentials {credentials, activeProfile}) = - maybeToEither (ReauthRequired host) $ - credentials ^? ix activeProfile . ix host - -setActiveTokens :: CodeserverId -> Tokens -> Credentials -> Credentials -setActiveTokens host tokens creds@(Credentials {credentials, activeProfile}) = - let newCredMap = - credentials - & at activeProfile . non Map.empty . at host .~ Just tokens - in creds {credentials = newCredMap} - instance Aeson.ToJSON Credentials where toJSON (Credentials credMap activeProfile) = Aeson.object @@ -160,3 +147,45 @@ instance Aeson.FromJSON Credentials where credentials <- obj .: "credentials" activeProfile <- obj .: "active_profile" pure Credentials {..} + +-- | Credentials for a specific codeserver +data CodeserverCredentials = CodeserverCredentials + { -- The most recent set of authentication tokens + tokens :: Tokens, + -- URI where the discovery document for this codeserver can be fetched. + discoveryURI :: URI + } + deriving (Eq) + +instance ToJSON CodeserverCredentials where + toJSON (CodeserverCredentials tokens discoveryURI) = + Aeson.object ["tokens" .= tokens, "discovery_uri" .= show discoveryURI] + +instance FromJSON CodeserverCredentials where + parseJSON = + Aeson.withObject "CodeserverCredentials" $ \v -> + do + tokens <- v .: "tokens" + discoveryURIString <- v .: "discovery_uri" + discoveryURI <- case parseURI discoveryURIString of + Nothing -> fail "discovery_uri is not a valid URI" + Just uri -> pure uri + pure $ CodeserverCredentials {..} + +emptyCredentials :: Credentials +emptyCredentials = Credentials mempty defaultProfileName + +codeserverCredentials :: URI -> Tokens -> CodeserverCredentials +codeserverCredentials discoveryURI tokens = CodeserverCredentials {discoveryURI, tokens} + +getCodeserverCredentials :: CodeserverId -> Credentials -> Either CredentialFailure CodeserverCredentials +getCodeserverCredentials host (Credentials {credentials, activeProfile}) = + maybeToEither (ReauthRequired host) $ + credentials ^? ix activeProfile . ix host + +setCodeserverCredentials :: CodeserverId -> CodeserverCredentials -> Credentials -> Credentials +setCodeserverCredentials host codeserverCreds creds@(Credentials {credentials, activeProfile}) = + let newCredMap = + credentials + & at activeProfile . non Map.empty . at host .~ Just codeserverCreds + in creds {credentials = newCredMap} From 8e5e2ca5de507889a8e441db1d23fcf6c31a9985 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Mon, 6 Jun 2022 15:12:13 -0400 Subject: [PATCH 309/529] megaparsec bounds --- parser-typechecker/package.yaml | 2 +- parser-typechecker/unison-parser-typechecker.cabal | 2 +- unison-cli/unison-cli.cabal | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 389581d619..487b52baf8 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -55,7 +55,7 @@ library: - http-client - lens - ListLike - - megaparsec >= 5.0.0 && < 7.0.0 + - megaparsec - memory - mmorph - monad-validate diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index e908589c56..00df9f9382 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -236,7 +236,7 @@ library , http-types , lens , lucid - , megaparsec >=5.0.0 && <7.0.0 + , megaparsec , memory , mmorph , monad-validate diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 9dd47d58ce..b8bf6de398 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack From 46e1587e3fc82c6dcc35b37608ad0696491e650f Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 7 Jun 2022 10:30:36 -0400 Subject: [PATCH 310/529] entity location queries --- .../U/Codebase/Sqlite/Queries.hs | 20 +++++++++++++++++++ 1 file changed, 20 insertions(+) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index e10d4625ca..70ccd08442 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -133,7 +133,9 @@ module U.Codebase.Sqlite.Queries garbageCollectWatchesWithoutObjects, -- * sync temp entities + EntityLocation, entityExists, + entityLocation, expectEntity, getMissingDependentsForTempEntity, getMissingDependencyJwtsForTempEntity, @@ -1445,6 +1447,24 @@ ancestorSql = -- * share sync / temp entities +-- | Where is an entity stored? +data EntityLocation + = -- | `object` / `causal` + EntityInMainStorage + | -- | `temp_entity` + EntityInTempStorage + +-- | Where is an entity stored? +entityLocation :: Hash32 -> Transaction (Maybe EntityLocation) +entityLocation hash = + entityExists hash >>= \case + True -> pure (Just EntityInMainStorage) + False -> do + let sql = [here|SELECT EXISTS (SELECT FROM temp_entity WHERE hash = ?)|] + queryOneCol sql (Only hash) <&> \case + True -> Just EntityInTempStorage + False -> Nothing + -- | Does this entity already exist in the database, i.e. in the `object` or `causal` table? entityExists :: Hash32 -> Transaction Bool entityExists hash = do From 5ad158701818523b4a6bc6dfd9d5cfc83e3bea5a Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 7 Jun 2022 14:52:47 -0400 Subject: [PATCH 311/529] delete duplicated EntityLocation/entityLocation and deal with the descrepancy --- .../U/Codebase/Sqlite/Queries.hs | 12 +-- unison-cli/src/Unison/Share/Sync.hs | 90 ++++++++----------- 2 files changed, 41 insertions(+), 61 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 70ccd08442..4aec2a3b56 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -133,7 +133,7 @@ module U.Codebase.Sqlite.Queries garbageCollectWatchesWithoutObjects, -- * sync temp entities - EntityLocation, + EntityLocation(..), entityExists, entityLocation, expectEntity, @@ -1447,7 +1447,7 @@ ancestorSql = -- * share sync / temp entities --- | Where is an entity stored? +-- | Where an entity is stored. data EntityLocation = -- | `object` / `causal` EntityInMainStorage @@ -1579,10 +1579,10 @@ elaborateHashesClient hashes = do WITH RECURSIVE elaborated_dependency (hash, hashJwt) AS ( SELECT (hash, hashJwt) FROM unelaborated_dependency UNION - SELECT (dependency, dependencyJwt) - FROM temp_entity_missing_dependency - JOIN elaborated_dependency - ON temp_entity_missing_dependency.dependent = elaborated_dependency.hash + SELECT (temd.dependency, temd.dependencyJwt) + FROM temp_entity_missing_dependency temd + JOIN elaborated_dependency ed + ON temd.dependent = ed.hash ) SELECT hashJwt FROM elaborated_dependency WHERE NOT EXISTS ( diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index c09c0fcacf..d9e4866ef2 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -27,12 +27,13 @@ where import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader -import qualified Data.Foldable as Foldable (find) +import qualified Data.Foldable as Foldable (find, toList) import Data.List.NonEmpty (pattern (:|)) import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as List.NonEmpty import Data.Map.NonEmpty (NEMap) import qualified Data.Map.NonEmpty as NEMap +import qualified Data.Map.Strict as Map import Data.Sequence.NonEmpty (NESeq ((:<||))) import qualified Data.Sequence.NonEmpty as NESeq (fromList, nonEmptySeq, (><|)) import qualified Data.Set as Set @@ -336,15 +337,15 @@ pull httpClient unisonShareUrl conn repoPath downloadCountCallback = do Right Nothing -> pure (Left (PullErrorNoHistoryAtPath repoPath)) Right (Just hashJwt) -> do let hash = Share.hashJWTHash hashJwt - Sqlite.runTransaction conn (entityLocation hash) >>= \case - Just EntityInMainStorage -> pure () - Just (EntityInTempStorage missingDependencies) -> doDownload missingDependencies - Nothing -> doDownload (NESet.singleton hashJwt) + Sqlite.runTransaction conn (Q.entityLocation hash) >>= \case + Just Q.EntityInMainStorage -> pure () + Just Q.EntityInTempStorage -> doDownload hashJwt + Nothing -> doDownload hashJwt pure (Right (hash32ToCausalHash hash)) where - doDownload :: NESet Share.HashJWT -> IO () - doDownload hashes = - downloadEntities httpClient unisonShareUrl conn (Share.pathRepoName repoPath) hashes downloadCountCallback + doDownload :: Share.HashJWT -> IO () + doDownload hashJwt = + downloadEntities httpClient unisonShareUrl conn (Share.pathRepoName repoPath) hashJwt downloadCountCallback ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path @@ -376,11 +377,11 @@ downloadEntities :: BaseUrl -> Sqlite.Connection -> Share.RepoName -> - NESet Share.HashJWT -> + Share.HashJWT -> (Int -> IO ()) -> IO () -downloadEntities httpClient unisonShareUrl conn repoName hashes_ downloadCountCallback = - loop 0 (NESet.map Share.decodeHashJWT hashes_) +downloadEntities httpClient unisonShareUrl conn repoName hash0 downloadCountCallback = + loop 0 (NESet.singleton (Share.decodeHashJWT hash0)) where loop :: Int -> NESet Share.DecodedHashJWT -> IO () loop downloadCount hashes0 = @@ -389,14 +390,29 @@ downloadEntities httpClient unisonShareUrl conn repoName hashes_ downloadCountCa let newDownloadCount = downloadCount + NEMap.size entities downloadCountCallback newDownloadCount - missingDependencies0 <- + -- For each HashJWT we just used to download an entity, set up a little mapping from the underlying hash back to + -- the JWT itself. This is necessary because when we upsert an entity, and it went into temp storage, we need to + -- know the JWT we used to download it (in order to elaborate it). + let hashToHashJwt :: Hash32 -> Share.HashJWT + hashToHashJwt = + \hash -> + case Map.lookup hash m of + Nothing -> error ("bad map; missing expected " ++ show hash ++ " key") + Just hashJwt -> hashJwt + where + m :: Map Hash32 Share.HashJWT + m = + Map.fromList (map (\hashJwt -> (Share.hashJWTHash hashJwt, hashJwt)) (Foldable.toList hashes1)) + + hashesThatHaveMissingDependencies0 <- Sqlite.runTransaction conn do NEMap.toList entities & foldMapM \(hash, entity) -> upsertEntitySomewhere hash entity <&> \case - EntityInMainStorage -> Set.empty - EntityInTempStorage missingDependencies -> Set.map Share.decodeHashJWT (NESet.toSet missingDependencies) + Q.EntityInMainStorage -> Set.empty + Q.EntityInTempStorage -> Set.singleton (hashToHashJwt hash) - whenJust (NESet.nonEmptySet missingDependencies0) (loop newDownloadCount) + whenJust (NESet.nonEmptySet hashesThatHaveMissingDependencies0) \hashesThatHaveMissingDependencies -> + loop newDownloadCount (NESet.map Share.decodeHashJWT hashesThatHaveMissingDependencies) doDownload :: NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) doDownload hashes = do @@ -458,23 +474,6 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadCountCallba ------------------------------------------------------------------------------------------------------------------------ -- Database operations --- | Where is an entity stored? -data EntityLocation - = -- | `object` / `causal` - EntityInMainStorage - | -- | `temp_entity`, evidenced by these missing dependencies. - EntityInTempStorage (NESet Share.HashJWT) - --- | Where is an entity stored? -entityLocation :: Hash32 -> Sqlite.Transaction (Maybe EntityLocation) -entityLocation hash = - Q.entityExists hash >>= \case - True -> pure (Just EntityInMainStorage) - False -> - Q.getMissingDependencyJwtsForTempEntity hash <&> \case - Nothing -> Nothing - Just missingDependencies -> Just (EntityInTempStorage (NESet.map Share.HashJWT missingDependencies)) - -- | "Elaborate" a set of hashes that we are considering downloading from Unison Share. -- -- For each hash, we determine whether we already have that entity in main storage, temp storage, or nowhere: @@ -495,25 +494,6 @@ elaborateHashes hashes = do result <- Q.elaborateHashesClient (coerce @[(Hash32, Share.HashJWT)] @[(Hash32, Text)] input) pure $ (NESet.nonEmptySet . Set.fromList) (coerce @[Text] @[Share.HashJWT] result) -_elaborateHashes1 :: NESet Share.DecodedHashJWT -> Sqlite.Transaction (Maybe (NESet Share.HashJWT)) -_elaborateHashes1 = - let loop :: Set Share.DecodedHashJWT -> Set Share.HashJWT -> Set Share.HashJWT -> Sqlite.Transaction (Maybe (NESet Share.HashJWT)) - loop hashes seen outputs = do - case Set.minView hashes of - Nothing -> pure (NESet.nonEmptySet outputs) - Just (Share.DecodedHashJWT (Share.HashJWTClaims {hash}) jwt, hashes') -> - let seen' = Set.insert jwt seen - in if Set.member jwt outputs || Set.member jwt seen - then -- skip โ€” if it's in outputs, it's already fully elaborated - loop hashes' seen' outputs - else - entityLocation hash >>= \case - Nothing -> loop hashes' seen' (Set.insert jwt outputs) - Just (EntityInTempStorage missingDependencies) -> do - loop (Set.union (Set.map Share.decodeHashJWT (NESet.toSet missingDependencies)) hashes') seen' outputs - Just EntityInMainStorage -> loop hashes' seen' outputs - in \hashes -> loop (NESet.toSet hashes) Set.empty Set.empty - -- | Upsert a downloaded entity "somewhere" - -- -- 1. Nowhere if we already had the entity (in main or temp storage). @@ -522,9 +502,9 @@ _elaborateHashes1 = upsertEntitySomewhere :: Hash32 -> Share.Entity Text Hash32 Share.HashJWT -> - Sqlite.Transaction EntityLocation + Sqlite.Transaction Q.EntityLocation upsertEntitySomewhere hash entity = - entityLocation hash >>= \case + Q.entityLocation hash >>= \case Just location -> pure location Nothing -> do missingDependencies0 <- @@ -534,10 +514,10 @@ upsertEntitySomewhere hash entity = case NESet.nonEmptySet missingDependencies0 of Nothing -> do insertEntity hash entity - pure EntityInMainStorage + pure Q.EntityInMainStorage Just missingDependencies -> do insertTempEntity hash entity missingDependencies - pure (EntityInTempStorage missingDependencies) + pure Q.EntityInTempStorage -- | Insert an entity that doesn't have any missing dependencies. insertEntity :: Hash32 -> Share.Entity Text Hash32 Share.HashJWT -> Sqlite.Transaction () From f75c4b56d55252caa111d469b154a79b918c720f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 7 Jun 2022 14:36:22 -0600 Subject: [PATCH 312/529] you are no longer bad --- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 077af6ffa6..aca0c04424 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1872,7 +1872,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l -- doesn't handle the case where a non-existent path is supplied Sqlite.runTransaction connection (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath))) >>= \case - Nothing -> respond (error "you are bad") + Nothing -> respond (BranchNotFound . Path.absoluteToPath' $ localPath) Just localCausalHash -> case behavior of PushBehavior.RequireEmpty -> do From 1b5ad28c5d10c4631380df859a516ebc73da0671 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 7 Jun 2022 16:56:43 -0400 Subject: [PATCH 313/529] fix some bad sql syntax --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 4aec2a3b56..f5028dbd5d 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -133,7 +133,7 @@ module U.Codebase.Sqlite.Queries garbageCollectWatchesWithoutObjects, -- * sync temp entities - EntityLocation(..), + EntityLocation (..), entityExists, entityLocation, expectEntity, @@ -1460,7 +1460,7 @@ entityLocation hash = entityExists hash >>= \case True -> pure (Just EntityInMainStorage) False -> do - let sql = [here|SELECT EXISTS (SELECT FROM temp_entity WHERE hash = ?)|] + let sql = [here|SELECT EXISTS (SELECT 1 FROM temp_entity WHERE hash = ?)|] queryOneCol sql (Only hash) <&> \case True -> Just EntityInTempStorage False -> Nothing @@ -1577,16 +1577,16 @@ elaborateHashesClient hashes = do queryListCol_ [here| WITH RECURSIVE elaborated_dependency (hash, hashJwt) AS ( - SELECT (hash, hashJwt) FROM unelaborated_dependency + SELECT hash, hashJwt FROM unelaborated_dependency UNION - SELECT (temd.dependency, temd.dependencyJwt) + SELECT temd.dependency, temd.dependencyJwt FROM temp_entity_missing_dependency temd JOIN elaborated_dependency ed ON temd.dependent = ed.hash ) SELECT hashJwt FROM elaborated_dependency WHERE NOT EXISTS ( - SELECT FROM temp_entity + SELECT 1 FROM temp_entity WHERE temp_entity.hash = elaborated_depdenency.hash ) |] From 1d1a963ed18e80ca476ecacd4a62516457534eb8 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 7 Jun 2022 17:31:26 -0400 Subject: [PATCH 314/529] draft - support alternate pull implementation --- .../U/Codebase/Sqlite/Queries.hs | 39 +++++++++ unison-cli/src/Unison/Share/Sync.hs | 84 +++++++++++++++++++ 2 files changed, 123 insertions(+) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index f5028dbd5d..7e26f8acb4 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -146,6 +146,7 @@ module U.Codebase.Sqlite.Queries -- * elaborate hashes elaborateHashesClient, + elaborateHashesClient', elaborateHashesServer, -- * db misc @@ -1592,3 +1593,41 @@ elaborateHashesClient hashes = do |] execute_ [here|DROP TABLE unelaborated_dependency|] pure result + +-- | looks up hashJwts for known transitive dependencies of temp_entities +elaborateHashesClient' :: [Hash32] -> Transaction [Text] +elaborateHashesClient' hashes = do + execute_ + [here| + CREATE TABLE new_temp_entity_dependents (hash text) + |] + executeMany + [here| + INSERT INTO new_temp_entity_dependents + (hash) + VALUES (?) + |] + (map Only hashes) + result <- + queryListCol_ + [here| + WITH RECURSIVE elaborated_dependency (hash, hashJwt) AS ( + SELECT dependency, dependencyJwt + FROM new_temp_entity_dependents AS new + JOIN temp_entity_missing_dependency + ON new_temp_entity_dependents.dependent = new.hash + + UNION + SELECT temd.dependency, temd.dependencyJwt + FROM temp_entity_missing_dependency temd + JOIN elaborated_dependency ed + ON temd.dependent = ed.hash + ) + SELECT hashJwt FROM elaborated_dependency + WHERE NOT EXISTS ( + SELECT FROM temp_entity + WHERE temp_entity.hash = elaborated_depdenency.hash + ) + |] + execute_ [here|DROP TABLE new_temp_entity_dependents|] + pure result diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index d9e4866ef2..499d05aa52 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -21,6 +21,7 @@ module Unison.Share.Sync uploadEntities, -- ** Download entities + downloadAndUpsertSomewhere, downloadEntities, ) where @@ -347,6 +348,39 @@ pull httpClient unisonShareUrl conn repoPath downloadCountCallback = do doDownload hashJwt = downloadEntities httpClient unisonShareUrl conn (Share.pathRepoName repoPath) hashJwt downloadCountCallback +pull' :: + -- | The HTTP client to use for Unison Share requests. + AuthenticatedHttpClient -> + -- | The Unison Share URL. + BaseUrl -> + -- | SQLite connection, for writing entities we pull. + Sqlite.Connection -> + -- | The repo+path to pull from. + Share.Path -> + -- | Callback that is given the total number of entities downloaded. + (Int -> IO ()) -> + IO (Either PullError CausalHash) +pull' httpClient unisonShareUrl conn repoPath@(Share.pathRepoName -> repoName) downloadCountCallback = do + getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case + Left err -> pure (Left (PullErrorGetCausalHashByPath err)) + -- There's nothing at the remote path, so there's no causal to pull. + Right Nothing -> pure (Left (PullErrorNoHistoryAtPath repoPath)) + Right (Just hashJwt) -> do + newTempEntities <- downloadAndUpsertSomewhere doDownload conn (NESet.singleton hashJwt) + whenJust (NESet.nonEmptySet newTempEntities) \newTempEntities -> + downloadMissingDependenciesOf httpClient unisonShareUrl conn (Share.pathRepoName repoPath) newTempEntities 1 downloadCountCallback + (pure . Right . hash32ToCausalHash . Share.hashJWTHash) hashJwt + where + doDownload :: NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) + doDownload hashes = do + -- we feel okay ignoring the "no read permission" case because it should have been triggered by getCausalHashByPath + Share.DownloadEntitiesSuccess entities <- + httpDownloadEntities + httpClient + unisonShareUrl + Share.DownloadEntitiesRequest {repoName, hashes} + pure entities + ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path @@ -423,6 +457,50 @@ downloadEntities httpClient unisonShareUrl conn repoName hash0 downloadCountCall Share.DownloadEntitiesRequest {repoName, hashes} pure entities +-- | download some entities and file them into the appropriate tables. +-- returns the list of incomplete/temp entities +downloadAndUpsertSomewhere :: (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -> Sqlite.Connection -> NESet Share.HashJWT -> IO (Set Hash32) +downloadAndUpsertSomewhere doDownload conn hashes = do + entities <- doDownload hashes + NEMap.toList entities & foldMapM \(hash, entity) -> + Sqlite.runTransaction conn (upsertEntitySomewhere hash entity) <&> \case + Q.EntityInMainStorage -> Set.empty + Q.EntityInTempStorage -> Set.singleton hash + +downloadMissingDependenciesOf :: + AuthenticatedHttpClient -> + BaseUrl -> + Sqlite.Connection -> + Share.RepoName -> + NESet Hash32 -> + Int -> + (Int -> IO ()) -> + IO () +downloadMissingDependenciesOf httpClient unisonShareUrl conn repoName hashes0 initialCount downloadCountCallback = do + elaborateAndLoop initialCount hashes0 + where + loop :: Int -> NESet Share.HashJWT -> IO () + loop downloadCount hashes = do + let newDownloadCount = downloadCount + NESet.size hashes + downloadCountCallback newDownloadCount + whenJustM (downloadAndUpsertSomewhere doDownload conn hashes <&> NESet.nonEmptySet) \newTempEntityHashes -> + elaborateAndLoop newDownloadCount newTempEntityHashes + + elaborateAndLoop :: Int -> NESet Hash32 -> IO () + elaborateAndLoop downloadCount hashes = + whenJustM (Sqlite.runTransaction conn (elaborateHashes' hashes)) \dependencyJwts -> + loop downloadCount dependencyJwts + + doDownload :: NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) + doDownload hashes = do + -- we feel okay ignoring the "no read permission" case because it should have been triggered by getCausalHashByPath + Share.DownloadEntitiesSuccess entities <- + httpDownloadEntities + httpClient + unisonShareUrl + Share.DownloadEntitiesRequest {repoName, hashes} + pure entities + ------------------------------------------------------------------------------------------------------------------------ -- Upload entities @@ -494,6 +572,12 @@ elaborateHashes hashes = do result <- Q.elaborateHashesClient (coerce @[(Hash32, Share.HashJWT)] @[(Hash32, Text)] input) pure $ (NESet.nonEmptySet . Set.fromList) (coerce @[Text] @[Share.HashJWT] result) +-- | elaborate hashes of temp entities +elaborateHashes' :: NESet Hash32 -> Sqlite.Transaction (Maybe (NESet Share.HashJWT)) +elaborateHashes' hashes = do + result <- Q.elaborateHashesClient' (toList hashes) + pure $ (NESet.nonEmptySet . Set.fromList) (coerce @[Text] @[Share.HashJWT] result) + -- | Upsert a downloaded entity "somewhere" - -- -- 1. Nowhere if we already had the entity (in main or temp storage). From 856c41c318b1eec8e66562b21670f039d8370338 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Wed, 8 Jun 2022 16:01:14 -0400 Subject: [PATCH 315/529] update pull' stuff --- .../src/Unison/Codebase/Editor/HandleInput.hs | 19 ++++++----- unison-cli/src/Unison/Share/Sync.hs | 34 +++++++++---------- 2 files changed, 27 insertions(+), 26 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index aca0c04424..c1ddc8d17f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -8,6 +8,7 @@ where -- TODO: Don't import backend +import Control.Concurrent.STM (atomically, newTVarIO, readTVar, readTVarIO, writeTVar) import qualified Control.Error.Util as ErrorUtil import Control.Lens import Control.Monad.Except (ExceptT (..), runExceptT, throwError, withExceptT) @@ -24,7 +25,6 @@ import qualified Data.Map as Map import Data.Sequence (Seq (..)) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) -import Control.Concurrent.STM (atomically, newTVarIO, readTVar, readTVarIO, writeTVar) import qualified Data.Set.NonEmpty as NESet import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) @@ -1783,13 +1783,14 @@ handlePushRemoteBranch :: SyncMode.SyncMode -> Action' m v () handlePushRemoteBranch mayRepo path pushBehavior syncMode = - time "handlePushRemoteBranch" - case mayRepo of - Nothing -> - runExceptT (resolveConfiguredUrl Push path) >>= \case - Left output -> respond output - Right repo -> push repo - Just repo -> push repo + time + "handlePushRemoteBranch" + case mayRepo of + Nothing -> + runExceptT (resolveConfiguredUrl Push path) >>= \case + Left output -> respond output + Right repo -> push repo + Just repo -> push repo where push repo = doPushRemoteBranch (NormalPush repo pushBehavior) path syncMode @@ -2312,7 +2313,7 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do let pull :: IO (Either Share.PullError CausalHash) pull = withEntitiesDownloadedProgressCallback \entitiesDownloadedProgressCallback -> - Share.pull + Share.pull' authHTTPClient baseURL connection diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 499d05aa52..2e2353562e 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -9,6 +9,7 @@ module Unison.Share.Sync -- ** Pull pull, + pull', PullError (..), -- * Low-level API @@ -366,9 +367,14 @@ pull' httpClient unisonShareUrl conn repoPath@(Share.pathRepoName -> repoName) d -- There's nothing at the remote path, so there's no causal to pull. Right Nothing -> pure (Left (PullErrorNoHistoryAtPath repoPath)) Right (Just hashJwt) -> do - newTempEntities <- downloadAndUpsertSomewhere doDownload conn (NESet.singleton hashJwt) + let hash = Share.hashJWTHash hashJwt + newTempEntities <- + Sqlite.runTransaction conn (Q.entityLocation hash) >>= \case + Just Q.EntityInMainStorage -> pure Set.empty + Just Q.EntityInTempStorage -> pure (Set.singleton hash) + Nothing -> downloadAndUpsertSomewhere doDownload conn (NESet.singleton hashJwt) whenJust (NESet.nonEmptySet newTempEntities) \newTempEntities -> - downloadMissingDependenciesOf httpClient unisonShareUrl conn (Share.pathRepoName repoPath) newTempEntities 1 downloadCountCallback + downloadMissingDependenciesOf doDownload conn newTempEntities 1 downloadCountCallback (pure . Right . hash32ToCausalHash . Share.hashJWTHash) hashJwt where doDownload :: NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) @@ -450,16 +456,22 @@ downloadEntities httpClient unisonShareUrl conn repoName hash0 downloadCountCall doDownload :: NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) doDownload hashes = do + -- we feel okay ignoring the "no read permission" case because it should have been triggered by getCausalHashByPath Share.DownloadEntitiesSuccess entities <- httpDownloadEntities httpClient unisonShareUrl Share.DownloadEntitiesRequest {repoName, hashes} + -- call the callback pure entities -- | download some entities and file them into the appropriate tables. -- returns the list of incomplete/temp entities -downloadAndUpsertSomewhere :: (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -> Sqlite.Connection -> NESet Share.HashJWT -> IO (Set Hash32) +downloadAndUpsertSomewhere :: + (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -> + Sqlite.Connection -> + NESet Share.HashJWT -> + IO (Set Hash32) downloadAndUpsertSomewhere doDownload conn hashes = do entities <- doDownload hashes NEMap.toList entities & foldMapM \(hash, entity) -> @@ -468,15 +480,13 @@ downloadAndUpsertSomewhere doDownload conn hashes = do Q.EntityInTempStorage -> Set.singleton hash downloadMissingDependenciesOf :: - AuthenticatedHttpClient -> - BaseUrl -> + (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -> Sqlite.Connection -> - Share.RepoName -> NESet Hash32 -> Int -> (Int -> IO ()) -> IO () -downloadMissingDependenciesOf httpClient unisonShareUrl conn repoName hashes0 initialCount downloadCountCallback = do +downloadMissingDependenciesOf doDownload conn hashes0 initialCount downloadCountCallback = do elaborateAndLoop initialCount hashes0 where loop :: Int -> NESet Share.HashJWT -> IO () @@ -491,16 +501,6 @@ downloadMissingDependenciesOf httpClient unisonShareUrl conn repoName hashes0 in whenJustM (Sqlite.runTransaction conn (elaborateHashes' hashes)) \dependencyJwts -> loop downloadCount dependencyJwts - doDownload :: NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) - doDownload hashes = do - -- we feel okay ignoring the "no read permission" case because it should have been triggered by getCausalHashByPath - Share.DownloadEntitiesSuccess entities <- - httpDownloadEntities - httpClient - unisonShareUrl - Share.DownloadEntitiesRequest {repoName, hashes} - pure entities - ------------------------------------------------------------------------------------------------------------------------ -- Upload entities From e531d6ba5a0878051c911a91c344e6d011960719 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 8 Jun 2022 18:05:28 -0400 Subject: [PATCH 316/529] work towards replacing old pull with new better pull --- .../U/Codebase/Sqlite/Queries.hs | 32 ++- .../src/Unison/Codebase/Editor/HandleInput.hs | 2 +- unison-cli/src/Unison/Share/Sync.hs | 253 ++++++------------ 3 files changed, 110 insertions(+), 177 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 7e26f8acb4..4546767928 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -1594,8 +1594,28 @@ elaborateHashesClient hashes = do execute_ [here|DROP TABLE unelaborated_dependency|] pure result --- | looks up hashJwts for known transitive dependencies of temp_entities -elaborateHashesClient' :: [Hash32] -> Transaction [Text] +data EmptyTempEntityMissingDependencies + = EmptyTempEntityMissingDependencies + deriving stock (Show) + deriving anyclass (SqliteExceptionReason) + +-- | "Elaborate" a set of `temp_entity` hashes. +-- +-- Given a set of `temp_entity` hashes, returns the (known) set of transitive dependencies that haven't already been +-- downloaded (i.e. aren't in the `temp_entity` table) +-- +-- For example, if we have temp entities A and B, where A depends on B and B depends on C... +-- +-- | temp_entity | | temp_entity_missing_dependency | +-- |=============| |================================| +-- | hash | | dependent | dependency | +-- |-------------| |--------------|-----------------| +-- | A | | A | B | +-- | B | | B | C | +-- +-- ... then `elaborateHashes {A}` would return the singleton set {C} (because we take the set of transitive +-- dependencies {A,B,C} and subtract the set we already have, {A,B}). +elaborateHashesClient' :: Nel.NonEmpty Hash32 -> Transaction (Nel.NonEmpty Text) elaborateHashesClient' hashes = do execute_ [here| @@ -1607,9 +1627,9 @@ elaborateHashesClient' hashes = do (hash) VALUES (?) |] - (map Only hashes) + (map Only (Nel.toList hashes)) result <- - queryListCol_ + queryListColCheck_ [here| WITH RECURSIVE elaborated_dependency (hash, hashJwt) AS ( SELECT dependency, dependencyJwt @@ -1629,5 +1649,9 @@ elaborateHashesClient' hashes = do WHERE temp_entity.hash = elaborated_depdenency.hash ) |] + ( \case + [] -> Left EmptyTempEntityMissingDependencies + x : xs -> Right (x Nel.:| xs) + ) execute_ [here|DROP TABLE new_temp_entity_dependents|] pure result diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index c1ddc8d17f..752102e260 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -2313,7 +2313,7 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do let pull :: IO (Either Share.PullError CausalHash) pull = withEntitiesDownloadedProgressCallback \entitiesDownloadedProgressCallback -> - Share.pull' + Share.pull authHTTPClient baseURL connection diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 507998fdc7..62a271bcbc 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -1,6 +1,13 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + module Unison.Share.Sync ( -- * High-level API + -- ** Get causal hash by path + getCausalHashByPath, + GetCausalHashByPathError (..), + -- ** Push checkAndSetPush, CheckAndSetPushError (..), @@ -9,40 +16,27 @@ module Unison.Share.Sync -- ** Pull pull, - pull', PullError (..), - - -- * Low-level API - - -- ** Get causal hash by path - getCausalHashByPath, - GetCausalHashByPathError (..), - - -- ** Upload entities - uploadEntities, - - -- ** Download entities - downloadAndUpsertSomewhere, - downloadEntities, ) where import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader -import qualified Data.Foldable as Foldable (find, toList) +import qualified Data.Foldable as Foldable (find) +import Data.IORef (atomicModifyIORef', newIORef) import Data.List.NonEmpty (pattern (:|)) import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as List.NonEmpty import Data.Map.NonEmpty (NEMap) import qualified Data.Map.NonEmpty as NEMap -import qualified Data.Map.Strict as Map +import Data.Proxy import Data.Sequence.NonEmpty (NESeq ((:<||))) import qualified Data.Sequence.NonEmpty as NESeq (fromList, nonEmptySeq, (><|)) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import Data.These (These (..)) -import qualified Servant.API as Servant ((:<|>) (..)) +import qualified Servant.API as Servant ((:<|>) (..), (:>)) import Servant.Client (BaseUrl) import qualified Servant.Client as Servant (ClientEnv, ClientM, client, hoistClient, mkClientEnv, runClientM) import U.Codebase.HashTags (CausalHash) @@ -53,7 +47,7 @@ import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import qualified Unison.Auth.HTTPClient as Auth import Unison.Prelude import qualified Unison.Sqlite as Sqlite -import qualified Unison.Sync.API as Share (api) +import qualified Unison.Sync.API as Share (API) import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash) import qualified Unison.Sync.Types as Share import Unison.Util.Monoid (foldMapM) @@ -333,60 +327,78 @@ pull :: -- | Callback that is given the total number of entities downloaded. (Int -> IO ()) -> IO (Either PullError CausalHash) -pull httpClient unisonShareUrl conn repoPath downloadCountCallback = do +pull httpClient unisonShareUrl conn repoPath@(Share.pathRepoName -> repoName) downloadCountCallback = do getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case Left err -> pure (Left (PullErrorGetCausalHashByPath err)) -- There's nothing at the remote path, so there's no causal to pull. Right Nothing -> pure (Left (PullErrorNoHistoryAtPath repoPath)) Right (Just hashJwt) -> do let hash = Share.hashJWTHash hashJwt - Sqlite.runTransaction conn (Q.entityLocation hash) >>= \case - Just Q.EntityInMainStorage -> pure () - Just Q.EntityInTempStorage -> doDownload hashJwt - Nothing -> doDownload hashJwt + doDownload <- makeDoDownload httpClient unisonShareUrl repoName downloadCountCallback + tempEntities <- + Sqlite.runTransaction conn (Q.entityLocation hash) >>= \case + Just Q.EntityInMainStorage -> pure Nothing + Just Q.EntityInTempStorage -> pure (Just (NESet.singleton hash)) + Nothing -> downloadEntities doDownload conn (NESet.singleton hashJwt) + whenJust tempEntities (completeTempEntities doDownload conn) pure (Right (hash32ToCausalHash hash)) - where - doDownload :: Share.HashJWT -> IO () - doDownload hashJwt = - downloadEntities httpClient unisonShareUrl conn (Share.pathRepoName repoPath) hashJwt downloadCountCallback -pull' :: +-- Make a "do download" function - it's in IO in order to close over an IORef that contains the total count of +-- entities we've downloaded. +makeDoDownload :: -- | The HTTP client to use for Unison Share requests. AuthenticatedHttpClient -> -- | The Unison Share URL. BaseUrl -> - -- | SQLite connection, for writing entities we pull. - Sqlite.Connection -> - -- | The repo+path to pull from. - Share.Path -> + -- | The repo to pull from. + Share.RepoName -> -- | Callback that is given the total number of entities downloaded. (Int -> IO ()) -> - IO (Either PullError CausalHash) -pull' httpClient unisonShareUrl conn repoPath@(Share.pathRepoName -> repoName) downloadCountCallback = do - getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case - Left err -> pure (Left (PullErrorGetCausalHashByPath err)) - -- There's nothing at the remote path, so there's no causal to pull. - Right Nothing -> pure (Left (PullErrorNoHistoryAtPath repoPath)) - Right (Just hashJwt) -> do - let hash = Share.hashJWTHash hashJwt - newTempEntities <- - Sqlite.runTransaction conn (Q.entityLocation hash) >>= \case - Just Q.EntityInMainStorage -> pure Set.empty - Just Q.EntityInTempStorage -> pure (Set.singleton hash) - Nothing -> downloadAndUpsertSomewhere doDownload conn (NESet.singleton hashJwt) - whenJust (NESet.nonEmptySet newTempEntities) \newTempEntities -> - downloadMissingDependenciesOf doDownload conn newTempEntities 1 downloadCountCallback - (pure . Right . hash32ToCausalHash . Share.hashJWTHash) hashJwt - where - doDownload :: NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) - doDownload hashes = do - -- we feel okay ignoring the "no read permission" case because it should have been triggered by getCausalHashByPath - Share.DownloadEntitiesSuccess entities <- - httpDownloadEntities - httpClient - unisonShareUrl - Share.DownloadEntitiesRequest {repoName, hashes} - pure entities + IO (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) +makeDoDownload httpClient unisonShareUrl repoName downloadCountCallback = do + downloadCountRef <- newIORef 0 + pure \hashes -> do + -- we feel okay ignoring the "no read permission" case because it should have been triggered by getCausalHashByPath + Share.DownloadEntitiesSuccess entities <- + httpDownloadEntities + httpClient + unisonShareUrl + Share.DownloadEntitiesRequest {repoName, hashes} + newDownloadCount <- + atomicModifyIORef' downloadCountRef \count -> let count' = count + NEMap.size entities in (count', count') + downloadCountCallback newDownloadCount + pure entities + +-- | Download a set of entities from Unison Share. Returns the subset of those entities that we stored in temp storage +-- (`temp_entitiy`) instead of main storage (`object` / `causal`) due to missing dependencies. +downloadEntities :: + (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -> + Sqlite.Connection -> + NESet Share.HashJWT -> + IO (Maybe (NESet Hash32)) +downloadEntities doDownload conn hashes = do + entities <- doDownload hashes + fmap NESet.nonEmptySet do + NEMap.toList entities & foldMapM \(hash, entity) -> + Sqlite.runTransaction conn (upsertEntitySomewhere hash entity) <&> \case + Q.EntityInMainStorage -> Set.empty + Q.EntityInTempStorage -> Set.singleton hash + +-- | Finish downloading entities from Unison Share +-- +-- Precondition: the entities were *already* downloaded at some point in the past, and are now sitting in the +-- `temp_entity` table, waiting for their dependencies to arrive so they can be flushed to main storage. +completeTempEntities :: + (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -> + Sqlite.Connection -> + NESet Hash32 -> + IO () +completeTempEntities doDownload conn = + let loop :: NESet Hash32 -> IO () + loop tempEntityHashes = do + hashJwtsToDownload <- Sqlite.runTransaction conn (elaborateHashes' tempEntityHashes) + whenJustM (downloadEntities doDownload conn hashJwtsToDownload) loop + in loop ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path @@ -409,99 +421,6 @@ getCausalHashByPath httpClient unisonShareUrl repoPath = Share.GetCausalHashByPathSuccess maybeHashJwt -> Right maybeHashJwt Share.GetCausalHashByPathNoReadPermission _ -> Left (GetCausalHashByPathErrorNoReadPermission repoPath) ------------------------------------------------------------------------------------------------------------------------- --- Download entities - --- | Download a set of entities from Unison Share. -downloadEntities :: - AuthenticatedHttpClient -> - BaseUrl -> - Sqlite.Connection -> - Share.RepoName -> - Share.HashJWT -> - (Int -> IO ()) -> - IO () -downloadEntities httpClient unisonShareUrl conn repoName hash0 downloadCountCallback = - loop 0 (NESet.singleton (Share.decodeHashJWT hash0)) - where - loop :: Int -> NESet Share.DecodedHashJWT -> IO () - loop downloadCount hashes0 = - whenJustM (Sqlite.runTransaction conn (elaborateHashes hashes0)) \hashes1 -> do - entities <- doDownload hashes1 - let newDownloadCount = downloadCount + NEMap.size entities - downloadCountCallback newDownloadCount - - -- For each HashJWT we just used to download an entity, set up a little mapping from the underlying hash back to - -- the JWT itself. This is necessary because when we upsert an entity, and it went into temp storage, we need to - -- know the JWT we used to download it (in order to elaborate it). - let hashToHashJwt :: Hash32 -> Share.HashJWT - hashToHashJwt = - \hash -> - case Map.lookup hash m of - Nothing -> error ("bad map; missing expected " ++ show hash ++ " key") - Just hashJwt -> hashJwt - where - m :: Map Hash32 Share.HashJWT - m = - Map.fromList (map (\hashJwt -> (Share.hashJWTHash hashJwt, hashJwt)) (Foldable.toList hashes1)) - - hashesThatHaveMissingDependencies0 <- - Sqlite.runTransaction conn do - NEMap.toList entities & foldMapM \(hash, entity) -> - upsertEntitySomewhere hash entity <&> \case - Q.EntityInMainStorage -> Set.empty - Q.EntityInTempStorage -> Set.singleton (hashToHashJwt hash) - - whenJust (NESet.nonEmptySet hashesThatHaveMissingDependencies0) \hashesThatHaveMissingDependencies -> - loop newDownloadCount (NESet.map Share.decodeHashJWT hashesThatHaveMissingDependencies) - - doDownload :: NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) - doDownload hashes = do - -- we feel okay ignoring the "no read permission" case because it should have been triggered by getCausalHashByPath - Share.DownloadEntitiesSuccess entities <- - httpDownloadEntities - httpClient - unisonShareUrl - Share.DownloadEntitiesRequest {repoName, hashes} - -- call the callback - pure entities - --- | download some entities and file them into the appropriate tables. --- returns the list of incomplete/temp entities -downloadAndUpsertSomewhere :: - (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -> - Sqlite.Connection -> - NESet Share.HashJWT -> - IO (Set Hash32) -downloadAndUpsertSomewhere doDownload conn hashes = do - entities <- doDownload hashes - NEMap.toList entities & foldMapM \(hash, entity) -> - Sqlite.runTransaction conn (upsertEntitySomewhere hash entity) <&> \case - Q.EntityInMainStorage -> Set.empty - Q.EntityInTempStorage -> Set.singleton hash - -downloadMissingDependenciesOf :: - (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -> - Sqlite.Connection -> - NESet Hash32 -> - Int -> - (Int -> IO ()) -> - IO () -downloadMissingDependenciesOf doDownload conn hashes0 initialCount downloadCountCallback = do - elaborateAndLoop initialCount hashes0 - where - loop :: Int -> NESet Share.HashJWT -> IO () - loop downloadCount hashes = do - let newDownloadCount = downloadCount + NESet.size hashes - downloadCountCallback newDownloadCount - whenJustM (downloadAndUpsertSomewhere doDownload conn hashes <&> NESet.nonEmptySet) \newTempEntityHashes -> - elaborateAndLoop newDownloadCount newTempEntityHashes - - elaborateAndLoop :: Int -> NESet Hash32 -> IO () - elaborateAndLoop downloadCount hashes = - whenJustM (Sqlite.runTransaction conn (elaborateHashes' hashes)) \dependencyJwts -> - loop downloadCount dependencyJwts - ------------------------------------------------------------------------------------------------------------------------ -- Upload entities @@ -566,31 +485,17 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadCountCallba ------------------------------------------------------------------------------------------------------------------------ -- Database operations --- | "Elaborate" a set of hashes that we are considering downloading from Unison Share. --- --- For each hash, we determine whether we already have that entity in main storage, temp storage, or nowhere: +-- | "Elaborate" a set of `temp_entity` hashes. -- --- 1. If it's nowhere, we should indeed proceed to download this hash from Unison Share. --- 2. If it's in temp storage, then we ought to instead download its missing dependencies (which themselves are +-- For each hash, then we ought to instead download its missing dependencies (which themselves are -- elaborated by this same procedure, in case we have any of *them* already in temp storage, too. -- 3. If it's in main storage, we should ignore it. -- -- In the end, we return a set of hashes that correspond to entities we actually need to download. -elaborateHashes :: NESet Share.DecodedHashJWT -> Sqlite.Transaction (Maybe (NESet Share.HashJWT)) -elaborateHashes hashes = do - let input :: [(Hash32, Share.HashJWT)] - input = - toList hashes - <&> \(Share.DecodedHashJWT (Share.HashJWTClaims {hash}) jwt) -> - (hash, jwt) - result <- Q.elaborateHashesClient (coerce @[(Hash32, Share.HashJWT)] @[(Hash32, Text)] input) - pure $ (NESet.nonEmptySet . Set.fromList) (coerce @[Text] @[Share.HashJWT] result) - --- | elaborate hashes of temp entities -elaborateHashes' :: NESet Hash32 -> Sqlite.Transaction (Maybe (NESet Share.HashJWT)) -elaborateHashes' hashes = do - result <- Q.elaborateHashesClient' (toList hashes) - pure $ (NESet.nonEmptySet . Set.fromList) (coerce @[Text] @[Share.HashJWT] result) +elaborateHashes' :: NESet Hash32 -> Sqlite.Transaction (NESet Share.HashJWT) +elaborateHashes' hashes = + Q.elaborateHashesClient' (NESet.toList hashes) + <&> NESet.fromList . coerce @(List.NonEmpty Text) @(List.NonEmpty Share.HashJWT) -- | Upsert a downloaded entity "somewhere" - -- @@ -661,7 +566,11 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt Servant.:<|> httpUpdatePath Servant.:<|> httpDownloadEntities Servant.:<|> httpUploadEntities - ) = Servant.hoistClient Share.api hoist (Servant.client Share.api) + ) = + -- FIXME remove this once the other thing lands + let pp :: Proxy ("sync" Servant.:> Share.API) + pp = Proxy + in Servant.hoistClient pp hoist (Servant.client pp) in ( go httpGetCausalHashByPath, go httpFastForwardPath, go httpUpdatePath, From dcb0b25ca4e62824ddfc6f0f6d43c1e0b7fbd920 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 8 Jun 2022 18:41:45 -0400 Subject: [PATCH 317/529] more minor cleanup --- .../U/Codebase/Sqlite/Queries.hs | 42 +------------------ unison-cli/src/Unison/Share/Sync.hs | 40 +++++++++--------- 2 files changed, 22 insertions(+), 60 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 4546767928..c8dff7388d 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -146,7 +146,6 @@ module U.Codebase.Sqlite.Queries -- * elaborate hashes elaborateHashesClient, - elaborateHashesClient', elaborateHashesServer, -- * db misc @@ -1557,43 +1556,6 @@ elaborateHashesServer hashes = do execute_ [here|DROP TABLE unelaborated_dependency|] pure result --- | where Text = HashJWT -elaborateHashesClient :: [(Hash32, Text)] -> Transaction [Text] -elaborateHashesClient hashes = do - execute_ - [here| - CREATE TABLE unelaborated_dependency ( - hash text, - hashJwt text - ) - |] - executeMany - [here| - INSERT INTO unelaborated_dependency - (hash, hashJwt) - VALUES (?,?) - |] - hashes - result <- - queryListCol_ - [here| - WITH RECURSIVE elaborated_dependency (hash, hashJwt) AS ( - SELECT hash, hashJwt FROM unelaborated_dependency - UNION - SELECT temd.dependency, temd.dependencyJwt - FROM temp_entity_missing_dependency temd - JOIN elaborated_dependency ed - ON temd.dependent = ed.hash - ) - SELECT hashJwt FROM elaborated_dependency - WHERE NOT EXISTS ( - SELECT 1 FROM temp_entity - WHERE temp_entity.hash = elaborated_depdenency.hash - ) - |] - execute_ [here|DROP TABLE unelaborated_dependency|] - pure result - data EmptyTempEntityMissingDependencies = EmptyTempEntityMissingDependencies deriving stock (Show) @@ -1615,8 +1577,8 @@ data EmptyTempEntityMissingDependencies -- -- ... then `elaborateHashes {A}` would return the singleton set {C} (because we take the set of transitive -- dependencies {A,B,C} and subtract the set we already have, {A,B}). -elaborateHashesClient' :: Nel.NonEmpty Hash32 -> Transaction (Nel.NonEmpty Text) -elaborateHashesClient' hashes = do +elaborateHashesClient :: Nel.NonEmpty Hash32 -> Transaction (Nel.NonEmpty Text) +elaborateHashesClient hashes = do execute_ [here| CREATE TABLE new_temp_entity_dependents (hash text) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 62a271bcbc..ac32a2dbee 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -369,21 +369,6 @@ makeDoDownload httpClient unisonShareUrl repoName downloadCountCallback = do downloadCountCallback newDownloadCount pure entities --- | Download a set of entities from Unison Share. Returns the subset of those entities that we stored in temp storage --- (`temp_entitiy`) instead of main storage (`object` / `causal`) due to missing dependencies. -downloadEntities :: - (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -> - Sqlite.Connection -> - NESet Share.HashJWT -> - IO (Maybe (NESet Hash32)) -downloadEntities doDownload conn hashes = do - entities <- doDownload hashes - fmap NESet.nonEmptySet do - NEMap.toList entities & foldMapM \(hash, entity) -> - Sqlite.runTransaction conn (upsertEntitySomewhere hash entity) <&> \case - Q.EntityInMainStorage -> Set.empty - Q.EntityInTempStorage -> Set.singleton hash - -- | Finish downloading entities from Unison Share -- -- Precondition: the entities were *already* downloaded at some point in the past, and are now sitting in the @@ -396,10 +381,25 @@ completeTempEntities :: completeTempEntities doDownload conn = let loop :: NESet Hash32 -> IO () loop tempEntityHashes = do - hashJwtsToDownload <- Sqlite.runTransaction conn (elaborateHashes' tempEntityHashes) + hashJwtsToDownload <- Sqlite.runTransaction conn (elaborateHashes tempEntityHashes) whenJustM (downloadEntities doDownload conn hashJwtsToDownload) loop in loop +-- | Download a set of entities from Unison Share. Returns the subset of those entities that we stored in temp storage +-- (`temp_entitiy`) instead of main storage (`object` / `causal`) due to missing dependencies. +downloadEntities :: + (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -> + Sqlite.Connection -> + NESet Share.HashJWT -> + IO (Maybe (NESet Hash32)) +downloadEntities doDownload conn hashes = do + entities <- doDownload hashes + fmap NESet.nonEmptySet do + NEMap.toList entities & foldMapM \(hash, entity) -> + Sqlite.runTransaction conn (upsertEntitySomewhere hash entity) <&> \case + Q.EntityInMainStorage -> Set.empty + Q.EntityInTempStorage -> Set.singleton hash + ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path @@ -455,7 +455,7 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadCountCallba entities <- Sqlite.runTransaction conn (traverse expectEntity hashesList) let uploadEntities :: IO Share.UploadEntitiesResponse - uploadEntities = Timing.time ("uploadEntities with " <> show (NESet.size hashesSet) <> " hashes.") do + uploadEntities = do -- Timing.time ("uploadEntities with " <> show (NESet.size hashesSet) <> " hashes.") do httpUploadEntities httpClient unisonShareUrl @@ -492,9 +492,9 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadCountCallba -- 3. If it's in main storage, we should ignore it. -- -- In the end, we return a set of hashes that correspond to entities we actually need to download. -elaborateHashes' :: NESet Hash32 -> Sqlite.Transaction (NESet Share.HashJWT) -elaborateHashes' hashes = - Q.elaborateHashesClient' (NESet.toList hashes) +elaborateHashes :: NESet Hash32 -> Sqlite.Transaction (NESet Share.HashJWT) +elaborateHashes hashes = + Q.elaborateHashesClient (NESet.toList hashes) <&> NESet.fromList . coerce @(List.NonEmpty Text) @(List.NonEmpty Share.HashJWT) -- | Upsert a downloaded entity "somewhere" - From 06bbf6d617446d022b87dd191f0a7c4b1f6f960b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 8 Jun 2022 20:19:47 -0400 Subject: [PATCH 318/529] on push, show number of entities enqueued to push too --- .../src/Unison/Codebase/Editor/HandleInput.hs | 20 ++++++++-- unison-cli/src/Unison/Share/Sync.hs | 40 ++++++++++--------- 2 files changed, 38 insertions(+), 22 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 752102e260..57d6c18e06 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1910,16 +1910,28 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l pathToSegments = coerce Path.toList - -- Provide the given action a callback that prints out the number of entities uploaded. - withEntitiesUploadedProgressCallback :: ((Int -> IO ()) -> IO a) -> IO a + -- Provide the given action a callback that prints out the number of entities uploaded, and the number of entities + -- enqueued to be uploaded. + withEntitiesUploadedProgressCallback :: ((Int -> Int -> IO ()) -> IO a) -> IO a withEntitiesUploadedProgressCallback action = do entitiesUploadedVar <- newTVarIO 0 + entitiesToUploadVar <- newTVarIO 0 Console.Regions.displayConsoleRegions do Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do Console.Regions.setConsoleRegion region do entitiesUploaded <- readTVar entitiesUploadedVar - pure ("\n Uploaded " <> tShow entitiesUploaded <> " entities...\n\n") - result <- action \entitiesUploaded -> atomically (writeTVar entitiesUploadedVar entitiesUploaded) + entitiesToUpload <- readTVar entitiesToUploadVar + pure $ + "\n Uploaded " + <> tShow entitiesUploaded + <> "/" + <> tShow (entitiesUploaded + entitiesToUpload) + <> " entities...\n\n" + result <- + action \entitiesUploaded entitiesToUpload -> + atomically do + writeTVar entitiesUploadedVar entitiesUploaded + writeTVar entitiesToUploadVar entitiesToUpload entitiesUploaded <- readTVarIO entitiesUploadedVar Console.Regions.finishConsoleRegion region $ "\n Uploaded " <> tShow entitiesUploaded <> " entities.\n" diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index ac32a2dbee..5428e7ce63 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -78,10 +78,10 @@ checkAndSetPush :: Maybe Hash32 -> -- | The hash of our local causal to push. CausalHash -> - -- | Callback that is given the total number of entities uploaded. - (Int -> IO ()) -> + -- | Callback that is given the total number of entities uploaded, and the number of outstanding entities to upload. + (Int -> Int -> IO ()) -> IO (Either CheckAndSetPushError ()) -checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash uploadCountCallback = do +checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash uploadProgressCallback = do -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs -- this causal (UpdatePathMissingDependencies). updatePath >>= \case @@ -89,7 +89,7 @@ checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash uplo Share.UpdatePathHashMismatch mismatch -> pure (Left (CheckAndSetPushErrorHashMismatch mismatch)) Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do -- Upload the causal and all of its dependencies. - uploadEntities httpClient unisonShareUrl conn (Share.pathRepoName path) dependencies uploadCountCallback >>= \case + uploadEntities httpClient unisonShareUrl conn (Share.pathRepoName path) dependencies uploadProgressCallback >>= \case False -> pure (Left (CheckAndSetPushErrorNoWritePermission path)) True -> -- After uploading the causal and all of its dependencies, try setting the remote path again. @@ -140,10 +140,10 @@ fastForwardPush :: Share.Path -> -- | The hash of our local causal to push. CausalHash -> - -- | Callback that is given the total number of entities uploaded. - (Int -> IO ()) -> + -- | Callback that is given the total number of entities uploaded, and the number of outstanding entities to upload. + (Int -> Int -> IO ()) -> IO (Either FastForwardPushError ()) -fastForwardPush httpClient unisonShareUrl conn path localHeadHash uploadCountCallback = +fastForwardPush httpClient unisonShareUrl conn path localHeadHash uploadProgressCallback = getCausalHashByPath httpClient unisonShareUrl path >>= \case Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path)) Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path)) @@ -188,7 +188,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash uploadCountCal conn (Share.pathRepoName path) (NESet.singleton (causalHashToHash32 headHash)) - uploadCountCallback + uploadProgressCallback -- Return a list from oldest to newst of the ancestors between (excluding) the latest local and the current remote -- hash. @@ -435,9 +435,9 @@ uploadEntities :: Sqlite.Connection -> Share.RepoName -> NESet Hash32 -> - (Int -> IO ()) -> + (Int -> Int -> IO ()) -> IO Bool -uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadCountCallback = +uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadProgressCallback = loop 0 hashes0 where loop :: Int -> NESet Hash32 -> IO Bool @@ -469,18 +469,22 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadCountCallba uploadEntities >>= \case Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> do - uploadCountCallback newUploadCount - loop newUploadCount $ - case NESet.nonEmptySet nextHashes of - Nothing -> moreHashes - Just nextHashes1 -> NESet.union moreHashes nextHashes1 + let newAllHashesSet = + case NESet.nonEmptySet nextHashes of + Nothing -> moreHashes + Just nextHashes1 -> NESet.union moreHashes nextHashes1 + uploadProgressCallback newUploadCount (NESet.size newAllHashesSet) + loop newUploadCount newAllHashesSet Share.UploadEntitiesNoWritePermission _ -> pure False Share.UploadEntitiesHashMismatchForEntity {} -> pure False Share.UploadEntitiesSuccess -> do - uploadCountCallback newUploadCount case NESet.nonEmptySet nextHashes of - Nothing -> pure True - Just nextHashes1 -> loop newUploadCount nextHashes1 + Nothing -> do + uploadProgressCallback newUploadCount 0 + pure True + Just nextHashes1 -> do + uploadProgressCallback newUploadCount (NESet.size nextHashes1) + loop newUploadCount nextHashes1 ------------------------------------------------------------------------------------------------------------------------ -- Database operations From ff2d5e391b925010baa355cd576ed9f687e000cf Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 8 Jun 2022 20:20:21 -0400 Subject: [PATCH 319/529] drop push entity size from 500 to 50 (for now) --- unison-cli/src/Unison/Share/Sync.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 5428e7ce63..5d167d1cb4 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -445,7 +445,7 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadProgressCal -- Each request only contains a certain maximum number of entities; split the set of hashes we need to upload into -- those we will upload right now, and those we will begin uploading let (hashesSet, nextHashes) = - case NESet.splitAt 500 allHashesSet of + case NESet.splitAt 50 allHashesSet of This hs1 -> (hs1, Set.empty) That hs2 -> (hs2, Set.empty) -- impossible, this only happens if we split at 0 These hs1 hs2 -> (hs1, NESet.toSet hs2) From 0f4ad47e2d16cea8e79026bee03b16032688d82e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 8 Jun 2022 21:59:18 -0400 Subject: [PATCH 320/529] slightly faster expectObjectIdForHash32 --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index c8dff7388d..135bed835f 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -497,8 +497,14 @@ expectObjectIdForPrimaryHash = expectObjectIdForHash32 :: Hash32 -> Transaction ObjectId expectObjectIdForHash32 hash = do - hashId <- expectHashId hash - expectObjectIdForPrimaryHashId hashId + queryOneCol + [here| + SELECT object.id + FROM object + JOIN hash ON object.primary_hash_id = hash.id + WHERE hash.base32 = ? + |] + (Only hash) expectBranchObjectIdForHash32 :: Hash32 -> Transaction BranchObjectId expectBranchObjectIdForHash32 = From 06ac988e82ffe0b4be23f635991f11d2d21c729c Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 8 Jun 2022 22:15:42 -0400 Subject: [PATCH 321/529] add saveTexts, use it in a couple places --- .../U/Codebase/Sqlite/Queries.hs | 21 +++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 135bed835f..a229c65501 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -8,6 +8,7 @@ module U.Codebase.Sqlite.Queries ( -- * text table saveText, + saveTexts, loadTextId, expectTextId, expectText, @@ -332,8 +333,20 @@ expectBranchHash :: BranchHashId -> Transaction BranchHash expectBranchHash = coerce expectHash saveText :: Text -> Transaction TextId -saveText t = execute sql (Only t) >> expectTextId t - where sql = [here| INSERT INTO text (text) VALUES (?) ON CONFLICT DO NOTHING|] +saveText t = execute saveTextSql (Only t) >> expectTextId t + +saveTexts :: [Text] -> Transaction [TextId] +saveTexts texts = do + executeMany saveTextSql (coerce @[Text] @[Only Text] texts) + traverse expectTextId texts + +saveTextSql :: Sql +saveTextSql = + [here| + INSERT INTO text (text) + VALUES (?) + ON CONFLICT DO NOTHING + |] loadTextId :: Text -> Transaction (Maybe TextId) loadTextId t = queryMaybeCol loadTextIdSql (Only t) @@ -766,7 +779,7 @@ tempToSyncEntity = \case tempToSyncNamespaceLocalIds :: TempEntity.TempNamespaceLocalIds -> Transaction NamespaceFormat.BranchLocalIds tempToSyncNamespaceLocalIds (NamespaceFormat.LocalIds texts defns patches children) = NamespaceFormat.LocalIds - <$> traverse saveText texts + <$> (Vector.fromList <$> saveTexts (Vector.toList texts)) <*> traverse expectObjectIdForHash32 defns <*> traverse expectPatchObjectIdForHash32 patches <*> traverse @@ -789,7 +802,7 @@ tempToSyncEntity = \case tempToSyncPatchLocalIds :: TempEntity.TempPatchLocalIds -> Transaction PatchFormat.PatchLocalIds tempToSyncPatchLocalIds (PatchFormat.LocalIds texts hashes defns) = PatchFormat.LocalIds - <$> traverse saveText texts + <$> (Vector.fromList <$> saveTexts (Vector.toList texts)) <*> traverse saveHash hashes <*> traverse expectObjectIdForHash32 defns From a2e432db2cad2de1df52e1826c73b9bed685c1b1 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 9 Jun 2022 08:54:20 -0400 Subject: [PATCH 322/529] fix warnings --- unison-cli/src/Unison/Share/Sync.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 5d167d1cb4..6d6a2e9e2e 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -42,7 +42,6 @@ import qualified Servant.Client as Servant (ClientEnv, ClientM, client, hoistCli import U.Codebase.HashTags (CausalHash) import qualified U.Codebase.Sqlite.Queries as Q import U.Util.Hash32 (Hash32) -import qualified U.Util.Timing as Timing import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import qualified Unison.Auth.HTTPClient as Auth import Unison.Prelude @@ -455,7 +454,8 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadProgressCal entities <- Sqlite.runTransaction conn (traverse expectEntity hashesList) let uploadEntities :: IO Share.UploadEntitiesResponse - uploadEntities = do -- Timing.time ("uploadEntities with " <> show (NESet.size hashesSet) <> " hashes.") do + uploadEntities = do + -- Timing.time ("uploadEntities with " <> show (NESet.size hashesSet) <> " hashes.") do httpUploadEntities httpClient unisonShareUrl From baaabcf92d910b928b6f8aa9c3936c13f5a2ba1e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 9 Jun 2022 11:14:29 -0400 Subject: [PATCH 323/529] disable client timeouts for sync endpoints --- unison-cli/src/Unison/Share/Sync.hs | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 6d6a2e9e2e..fa140171d4 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -36,9 +36,10 @@ import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import Data.These (These (..)) +import qualified Network.HTTP.Client as Http.Client import qualified Servant.API as Servant ((:<|>) (..), (:>)) import Servant.Client (BaseUrl) -import qualified Servant.Client as Servant (ClientEnv, ClientM, client, hoistClient, mkClientEnv, runClientM) +import qualified Servant.Client as Servant (ClientEnv (..), ClientM, client, defaultMakeClientRequest, hoistClient, mkClientEnv, runClientM) import U.Codebase.HashTags (CausalHash) import qualified U.Codebase.Sqlite.Queries as Q import U.Util.Hash32 (Hash32) @@ -594,4 +595,13 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt req -> IO resp go f (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req = - runReaderT (f req) (Servant.mkClientEnv httpClient unisonShareUrl) + runReaderT + (f req) + ( (Servant.mkClientEnv httpClient unisonShareUrl) + { Servant.makeClientRequest = \url request -> + -- Disable client-side timeouts + (Servant.defaultMakeClientRequest url request) + { Http.Client.responseTimeout = Http.Client.responseTimeoutNone + } + } + ) From dc3d0f75d71f033db28c3b3bbd3b4835c2133a2a Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 9 Jun 2022 14:23:36 -0400 Subject: [PATCH 324/529] Add builtin array types and functions --- parser-typechecker/src/Unison/Builtin.hs | 60 +++- .../src/Unison/Builtin/Decls.hs | 14 +- .../src/Unison/Runtime/Builtin.hs | 275 ++++++++++++++++++ .../src/Unison/Runtime/Foreign.hs | 1 + .../src/Unison/Runtime/Foreign/Function.hs | 43 ++- unison-core/src/Unison/Type.hs | 16 +- 6 files changed, 403 insertions(+), 6 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 7fa998f52d..68c8be6cd1 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -523,7 +523,53 @@ builtinsSrc = B "Ref.read" . forall2 "a" "g" $ \a g -> reft g a --> Type.effect1 () g a, B "Ref.write" . forall2 "a" "g" $ \a g -> - reft g a --> a --> Type.effect1 () g unit + reft g a --> a --> Type.effect1 () g unit, + B "MutableArray.read" . forall2 "g" "a" $ \g a -> + marrayt g a --> nat --> Type.effect () [g, DD.exceptionType ()] a, + B "MutableByteArray.read8" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, + B "MutableByteArray.read16" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, + B "MutableByteArray.read32" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, + B "MutableByteArray.read64" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, + B "MutableArray.write" . forall2 "g" "a" $ \g a -> + marrayt g a --> nat --> a --> Type.effect () [g, DD.exceptionType ()] unit, + B "MutableByteArray.write8" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> nat --> Type.effect () [g, DD.exceptionType ()] unit, + B "MutableByteArray.write16" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> nat --> Type.effect () [g, DD.exceptionType ()] unit, + B "MutableByteArray.write32" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> nat --> Type.effect () [g, DD.exceptionType ()] unit, + B "MutableByteArray.write64" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> nat --> Type.effect () [g, DD.exceptionType ()] unit, + B "ImmutableArray.read" . forall1 "a" $ \a -> + iarrayt a --> nat --> Type.effect1 () (DD.exceptionType ()) a, + B "ImmutableByteArray.read8" $ + ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, + B "ImmutableByteArray.read16" $ + ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, + B "ImmutableByteArray.read32" $ + ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, + B "ImmutableByteArray.read64" $ + ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, + B "MutableArray.freeze!" . forall2 "g" "a" $ \g a -> + marrayt g a --> Type.effect1 () g (iarrayt a), + B "MutableByteArray.freeze!" . forall1 "g" $ \g -> + mbytearrayt g --> Type.effect1 () g ibytearrayt, + B "IO.arrayOf" . forall1 "a" $ \a -> + a --> nat --> io (marrayt (Type.effects () [Type.builtinIO ()]) a), + B "IO.bytearray" $ + nat --> io (mbytearrayt (Type.effects () [Type.builtinIO ()])), + B "IO.bytearrayOf" $ + nat --> nat --> io (mbytearrayt (Type.effects () [Type.builtinIO ()])), + B "Scope.arrayOf" . forall2 "s" "a" $ \s a -> + a --> nat --> Type.effect1 () (scopet s) (marrayt (scopet s) a), + B "Scope.bytearray" . forall1 "s" $ \s -> + nat --> Type.effect1 () (scopet s) (mbytearrayt (scopet s)), + B "Scope.bytearrayOf" . forall1 "s" $ \s -> + nat --> nat --> Type.effect1 () (scopet s) (mbytearrayt (scopet s)) ] ++ -- avoid name conflicts with Universal == < > <= >= @@ -794,6 +840,18 @@ scopet s = Type.scopeType () `app` s reft :: Type -> Type -> Type reft s a = Type.refType () `app` s `app` a +ibytearrayt :: Type +ibytearrayt = Type.ibytearrayType () + +mbytearrayt :: Type -> Type +mbytearrayt g = Type.ibytearrayType () `app` g + +iarrayt :: Type -> Type +iarrayt a = Type.iarrayType () `app` a + +marrayt :: Type -> Type -> Type +marrayt g a = Type.marrayType () `app` g `app` a + socket, threadId, handle, unit :: Type socket = Type.socket () threadId = Type.threadId () diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index c3075b9a41..935b810126 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -52,7 +52,7 @@ optionalRef = lookupDeclRef "Optional" eitherRef = lookupDeclRef "Either" testResultRef, linkRef, docRef, ioErrorRef, stdHandleRef :: Reference -failureRef, ioFailureRef, tlsFailureRef :: Reference +failureRef, ioFailureRef, tlsFailureRef, arrayFailureRef :: Reference exceptionRef, tlsSignedCertRef, tlsPrivateKeyRef :: Reference isPropagatedRef, isTestRef :: Reference isPropagatedRef = lookupDeclRef "IsPropagated" @@ -77,6 +77,8 @@ ioFailureRef = lookupDeclRef "io2.IOFailure" tlsFailureRef = lookupDeclRef "io2.TlsFailure" +arrayFailureRef = lookupDeclRef "io2.ArrayFailure" + tlsSignedCertRef = lookupDeclRef "io2.Tls.SignedCert" tlsPrivateKeyRef = lookupDeclRef "io2.Tls.PrivateKey" @@ -176,7 +178,8 @@ builtinDataDecls = rs1 ++ rs (v "io2.StdHandle", stdhnd), (v "io2.Failure", failure), (v "io2.TlsFailure", tlsFailure), - (v "io2.IOFailure", ioFailure) + (v "io2.IOFailure", ioFailure), + (v "io2.ArrayFailure", arrayFailure) ] of Right a -> a Left e -> error $ "builtinDataDecls: " <> show e @@ -318,6 +321,13 @@ builtinDataDecls = rs1 ++ rs [] [] + arrayFailure = + DataDeclaration + (Unique "8e877b3a45a3029904dbca9cbd8dda0ec0d147d67bd5b89027a90632c9e927fb") + () + [] + [] + stdhnd = DataDeclaration (Unique "67bf7a8e517cbb1e9f42bc078e35498212d3be3c") diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 14749ef283..fd9d947576 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -30,6 +30,7 @@ import qualified Control.Concurrent.STM as STM import Control.DeepSeq (NFData) import qualified Control.Exception.Safe as Exception import Control.Monad.Catch (MonadCatch) +import qualified Control.Monad.Primitive as PA import Control.Monad.State.Strict (State, execState, modify) import qualified Crypto.Hash as Hash import qualified Crypto.MAC.HMAC as HMAC @@ -45,6 +46,7 @@ import Data.IORef as SYS ) import qualified Data.Map as Map import Data.PEM (PEM, pemContent, pemParseLBS) +import qualified Data.Primitive as PA import Data.Set (insert) import qualified Data.Set as Set import qualified Data.Text @@ -182,6 +184,11 @@ fresh8 = (v1, v2, v3, v4, v5, v6, v7, v8) where [v1, v2, v3, v4, v5, v6, v7, v8] = freshes 8 +fresh9 :: Var v => (v, v, v, v, v, v, v, v, v) +fresh9 = (v1, v2, v3, v4, v5, v6, v7, v8, v9) + where + [v1, v2, v3, v4, v5, v6, v7, v8, v9] = freshes 9 + fresh11 :: Var v => (v, v, v, v, v, v, v, v, v, v, v) fresh11 = (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11) where @@ -1086,6 +1093,22 @@ inBxNat arg1 arg2 nat result cont instr = . unbox arg2 Ty.natRef nat $ TLetD result UN (TFOp instr [arg1, nat]) cont +inBxNatNat :: + Var v => v -> v -> v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +inBxNatNat arg1 arg2 arg3 nat1 nat2 result cont instr = + ([BX, BX, BX],) + . TAbss [arg1, arg2, arg3] + . unbox arg2 Ty.natRef nat1 + . unbox arg3 Ty.natRef nat2 + $ TLetD result UN (TFOp instr [arg1, nat1, nat2]) cont + +inBxNatBx :: Var v => v -> v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) +inBxNatBx arg1 arg2 arg3 nat result cont instr = + ([BX, BX, BX],) + . TAbss [arg1, arg2, arg3] + . unbox arg2 Ty.natRef nat + $ TLetD result UN (TFOp instr [arg1, nat, arg3]) cont + -- a -> IOMode -> ... inBxIomr :: forall v. Var v => v -> v -> v -> v -> ANormal v -> FOp -> ([Mem], ANormal v) inBxIomr arg1 arg2 fm result cont instr = @@ -1161,6 +1184,33 @@ outIoFailNat stack1 stack2 stack3 fail nat result = ) ] +exnCase :: Var v => v -> v -> v -> v -> (Word64, ([Mem], ANormal v)) +exnCase stack1 stack2 stack3 fail = + (0,) . ([BX, BX, BX],) + . TAbss [stack1, stack2, stack3] + . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2, stack3]) + $ TReq Ty.exceptionRef 1 [fail] + +outIoExnNat :: forall v. Var v => v -> v -> v -> v -> v -> ANormal v +outIoExnNat stack1 stack2 stack3 fail result = + TMatch result . MatchSum $ + mapFromList + [ exnCase stack1 stack2 stack3 fail, + ( 1, + ([UN],) + . TAbs stack1 + $ TCon Ty.natRef 0 [stack1] + ) + ] + +outIoExnBox :: Var v => v -> v -> v -> v -> v -> ANormal v +outIoExnBox stack1 stack2 stack3 fail result = + TMatch result . MatchSum $ + mapFromList + [ exnCase stack1 stack2 stack3 fail, + (1, ([BX], TAbs stack1 $ TVar stack1)) + ] + outIoFailBox :: forall v. Var v => v -> v -> v -> v -> v -> ANormal v outIoFailBox stack1 stack2 stack3 fail result = TMatch result . MatchSum $ @@ -1344,6 +1394,17 @@ wordDirect wordType instr = where (b1, ub1) = fresh2 +-- Nat -> Nat -> c +wordWordDirect :: Reference -> Reference -> ForeignOp +wordWordDirect word1 word2 instr = + ([BX, BX],) + . TAbss [b1, b2] + . unbox b1 word1 ub1 + . unbox b2 word2 ub2 + $ TFOp instr [ub1, ub2] + where + (b1, b2, ub1, ub2) = fresh4 + -- Nat -> a -> c -- Works for an type that's packed into a word, just -- pass `wordBoxDirect Ty.natRef`, `wordBoxDirect Ty.floatRef` @@ -1469,6 +1530,16 @@ boxBoxToEFBox = where (arg1, arg2, result, stack1, stack2, fail) = fresh6 +-- Nat -> a +-- Nat only +natToBox :: ForeignOp +natToBox = wordDirect Ty.natRef + +-- Nat -> Nat -> a +-- Nat only +natNatToBox :: ForeignOp +natNatToBox = wordWordDirect Ty.natRef Ty.natRef + -- a -> Nat -> Either Failure b boxNatToEFBox :: ForeignOp boxNatToEFBox = @@ -1477,6 +1548,58 @@ boxNatToEFBox = where (arg1, arg2, nat, stack1, stack2, fail, result) = fresh7 +-- a -> Nat ->{Exception} b +boxNatToExnBox :: ForeignOp +boxNatToExnBox = + inBxNat arg1 arg2 nat result $ + outIoExnBox stack1 stack2 stack3 fail result + where + (arg1, arg2, nat, stack1, stack2, stack3, fail, result) = fresh8 + +-- a -> Nat -> b ->{Exception} () +boxNatBoxToExnUnit :: ForeignOp +boxNatBoxToExnUnit = + inBxNatBx arg1 arg2 arg3 nat result + . TMatch result + . MatchSum + $ mapFromList + [ ( 0, + ([BX, BX],) + . TAbss [stack1, stack2, stack3] + . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2, stack3]) + $ TReq Ty.exceptionRef 1 [fail] + ), + (1, ([], TCon Ty.unitRef 0 [])) + ] + where + (arg1, arg2, arg3, nat, stack1, stack2, stack3, fail, result) = fresh9 + +-- a -> Nat ->{Exception} Nat +boxNatToExnNat :: ForeignOp +boxNatToExnNat = + inBxNat arg1 arg2 nat result $ + outIoExnNat stack1 stack2 stack3 fail result + where + (arg1, arg2, nat, stack1, stack2, stack3, fail, result) = fresh8 + +-- a -> Nat -> Nat ->{Exception} () +boxNatNatToExnUnit :: ForeignOp +boxNatNatToExnUnit = + inBxNatNat arg1 arg2 arg3 nat1 nat2 result + . TMatch result + . MatchSum + $ mapFromList + [ ( 0, + ([BX, BX],) + . TAbss [stack1, stack2] + . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) + $ TReq Ty.exceptionRef 1 [fail] + ), + (1, ([], TCon Ty.unitRef 0 [])) + ] + where + (arg1, arg2, arg3, nat1, nat2, result, stack1, stack2, fail) = fresh9 + -- Nat -> Either Failure b -- natToEFBox :: ForeignOp -- natToEFBox = inNat arg nat result $ outIoFail stack1 stack2 fail result @@ -1730,6 +1853,9 @@ mkForeignIOF f = mkForeign $ \a -> tryIOE (f a) unitValue :: Closure unitValue = Closure.Enum Ty.unitRef 0 +natValue :: Word64 -> Closure +natValue w = Closure.DataU1 Ty.natRef 0 (fromIntegral w) + mkForeignTls :: forall a r. (ForeignConvention a, ForeignConvention r) => @@ -2228,6 +2354,155 @@ declareForeigns = do declareForeign Untracked "Bytes.encodeNat16be" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat16be declareForeign Untracked "Bytes.encodeNat16le" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat16le + declareForeign Tracked "MutableArray.read" boxNatToExnBox + . mkForeign + $ checkedRead + declareForeign Tracked "MutableByteArray.read8" boxNatToExnNat + . mkForeign + $ checkedReadPrim @Word8 + declareForeign Tracked "MutableByteArray.read16" boxNatToExnNat + . mkForeign + $ checkedReadPrim @Word16 + declareForeign Tracked "MutableByteArray.read32" boxNatToExnNat + . mkForeign + $ checkedReadPrim @Word32 + declareForeign Tracked "MutableByteArray.read64" boxNatToExnNat + . mkForeign + $ checkedReadPrim @Word64 + + declareForeign Tracked "MutableArray.write" boxNatBoxToExnUnit + . mkForeign + $ checkedWrite + declareForeign Tracked "MutableByteArray.write8" boxNatNatToExnUnit + . mkForeign + $ checkedWritePrim @Word8 + declareForeign Tracked "MutableByteArray.write16" boxNatNatToExnUnit + . mkForeign + $ checkedWritePrim @Word16 + declareForeign Tracked "MutableByteArray.write32" boxNatNatToExnUnit + . mkForeign + $ checkedWritePrim @Word32 + declareForeign Tracked "MutableByteArray.write64" boxNatNatToExnUnit + . mkForeign + $ checkedWritePrim @Word64 + + declareForeign Untracked "ImmutableArray.read" boxNatToExnBox + . mkForeign + $ checkedIndex + declareForeign Untracked "ImmutableByteArray.read8" boxNatToExnNat + . mkForeign + $ checkedIndexPrim @Word8 + declareForeign Untracked "ImmutableByteArray.read16" boxNatToExnNat + . mkForeign + $ checkedIndexPrim @Word16 + declareForeign Untracked "ImmutableByteArray.read32" boxNatToExnNat + . mkForeign + $ checkedIndexPrim @Word32 + declareForeign Untracked "ImmutableByteArray.read64" boxNatToExnNat + . mkForeign + $ checkedIndexPrim @Word64 + + declareForeign Tracked "MutableByteArray.freeze!" boxDirect . mkForeign $ + PA.unsafeFreezeByteArray + + declareForeign Untracked "MutableByteArray.length" boxToNat . mkForeign $ + pure . PA.sizeofMutableByteArray + + declareForeign Untracked "ImmutableByteArray.length" boxToNat . mkForeign $ + pure . PA.sizeofByteArray + + declareForeign Tracked "IO.bytearray" natToBox . mkForeign $ PA.newByteArray + declareForeign Tracked "IO.bytearrayOf" natNatToBox + . mkForeign + $ \(init, sz) -> do + arr <- PA.newByteArray sz + PA.fillByteArray arr 0 sz init + pure arr + + declareForeign Tracked "Scope.bytearray" natToBox . mkForeign $ PA.newByteArray + declareForeign Tracked "Scope.bytearrayOf" natNatToBox + . mkForeign + $ \(sz, init) -> do + arr <- PA.newByteArray sz + PA.fillByteArray arr 0 sz init + pure arr + +type RW = PA.PrimState IO + +checkedRead :: (PA.MutableArray RW Closure, Word64) -> IO (Either Failure Closure) +checkedRead (arr, w) = + checkBounds (PA.sizeofMutableArray arr) w (PA.readArray arr (fromIntegral w)) + +checkedWrite :: + (PA.MutableArray RW Closure, Word64, Closure) -> IO (Either Failure ()) +checkedWrite (arr, w, v) = + checkBounds (PA.sizeofMutableArray arr) w (PA.writeArray arr (fromIntegral w) v) + +checkedIndex :: + (PA.Array Closure, Word64) -> IO (Either Failure Closure) +checkedIndex (arr, w) = + checkBounds (PA.sizeofArray arr) w (PA.indexArrayM arr (fromIntegral w)) + +checkedReadPrim :: + forall a. + PA.Prim a => + (PA.MutableByteArray RW, Word64) -> + IO (Either Failure a) +checkedReadPrim (arr, i) = + checkBoundsPrim + (PA.sizeofMutableByteArray arr) + i + (undefined :: a) + (PA.readByteArray arr (fromIntegral i)) + +checkedWritePrim :: + forall a. + PA.Prim a => + (PA.MutableByteArray RW, Word64, a) -> + IO (Either Failure ()) +checkedWritePrim (arr, i, v) = + checkBoundsPrim + (PA.sizeofMutableByteArray arr) + i + v + (PA.writeByteArray arr (fromIntegral i) v) + +checkedIndexPrim :: + forall a. PA.Prim a => (PA.ByteArray, Word64) -> IO (Either Failure a) +checkedIndexPrim (arr, i) = + checkBoundsPrim + (PA.sizeofByteArray arr) + i + (undefined :: a) + (pure $ PA.indexByteArray arr (fromIntegral i)) + +checkBounds :: Int -> Word64 -> IO b -> IO (Either Failure b) +checkBounds l w act + | w < fromIntegral l = Right <$> act + | otherwise = pure $ Left err + where + err = Failure Ty.arrayFailureRef "array index out of bounds" (natValue w) + +-- Performs a bounds check on a byte array. Strategy is as follows: +-- +-- 1. Turn the signed size-in-bytes of the array unsigned +-- 2. Get the size of an element to be read +-- 3. Divide 1 by 2 to get the size-in-elements +-- 4. Check if the unsigned index is too large +-- +-- This should avoid having to worry about overflows. +checkBoundsPrim :: + PA.Prim a => Int -> Word64 -> a -> IO b -> IO (Either Failure b) +checkBoundsPrim isz w a act + | w >= asz = pure $ Left err + | otherwise = Right <$> act + where + err = Failure Ty.arrayFailureRef "array index out of bounds" (natValue w) + + bsz = fromIntegral isz + sz = fromIntegral $ PA.sizeOf a + asz = bsz `div` sz + hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference hostPreference Nothing = SYS.HostAny hostPreference (Just host) = SYS.Host $ Util.Text.unpack host diff --git a/parser-typechecker/src/Unison/Runtime/Foreign.hs b/parser-typechecker/src/Unison/Runtime/Foreign.hs index 73f29100f2..c952b26059 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign.hs @@ -143,6 +143,7 @@ instance BuiltinForeign Value where foreignRef = Tagged Ty.valueRef instance BuiltinForeign TimeSpec where foreignRef = Tagged Ty.timeSpecRef + data HashAlgorithm where -- Reference is a reference to the hash algorithm HashAlgorithm :: Hash.HashAlgorithm a => Reference -> a -> HashAlgorithm diff --git a/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs b/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs index ffea2a204f..3a5937f542 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs @@ -18,9 +18,11 @@ import Control.Exception (evaluate) import qualified Data.Char as Char import Data.Foldable (toList) import Data.IORef (IORef) +import Data.Primitive.Array as PA +import Data.Primitive.ByteArray as PA import qualified Data.Sequence as Sq import Data.Time.Clock.POSIX (POSIXTime) -import Data.Word (Word64) +import Data.Word (Word16, Word32, Word64, Word8) import GHC.IO.Exception (IOErrorType (..), IOException (..)) import Network.Socket (Socket) import System.IO (BufferMode (..), Handle, IOMode, SeekMode) @@ -32,7 +34,16 @@ import Unison.Runtime.Foreign import Unison.Runtime.MCode import Unison.Runtime.Stack import Unison.Symbol (Symbol) -import Unison.Type (mvarRef, refRef, tvarRef, typeLinkRef) +import Unison.Type + ( iarrayRef, + ibytearrayRef, + marrayRef, + mbytearrayRef, + mvarRef, + refRef, + tvarRef, + typeLinkRef, + ) import Unison.Util.Bytes (Bytes) import Unison.Util.Text (Text, pack, unpack) @@ -86,6 +97,18 @@ instance ForeignConvention Word64 where ustk <- bump ustk (ustk, bstk) <$ pokeN ustk n +instance ForeignConvention Word8 where + readForeign = readForeignAs (fromIntegral :: Word64 -> Word8) + writeForeign = writeForeignAs (fromIntegral :: Word8 -> Word64) + +instance ForeignConvention Word16 where + readForeign = readForeignAs (fromIntegral :: Word64 -> Word16) + writeForeign = writeForeignAs (fromIntegral :: Word16 -> Word64) + +instance ForeignConvention Word32 where + readForeign = readForeignAs (fromIntegral :: Word64 -> Word32) + writeForeign = writeForeignAs (fromIntegral :: Word32 -> Word64) + instance ForeignConvention Char where readForeign (i : us) bs ustk _ = (us,bs,) . Char.chr <$> peekOff ustk i readForeign [] _ _ _ = foreignCCError "Char" @@ -395,6 +418,22 @@ instance ForeignConvention Foreign where readForeign = readForeignAs marshalToForeign writeForeign = writeForeignAs Foreign +instance ForeignConvention (PA.MutableArray s Closure) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap marrayRef) + +instance ForeignConvention (PA.MutableByteArray s) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap mbytearrayRef) + +instance ForeignConvention (PA.Array Closure) where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap iarrayRef) + +instance ForeignConvention PA.ByteArray where + readForeign = readForeignAs (unwrapForeign . marshalToForeign) + writeForeign = writeForeignAs (Foreign . Wrap ibytearrayRef) + instance {-# OVERLAPPABLE #-} BuiltinForeign b => ForeignConvention b where readForeign = readForeignBuiltin writeForeign = writeForeignBuiltin diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index 21c91e39ee..caeaf49e53 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -253,6 +253,14 @@ scopeRef, refRef :: Reference scopeRef = Reference.Builtin "Scope" refRef = Reference.Builtin "Ref" +iarrayRef, marrayRef :: Reference +iarrayRef = Reference.Builtin "ImmutableArray" +marrayRef = Reference.Builtin "MutableArray" + +ibytearrayRef, mbytearrayRef :: Reference +ibytearrayRef = Reference.Builtin "ImmutableByteArray" +mbytearrayRef = Reference.Builtin "MutableByteArray" + mvarRef, tvarRef :: Reference mvarRef = Reference.Builtin "MVar" tvarRef = Reference.Builtin "TVar" @@ -333,6 +341,12 @@ scopeType a = ref a scopeRef refType :: Ord v => a -> Type v a refType a = ref a refRef +iarrayType, marrayType, ibytearrayType, mbytearrayType :: Ord v => a -> Type v a +iarrayType a = ref a iarrayRef +marrayType a = ref a marrayRef +ibytearrayType a = ref a ibytearrayRef +mbytearrayType a = ref a mbytearrayRef + socket :: Ord v => a -> Type v a socket a = ref a socketRef @@ -599,7 +613,7 @@ removePureEffects :: ABT.Var v => Type v a -> Type v a removePureEffects t | not Settings.removePureEffects = t | otherwise = - generalize vs $ removeEffectVars fvs tu + generalize vs $ removeEffectVars fvs tu where (vs, tu) = unforall' t vss = Set.fromList vs From 88269997ec976dde805b7932e29f3f7b2e094b71 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 9 Jun 2022 15:40:43 -0400 Subject: [PATCH 325/529] Missed builtin array types + transcript changes --- parser-typechecker/src/Unison/Builtin.hs | 6 +- unison-src/transcripts/alias-many.output.md | 618 ++++++------ .../transcripts/builtins-merge.output.md | 127 +-- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- .../transcripts/name-selection.output.md | 896 ++++++++++-------- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 8 files changed, 946 insertions(+), 747 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 68c8be6cd1..c2639773e2 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -234,7 +234,11 @@ builtinTypesSrc = B' "Ref" CT.Data, B' "Scope" CT.Effect, B' "TimeSpec" CT.Data, - Rename' "TimeSpec" "io2.Clock.internals.TimeSpec" + Rename' "TimeSpec" "io2.Clock.internals.TimeSpec", + B' "ImmutableArray" CT.Data, + B' "MutableArray" CT.Data, + B' "ImmutableByteArray" CT.Data, + B' "MutableByteArray" CT.Data ] -- rename these to "builtin" later, when builtin means intrinsic as opposed to diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 2dad53a332..ed41e104ae 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -140,351 +140,425 @@ Let's try it! 117. Float.toText : Float -> Text 118. Float.truncate : Float -> Int 119. Handle.toText : Handle -> Text - 120. builtin type Int - 121. Int.* : Int -> Int -> Int - 122. Int.+ : Int -> Int -> Int - 123. Int.- : Int -> Int -> Int - 124. Int./ : Int -> Int -> Int - 125. Int.and : Int -> Int -> Int - 126. Int.complement : Int -> Int - 127. Int.eq : Int -> Int -> Boolean - 128. Int.fromRepresentation : Nat -> Int - 129. Int.fromText : Text -> Optional Int - 130. Int.gt : Int -> Int -> Boolean - 131. Int.gteq : Int -> Int -> Boolean - 132. Int.increment : Int -> Int - 133. Int.isEven : Int -> Boolean - 134. Int.isOdd : Int -> Boolean - 135. Int.leadingZeros : Int -> Nat - 136. Int.lt : Int -> Int -> Boolean - 137. Int.lteq : Int -> Int -> Boolean - 138. Int.mod : Int -> Int -> Int - 139. Int.negate : Int -> Int - 140. Int.or : Int -> Int -> Int - 141. Int.popCount : Int -> Nat - 142. Int.pow : Int -> Nat -> Int - 143. Int.shiftLeft : Int -> Nat -> Int - 144. Int.shiftRight : Int -> Nat -> Int - 145. Int.signum : Int -> Int - 146. Int.toFloat : Int -> Float - 147. Int.toRepresentation : Int -> Nat - 148. Int.toText : Int -> Text - 149. Int.trailingZeros : Int -> Nat - 150. Int.truncate0 : Int -> Nat - 151. Int.xor : Int -> Int -> Int - 152. unique type io2.BufferMode - 153. io2.BufferMode.BlockBuffering : BufferMode - 154. io2.BufferMode.LineBuffering : BufferMode - 155. io2.BufferMode.NoBuffering : BufferMode - 156. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 157. io2.Clock.internals.monotonic : '{IO} Either + 120. builtin type ImmutableArray + 121. ImmutableArray.read : ImmutableArray a + -> Nat + ->{Exception} a + 122. builtin type ImmutableByteArray + 123. ImmutableByteArray.read16 : ImmutableByteArray + -> Nat + ->{Exception} Nat + 124. ImmutableByteArray.read32 : ImmutableByteArray + -> Nat + ->{Exception} Nat + 125. ImmutableByteArray.read64 : ImmutableByteArray + -> Nat + ->{Exception} Nat + 126. ImmutableByteArray.read8 : ImmutableByteArray + -> Nat + ->{Exception} Nat + 127. builtin type Int + 128. Int.* : Int -> Int -> Int + 129. Int.+ : Int -> Int -> Int + 130. Int.- : Int -> Int -> Int + 131. Int./ : Int -> Int -> Int + 132. Int.and : Int -> Int -> Int + 133. Int.complement : Int -> Int + 134. Int.eq : Int -> Int -> Boolean + 135. Int.fromRepresentation : Nat -> Int + 136. Int.fromText : Text -> Optional Int + 137. Int.gt : Int -> Int -> Boolean + 138. Int.gteq : Int -> Int -> Boolean + 139. Int.increment : Int -> Int + 140. Int.isEven : Int -> Boolean + 141. Int.isOdd : Int -> Boolean + 142. Int.leadingZeros : Int -> Nat + 143. Int.lt : Int -> Int -> Boolean + 144. Int.lteq : Int -> Int -> Boolean + 145. Int.mod : Int -> Int -> Int + 146. Int.negate : Int -> Int + 147. Int.or : Int -> Int -> Int + 148. Int.popCount : Int -> Nat + 149. Int.pow : Int -> Nat -> Int + 150. Int.shiftLeft : Int -> Nat -> Int + 151. Int.shiftRight : Int -> Nat -> Int + 152. Int.signum : Int -> Int + 153. Int.toFloat : Int -> Float + 154. Int.toRepresentation : Int -> Nat + 155. Int.toText : Int -> Text + 156. Int.trailingZeros : Int -> Nat + 157. Int.truncate0 : Int -> Nat + 158. Int.xor : Int -> Int -> Int + 159. IO.arrayOf : a -> Nat ->{IO} MutableArray {IO} a + 160. IO.bytearray : Nat ->{IO} ImmutableByteArray {IO} + 161. IO.bytearrayOf : Nat + -> Nat + ->{IO} ImmutableByteArray {IO} + 162. unique type io2.ArrayFailure + 163. unique type io2.BufferMode + 164. io2.BufferMode.BlockBuffering : BufferMode + 165. io2.BufferMode.LineBuffering : BufferMode + 166. io2.BufferMode.NoBuffering : BufferMode + 167. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 168. io2.Clock.internals.monotonic : '{IO} Either Failure TimeSpec - 158. io2.Clock.internals.nsec : TimeSpec -> Nat - 159. io2.Clock.internals.processCPUTime : '{IO} Either + 169. io2.Clock.internals.nsec : TimeSpec -> Nat + 170. io2.Clock.internals.processCPUTime : '{IO} Either Failure TimeSpec - 160. io2.Clock.internals.realtime : '{IO} Either + 171. io2.Clock.internals.realtime : '{IO} Either Failure TimeSpec - 161. io2.Clock.internals.sec : TimeSpec -> Int - 162. io2.Clock.internals.threadCPUTime : '{IO} Either + 172. io2.Clock.internals.sec : TimeSpec -> Int + 173. io2.Clock.internals.threadCPUTime : '{IO} Either Failure TimeSpec - 163. builtin type io2.Clock.internals.TimeSpec - 164. unique type io2.Failure - 165. io2.Failure.Failure : Type -> Text -> Any -> Failure - 166. unique type io2.FileMode - 167. io2.FileMode.Append : FileMode - 168. io2.FileMode.Read : FileMode - 169. io2.FileMode.ReadWrite : FileMode - 170. io2.FileMode.Write : FileMode - 171. builtin type io2.Handle - 172. builtin type io2.IO - 173. io2.IO.clientSocket.impl : Text + 174. builtin type io2.Clock.internals.TimeSpec + 175. unique type io2.Failure + 176. io2.Failure.Failure : Type -> Text -> Any -> Failure + 177. unique type io2.FileMode + 178. io2.FileMode.Append : FileMode + 179. io2.FileMode.Read : FileMode + 180. io2.FileMode.ReadWrite : FileMode + 181. io2.FileMode.Write : FileMode + 182. builtin type io2.Handle + 183. builtin type io2.IO + 184. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 174. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 175. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 176. io2.IO.createDirectory.impl : Text + 185. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 186. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 187. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 177. io2.IO.createTempDirectory.impl : Text + 188. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 178. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 179. io2.IO.directoryContents.impl : Text + 189. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 190. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 180. io2.IO.fileExists.impl : Text + 191. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 181. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 182. io2.IO.getArgs.impl : '{IO} Either Failure [Text] - 183. io2.IO.getBuffering.impl : Handle + 192. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 193. io2.IO.getArgs.impl : '{IO} Either Failure [Text] + 194. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 184. io2.IO.getBytes.impl : Handle + 195. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 185. io2.IO.getCurrentDirectory.impl : '{IO} Either + 196. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 186. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 187. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 188. io2.IO.getFileTimestamp.impl : Text + 197. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 198. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 199. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 189. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 190. io2.IO.getSomeBytes.impl : Handle + 200. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 201. io2.IO.getSomeBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 191. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 192. io2.IO.handlePosition.impl : Handle + 202. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 203. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 193. io2.IO.isDirectory.impl : Text + 204. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 194. io2.IO.isFileEOF.impl : Handle + 205. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 195. io2.IO.isFileOpen.impl : Handle + 206. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 196. io2.IO.isSeekable.impl : Handle + 207. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 197. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 198. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 199. io2.IO.openFile.impl : Text + 208. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 209. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 210. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 200. io2.IO.putBytes.impl : Handle + 211. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 201. io2.IO.ref : a ->{IO} Ref {IO} a - 202. io2.IO.removeDirectory.impl : Text + 212. io2.IO.ref : a ->{IO} Ref {IO} a + 213. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 203. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 204. io2.IO.renameDirectory.impl : Text + 214. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 215. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 205. io2.IO.renameFile.impl : Text + 216. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 206. io2.IO.seekHandle.impl : Handle + 217. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 207. io2.IO.serverSocket.impl : Optional Text + 218. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 208. io2.IO.setBuffering.impl : Handle + 219. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 209. io2.IO.setCurrentDirectory.impl : Text + 220. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 210. io2.IO.socketAccept.impl : Socket + 221. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 211. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 212. io2.IO.socketReceive.impl : Socket + 222. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 223. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 213. io2.IO.socketSend.impl : Socket + 224. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 214. io2.IO.stdHandle : StdHandle -> Handle - 215. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 216. io2.IO.systemTimeMicroseconds : '{IO} Int - 217. unique type io2.IOError - 218. io2.IOError.AlreadyExists : IOError - 219. io2.IOError.EOF : IOError - 220. io2.IOError.IllegalOperation : IOError - 221. io2.IOError.NoSuchThing : IOError - 222. io2.IOError.PermissionDenied : IOError - 223. io2.IOError.ResourceBusy : IOError - 224. io2.IOError.ResourceExhausted : IOError - 225. io2.IOError.UserError : IOError - 226. unique type io2.IOFailure - 227. builtin type io2.MVar - 228. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 229. io2.MVar.new : a ->{IO} MVar a - 230. io2.MVar.newEmpty : '{IO} MVar a - 231. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 232. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 233. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 234. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 235. io2.MVar.tryPut.impl : MVar a + 225. io2.IO.stdHandle : StdHandle -> Handle + 226. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 227. io2.IO.systemTimeMicroseconds : '{IO} Int + 228. unique type io2.IOError + 229. io2.IOError.AlreadyExists : IOError + 230. io2.IOError.EOF : IOError + 231. io2.IOError.IllegalOperation : IOError + 232. io2.IOError.NoSuchThing : IOError + 233. io2.IOError.PermissionDenied : IOError + 234. io2.IOError.ResourceBusy : IOError + 235. io2.IOError.ResourceExhausted : IOError + 236. io2.IOError.UserError : IOError + 237. unique type io2.IOFailure + 238. builtin type io2.MVar + 239. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 240. io2.MVar.new : a ->{IO} MVar a + 241. io2.MVar.newEmpty : '{IO} MVar a + 242. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 243. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 244. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 245. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 246. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 236. io2.MVar.tryRead.impl : MVar a + 247. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 237. io2.MVar.tryTake : MVar a ->{IO} Optional a - 238. unique type io2.SeekMode - 239. io2.SeekMode.AbsoluteSeek : SeekMode - 240. io2.SeekMode.RelativeSeek : SeekMode - 241. io2.SeekMode.SeekFromEnd : SeekMode - 242. builtin type io2.Socket - 243. unique type io2.StdHandle - 244. io2.StdHandle.StdErr : StdHandle - 245. io2.StdHandle.StdIn : StdHandle - 246. io2.StdHandle.StdOut : StdHandle - 247. builtin type io2.STM - 248. io2.STM.atomically : '{STM} a ->{IO} a - 249. io2.STM.retry : '{STM} a - 250. builtin type io2.ThreadId - 251. builtin type io2.Tls - 252. builtin type io2.Tls.Cipher - 253. builtin type io2.Tls.ClientConfig - 254. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 248. io2.MVar.tryTake : MVar a ->{IO} Optional a + 249. unique type io2.SeekMode + 250. io2.SeekMode.AbsoluteSeek : SeekMode + 251. io2.SeekMode.RelativeSeek : SeekMode + 252. io2.SeekMode.SeekFromEnd : SeekMode + 253. builtin type io2.Socket + 254. unique type io2.StdHandle + 255. io2.StdHandle.StdErr : StdHandle + 256. io2.StdHandle.StdIn : StdHandle + 257. io2.StdHandle.StdOut : StdHandle + 258. builtin type io2.STM + 259. io2.STM.atomically : '{STM} a ->{IO} a + 260. io2.STM.retry : '{STM} a + 261. builtin type io2.ThreadId + 262. builtin type io2.Tls + 263. builtin type io2.Tls.Cipher + 264. builtin type io2.Tls.ClientConfig + 265. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 255. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 266. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 256. io2.Tls.ClientConfig.default : Text + 267. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 257. io2.Tls.ClientConfig.versions.set : [Version] + 268. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 258. io2.Tls.decodeCert.impl : Bytes + 269. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 259. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 260. io2.Tls.encodeCert : SignedCert -> Bytes - 261. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 262. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 263. io2.Tls.newClient.impl : ClientConfig + 270. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 271. io2.Tls.encodeCert : SignedCert -> Bytes + 272. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 273. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 274. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 264. io2.Tls.newServer.impl : ServerConfig + 275. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 265. builtin type io2.Tls.PrivateKey - 266. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 267. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 268. builtin type io2.Tls.ServerConfig - 269. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 276. builtin type io2.Tls.PrivateKey + 277. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 278. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 279. builtin type io2.Tls.ServerConfig + 280. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 270. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 281. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 271. io2.Tls.ServerConfig.default : [SignedCert] + 282. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 272. io2.Tls.ServerConfig.versions.set : [Version] + 283. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 273. builtin type io2.Tls.SignedCert - 274. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 275. builtin type io2.Tls.Version - 276. unique type io2.TlsFailure - 277. builtin type io2.TVar - 278. io2.TVar.new : a ->{STM} TVar a - 279. io2.TVar.newIO : a ->{IO} TVar a - 280. io2.TVar.read : TVar a ->{STM} a - 281. io2.TVar.readIO : TVar a ->{IO} a - 282. io2.TVar.swap : TVar a -> a ->{STM} a - 283. io2.TVar.write : TVar a -> a ->{STM} () - 284. io2.validateSandboxed : [Term] -> a -> Boolean - 285. unique type IsPropagated - 286. IsPropagated.IsPropagated : IsPropagated - 287. unique type IsTest - 288. IsTest.IsTest : IsTest - 289. unique type Link - 290. builtin type Link.Term - 291. Link.Term : Term -> Link - 292. Link.Term.toText : Term -> Text - 293. builtin type Link.Type - 294. Link.Type : Type -> Link - 295. builtin type List - 296. List.++ : [a] -> [a] -> [a] - 297. List.+: : a -> [a] -> [a] - 298. List.:+ : [a] -> a -> [a] - 299. List.at : Nat -> [a] -> Optional a - 300. List.cons : a -> [a] -> [a] - 301. List.drop : Nat -> [a] -> [a] - 302. List.empty : [a] - 303. List.size : [a] -> Nat - 304. List.snoc : [a] -> a -> [a] - 305. List.take : Nat -> [a] -> [a] - 306. metadata.isPropagated : IsPropagated - 307. metadata.isTest : IsTest - 308. builtin type Nat - 309. Nat.* : Nat -> Nat -> Nat - 310. Nat.+ : Nat -> Nat -> Nat - 311. Nat./ : Nat -> Nat -> Nat - 312. Nat.and : Nat -> Nat -> Nat - 313. Nat.complement : Nat -> Nat - 314. Nat.drop : Nat -> Nat -> Nat - 315. Nat.eq : Nat -> Nat -> Boolean - 316. Nat.fromText : Text -> Optional Nat - 317. Nat.gt : Nat -> Nat -> Boolean - 318. Nat.gteq : Nat -> Nat -> Boolean - 319. Nat.increment : Nat -> Nat - 320. Nat.isEven : Nat -> Boolean - 321. Nat.isOdd : Nat -> Boolean - 322. Nat.leadingZeros : Nat -> Nat - 323. Nat.lt : Nat -> Nat -> Boolean - 324. Nat.lteq : Nat -> Nat -> Boolean - 325. Nat.mod : Nat -> Nat -> Nat - 326. Nat.or : Nat -> Nat -> Nat - 327. Nat.popCount : Nat -> Nat - 328. Nat.pow : Nat -> Nat -> Nat - 329. Nat.shiftLeft : Nat -> Nat -> Nat - 330. Nat.shiftRight : Nat -> Nat -> Nat - 331. Nat.sub : Nat -> Nat -> Int - 332. Nat.toFloat : Nat -> Float - 333. Nat.toInt : Nat -> Int - 334. Nat.toText : Nat -> Text - 335. Nat.trailingZeros : Nat -> Nat - 336. Nat.xor : Nat -> Nat -> Nat - 337. structural type Optional a - 338. Optional.None : Optional a - 339. Optional.Some : a -> Optional a - 340. builtin type Ref - 341. Ref.read : Ref g a ->{g} a - 342. Ref.write : Ref g a -> a ->{g} () - 343. builtin type Request - 344. builtin type Scope - 345. Scope.ref : a ->{Scope s} Ref {Scope s} a - 346. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 347. structural type SeqView a b - 348. SeqView.VElem : a -> b -> SeqView a b - 349. SeqView.VEmpty : SeqView a b - 350. Socket.toText : Socket -> Text - 351. unique type Test.Result - 352. Test.Result.Fail : Text -> Result - 353. Test.Result.Ok : Text -> Result - 354. builtin type Text - 355. Text.!= : Text -> Text -> Boolean - 356. Text.++ : Text -> Text -> Text - 357. Text.drop : Nat -> Text -> Text - 358. Text.empty : Text - 359. Text.eq : Text -> Text -> Boolean - 360. Text.fromCharList : [Char] -> Text - 361. Text.fromUtf8.impl : Bytes -> Either Failure Text - 362. Text.gt : Text -> Text -> Boolean - 363. Text.gteq : Text -> Text -> Boolean - 364. Text.lt : Text -> Text -> Boolean - 365. Text.lteq : Text -> Text -> Boolean - 366. Text.repeat : Nat -> Text -> Text - 367. Text.size : Text -> Nat - 368. Text.take : Nat -> Text -> Text - 369. Text.toCharList : Text -> [Char] - 370. Text.toUtf8 : Text -> Bytes - 371. Text.uncons : Text -> Optional (Char, Text) - 372. Text.unsnoc : Text -> Optional (Text, Char) - 373. ThreadId.toText : ThreadId -> Text - 374. todo : a -> b - 375. structural type Tuple a b - 376. Tuple.Cons : a -> b -> Tuple a b - 377. structural type Unit - 378. Unit.Unit : () - 379. Universal.< : a -> a -> Boolean - 380. Universal.<= : a -> a -> Boolean - 381. Universal.== : a -> a -> Boolean - 382. Universal.> : a -> a -> Boolean - 383. Universal.>= : a -> a -> Boolean - 384. Universal.compare : a -> a -> Int - 385. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 386. builtin type Value - 387. Value.dependencies : Value -> [Term] - 388. Value.deserialize : Bytes -> Either Text Value - 389. Value.load : Value ->{IO} Either [Term] a - 390. Value.serialize : Value -> Bytes - 391. Value.value : a -> Value + 284. builtin type io2.Tls.SignedCert + 285. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 286. builtin type io2.Tls.Version + 287. unique type io2.TlsFailure + 288. builtin type io2.TVar + 289. io2.TVar.new : a ->{STM} TVar a + 290. io2.TVar.newIO : a ->{IO} TVar a + 291. io2.TVar.read : TVar a ->{STM} a + 292. io2.TVar.readIO : TVar a ->{IO} a + 293. io2.TVar.swap : TVar a -> a ->{STM} a + 294. io2.TVar.write : TVar a -> a ->{STM} () + 295. io2.validateSandboxed : [Term] -> a -> Boolean + 296. unique type IsPropagated + 297. IsPropagated.IsPropagated : IsPropagated + 298. unique type IsTest + 299. IsTest.IsTest : IsTest + 300. unique type Link + 301. builtin type Link.Term + 302. Link.Term : Term -> Link + 303. Link.Term.toText : Term -> Text + 304. builtin type Link.Type + 305. Link.Type : Type -> Link + 306. builtin type List + 307. List.++ : [a] -> [a] -> [a] + 308. List.+: : a -> [a] -> [a] + 309. List.:+ : [a] -> a -> [a] + 310. List.at : Nat -> [a] -> Optional a + 311. List.cons : a -> [a] -> [a] + 312. List.drop : Nat -> [a] -> [a] + 313. List.empty : [a] + 314. List.size : [a] -> Nat + 315. List.snoc : [a] -> a -> [a] + 316. List.take : Nat -> [a] -> [a] + 317. metadata.isPropagated : IsPropagated + 318. metadata.isTest : IsTest + 319. builtin type MutableArray + 320. MutableArray.freeze! : MutableArray g a + ->{g} ImmutableArray a + 321. MutableArray.read : MutableArray g a + -> Nat + ->{g, Exception} a + 322. MutableArray.write : MutableArray g a + -> Nat + -> a + ->{g, Exception} () + 323. builtin type MutableByteArray + 324. MutableByteArray.freeze! : ImmutableByteArray g + ->{g} ImmutableByteArray + 325. MutableByteArray.read16 : ImmutableByteArray g + -> Nat + ->{g, Exception} Nat + 326. MutableByteArray.read32 : ImmutableByteArray g + -> Nat + ->{g, Exception} Nat + 327. MutableByteArray.read64 : ImmutableByteArray g + -> Nat + ->{g, Exception} Nat + 328. MutableByteArray.read8 : ImmutableByteArray g + -> Nat + ->{g, Exception} Nat + 329. MutableByteArray.write16 : ImmutableByteArray g + -> Nat + -> Nat + ->{g, Exception} () + 330. MutableByteArray.write32 : ImmutableByteArray g + -> Nat + -> Nat + ->{g, Exception} () + 331. MutableByteArray.write64 : ImmutableByteArray g + -> Nat + -> Nat + ->{g, Exception} () + 332. MutableByteArray.write8 : ImmutableByteArray g + -> Nat + -> Nat + ->{g, Exception} () + 333. builtin type Nat + 334. Nat.* : Nat -> Nat -> Nat + 335. Nat.+ : Nat -> Nat -> Nat + 336. Nat./ : Nat -> Nat -> Nat + 337. Nat.and : Nat -> Nat -> Nat + 338. Nat.complement : Nat -> Nat + 339. Nat.drop : Nat -> Nat -> Nat + 340. Nat.eq : Nat -> Nat -> Boolean + 341. Nat.fromText : Text -> Optional Nat + 342. Nat.gt : Nat -> Nat -> Boolean + 343. Nat.gteq : Nat -> Nat -> Boolean + 344. Nat.increment : Nat -> Nat + 345. Nat.isEven : Nat -> Boolean + 346. Nat.isOdd : Nat -> Boolean + 347. Nat.leadingZeros : Nat -> Nat + 348. Nat.lt : Nat -> Nat -> Boolean + 349. Nat.lteq : Nat -> Nat -> Boolean + 350. Nat.mod : Nat -> Nat -> Nat + 351. Nat.or : Nat -> Nat -> Nat + 352. Nat.popCount : Nat -> Nat + 353. Nat.pow : Nat -> Nat -> Nat + 354. Nat.shiftLeft : Nat -> Nat -> Nat + 355. Nat.shiftRight : Nat -> Nat -> Nat + 356. Nat.sub : Nat -> Nat -> Int + 357. Nat.toFloat : Nat -> Float + 358. Nat.toInt : Nat -> Int + 359. Nat.toText : Nat -> Text + 360. Nat.trailingZeros : Nat -> Nat + 361. Nat.xor : Nat -> Nat -> Nat + 362. structural type Optional a + 363. Optional.None : Optional a + 364. Optional.Some : a -> Optional a + 365. builtin type Ref + 366. Ref.read : Ref g a ->{g} a + 367. Ref.write : Ref g a -> a ->{g} () + 368. builtin type Request + 369. builtin type Scope + 370. Scope.arrayOf : a + -> Nat + ->{Scope s} MutableArray (Scope s) a + 371. Scope.bytearray : Nat + ->{Scope s} ImmutableByteArray + (Scope s) + 372. Scope.bytearrayOf : Nat + -> Nat + ->{Scope s} ImmutableByteArray + (Scope s) + 373. Scope.ref : a ->{Scope s} Ref {Scope s} a + 374. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r + 375. structural type SeqView a b + 376. SeqView.VElem : a -> b -> SeqView a b + 377. SeqView.VEmpty : SeqView a b + 378. Socket.toText : Socket -> Text + 379. unique type Test.Result + 380. Test.Result.Fail : Text -> Result + 381. Test.Result.Ok : Text -> Result + 382. builtin type Text + 383. Text.!= : Text -> Text -> Boolean + 384. Text.++ : Text -> Text -> Text + 385. Text.drop : Nat -> Text -> Text + 386. Text.empty : Text + 387. Text.eq : Text -> Text -> Boolean + 388. Text.fromCharList : [Char] -> Text + 389. Text.fromUtf8.impl : Bytes -> Either Failure Text + 390. Text.gt : Text -> Text -> Boolean + 391. Text.gteq : Text -> Text -> Boolean + 392. Text.lt : Text -> Text -> Boolean + 393. Text.lteq : Text -> Text -> Boolean + 394. Text.repeat : Nat -> Text -> Text + 395. Text.size : Text -> Nat + 396. Text.take : Nat -> Text -> Text + 397. Text.toCharList : Text -> [Char] + 398. Text.toUtf8 : Text -> Bytes + 399. Text.uncons : Text -> Optional (Char, Text) + 400. Text.unsnoc : Text -> Optional (Text, Char) + 401. ThreadId.toText : ThreadId -> Text + 402. todo : a -> b + 403. structural type Tuple a b + 404. Tuple.Cons : a -> b -> Tuple a b + 405. structural type Unit + 406. Unit.Unit : () + 407. Universal.< : a -> a -> Boolean + 408. Universal.<= : a -> a -> Boolean + 409. Universal.== : a -> a -> Boolean + 410. Universal.> : a -> a -> Boolean + 411. Universal.>= : a -> a -> Boolean + 412. Universal.compare : a -> a -> Int + 413. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 414. builtin type Value + 415. Value.dependencies : Value -> [Term] + 416. Value.deserialize : Bytes -> Either Text Value + 417. Value.load : Value ->{IO} Either [Term] a + 418. Value.serialize : Value -> Bytes + 419. Value.value : a -> Value .builtin> alias.many 94-104 .mylib diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index 719d7a5f5a..df210f5abd 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -9,64 +9,73 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace .tmp> ls builtin - 1. Any (builtin type) - 2. Any/ (2 definitions) - 3. Boolean (builtin type) - 4. Boolean/ (1 definition) - 5. Bytes (builtin type) - 6. Bytes/ (33 definitions) - 7. Char (builtin type) - 8. Char/ (3 definitions) - 9. Code (builtin type) - 10. Code/ (8 definitions) - 11. Debug/ (2 definitions) - 12. Doc (type) - 13. Doc/ (6 definitions) - 14. Either (type) - 15. Either/ (2 definitions) - 16. Exception (type) - 17. Exception/ (1 definition) - 18. Float (builtin type) - 19. Float/ (38 definitions) - 20. Handle/ (1 definition) - 21. Int (builtin type) - 22. Int/ (31 definitions) - 23. IsPropagated (type) - 24. IsPropagated/ (1 definition) - 25. IsTest (type) - 26. IsTest/ (1 definition) - 27. Link (type) - 28. Link/ (5 definitions) - 29. List (builtin type) - 30. List/ (10 definitions) - 31. Nat (builtin type) - 32. Nat/ (28 definitions) - 33. Optional (type) - 34. Optional/ (2 definitions) - 35. Ref (builtin type) - 36. Ref/ (2 definitions) - 37. Request (builtin type) - 38. Scope (builtin type) - 39. Scope/ (2 definitions) - 40. SeqView (type) - 41. SeqView/ (2 definitions) - 42. Socket/ (1 definition) - 43. Test/ (3 definitions) - 44. Text (builtin type) - 45. Text/ (18 definitions) - 46. ThreadId/ (1 definition) - 47. Tuple (type) - 48. Tuple/ (1 definition) - 49. Unit (type) - 50. Unit/ (1 definition) - 51. Universal/ (6 definitions) - 52. Value (builtin type) - 53. Value/ (5 definitions) - 54. bug (a -> b) - 55. crypto/ (12 definitions) - 56. io2/ (133 definitions) - 57. metadata/ (2 definitions) - 58. todo (a -> b) - 59. unsafe/ (1 definition) + 1. Any (builtin type) + 2. Any/ (2 definitions) + 3. Boolean (builtin type) + 4. Boolean/ (1 definition) + 5. Bytes (builtin type) + 6. Bytes/ (33 definitions) + 7. Char (builtin type) + 8. Char/ (3 definitions) + 9. Code (builtin type) + 10. Code/ (8 definitions) + 11. Debug/ (2 definitions) + 12. Doc (type) + 13. Doc/ (6 definitions) + 14. Either (type) + 15. Either/ (2 definitions) + 16. Exception (type) + 17. Exception/ (1 definition) + 18. Float (builtin type) + 19. Float/ (38 definitions) + 20. Handle/ (1 definition) + 21. IO/ (3 definitions) + 22. ImmutableArray (builtin type) + 23. ImmutableArray/ (1 definition) + 24. ImmutableByteArray (builtin type) + 25. ImmutableByteArray/ (4 definitions) + 26. Int (builtin type) + 27. Int/ (31 definitions) + 28. IsPropagated (type) + 29. IsPropagated/ (1 definition) + 30. IsTest (type) + 31. IsTest/ (1 definition) + 32. Link (type) + 33. Link/ (5 definitions) + 34. List (builtin type) + 35. List/ (10 definitions) + 36. MutableArray (builtin type) + 37. MutableArray/ (3 definitions) + 38. MutableByteArray (builtin type) + 39. MutableByteArray/ (9 definitions) + 40. Nat (builtin type) + 41. Nat/ (28 definitions) + 42. Optional (type) + 43. Optional/ (2 definitions) + 44. Ref (builtin type) + 45. Ref/ (2 definitions) + 46. Request (builtin type) + 47. Scope (builtin type) + 48. Scope/ (5 definitions) + 49. SeqView (type) + 50. SeqView/ (2 definitions) + 51. Socket/ (1 definition) + 52. Test/ (3 definitions) + 53. Text (builtin type) + 54. Text/ (18 definitions) + 55. ThreadId/ (1 definition) + 56. Tuple (type) + 57. Tuple/ (1 definition) + 58. Unit (type) + 59. Unit/ (1 definition) + 60. Universal/ (6 definitions) + 61. Value (builtin type) + 62. Value/ (5 definitions) + 63. bug (a -> b) + 64. crypto/ (12 definitions) + 65. io2/ (134 definitions) + 66. metadata/ (2 definitions) + 67. todo (a -> b) + 68. unsafe/ (1 definition) ``` diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index b11235a4eb..2bb4365a82 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (391 definitions) + 1. builtin/ (419 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (577 definitions) + 1. builtin/ (605 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 09685e42b8..6146191c21 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -121,13 +121,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #1q6g6u3m73 + โŠ™ 1. #1s8a7bk9ta - Deletes: feature1.y - โŠ™ 2. #9e4kqo72l2 + โŠ™ 2. #1c6m7928vs + Adds / updates: @@ -138,26 +138,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - โŠ™ 3. #n59irrs1fe + โŠ™ 3. #j0qoj3r276 + Adds / updates: feature1.y - โŠ™ 4. #7qstntsn5f + โŠ™ 4. #h3kqn9af5i > Moves: Original name New name x master.x - โŠ™ 5. #4360t4806a + โŠ™ 5. #argto4qqhg + Adds / updates: x - โ–ก 6. #n38tt1aodo (start of history) + โ–ก 6. #ou466aob20 (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md index d8cb9c264e..e60359ca54 100644 --- a/unison-src/transcripts/name-selection.output.md +++ b/unison-src/transcripts/name-selection.output.md @@ -93,986 +93,1098 @@ d = c + 10 Added definitions: 7. builtin type builtin.Any - 8. builtin type builtin.Boolean - 9. unique type builtin.io2.BufferMode - 10. builtin type builtin.Bytes - 11. builtin type builtin.Char - 12. builtin type builtin.io2.Tls.Cipher - 13. builtin type builtin.io2.Tls.ClientConfig - 14. builtin type builtin.Code - 15. unique type builtin.Doc - 16. structural type builtin.Either a b - 17. structural ability builtin.Exception - 18. unique type builtin.io2.Failure - 19. unique type builtin.io2.FileMode - 20. builtin type builtin.Float - 21. builtin type builtin.io2.Handle - 22. builtin type builtin.crypto.HashAlgorithm - 23. builtin ability builtin.io2.IO - 24. unique type builtin.io2.IOError - 25. unique type builtin.io2.IOFailure - 26. builtin type builtin.Int - 27. unique type builtin.IsPropagated - 28. unique type builtin.IsTest - 29. unique type builtin.Link - 30. builtin type builtin.List - 31. builtin type builtin.io2.MVar - 32. builtin type builtin.Nat - 33. structural type builtin.Optional a - 34. builtin type builtin.io2.Tls.PrivateKey - 35. builtin type builtin.Ref - 36. builtin type builtin.Request - 37. unique type builtin.Test.Result - 38. builtin ability builtin.io2.STM - 39. builtin ability builtin.Scope - 40. unique type builtin.io2.SeekMode - 41. structural type builtin.SeqView a b - 42. builtin type builtin.io2.Tls.ServerConfig - 43. builtin type builtin.io2.Tls.SignedCert - 44. builtin type builtin.io2.Socket - 45. unique type builtin.io2.StdHandle - 46. builtin type builtin.io2.TVar - 47. builtin type builtin.Link.Term - 48. builtin type builtin.Text - 49. builtin type builtin.io2.ThreadId - 50. builtin type builtin.io2.Clock.internals.TimeSpec - 51. builtin type builtin.io2.Tls - 52. unique type builtin.io2.TlsFailure - 53. structural type builtin.Tuple a b - 54. builtin type builtin.Link.Type - 55. structural type builtin.Unit - 56. builtin type builtin.Value - 57. builtin type builtin.io2.Tls.Version - 58. builtin.io2.SeekMode.AbsoluteSeek : SeekMode - 59. builtin.io2.IOError.AlreadyExists : IOError - 60. builtin.io2.FileMode.Append : FileMode - 61. builtin.Doc.Blob : Text + 8. unique type builtin.io2.ArrayFailure + 9. builtin type builtin.Boolean + 10. unique type builtin.io2.BufferMode + 11. builtin type builtin.Bytes + 12. builtin type builtin.Char + 13. builtin type builtin.io2.Tls.Cipher + 14. builtin type builtin.io2.Tls.ClientConfig + 15. builtin type builtin.Code + 16. unique type builtin.Doc + 17. structural type builtin.Either a b + 18. structural ability builtin.Exception + 19. unique type builtin.io2.Failure + 20. unique type builtin.io2.FileMode + 21. builtin type builtin.Float + 22. builtin type builtin.io2.Handle + 23. builtin type builtin.crypto.HashAlgorithm + 24. builtin ability builtin.io2.IO + 25. unique type builtin.io2.IOError + 26. unique type builtin.io2.IOFailure + 27. builtin type builtin.ImmutableArray + 28. builtin type builtin.ImmutableByteArray + 29. builtin type builtin.Int + 30. unique type builtin.IsPropagated + 31. unique type builtin.IsTest + 32. unique type builtin.Link + 33. builtin type builtin.List + 34. builtin type builtin.io2.MVar + 35. builtin type builtin.MutableArray + 36. builtin type builtin.MutableByteArray + 37. builtin type builtin.Nat + 38. structural type builtin.Optional a + 39. builtin type builtin.io2.Tls.PrivateKey + 40. builtin type builtin.Ref + 41. builtin type builtin.Request + 42. unique type builtin.Test.Result + 43. builtin ability builtin.io2.STM + 44. builtin ability builtin.Scope + 45. unique type builtin.io2.SeekMode + 46. structural type builtin.SeqView a b + 47. builtin type builtin.io2.Tls.ServerConfig + 48. builtin type builtin.io2.Tls.SignedCert + 49. builtin type builtin.io2.Socket + 50. unique type builtin.io2.StdHandle + 51. builtin type builtin.io2.TVar + 52. builtin type builtin.Link.Term + 53. builtin type builtin.Text + 54. builtin type builtin.io2.ThreadId + 55. builtin type builtin.io2.Clock.internals.TimeSpec + 56. builtin type builtin.io2.Tls + 57. unique type builtin.io2.TlsFailure + 58. structural type builtin.Tuple a b + 59. builtin type builtin.Link.Type + 60. structural type builtin.Unit + 61. builtin type builtin.Value + 62. builtin type builtin.io2.Tls.Version + 63. builtin.io2.SeekMode.AbsoluteSeek : SeekMode + 64. builtin.io2.IOError.AlreadyExists : IOError + 65. builtin.io2.FileMode.Append : FileMode + 66. builtin.Doc.Blob : Text -> Doc - 62. builtin.io2.BufferMode.BlockBuffering : BufferMode - 63. builtin.Tuple.Cons : a + 67. builtin.io2.BufferMode.BlockBuffering : BufferMode + 68. builtin.Tuple.Cons : a -> b -> Tuple a b - 64. builtin.io2.IOError.EOF : IOError - 65. builtin.Doc.Evaluate : Term + 69. builtin.io2.IOError.EOF : IOError + 70. builtin.Doc.Evaluate : Term -> Doc - 66. builtin.Test.Result.Fail : Text + 71. builtin.Test.Result.Fail : Text -> Result - 67. builtin.io2.Failure.Failure : Type + 72. builtin.io2.Failure.Failure : Type -> Text -> Any -> Failure - 68. builtin.io2.IOError.IllegalOperation : IOError - 69. builtin.IsPropagated.IsPropagated : IsPropagated - 70. builtin.IsTest.IsTest : IsTest - 71. builtin.Doc.Join : [Doc] + 73. builtin.io2.IOError.IllegalOperation : IOError + 74. builtin.IsPropagated.IsPropagated : IsPropagated + 75. builtin.IsTest.IsTest : IsTest + 76. builtin.Doc.Join : [Doc] -> Doc - 72. builtin.Either.Left : a + 77. builtin.Either.Left : a -> Either a b - 73. builtin.io2.BufferMode.LineBuffering : BufferMode - 74. builtin.Doc.Link : Link + 78. builtin.io2.BufferMode.LineBuffering : BufferMode + 79. builtin.Doc.Link : Link -> Doc - 75. builtin.io2.BufferMode.NoBuffering : BufferMode - 76. builtin.io2.IOError.NoSuchThing : IOError - 77. builtin.Optional.None : Optional + 80. builtin.io2.BufferMode.NoBuffering : BufferMode + 81. builtin.io2.IOError.NoSuchThing : IOError + 82. builtin.Optional.None : Optional a - 78. builtin.Test.Result.Ok : Text + 83. builtin.Test.Result.Ok : Text -> Result - 79. builtin.io2.IOError.PermissionDenied : IOError - 80. builtin.io2.FileMode.Read : FileMode - 81. builtin.io2.FileMode.ReadWrite : FileMode - 82. builtin.io2.SeekMode.RelativeSeek : SeekMode - 83. builtin.io2.IOError.ResourceBusy : IOError - 84. builtin.io2.IOError.ResourceExhausted : IOError - 85. builtin.Either.Right : b + 84. builtin.io2.IOError.PermissionDenied : IOError + 85. builtin.io2.FileMode.Read : FileMode + 86. builtin.io2.FileMode.ReadWrite : FileMode + 87. builtin.io2.SeekMode.RelativeSeek : SeekMode + 88. builtin.io2.IOError.ResourceBusy : IOError + 89. builtin.io2.IOError.ResourceExhausted : IOError + 90. builtin.Either.Right : b -> Either a b - 86. builtin.io2.SeekMode.SeekFromEnd : SeekMode - 87. builtin.Doc.Signature : Term + 91. builtin.io2.SeekMode.SeekFromEnd : SeekMode + 92. builtin.Doc.Signature : Term -> Doc - 88. builtin.io2.BufferMode.SizedBlockBuffering : Nat + 93. builtin.io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 89. builtin.Optional.Some : a + 94. builtin.Optional.Some : a -> Optional a - 90. builtin.Doc.Source : Link + 95. builtin.Doc.Source : Link -> Doc - 91. builtin.io2.StdHandle.StdErr : StdHandle - 92. builtin.io2.StdHandle.StdIn : StdHandle - 93. builtin.io2.StdHandle.StdOut : StdHandle - 94. builtin.Link.Term : Term + 96. builtin.io2.StdHandle.StdErr : StdHandle + 97. builtin.io2.StdHandle.StdIn : StdHandle + 98. builtin.io2.StdHandle.StdOut : StdHandle + 99. builtin.Link.Term : Term -> Link - 95. builtin.Link.Type : Type + 100. builtin.Link.Type : Type -> Link - 96. builtin.Unit.Unit : () - 97. builtin.io2.IOError.UserError : IOError - 98. builtin.SeqView.VElem : a + 101. builtin.Unit.Unit : () + 102. builtin.io2.IOError.UserError : IOError + 103. builtin.SeqView.VElem : a -> b -> SeqView a b - 99. builtin.SeqView.VEmpty : SeqView + 104. builtin.SeqView.VEmpty : SeqView a b - 100. builtin.io2.FileMode.Write : FileMode - 101. builtin.Exception.raise : Failure + 105. builtin.io2.FileMode.Write : FileMode + 106. builtin.Exception.raise : Failure ->{Exception} x - 102. builtin.Text.!= : Text + 107. builtin.Text.!= : Text -> Text -> Boolean - 103. builtin.Float.* : Float + 108. builtin.Float.* : Float -> Float -> Float - 104. builtin.Int.* : Int + 109. builtin.Int.* : Int -> Int -> Int - 105. builtin.Nat.* : Nat + 110. builtin.Nat.* : Nat -> Nat -> Nat - 106. builtin.Float.+ : Float + 111. builtin.Float.+ : Float -> Float -> Float - 107. builtin.Int.+ : Int + 112. builtin.Int.+ : Int -> Int -> Int - 108. builtin.Nat.+ : Nat + 113. builtin.Nat.+ : Nat -> Nat -> Nat - 109. builtin.Bytes.++ : Bytes + 114. builtin.Bytes.++ : Bytes -> Bytes -> Bytes - 110. builtin.List.++ : [a] + 115. builtin.List.++ : [a] -> [a] -> [a] - 111. builtin.Text.++ : Text + 116. builtin.Text.++ : Text -> Text -> Text - 112. โ”Œ builtin.List.+: : a + 117. โ”Œ builtin.List.+: : a -> [a] -> [a] - 113. โ”” builtin.List.cons : a + 118. โ”” builtin.List.cons : a -> [a] -> [a] - 114. builtin.Float.- : Float + 119. builtin.Float.- : Float -> Float -> Float - 115. builtin.Int.- : Int + 120. builtin.Int.- : Int -> Int -> Int - 116. builtin.Float./ : Float + 121. builtin.Float./ : Float -> Float -> Float - 117. builtin.Int./ : Int + 122. builtin.Int./ : Int -> Int -> Int - 118. builtin.Nat./ : Nat + 123. builtin.Nat./ : Nat -> Nat -> Nat - 119. โ”Œ builtin.List.:+ : [a] + 124. โ”Œ builtin.List.:+ : [a] -> a -> [a] - 120. โ”” builtin.List.snoc : [a] + 125. โ”” builtin.List.snoc : [a] -> a -> [a] - 121. builtin.Universal.< : a + 126. builtin.Universal.< : a -> a -> Boolean - 122. builtin.Universal.<= : a + 127. builtin.Universal.<= : a -> a -> Boolean - 123. builtin.Universal.== : a + 128. builtin.Universal.== : a -> a -> Boolean - 124. builtin.Universal.> : a + 129. builtin.Universal.> : a -> a -> Boolean - 125. builtin.Universal.>= : a + 130. builtin.Universal.>= : a -> a -> Boolean - 126. builtin.Any.Any : a + 131. builtin.Any.Any : a -> Any - 127. builtin.crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm - 128. builtin.crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm - 129. builtin.crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm - 130. builtin.crypto.HashAlgorithm.Sha2_256 : HashAlgorithm - 131. builtin.crypto.HashAlgorithm.Sha2_512 : HashAlgorithm - 132. builtin.crypto.HashAlgorithm.Sha3_256 : HashAlgorithm - 133. builtin.crypto.HashAlgorithm.Sha3_512 : HashAlgorithm - 134. builtin.Float.abs : Float + 132. builtin.crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm + 133. builtin.crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm + 134. builtin.crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm + 135. builtin.crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 136. builtin.crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 137. builtin.crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 138. builtin.crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 139. builtin.Float.abs : Float -> Float - 135. builtin.Float.acos : Float + 140. builtin.Float.acos : Float -> Float - 136. builtin.Float.acosh : Float + 141. builtin.Float.acosh : Float -> Float - 137. builtin.Int.and : Int + 142. builtin.Int.and : Int -> Int -> Int - 138. builtin.Nat.and : Nat + 143. builtin.Nat.and : Nat -> Nat -> Nat - 139. builtin.Float.asin : Float + 144. builtin.IO.arrayOf : a + -> Nat + ->{IO} MutableArray + {IO} a + 145. builtin.Scope.arrayOf : a + -> Nat + ->{Scope + s} MutableArray + (Scope + s) + a + 146. builtin.Float.asin : Float -> Float - 140. builtin.Float.asinh : Float + 147. builtin.Float.asinh : Float -> Float - 141. builtin.Bytes.at : Nat + 148. builtin.Bytes.at : Nat -> Bytes -> Optional Nat - 142. builtin.List.at : Nat + 149. builtin.List.at : Nat -> [a] -> Optional a - 143. builtin.Float.atan : Float + 150. builtin.Float.atan : Float -> Float - 144. builtin.Float.atan2 : Float + 151. builtin.Float.atan2 : Float -> Float -> Float - 145. builtin.Float.atanh : Float + 152. builtin.Float.atanh : Float -> Float - 146. builtin.io2.STM.atomically : '{STM} a + 153. builtin.io2.STM.atomically : '{STM} a ->{IO} a - 147. builtin.bug : a -> b - 148. โ”Œ c#gjmq673r1v : Nat - 149. โ”” aaaa.tooManySegments : Nat - 150. builtin.Code.cache_ : [( Term, + 154. builtin.bug : a -> b + 155. builtin.IO.bytearray : Nat + ->{IO} ImmutableByteArray + {IO} + 156. builtin.Scope.bytearray : Nat + ->{Scope + s} ImmutableByteArray + (Scope + s) + 157. builtin.IO.bytearrayOf : Nat + -> Nat + ->{IO} ImmutableByteArray + {IO} + 158. builtin.Scope.bytearrayOf : Nat + -> Nat + ->{Scope + s} ImmutableByteArray + (Scope + s) + 159. โ”Œ c#gjmq673r1v : Nat + 160. โ”” aaaa.tooManySegments : Nat + 161. builtin.Code.cache_ : [( Term, Code)] ->{IO} [Term] - 151. builtin.Float.ceiling : Float + 162. builtin.Float.ceiling : Float -> Int - 152. builtin.unsafe.coerceAbilities : (a + 163. builtin.unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 153. builtin.Universal.compare : a + 164. builtin.Universal.compare : a -> a -> Int - 154. builtin.Int.complement : Int + 165. builtin.Int.complement : Int -> Int - 155. builtin.Nat.complement : Nat + 166. builtin.Nat.complement : Nat -> Nat - 156. builtin.Bytes.gzip.compress : Bytes + 167. builtin.Bytes.gzip.compress : Bytes -> Bytes - 157. builtin.Bytes.zlib.compress : Bytes + 168. builtin.Bytes.zlib.compress : Bytes -> Bytes - 158. builtin.Float.cos : Float + 169. builtin.Float.cos : Float -> Float - 159. builtin.Float.cosh : Float + 170. builtin.Float.cosh : Float -> Float - 160. builtin.Bytes.decodeNat16be : Bytes + 171. builtin.Bytes.decodeNat16be : Bytes -> Optional ( Nat, Bytes) - 161. builtin.Bytes.decodeNat16le : Bytes + 172. builtin.Bytes.decodeNat16le : Bytes -> Optional ( Nat, Bytes) - 162. builtin.Bytes.decodeNat32be : Bytes + 173. builtin.Bytes.decodeNat32be : Bytes -> Optional ( Nat, Bytes) - 163. builtin.Bytes.decodeNat32le : Bytes + 174. builtin.Bytes.decodeNat32le : Bytes -> Optional ( Nat, Bytes) - 164. builtin.Bytes.decodeNat64be : Bytes + 175. builtin.Bytes.decodeNat64be : Bytes -> Optional ( Nat, Bytes) - 165. builtin.Bytes.decodeNat64le : Bytes + 176. builtin.Bytes.decodeNat64le : Bytes -> Optional ( Nat, Bytes) - 166. builtin.io2.Tls.decodePrivateKey : Bytes + 177. builtin.io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 167. builtin.Bytes.gzip.decompress : Bytes + 178. builtin.Bytes.gzip.decompress : Bytes -> Either Text Bytes - 168. builtin.Bytes.zlib.decompress : Bytes + 179. builtin.Bytes.zlib.decompress : Bytes -> Either Text Bytes - 169. builtin.io2.Tls.ClientConfig.default : Text + 180. builtin.io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 170. builtin.io2.Tls.ServerConfig.default : [SignedCert] + 181. builtin.io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 171. builtin.Code.dependencies : Code + 182. builtin.Code.dependencies : Code -> [Term] - 172. builtin.Value.dependencies : Value + 183. builtin.Value.dependencies : Value -> [Term] - 173. builtin.Code.deserialize : Bytes + 184. builtin.Code.deserialize : Bytes -> Either Text Code - 174. builtin.Value.deserialize : Bytes + 185. builtin.Value.deserialize : Bytes -> Either Text Value - 175. builtin.Code.display : Text + 186. builtin.Code.display : Text -> Code -> Text - 176. builtin.Bytes.drop : Nat + 187. builtin.Bytes.drop : Nat -> Bytes -> Bytes - 177. builtin.List.drop : Nat + 188. builtin.List.drop : Nat -> [a] -> [a] - 178. builtin.Nat.drop : Nat + 189. builtin.Nat.drop : Nat -> Nat -> Nat - 179. builtin.Text.drop : Nat + 190. builtin.Text.drop : Nat -> Text -> Text - 180. builtin.Bytes.empty : Bytes - 181. builtin.List.empty : [a] - 182. builtin.Text.empty : Text - 183. builtin.io2.Tls.encodeCert : SignedCert + 191. builtin.Bytes.empty : Bytes + 192. builtin.List.empty : [a] + 193. builtin.Text.empty : Text + 194. builtin.io2.Tls.encodeCert : SignedCert -> Bytes - 184. builtin.Bytes.encodeNat16be : Nat + 195. builtin.Bytes.encodeNat16be : Nat -> Bytes - 185. builtin.Bytes.encodeNat16le : Nat + 196. builtin.Bytes.encodeNat16le : Nat -> Bytes - 186. builtin.Bytes.encodeNat32be : Nat + 197. builtin.Bytes.encodeNat32be : Nat -> Bytes - 187. builtin.Bytes.encodeNat32le : Nat + 198. builtin.Bytes.encodeNat32le : Nat -> Bytes - 188. builtin.Bytes.encodeNat64be : Nat + 199. builtin.Bytes.encodeNat64be : Nat -> Bytes - 189. builtin.Bytes.encodeNat64le : Nat + 200. builtin.Bytes.encodeNat64le : Nat -> Bytes - 190. builtin.io2.Tls.encodePrivateKey : PrivateKey + 201. builtin.io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 191. builtin.Float.eq : Float + 202. builtin.Float.eq : Float -> Float -> Boolean - 192. builtin.Int.eq : Int + 203. builtin.Int.eq : Int -> Int -> Boolean - 193. builtin.Nat.eq : Nat + 204. builtin.Nat.eq : Nat -> Nat -> Boolean - 194. builtin.Text.eq : Text + 205. builtin.Text.eq : Text -> Text -> Boolean - 195. builtin.Float.exp : Float + 206. builtin.Float.exp : Float -> Float - 196. builtin.Bytes.flatten : Bytes + 207. builtin.Bytes.flatten : Bytes -> Bytes - 197. builtin.Float.floor : Float + 208. builtin.Float.floor : Float -> Int - 198. builtin.io2.IO.forkComp : '{IO} a + 209. builtin.io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 199. builtin.Bytes.fromBase16 : Bytes + 210. builtin.MutableArray.freeze! : MutableArray + g a + ->{g} ImmutableArray + a + 211. builtin.MutableByteArray.freeze! : ImmutableByteArray + g + ->{g} ImmutableByteArray + 212. builtin.Bytes.fromBase16 : Bytes -> Either Text Bytes - 200. builtin.Bytes.fromBase32 : Bytes + 213. builtin.Bytes.fromBase32 : Bytes -> Either Text Bytes - 201. builtin.Bytes.fromBase64 : Bytes + 214. builtin.Bytes.fromBase64 : Bytes -> Either Text Bytes - 202. builtin.Bytes.fromBase64UrlUnpadded : Bytes + 215. builtin.Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes - 203. builtin.Text.fromCharList : [Char] + 216. builtin.Text.fromCharList : [Char] -> Text - 204. builtin.Bytes.fromList : [Nat] + 217. builtin.Bytes.fromList : [Nat] -> Bytes - 205. builtin.Char.fromNat : Nat + 218. builtin.Char.fromNat : Nat -> Char - 206. builtin.Float.fromRepresentation : Nat + 219. builtin.Float.fromRepresentation : Nat -> Float - 207. builtin.Int.fromRepresentation : Nat + 220. builtin.Int.fromRepresentation : Nat -> Int - 208. builtin.Float.fromText : Text + 221. builtin.Float.fromText : Text -> Optional Float - 209. builtin.Int.fromText : Text + 222. builtin.Int.fromText : Text -> Optional Int - 210. builtin.Nat.fromText : Text + 223. builtin.Nat.fromText : Text -> Optional Nat - 211. builtin.Float.gt : Float + 224. builtin.Float.gt : Float -> Float -> Boolean - 212. builtin.Int.gt : Int + 225. builtin.Int.gt : Int -> Int -> Boolean - 213. builtin.Nat.gt : Nat + 226. builtin.Nat.gt : Nat -> Nat -> Boolean - 214. builtin.Text.gt : Text + 227. builtin.Text.gt : Text -> Text -> Boolean - 215. builtin.Float.gteq : Float + 228. builtin.Float.gteq : Float -> Float -> Boolean - 216. builtin.Int.gteq : Int + 229. builtin.Int.gteq : Int -> Int -> Boolean - 217. builtin.Nat.gteq : Nat + 230. builtin.Nat.gteq : Nat -> Nat -> Boolean - 218. builtin.Text.gteq : Text + 231. builtin.Text.gteq : Text -> Text -> Boolean - 219. builtin.crypto.hash : HashAlgorithm + 232. builtin.crypto.hash : HashAlgorithm -> a -> Bytes - 220. builtin.crypto.hashBytes : HashAlgorithm + 233. builtin.crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 221. builtin.crypto.hmac : HashAlgorithm + 234. builtin.crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 222. builtin.crypto.hmacBytes : HashAlgorithm + 235. builtin.crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 223. builtin.io2.IO.clientSocket.impl : Text + 236. builtin.io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 224. builtin.io2.IO.closeFile.impl : Handle + 237. builtin.io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 225. builtin.io2.IO.closeSocket.impl : Socket + 238. builtin.io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 226. builtin.io2.IO.createDirectory.impl : Text + 239. builtin.io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 227. builtin.io2.IO.createTempDirectory.impl : Text + 240. builtin.io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 228. builtin.io2.Tls.decodeCert.impl : Bytes + 241. builtin.io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 229. builtin.io2.IO.delay.impl : Nat + 242. builtin.io2.IO.delay.impl : Nat ->{IO} Either Failure () - 230. builtin.io2.IO.directoryContents.impl : Text + 243. builtin.io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 231. builtin.io2.IO.fileExists.impl : Text + 244. builtin.io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 232. builtin.Text.fromUtf8.impl : Bytes + 245. builtin.Text.fromUtf8.impl : Bytes -> Either Failure Text - 233. builtin.io2.IO.getArgs.impl : '{IO} Either + 246. builtin.io2.IO.getArgs.impl : '{IO} Either Failure [Text] - 234. builtin.io2.IO.getBuffering.impl : Handle + 247. builtin.io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 235. builtin.io2.IO.getBytes.impl : Handle + 248. builtin.io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 236. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either + 249. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 237. builtin.io2.IO.getEnv.impl : Text + 250. builtin.io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 238. builtin.io2.IO.getFileSize.impl : Text + 251. builtin.io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 239. builtin.io2.IO.getFileTimestamp.impl : Text + 252. builtin.io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 240. builtin.io2.IO.getLine.impl : Handle + 253. builtin.io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 241. builtin.io2.IO.getSomeBytes.impl : Handle + 254. builtin.io2.IO.getSomeBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 242. builtin.io2.IO.getTempDirectory.impl : '{IO} Either + 255. builtin.io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 243. builtin.io2.IO.handlePosition.impl : Handle + 256. builtin.io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 244. builtin.io2.Tls.handshake.impl : Tls + 257. builtin.io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 245. builtin.io2.IO.isDirectory.impl : Text + 258. builtin.io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 246. builtin.io2.IO.isFileEOF.impl : Handle + 259. builtin.io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 247. builtin.io2.IO.isFileOpen.impl : Handle + 260. builtin.io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 248. builtin.io2.IO.isSeekable.impl : Handle + 261. builtin.io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 249. builtin.io2.IO.kill.impl : ThreadId + 262. builtin.io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 250. builtin.io2.IO.listen.impl : Socket + 263. builtin.io2.IO.listen.impl : Socket ->{IO} Either Failure () - 251. builtin.io2.Tls.newClient.impl : ClientConfig + 264. builtin.io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 252. builtin.io2.Tls.newServer.impl : ServerConfig + 265. builtin.io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 253. builtin.io2.IO.openFile.impl : Text + 266. builtin.io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 254. builtin.io2.MVar.put.impl : MVar a + 267. builtin.io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 255. builtin.io2.IO.putBytes.impl : Handle + 268. builtin.io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 256. builtin.io2.MVar.read.impl : MVar a + 269. builtin.io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 257. builtin.io2.Tls.receive.impl : Tls + 270. builtin.io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 258. builtin.io2.IO.removeDirectory.impl : Text + 271. builtin.io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 259. builtin.io2.IO.removeFile.impl : Text + 272. builtin.io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 260. builtin.io2.IO.renameDirectory.impl : Text + 273. builtin.io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 261. builtin.io2.IO.renameFile.impl : Text + 274. builtin.io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 262. builtin.io2.IO.seekHandle.impl : Handle + 275. builtin.io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 263. builtin.io2.Tls.send.impl : Tls + 276. builtin.io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 264. builtin.io2.IO.serverSocket.impl : Optional + 277. builtin.io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 265. builtin.io2.IO.setBuffering.impl : Handle + 278. builtin.io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 266. builtin.io2.IO.setCurrentDirectory.impl : Text + 279. builtin.io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 267. builtin.io2.IO.socketAccept.impl : Socket + 280. builtin.io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 268. builtin.io2.IO.socketPort.impl : Socket + 281. builtin.io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 269. builtin.io2.IO.socketReceive.impl : Socket + 282. builtin.io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 270. builtin.io2.IO.socketSend.impl : Socket + 283. builtin.io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 271. builtin.io2.MVar.swap.impl : MVar a + 284. builtin.io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 272. builtin.io2.IO.systemTime.impl : '{IO} Either + 285. builtin.io2.IO.systemTime.impl : '{IO} Either Failure Nat - 273. builtin.io2.MVar.take.impl : MVar a + 286. builtin.io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 274. builtin.io2.Tls.terminate.impl : Tls + 287. builtin.io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 275. builtin.io2.MVar.tryPut.impl : MVar a + 288. builtin.io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 276. builtin.io2.MVar.tryRead.impl : MVar a + 289. builtin.io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 277. builtin.Int.increment : Int + 290. builtin.Int.increment : Int -> Int - 278. builtin.Nat.increment : Nat + 291. builtin.Nat.increment : Nat -> Nat - 279. builtin.io2.MVar.isEmpty : MVar a + 292. builtin.io2.MVar.isEmpty : MVar a ->{IO} Boolean - 280. builtin.Int.isEven : Int + 293. builtin.Int.isEven : Int -> Boolean - 281. builtin.Nat.isEven : Nat + 294. builtin.Nat.isEven : Nat -> Boolean - 282. builtin.Code.isMissing : Term + 295. builtin.Code.isMissing : Term ->{IO} Boolean - 283. builtin.Int.isOdd : Int + 296. builtin.Int.isOdd : Int -> Boolean - 284. builtin.Nat.isOdd : Nat + 297. builtin.Nat.isOdd : Nat -> Boolean - 285. builtin.metadata.isPropagated : IsPropagated - 286. builtin.metadata.isTest : IsTest - 287. builtin.Int.leadingZeros : Int + 298. builtin.metadata.isPropagated : IsPropagated + 299. builtin.metadata.isTest : IsTest + 300. builtin.Int.leadingZeros : Int -> Nat - 288. builtin.Nat.leadingZeros : Nat + 301. builtin.Nat.leadingZeros : Nat -> Nat - 289. builtin.Value.load : Value + 302. builtin.Value.load : Value ->{IO} Either [Term] a - 290. builtin.Float.log : Float + 303. builtin.Float.log : Float -> Float - 291. builtin.Float.logBase : Float + 304. builtin.Float.logBase : Float -> Float -> Float - 292. builtin.Code.lookup : Term + 305. builtin.Code.lookup : Term ->{IO} Optional Code - 293. builtin.Float.lt : Float + 306. builtin.Float.lt : Float -> Float -> Boolean - 294. builtin.Int.lt : Int + 307. builtin.Int.lt : Int -> Int -> Boolean - 295. builtin.Nat.lt : Nat + 308. builtin.Nat.lt : Nat -> Nat -> Boolean - 296. builtin.Text.lt : Text + 309. builtin.Text.lt : Text -> Text -> Boolean - 297. builtin.Float.lteq : Float + 310. builtin.Float.lteq : Float -> Float -> Boolean - 298. builtin.Int.lteq : Int + 311. builtin.Int.lteq : Int -> Int -> Boolean - 299. builtin.Nat.lteq : Nat + 312. builtin.Nat.lteq : Nat -> Nat -> Boolean - 300. builtin.Text.lteq : Text + 313. builtin.Text.lteq : Text -> Text -> Boolean - 301. builtin.Float.max : Float + 314. builtin.Float.max : Float -> Float -> Float - 302. builtin.Float.min : Float + 315. builtin.Float.min : Float -> Float -> Float - 303. builtin.Int.mod : Int + 316. builtin.Int.mod : Int -> Int -> Int - 304. builtin.Nat.mod : Nat + 317. builtin.Nat.mod : Nat -> Nat -> Nat - 305. builtin.io2.Clock.internals.monotonic : '{IO} Either + 318. builtin.io2.Clock.internals.monotonic : '{IO} Either Failure TimeSpec - 306. builtin.Int.negate : Int + 319. builtin.Int.negate : Int -> Int - 307. builtin.io2.MVar.new : a + 320. builtin.io2.MVar.new : a ->{IO} MVar a - 308. builtin.io2.TVar.new : a + 321. builtin.io2.TVar.new : a ->{STM} TVar a - 309. builtin.io2.MVar.newEmpty : '{IO} MVar + 322. builtin.io2.MVar.newEmpty : '{IO} MVar a - 310. builtin.io2.TVar.newIO : a + 323. builtin.io2.TVar.newIO : a ->{IO} TVar a - 311. builtin.Boolean.not : Boolean + 324. builtin.Boolean.not : Boolean -> Boolean - 312. builtin.io2.Clock.internals.nsec : TimeSpec + 325. builtin.io2.Clock.internals.nsec : TimeSpec -> Nat - 313. builtin.Int.or : Int + 326. builtin.Int.or : Int -> Int -> Int - 314. builtin.Nat.or : Nat + 327. builtin.Nat.or : Nat -> Nat -> Nat - 315. builtin.Int.popCount : Int + 328. builtin.Int.popCount : Int -> Nat - 316. builtin.Nat.popCount : Nat + 329. builtin.Nat.popCount : Nat -> Nat - 317. builtin.Float.pow : Float + 330. builtin.Float.pow : Float -> Float -> Float - 318. builtin.Int.pow : Int + 331. builtin.Int.pow : Int -> Nat -> Int - 319. builtin.Nat.pow : Nat + 332. builtin.Nat.pow : Nat -> Nat -> Nat - 320. builtin.io2.Clock.internals.processCPUTime : '{IO} Either + 333. builtin.io2.Clock.internals.processCPUTime : '{IO} Either Failure TimeSpec - 321. builtin.Ref.read : Ref g a + 334. builtin.ImmutableArray.read : ImmutableArray + a + -> Nat + ->{Exception} a + 335. builtin.MutableArray.read : MutableArray + g a + -> Nat + ->{g, + Exception} a + 336. builtin.Ref.read : Ref g a ->{g} a - 322. builtin.io2.TVar.read : TVar a + 337. builtin.io2.TVar.read : TVar a ->{STM} a - 323. builtin.io2.TVar.readIO : TVar a + 338. builtin.ImmutableByteArray.read16 : ImmutableByteArray + -> Nat + ->{Exception} Nat + 339. builtin.MutableByteArray.read16 : ImmutableByteArray + g + -> Nat + ->{g, + Exception} Nat + 340. builtin.ImmutableByteArray.read32 : ImmutableByteArray + -> Nat + ->{Exception} Nat + 341. builtin.MutableByteArray.read32 : ImmutableByteArray + g + -> Nat + ->{g, + Exception} Nat + 342. builtin.ImmutableByteArray.read64 : ImmutableByteArray + -> Nat + ->{Exception} Nat + 343. builtin.MutableByteArray.read64 : ImmutableByteArray + g + -> Nat + ->{g, + Exception} Nat + 344. builtin.ImmutableByteArray.read8 : ImmutableByteArray + -> Nat + ->{Exception} Nat + 345. builtin.MutableByteArray.read8 : ImmutableByteArray + g + -> Nat + ->{g, + Exception} Nat + 346. builtin.io2.TVar.readIO : TVar a ->{IO} a - 324. builtin.io2.Clock.internals.realtime : '{IO} Either + 347. builtin.io2.Clock.internals.realtime : '{IO} Either Failure TimeSpec - 325. builtin.io2.IO.ref : a + 348. builtin.io2.IO.ref : a ->{IO} Ref {IO} a - 326. builtin.Scope.ref : a + 349. builtin.Scope.ref : a ->{Scope s} Ref {Scope s} a - 327. builtin.Text.repeat : Nat + 350. builtin.Text.repeat : Nat -> Text -> Text - 328. builtin.io2.STM.retry : '{STM} a - 329. builtin.Float.round : Float + 351. builtin.io2.STM.retry : '{STM} a + 352. builtin.Float.round : Float -> Int - 330. builtin.Scope.run : (โˆ€ s. + 353. builtin.Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 331. builtin.io2.Clock.internals.sec : TimeSpec + 354. builtin.io2.Clock.internals.sec : TimeSpec -> Int - 332. builtin.Code.serialize : Code + 355. builtin.Code.serialize : Code -> Bytes - 333. builtin.Value.serialize : Value + 356. builtin.Value.serialize : Value -> Bytes - 334. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] + 357. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 335. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] + 358. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 336. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] + 359. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 337. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] + 360. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 338. builtin.io2.Tls.ClientConfig.versions.set : [Version] + 361. builtin.io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 339. builtin.io2.Tls.ServerConfig.versions.set : [Version] + 362. builtin.io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 340. builtin.Int.shiftLeft : Int + 363. builtin.Int.shiftLeft : Int -> Nat -> Int - 341. builtin.Nat.shiftLeft : Nat + 364. builtin.Nat.shiftLeft : Nat -> Nat -> Nat - 342. builtin.Int.shiftRight : Int + 365. builtin.Int.shiftRight : Int -> Nat -> Int - 343. builtin.Nat.shiftRight : Nat + 366. builtin.Nat.shiftRight : Nat -> Nat -> Nat - 344. builtin.Int.signum : Int + 367. builtin.Int.signum : Int -> Int - 345. builtin.Float.sin : Float + 368. builtin.Float.sin : Float -> Float - 346. builtin.Float.sinh : Float + 369. builtin.Float.sinh : Float -> Float - 347. builtin.Bytes.size : Bytes + 370. builtin.Bytes.size : Bytes -> Nat - 348. builtin.List.size : [a] + 371. builtin.List.size : [a] -> Nat - 349. builtin.Text.size : Text + 372. builtin.Text.size : Text -> Nat - 350. builtin.Float.sqrt : Float + 373. builtin.Float.sqrt : Float -> Float - 351. builtin.io2.IO.stdHandle : StdHandle + 374. builtin.io2.IO.stdHandle : StdHandle -> Handle - 352. builtin.Nat.sub : Nat + 375. builtin.Nat.sub : Nat -> Nat -> Int - 353. builtin.io2.TVar.swap : TVar a + 376. builtin.io2.TVar.swap : TVar a -> a ->{STM} a - 354. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int - 355. builtin.Bytes.take : Nat + 377. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int + 378. builtin.Bytes.take : Nat -> Bytes -> Bytes - 356. builtin.List.take : Nat + 379. builtin.List.take : Nat -> [a] -> [a] - 357. builtin.Text.take : Nat + 380. builtin.Text.take : Nat -> Text -> Text - 358. builtin.Float.tan : Float + 381. builtin.Float.tan : Float -> Float - 359. builtin.Float.tanh : Float + 382. builtin.Float.tanh : Float -> Float - 360. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either + 383. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either Failure TimeSpec - 361. builtin.Bytes.toBase16 : Bytes + 384. builtin.Bytes.toBase16 : Bytes -> Bytes - 362. builtin.Bytes.toBase32 : Bytes + 385. builtin.Bytes.toBase32 : Bytes -> Bytes - 363. builtin.Bytes.toBase64 : Bytes + 386. builtin.Bytes.toBase64 : Bytes -> Bytes - 364. builtin.Bytes.toBase64UrlUnpadded : Bytes + 387. builtin.Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 365. builtin.Text.toCharList : Text + 388. builtin.Text.toCharList : Text -> [Char] - 366. builtin.Int.toFloat : Int + 389. builtin.Int.toFloat : Int -> Float - 367. builtin.Nat.toFloat : Nat + 390. builtin.Nat.toFloat : Nat -> Float - 368. builtin.Nat.toInt : Nat + 391. builtin.Nat.toInt : Nat -> Int - 369. builtin.Bytes.toList : Bytes + 392. builtin.Bytes.toList : Bytes -> [Nat] - 370. builtin.Char.toNat : Char + 393. builtin.Char.toNat : Char -> Nat - 371. builtin.Float.toRepresentation : Float + 394. builtin.Float.toRepresentation : Float -> Nat - 372. builtin.Int.toRepresentation : Int + 395. builtin.Int.toRepresentation : Int -> Nat - 373. builtin.Char.toText : Char + 396. builtin.Char.toText : Char -> Text - 374. builtin.Float.toText : Float + 397. builtin.Float.toText : Float -> Text - 375. builtin.Handle.toText : Handle + 398. builtin.Handle.toText : Handle -> Text - 376. builtin.Int.toText : Int + 399. builtin.Int.toText : Int -> Text - 377. builtin.Nat.toText : Nat + 400. builtin.Nat.toText : Nat -> Text - 378. builtin.Socket.toText : Socket + 401. builtin.Socket.toText : Socket -> Text - 379. builtin.Link.Term.toText : Term + 402. builtin.Link.Term.toText : Term -> Text - 380. builtin.ThreadId.toText : ThreadId + 403. builtin.ThreadId.toText : ThreadId -> Text - 381. builtin.Text.toUtf8 : Text + 404. builtin.Text.toUtf8 : Text -> Bytes - 382. builtin.todo : a -> b - 383. builtin.Debug.trace : Text + 405. builtin.todo : a -> b + 406. builtin.Debug.trace : Text -> a -> () - 384. builtin.Int.trailingZeros : Int + 407. builtin.Int.trailingZeros : Int -> Nat - 385. builtin.Nat.trailingZeros : Nat + 408. builtin.Nat.trailingZeros : Nat -> Nat - 386. builtin.Float.truncate : Float + 409. builtin.Float.truncate : Float -> Int - 387. builtin.Int.truncate0 : Int + 410. builtin.Int.truncate0 : Int -> Nat - 388. builtin.io2.MVar.tryTake : MVar a + 411. builtin.io2.MVar.tryTake : MVar a ->{IO} Optional a - 389. builtin.Text.uncons : Text + 412. builtin.Text.uncons : Text -> Optional ( Char, Text) - 390. builtin.Any.unsafeExtract : Any + 413. builtin.Any.unsafeExtract : Any -> a - 391. builtin.Text.unsnoc : Text + 414. builtin.Text.unsnoc : Text -> Optional ( Text, Char) - 392. builtin.Code.validate : [( Term, + 415. builtin.Code.validate : [( Term, Code)] ->{IO} Optional Failure - 393. builtin.io2.validateSandboxed : [Term] + 416. builtin.io2.validateSandboxed : [Term] -> a -> Boolean - 394. builtin.Value.value : a + 417. builtin.Value.value : a -> Value - 395. builtin.Debug.watch : Text + 418. builtin.Debug.watch : Text + -> a -> a + 419. builtin.MutableArray.write : MutableArray + g a + -> Nat -> a - 396. builtin.Ref.write : Ref g a + ->{g, + Exception} () + 420. builtin.Ref.write : Ref g a -> a ->{g} () - 397. builtin.io2.TVar.write : TVar a + 421. builtin.io2.TVar.write : TVar a -> a ->{STM} () - 398. builtin.Int.xor : Int + 422. builtin.MutableByteArray.write16 : ImmutableByteArray + g + -> Nat + -> Nat + ->{g, + Exception} () + 423. builtin.MutableByteArray.write32 : ImmutableByteArray + g + -> Nat + -> Nat + ->{g, + Exception} () + 424. builtin.MutableByteArray.write64 : ImmutableByteArray + g + -> Nat + -> Nat + ->{g, + Exception} () + 425. builtin.MutableByteArray.write8 : ImmutableByteArray + g + -> Nat + -> Nat + ->{g, + Exception} () + 426. builtin.Int.xor : Int -> Int -> Int - 399. builtin.Nat.xor : Nat + 427. builtin.Nat.xor : Nat -> Nat -> Nat diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index 2c10714665..c51ef7fbb5 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #j7ar890fgd .old` to make an old namespace + `fork #8e6k8q9nsu .old` to make an old namespace accessible again, - `reset-root #j7ar890fgd` to reset the root namespace and + `reset-root #8e6k8q9nsu` to reset the root namespace and its history to that of the specified namespace. - 1. #396ap2v898 : add - 2. #j7ar890fgd : add - 3. #7eacs027uv : builtins.merge + 1. #r2injt702j : add + 2. #8e6k8q9nsu : add + 3. #tgct85ingr : builtins.merge 4. #sg60bvjo91 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index aeaa5fb227..fae0bf6e4f 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - โ–ก 1. #4vt616ak19 (start of history) + โ–ก 1. #svtklo709a (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #6k85v9fd02 + โŠ™ 1. #k7oo4v3lfh > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #0rpodsf1gq + โŠ™ 2. #cvqfq5n5g8 > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #4vt616ak19 (start of history) + โ–ก 3. #svtklo709a (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #6k85v9fd02 + โŠ™ 1. #k7oo4v3lfh > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #0rpodsf1gq + โŠ™ 2. #cvqfq5n5g8 > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #4vt616ak19 (start of history) + โ–ก 3. #svtklo709a (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - โ–ก 1. #4vt616ak19 (start of history) + โ–ก 1. #svtklo709a (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #h1ecefevst + โŠ™ 1. #feds6g84di - Deletes: Nat.* Nat.+ - โ–ก 2. #4vt616ak19 (start of history) + โ–ก 2. #svtklo709a (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From 399db85f2a3bf093258fd93e1a14f3cbbc037f7e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 9 Jun 2022 19:03:43 -0400 Subject: [PATCH 326/529] don't upload or fast-forward push at all if local == remote --- unison-cli/src/Unison/Share/Sync.hs | 60 +++++++++++++++-------------- 1 file changed, 32 insertions(+), 28 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index fa140171d4..b2be849e5c 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -148,34 +148,38 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash uploadProgress Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path)) Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path)) Right (Just (Share.hashJWTHash -> remoteHeadHash)) -> - Sqlite.runTransaction conn (fancyBfs localHeadHash remoteHeadHash) >>= \case - -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a - -- fast-forward push, so we don't bother trying - just report the error now. - Nothing -> pure (Left (FastForwardPushErrorNotFastForward path)) - Just localInnerHashes -> do - doUpload (localHeadHash :| localInnerHashes) >>= \case - False -> pure (Left (FastForwardPushErrorNoWritePermission path)) - True -> do - let doFastForwardPath = - httpFastForwardPath - httpClient - unisonShareUrl - Share.FastForwardPathRequest - { expectedHash = remoteHeadHash, - hashes = - causalHashToHash32 <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), - path - } - doFastForwardPath <&> \case - Share.FastForwardPathSuccess -> Right () - Share.FastForwardPathMissingDependencies (Share.NeedDependencies dependencies) -> - Left (FastForwardPushErrorServerMissingDependencies dependencies) - -- Weird: someone must have force-pushed no history here, or something. We observed a history at this - -- path but moments ago! - Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory path) - Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission path) - Share.FastForwardPathNotFastForward _ -> Left (FastForwardPushErrorNotFastForward path) - Share.FastForwardPathInvalidParentage (Share.InvalidParentage parent child) -> Left (FastForwardPushInvalidParentage parent child) + if localHeadHash == hash32ToCausalHash remoteHeadHash + then pure (Right ()) + else do + Sqlite.runTransaction conn (fancyBfs localHeadHash remoteHeadHash) >>= \case + -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a + -- fast-forward push, so we don't bother trying - just report the error now. + Nothing -> pure (Left (FastForwardPushErrorNotFastForward path)) + Just localInnerHashes -> do + doUpload (localHeadHash :| localInnerHashes) >>= \case + False -> pure (Left (FastForwardPushErrorNoWritePermission path)) + True -> do + let doFastForwardPath = + httpFastForwardPath + httpClient + unisonShareUrl + Share.FastForwardPathRequest + { expectedHash = remoteHeadHash, + hashes = + causalHashToHash32 <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), + path + } + doFastForwardPath <&> \case + Share.FastForwardPathSuccess -> Right () + Share.FastForwardPathMissingDependencies (Share.NeedDependencies dependencies) -> + Left (FastForwardPushErrorServerMissingDependencies dependencies) + -- Weird: someone must have force-pushed no history here, or something. We observed a history at + -- this path but moments ago! + Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory path) + Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission path) + Share.FastForwardPathNotFastForward _ -> Left (FastForwardPushErrorNotFastForward path) + Share.FastForwardPathInvalidParentage (Share.InvalidParentage parent child) -> + Left (FastForwardPushInvalidParentage parent child) where doUpload :: List.NonEmpty CausalHash -> IO Bool -- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes", but we From 382816e7b4eab2a9bb076731ff7ea460b22ce72b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 9 Jun 2022 23:42:07 -0400 Subject: [PATCH 327/529] extract unison-hashing-v2 package from unison-parser-typechecker --- hie.yaml | 69 +++++++++++------ parser-typechecker/package.yaml | 1 + .../unison-parser-typechecker.cabal | 19 +---- stack.yaml | 1 + unison-hashing-v2/package.yaml | 50 ++++++++++++ .../src/Unison/Hashing/V2/ABT.hs | 0 .../src/Unison/Hashing/V2/Branch.hs | 0 .../src/Unison/Hashing/V2/Causal.hs | 0 .../src/Unison/Hashing/V2/DataDeclaration.hs | 0 .../src/Unison/Hashing/V2/Hashable.hs | 0 .../src/Unison/Hashing/V2/Kind.hs | 0 .../src/Unison/Hashing/V2/Patch.hs | 0 .../src/Unison/Hashing/V2/Pattern.hs | 0 .../src/Unison/Hashing/V2/Reference.hs | 0 .../src/Unison/Hashing/V2/Reference/Util.hs | 0 .../src/Unison/Hashing/V2/Referent.hs | 0 .../src/Unison/Hashing/V2/Term.hs | 0 .../src/Unison/Hashing/V2/TermEdit.hs | 0 .../src/Unison/Hashing/V2/Tokenizable.hs | 0 .../src/Unison/Hashing/V2/Type.hs | 0 .../src/Unison/Hashing/V2/TypeEdit.hs | 0 unison-hashing-v2/unison-hashing-v2.cabal | 76 +++++++++++++++++++ 22 files changed, 175 insertions(+), 41 deletions(-) create mode 100644 unison-hashing-v2/package.yaml rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/ABT.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Branch.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Causal.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/DataDeclaration.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Hashable.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Kind.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Patch.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Pattern.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Reference.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Reference/Util.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Referent.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Term.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/TermEdit.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Tokenizable.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Type.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/TypeEdit.hs (100%) create mode 100644 unison-hashing-v2/unison-hashing-v2.cabal diff --git a/hie.yaml b/hie.yaml index 01a7d9d04e..56b1e20a6e 100644 --- a/hie.yaml +++ b/hie.yaml @@ -1,74 +1,95 @@ cradle: stack: - - path: "codebase2/codebase" + - path: "codebase2/codebase/./" component: "unison-codebase:lib" - - path: "codebase2/codebase-sqlite" + - path: "codebase2/codebase-sqlite/./" component: "unison-codebase-sqlite:lib" - - path: "codebase2/codebase-sync" + - path: "codebase2/codebase-sync/./" component: "unison-codebase-sync:lib" - - path: "codebase2/core" + - path: "codebase2/core/./" component: "unison-core:lib" - - path: "codebase2/util/bench" - component: "unison-util:bench:bench" - - path: "codebase2/util/src" component: "unison-util:lib" - - path: "codebase2/util-serialization" + - path: "codebase2/util/bench/Main.hs" + component: "unison-util:bench:bench" + + - path: "codebase2/util-serialization/./" component: "unison-util-serialization:lib" - - path: "codebase2/util-term" + - path: "codebase2/util-term/./" component: "unison-util-term:lib" - path: "lib/unison-prelude/src" component: "unison-prelude:lib" + - path: "lib/unison-pretty-printer/src" + component: "unison-pretty-printer:lib" + + - path: "lib/unison-pretty-printer/prettyprintdemo/Main.hs" + component: "unison-pretty-printer:exe:prettyprintdemo" + + - path: "lib/unison-pretty-printer/tests" + component: "unison-pretty-printer:test:pretty-printer-tests" + - path: "lib/unison-sqlite/src" component: "unison-sqlite:lib" - - path: "unison-share-api/src" - component: "unison-share-api:lib" - - path: "lib/unison-util-relation/src" component: "unison-util-relation:lib" - path: "lib/unison-util-relation/test" - component: "unison-util-relation:test:tests" + component: "unison-util-relation:test:util-relation-tests" - - path: "lib/unison-util-relation/benchmarks/relation" + - path: "lib/unison-util-relation/benchmarks/relation/Main.hs" component: "unison-util-relation:bench:relation" - path: "parser-typechecker/src" component: "unison-parser-typechecker:lib" - - path: "parser-typechecker/prettyprintdemo" - component: "unison-parser-typechecker:exe:prettyprintdemo" - - path: "parser-typechecker/tests" - component: "unison-parser-typechecker:exe:tests" + component: "unison-parser-typechecker:test:parser-typechecker-tests" - path: "unison-cli/src" component: "unison-cli:lib" - - path: "unison-cli/integration-tests" - component: "unison-cli:exe:integration-tests" + - path: "unison-cli/integration-tests/Suite.hs" + component: "unison-cli:exe:cli-integration-tests" - - path: "unison-cli/tests" - component: "unison-cli:test:tests" + - path: "unison-cli/integration-tests/IntegrationTests/ArgumentParsing.hs" + component: "unison-cli:exe:cli-integration-tests" - - path: "unison-cli/transcripts" + - path: "unison-cli/transcripts/Transcripts.hs" component: "unison-cli:exe:transcripts" - - path: "unison-cli/unison" + - path: "unison-cli/unison/Main.hs" component: "unison-cli:exe:unison" + - path: "unison-cli/unison/ArgParse.hs" + component: "unison-cli:exe:unison" + + - path: "unison-cli/unison/System/Path.hs" + component: "unison-cli:exe:unison" + + - path: "unison-cli/unison/Version.hs" + component: "unison-cli:exe:unison" + + - path: "unison-cli/tests" + component: "unison-cli:test:cli-tests" + - path: "unison-core/src" component: "unison-core1:lib" + - path: "unison-hashing-v2/src" + component: "unison-hashing-v2:lib" + + - path: "unison-share-api/src" + component: "unison-share-api:lib" + - path: "yaks/easytest/src" component: "easytest:lib" diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index ea57177157..2183c4dfa5 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -116,6 +116,7 @@ library: - unison-codebase-sync - unison-core - unison-core1 + - unison-hashing-v2 - unison-prelude - unison-pretty-printer - unison-sqlite diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 5be4084782..0e3fafe8a2 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack @@ -86,23 +86,7 @@ library Unison.DeclPrinter Unison.FileParser Unison.FileParsers - Unison.Hashing.V2.ABT - Unison.Hashing.V2.Branch - Unison.Hashing.V2.Causal Unison.Hashing.V2.Convert - Unison.Hashing.V2.DataDeclaration - Unison.Hashing.V2.Hashable - Unison.Hashing.V2.Kind - Unison.Hashing.V2.Patch - Unison.Hashing.V2.Pattern - Unison.Hashing.V2.Reference - Unison.Hashing.V2.Reference.Util - Unison.Hashing.V2.Referent - Unison.Hashing.V2.Term - Unison.Hashing.V2.TermEdit - Unison.Hashing.V2.Tokenizable - Unison.Hashing.V2.Type - Unison.Hashing.V2.TypeEdit Unison.Lexer Unison.NamePrinter Unison.Parser @@ -282,6 +266,7 @@ library , unison-codebase-sync , unison-core , unison-core1 + , unison-hashing-v2 , unison-prelude , unison-pretty-printer , unison-sqlite diff --git a/stack.yaml b/stack.yaml index c27a459300..f6445f6f84 100644 --- a/stack.yaml +++ b/stack.yaml @@ -14,6 +14,7 @@ packages: - parser-typechecker - unison-core - unison-cli +- unison-hashing-v2 - unison-share-api - codebase2/codebase - codebase2/codebase-sqlite diff --git a/unison-hashing-v2/package.yaml b/unison-hashing-v2/package.yaml new file mode 100644 index 0000000000..c1c1bed758 --- /dev/null +++ b/unison-hashing-v2/package.yaml @@ -0,0 +1,50 @@ +name: unison-hashing-v2 +github: unisonweb/unison +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors + +ghc-options: -Wall + +dependencies: + - base + - bytestring + - containers + - cryptonite + - lens + - memory + - semialign + - text + - unison-core1 + - unison-prelude + - unison-util + - unison-util-relation + +library: + source-dirs: src + when: + - condition: false + other-modules: Paths_unison_hashing_v2 + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveAnyClass + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - TupleSections + - TypeApplications + - ViewPatterns diff --git a/parser-typechecker/src/Unison/Hashing/V2/ABT.hs b/unison-hashing-v2/src/Unison/Hashing/V2/ABT.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/ABT.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/ABT.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Branch.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Branch.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Branch.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Branch.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Causal.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Causal.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Causal.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Causal.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs b/unison-hashing-v2/src/Unison/Hashing/V2/DataDeclaration.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/DataDeclaration.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Hashable.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Hashable.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Hashable.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Hashable.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Kind.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Kind.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Kind.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Kind.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Patch.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Patch.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Patch.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Patch.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Pattern.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Pattern.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Pattern.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Pattern.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Reference.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Reference.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Reference.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Reference.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Reference/Util.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Reference/Util.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Referent.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Referent.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Referent.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Referent.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Term.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Term.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Term.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Term.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/TermEdit.hs b/unison-hashing-v2/src/Unison/Hashing/V2/TermEdit.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/TermEdit.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/TermEdit.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Tokenizable.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Tokenizable.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Tokenizable.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Tokenizable.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Type.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Type.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Type.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/TypeEdit.hs b/unison-hashing-v2/src/Unison/Hashing/V2/TypeEdit.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/TypeEdit.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/TypeEdit.hs diff --git a/unison-hashing-v2/unison-hashing-v2.cabal b/unison-hashing-v2/unison-hashing-v2.cabal new file mode 100644 index 0000000000..033f89e05d --- /dev/null +++ b/unison-hashing-v2/unison-hashing-v2.cabal @@ -0,0 +1,76 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: unison-hashing-v2 +version: 0.0.0 +homepage: https://github.com/unisonweb/unison#readme +bug-reports: https://github.com/unisonweb/unison/issues +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors +build-type: Simple + +source-repository head + type: git + location: https://github.com/unisonweb/unison + +library + exposed-modules: + Unison.Hashing.V2.ABT + Unison.Hashing.V2.Branch + Unison.Hashing.V2.Causal + Unison.Hashing.V2.DataDeclaration + Unison.Hashing.V2.Hashable + Unison.Hashing.V2.Kind + Unison.Hashing.V2.Patch + Unison.Hashing.V2.Pattern + Unison.Hashing.V2.Reference + Unison.Hashing.V2.Reference.Util + Unison.Hashing.V2.Referent + Unison.Hashing.V2.Term + Unison.Hashing.V2.TermEdit + Unison.Hashing.V2.Tokenizable + Unison.Hashing.V2.Type + Unison.Hashing.V2.TypeEdit + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall + build-depends: + base + , bytestring + , containers + , cryptonite + , lens + , memory + , semialign + , text + , unison-core1 + , unison-prelude + , unison-util + , unison-util-relation + default-language: Haskell2010 From 40b372b898be10c69e07784cdb33e51dff6f686f Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 10 Jun 2022 11:24:48 -0400 Subject: [PATCH 328/529] remove unnecessary delete --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index a229c65501..e703171a2e 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -647,16 +647,14 @@ flushCausalDependents chId = do -- | `tryMoveTempEntityDependents #foo` does this: -- 0. Precondition: We just inserted object #foo. --- 0.5. look up the dependents of #foo --- 1. Delete #foo as dependency from temp_entity_missing_dependency. e.g. (#bar, #foo), (#baz, #foo) --- 2. Delete #foo from temp_entity (if it's there) +-- 1. Look up the dependents of #foo +-- 2. Delete #foo as dependency from temp_entity_missing_dependency. e.g. (#bar, #foo), (#baz, #foo) -- 3. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, -- insert_entity them. tryMoveTempEntityDependents :: Hash32 -> Transaction () tryMoveTempEntityDependents dependency = do dependents <- getMissingDependentsForTempEntity dependency execute deleteMissingDependency (Only dependency) - deleteTempEntity dependency traverse_ flushIfReadyToFlush dependents where deleteMissingDependency :: Sql From 0f6c485d7c017ee0d56545a541e0efa0e88a2568 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 10 Jun 2022 12:45:40 -0400 Subject: [PATCH 329/529] make part of trying to flush temp entities more efficient --- .../U/Codebase/Sqlite/Queries.hs | 39 ++++--------------- 1 file changed, 8 insertions(+), 31 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index e703171a2e..bc2dffda69 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -138,8 +138,6 @@ module U.Codebase.Sqlite.Queries entityExists, entityLocation, expectEntity, - getMissingDependentsForTempEntity, - getMissingDependencyJwtsForTempEntity, tempToSyncEntity, syncToTempEntity, insertTempEntity, @@ -653,16 +651,16 @@ flushCausalDependents chId = do -- insert_entity them. tryMoveTempEntityDependents :: Hash32 -> Transaction () tryMoveTempEntityDependents dependency = do - dependents <- getMissingDependentsForTempEntity dependency - execute deleteMissingDependency (Only dependency) + dependents <- + queryListCol + [here| + DELETE FROM temp_entity_missing_dependency + WHERE dependency = ? + RETURNING dependent + |] + (Only dependency) traverse_ flushIfReadyToFlush dependents where - deleteMissingDependency :: Sql - deleteMissingDependency = [here| - DELETE FROM temp_entity_missing_dependency - WHERE dependency = ? - |] - flushIfReadyToFlush :: Hash32 -> Transaction () flushIfReadyToFlush dependent = do readyToFlush dependent >>= \case @@ -1491,27 +1489,6 @@ entityExists hash = do -- then check if is causal hash or if object exists for hash id Just hashId -> isCausalHash hashId ||^ isObjectHash hashId -getMissingDependencyJwtsForTempEntity :: Hash32 -> Transaction (Maybe (NESet Text)) -getMissingDependencyJwtsForTempEntity h = do - jwts <- - queryListCol - [here| - SELECT dependencyJwt FROM temp_entity_missing_dependency - WHERE dependent = ? - |] - (Only h) - pure (NESet.nonEmptySet (Set.fromList jwts)) - -getMissingDependentsForTempEntity :: Hash32 -> Transaction [Hash32] -getMissingDependentsForTempEntity h = - queryListCol - [here| - SELECT dependent - FROM temp_entity_missing_dependency - WHERE dependency = ? - |] - (Only h) - -- | Insert a new `temp_entity` row, and its associated 1+ `temp_entity_missing_dependency` rows. -- -- Preconditions: From 06bdfa1e4e4214da8d41fda69e7fa22fdd5076e4 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 10 Jun 2022 14:04:16 -0400 Subject: [PATCH 330/529] bump direct-sqlite dep --- stack.yaml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/stack.yaml b/stack.yaml index adbe564c4d..2131f87644 100644 --- a/stack.yaml +++ b/stack.yaml @@ -49,6 +49,8 @@ extra-deps: - fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 - monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 - NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 +# Older vers bundle sqlite without support for 'delete returning' +- direct-sqlite-2.3.27 # not in lts-18.13 - recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 - lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 From 12e1c778b3931428b7199886f6b56b7b537a3072 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 10 Jun 2022 16:57:01 -0400 Subject: [PATCH 331/529] minor sql improvements --- .../U/Codebase/Sqlite/Queries.hs | 42 ++++++++-- stack.yaml.lock | 81 ++++++++++--------- 2 files changed, 79 insertions(+), 44 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index bc2dffda69..2f9bb88c28 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -16,6 +16,7 @@ module U.Codebase.Sqlite.Queries -- * hash table saveHash, + saveHashes, saveHashHash, loadHashId, expectHash, @@ -190,6 +191,7 @@ import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat import U.Codebase.Sqlite.Decode import U.Codebase.Sqlite.Entity (SyncEntity) import qualified U.Codebase.Sqlite.Entity as Entity +import qualified U.Codebase.Sqlite.LocalIds as LocalIds import qualified U.Codebase.Sqlite.NamedRef as S import U.Codebase.Sqlite.ObjectType (ObjectType (DeclComponent, Namespace, Patch, TermComponent)) import qualified U.Codebase.Sqlite.ObjectType as ObjectType @@ -273,6 +275,15 @@ saveHash hash = execute sql (Only hash) >> expectHashId hash ON CONFLICT DO NOTHING |] +saveHashes :: Traversable f => f Hash32 -> Transaction (f HashId) +saveHashes hashes = do + executeMany sql (coerce @[Hash32] @[Only Hash32] (Foldable.toList hashes)) + traverse expectHashId hashes + where sql = [here| + INSERT INTO hash (base32) VALUES (?) + ON CONFLICT DO NOTHING + |] + saveHashHash :: Hash -> Transaction HashId saveHashHash = saveHash . Hash32.fromHash @@ -333,9 +344,9 @@ expectBranchHash = coerce expectHash saveText :: Text -> Transaction TextId saveText t = execute saveTextSql (Only t) >> expectTextId t -saveTexts :: [Text] -> Transaction [TextId] +saveTexts :: Traversable f => f Text -> Transaction (f TextId) saveTexts texts = do - executeMany saveTextSql (coerce @[Text] @[Only Text] texts) + executeMany saveTextSql (coerce @[Text] @[Only Text] (Foldable.toList texts)) traverse expectTextId texts saveTextSql :: Sql @@ -741,6 +752,7 @@ expectTempEntity hash = do WHERE hash = ? |] +{- ORMOLU_ENABLE -} -- | look up all of the input entity's dependencies in the main table, to convert it to a sync entity tempToSyncEntity :: TempEntity -> Transaction SyncEntity tempToSyncEntity = \case @@ -760,7 +772,14 @@ tempToSyncEntity = \case tempToSyncDeclComponent = \case DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent decls) -> DeclFormat.SyncDecl . DeclFormat.SyncLocallyIndexedComponent - <$> Lens.traverseOf (traverse . Lens._1) (bitraverse saveText expectObjectIdForHash32) decls + <$> Lens.traverseOf + (traverse . Lens._1) + ( \LocalIds.LocalIds {textLookup, defnLookup} -> + LocalIds.LocalIds + <$> saveTexts textLookup + <*> traverse expectObjectIdForHash32 defnLookup + ) + decls tempToSyncNamespace :: TempEntity.TempNamespaceFormat -> Transaction NamespaceFormat.SyncBranchFormat tempToSyncNamespace = \case @@ -775,7 +794,7 @@ tempToSyncEntity = \case tempToSyncNamespaceLocalIds :: TempEntity.TempNamespaceLocalIds -> Transaction NamespaceFormat.BranchLocalIds tempToSyncNamespaceLocalIds (NamespaceFormat.LocalIds texts defns patches children) = NamespaceFormat.LocalIds - <$> (Vector.fromList <$> saveTexts (Vector.toList texts)) + <$> saveTexts texts <*> traverse expectObjectIdForHash32 defns <*> traverse expectPatchObjectIdForHash32 patches <*> traverse @@ -798,15 +817,24 @@ tempToSyncEntity = \case tempToSyncPatchLocalIds :: TempEntity.TempPatchLocalIds -> Transaction PatchFormat.PatchLocalIds tempToSyncPatchLocalIds (PatchFormat.LocalIds texts hashes defns) = PatchFormat.LocalIds - <$> (Vector.fromList <$> saveTexts (Vector.toList texts)) - <*> traverse saveHash hashes + <$> saveTexts texts + <*> saveHashes hashes <*> traverse expectObjectIdForHash32 defns tempToSyncTermComponent :: TempEntity.TempTermFormat -> Transaction TermFormat.SyncTermFormat tempToSyncTermComponent = \case TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent terms) -> TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent - <$> Lens.traverseOf (traverse . Lens._1) (bitraverse saveText expectObjectIdForHash32) terms + <$> Lens.traverseOf + (traverse . Lens._1) + ( \LocalIds.LocalIds {textLookup, defnLookup} -> + LocalIds.LocalIds + <$> saveTexts textLookup + <*> traverse expectObjectIdForHash32 defnLookup + ) + terms + +{- ORMOLU_DISABLE -} syncToTempEntity :: SyncEntity -> Transaction TempEntity syncToTempEntity = \case diff --git a/stack.yaml.lock b/stack.yaml.lock index 07ed778d63..e5bf4b29fa 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,122 +5,129 @@ packages: - completed: - sha256: d4fd87fb7bfc5d8e9fbc3e4ee7302c6b1500cdc00fdb9b659d0f4849b6ebe2d5 - name: configurator size: 15989 url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz + name: configurator + version: 0.3.0.0 + sha256: d4fd87fb7bfc5d8e9fbc3e4ee7302c6b1500cdc00fdb9b659d0f4849b6ebe2d5 pantry-tree: - sha256: 90547cd983fd15ebdc803e057d3ef8735fe93a75e29a00f8a74eadc13ee0f6e9 size: 955 - version: 0.3.0.0 + sha256: 90547cd983fd15ebdc803e057d3ef8735fe93a75e29a00f8a74eadc13ee0f6e9 original: url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz - completed: - sha256: 6d44207a4e94a16bc99d13dccbbb79bf676190c0476436b03235eeeaf6c72f9d - name: haskeline size: 75098 url: https://github.com/unisonweb/haskeline/archive/2944b11d19ee034c48276edc991736105c9d6143.tar.gz + name: haskeline + version: 0.7.5.0 + sha256: 6d44207a4e94a16bc99d13dccbbb79bf676190c0476436b03235eeeaf6c72f9d pantry-tree: - sha256: 878c7fb5801ec7418761a49b529ca3fdab274f22707c7d2759f2b3a2df06c3ea size: 3717 - version: 0.7.5.0 + sha256: 878c7fb5801ec7418761a49b529ca3fdab274f22707c7d2759f2b3a2df06c3ea original: url: https://github.com/unisonweb/haskeline/archive/2944b11d19ee034c48276edc991736105c9d6143.tar.gz - completed: - sha256: 94f9573735fefda868371ff735a6b1f52bea22b9e52289abeb8114c99bbf8832 - name: megaparsec size: 92490 url: https://github.com/unisonweb/megaparsec/archive/c4463124c578e8d1074c04518779b5ce5957af6b.tar.gz + name: megaparsec + version: 6.5.0 + sha256: 94f9573735fefda868371ff735a6b1f52bea22b9e52289abeb8114c99bbf8832 pantry-tree: - sha256: 7d3f8b23c862d878b4adce628caaf7bc337f0ac10b2556e1cdf0913c28a45929 size: 2635 - version: 6.5.0 + sha256: 7d3f8b23c862d878b4adce628caaf7bc337f0ac10b2556e1cdf0913c28a45929 original: url: https://github.com/unisonweb/megaparsec/archive/c4463124c578e8d1074c04518779b5ce5957af6b.tar.gz - completed: - sha256: 6e642163070a217cc3363bdbefde571ff6c1878f4fc3d92e9c910db7fa88eaf2 - name: shellmet size: 10460 url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz + name: shellmet + version: 0.0.4.0 + sha256: 6e642163070a217cc3363bdbefde571ff6c1878f4fc3d92e9c910db7fa88eaf2 pantry-tree: - sha256: 05a169a7a6b68100630e885054dc1821d31cd06571b0317ec90c75ac2c41aeb7 size: 654 - version: 0.0.4.0 + sha256: 05a169a7a6b68100630e885054dc1821d31cd06571b0317ec90c75ac2c41aeb7 original: url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz - completed: + hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 pantry-tree: - sha256: a33838b7b1c54f6ac3e1b436b25674948713a4189658e4d82e639b9a689bc90d size: 364 - hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 + sha256: a33838b7b1c54f6ac3e1b436b25674948713a4189658e4d82e639b9a689bc90d original: hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 - completed: + hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 pantry-tree: - sha256: a03f60a1250c9d0daaf208ba58ccf24e05e0807f2e3dc7892fad3f2f3a196f7f size: 476 - hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 + sha256: a03f60a1250c9d0daaf208ba58ccf24e05e0807f2e3dc7892fad3f2f3a196f7f original: hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 - completed: + hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 pantry-tree: - sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350 size: 3455 - hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 + sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350 original: hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 - completed: + hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 pantry-tree: - sha256: 876e5a679244143e2a7e74357427c7522a8d61f68a4cc3ae265fe4960b75a2e2 size: 212 - hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 + sha256: 876e5a679244143e2a7e74357427c7522a8d61f68a4cc3ae265fe4960b75a2e2 original: hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 - completed: + hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 pantry-tree: - sha256: 0e6c6d4f89083c8385de5adc4f36ad01b2b0ff45261b47f7d90d919969c8b5ed size: 542 - hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 + sha256: 0e6c6d4f89083c8385de5adc4f36ad01b2b0ff45261b47f7d90d919969c8b5ed original: hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 - completed: + hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 pantry-tree: - sha256: 8e049bd12ce2bd470909578f2ee8eb80b89d5ff88860afa30e29dd4eafecfa3e size: 713 - hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 + sha256: 8e049bd12ce2bd470909578f2ee8eb80b89d5ff88860afa30e29dd4eafecfa3e original: hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 - completed: + hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 pantry-tree: - sha256: d33d603a2f0d1a220ff0d5e7edb6273def89120e6bb958c2d836cae89e788334 size: 363 - hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 + sha256: d33d603a2f0d1a220ff0d5e7edb6273def89120e6bb958c2d836cae89e788334 original: hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 - completed: + hackage: direct-sqlite-2.3.27@sha256:94207d3018da3bda84bc6ce00d2c0236ced7edb37afbd726ed2a0bfa236e149b,3771 pantry-tree: - sha256: d87d84c3f760c1b2540f74e4a301cd4e8294df891e8e4262e8bdd313bc8e0bfd - size: 2410 + size: 770 + sha256: c7f5afe70db567e2cf9f3119b49f4b402705e6bd08ed8ba98747a64a8a0bef41 + original: + hackage: direct-sqlite-2.3.27 +- completed: hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 + pantry-tree: + size: 2410 + sha256: d87d84c3f760c1b2540f74e4a301cd4e8294df891e8e4262e8bdd313bc8e0bfd original: hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 - completed: + hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 pantry-tree: - sha256: 3634593ce191e82793ea0e060598ab3cf67f2ef2fe1d65345dc9335ad529d25f size: 718 - hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 + sha256: 3634593ce191e82793ea0e060598ab3cf67f2ef2fe1d65345dc9335ad529d25f original: hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 - completed: + hackage: http-client-0.7.11@sha256:3f59ac8ffe2a3768846cdda040a0d1df2a413960529ba61c839861c948871967,5756 pantry-tree: - sha256: 8372e84e9c710097f4f80f2016ca15a5a0cd7884b8ac5ce70f26b3110f4401bd size: 2547 - hackage: http-client-0.7.11@sha256:3f59ac8ffe2a3768846cdda040a0d1df2a413960529ba61c839861c948871967,5756 + sha256: 8372e84e9c710097f4f80f2016ca15a5a0cd7884b8ac5ce70f26b3110f4401bd original: hackage: http-client-0.7.11 snapshots: - completed: - sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 size: 590100 url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml + sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 original: lts-18.28 From cdfaa173d26754699ea26e2599ea1ff3da955ff7 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 10 Jun 2022 16:57:14 -0400 Subject: [PATCH 332/529] collate nocase on where clauses involving hash.base32 --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 2f9bb88c28..38db128efc 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -295,7 +295,7 @@ expectHashId hash = queryOneCol loadHashIdSql (Only hash) loadHashIdSql :: Sql loadHashIdSql = - [here| SELECT id FROM hash WHERE base32 = ? |] + [here| SELECT id FROM hash WHERE base32 = ? COLLATE NOCASE |] loadHashIdByHash :: Hash -> Transaction (Maybe HashId) loadHashIdByHash = loadHashId . Hash32.fromHash @@ -524,7 +524,7 @@ expectObjectIdForHash32 hash = do SELECT object.id FROM object JOIN hash ON object.primary_hash_id = hash.id - WHERE hash.base32 = ? + WHERE hash.base32 = ? COLLATE NOCASE |] (Only hash) @@ -545,7 +545,7 @@ expectBranchHashIdForHash32 = queryOneCol sql . Only INNER JOIN hash_object ON hash_object.object_id = object.id INNER JOIN hash ON hash_object.hash_id = hash.id WHERE object.type_id = 2 - AND hash.base32 = ? + AND hash.base32 = ? COLLATE NOCASE |] expectCausalHashIdForHash32 :: Hash32 -> Transaction CausalHashId @@ -555,7 +555,7 @@ expectCausalHashIdForHash32 = queryOneCol sql . Only [here| SELECT self_hash_id FROM causal INNER JOIN hash ON hash.id = self_hash_id - WHERE base32 = ? + WHERE base32 = ? COLLATE NOCASE |] loadPatchObjectIdForPrimaryHash :: PatchHash -> Transaction (Maybe PatchObjectId) @@ -991,7 +991,7 @@ loadCausalParentsByHash hash = FROM causal_parent cp JOIN hash h1 ON cp.causal_id = h1.id JOIN hash h2 ON cp.parent_id = h2.id - WHERE h1.base32 = ? + WHERE h1.base32 = ? COLLATE NOCASE |] (Only hash) From f842baa1518ff598713ded9dba6ec40f4c4a4d81 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 10 Jun 2022 17:37:14 -0400 Subject: [PATCH 333/529] delete unused import --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 38db128efc..48d1a3abb4 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -167,7 +167,6 @@ import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NESet import Data.String.Here.Uninterpolated (here, hereFile) import qualified Data.Vector as Vector import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) From 1d970904a30305b8b575402aea1d7cd45a04e57d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 10 Jun 2022 16:30:53 -0600 Subject: [PATCH 334/529] Use Output for credential failures (#3106) --- unison-cli/src/Unison/Auth/HTTPClient.hs | 20 ++++++----- .../src/Unison/Codebase/Editor/Output.hs | 2 +- .../src/Unison/Codebase/TranscriptParser.hs | 6 ++-- unison-cli/src/Unison/CommandLine/Main.hs | 2 +- unison-cli/src/Unison/Share/Sync.hs | 28 +--------------- unison-cli/src/Unison/Share/Sync/Types.hs | 33 +++++++++++++++++++ unison-cli/unison-cli.cabal | 1 + 7 files changed, 53 insertions(+), 39 deletions(-) create mode 100644 unison-cli/src/Unison/Share/Sync/Types.hs diff --git a/unison-cli/src/Unison/Auth/HTTPClient.hs b/unison-cli/src/Unison/Auth/HTTPClient.hs index ebc956760c..4b7b0c25ff 100644 --- a/unison-cli/src/Unison/Auth/HTTPClient.hs +++ b/unison-cli/src/Unison/Auth/HTTPClient.hs @@ -5,6 +5,8 @@ import Network.HTTP.Client (Request) import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTP import Unison.Auth.Tokens (TokenProvider) +import Unison.Codebase.Editor.Output (Output) +import qualified Unison.Codebase.Editor.Output as Output import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Prelude import Unison.Share.Types (codeserverIdFromURI) @@ -15,11 +17,11 @@ newtype AuthenticatedHttpClient = AuthenticatedHttpClient HTTP.Manager -- | Returns a new http manager which applies the appropriate Authorization header to -- any hosts our UCM is authenticated with. -newAuthenticatedHTTPClient :: MonadIO m => TokenProvider -> UCMVersion -> m AuthenticatedHttpClient -newAuthenticatedHTTPClient tokenProvider ucmVersion = liftIO $ do +newAuthenticatedHTTPClient :: MonadIO m => (Output v -> IO ()) -> TokenProvider -> UCMVersion -> m AuthenticatedHttpClient +newAuthenticatedHTTPClient responder tokenProvider ucmVersion = liftIO $ do let managerSettings = HTTP.tlsManagerSettings - & HTTP.addRequestMiddleware (authMiddleware tokenProvider) + & HTTP.addRequestMiddleware (authMiddleware responder tokenProvider) & HTTP.setUserAgent (HTTP.ucmUserAgent ucmVersion) AuthenticatedHttpClient <$> HTTP.newTlsManagerWith managerSettings @@ -28,12 +30,14 @@ newAuthenticatedHTTPClient tokenProvider ucmVersion = liftIO $ do -- and the request is likely to trigger a 401 response which the caller can detect and initiate a re-auth. -- -- If a host isn't associated with any credentials auth is omitted. -authMiddleware :: TokenProvider -> (Request -> IO Request) -authMiddleware tokenProvider req = do +authMiddleware :: (Output v -> IO ()) -> TokenProvider -> (Request -> IO Request) +authMiddleware responder tokenProvider req = do case codeserverIdFromURI $ (HTTP.getUri req) of -- If we can't identify an appropriate codeserver we pass it through without any auth. Left _ -> pure req Right codeserverHost -> do - tokenProvider codeserverHost <&> \case - Right token -> HTTP.applyBearerAuth (Text.encodeUtf8 token) req - Left _ -> req + tokenProvider codeserverHost >>= \case + Right token -> pure $ HTTP.applyBearerAuth (Text.encodeUtf8 token) req + Left err -> do + responder (Output.CredentialFailureMsg err) + pure req diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index b5498df726..2196ec69f1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -58,7 +58,7 @@ import qualified Unison.Reference as Reference import Unison.Referent (Referent) import Unison.Server.Backend (ShallowListEntry (..)) import Unison.Server.SearchResult' (SearchResult') -import qualified Unison.Share.Sync as Sync +import qualified Unison.Share.Sync.Types as Sync import Unison.ShortHash (ShortHash) import Unison.Term (Term) import Unison.Type (Type) diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index d5a606823a..d243700ad6 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -239,7 +239,6 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do AuthN.newTokenProvider credMan Just accessToken -> \_codeserverID -> pure $ Right accessToken - authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion pathRef <- newIORef initialPath rootBranchRef <- newIORef root numberedArgsRef <- newIORef [] @@ -382,6 +381,7 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do let f = LoadSuccess <$> readUtf8 (Text.unpack name) in f <|> pure InvalidSourceNameError + print :: Output.Output Symbol -> IO () print o = do msg <- notifyUser dir o errOk <- readIORef allowErrors @@ -392,6 +392,7 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do then writeIORef hasErrors True else dieWithMsg rendered + printNumbered :: Output.NumberedOutput Symbol -> IO Output.NumberedArgs printNumbered o = do let (msg, numberedArgs) = notifyNumbered o errOk <- readIORef allowErrors @@ -441,7 +442,8 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do "The transcript was expecting an error in the stanza above, but did not encounter one." ] - loop state = do + authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient print tokenProvider ucmVersion + let loop state = do writeIORef pathRef (view LoopState.currentPath state) let env = LoopState.Env diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index bcfc55a5bd..923568e792 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -195,7 +195,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba writeIORef pathRef (view LoopState.currentPath state) credMan <- newCredentialManager let tokenProvider = AuthN.newTokenProvider credMan - authorizedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion + authorizedHTTPClient <- AuthN.newAuthenticatedHTTPClient notify tokenProvider ucmVersion let env = LoopState.Env { LoopState.authHTTPClient = authorizedHTTPClient, diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index b2be849e5c..830050afe8 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -46,6 +46,7 @@ import U.Util.Hash32 (Hash32) import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import qualified Unison.Auth.HTTPClient as Auth import Unison.Prelude +import Unison.Share.Sync.Types import qualified Unison.Sqlite as Sqlite import qualified Unison.Sync.API as Share (API) import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash) @@ -56,12 +57,6 @@ import qualified Unison.Util.Set as Set ------------------------------------------------------------------------------------------------------------------------ -- Push --- | An error occurred while pushing code to Unison Share. -data CheckAndSetPushError - = CheckAndSetPushErrorHashMismatch Share.HashMismatch - | CheckAndSetPushErrorNoWritePermission Share.Path - | CheckAndSetPushErrorServerMissingDependencies (NESet Hash32) - -- | Push a causal to Unison Share. -- FIXME reword this checkAndSetPush :: @@ -117,16 +112,6 @@ checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash uplo newHash = causalHashToHash32 causalHash } --- | An error occurred while fast-forward pushing code to Unison Share. -data FastForwardPushError - = FastForwardPushErrorNoHistory Share.Path - | FastForwardPushErrorNoReadPermission Share.Path - | FastForwardPushErrorNotFastForward Share.Path - | FastForwardPushErrorNoWritePermission Share.Path - | FastForwardPushErrorServerMissingDependencies (NESet Hash32) - | -- Parent Child - FastForwardPushInvalidParentage Hash32 Hash32 - -- | Push a causal to Unison Share. -- FIXME reword this fastForwardPush :: @@ -313,12 +298,6 @@ dagbfs goal children = ------------------------------------------------------------------------------------------------------------------------ -- Pull --- | An error occurred while pulling code from Unison Share. -data PullError - = -- | An error occurred while resolving a repo+path to a causal hash. - PullErrorGetCausalHashByPath GetCausalHashByPathError - | PullErrorNoHistoryAtPath Share.Path - pull :: -- | The HTTP client to use for Unison Share requests. AuthenticatedHttpClient -> @@ -407,11 +386,6 @@ downloadEntities doDownload conn hashes = do ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path --- | An error occurred when getting causal hash by path. -data GetCausalHashByPathError - = -- | The user does not have permission to read this path. - GetCausalHashByPathErrorNoReadPermission Share.Path - -- | Get the causal hash of a path hosted on Unison Share. getCausalHashByPath :: -- | The HTTP client to use for Unison Share requests. diff --git a/unison-cli/src/Unison/Share/Sync/Types.hs b/unison-cli/src/Unison/Share/Sync/Types.hs new file mode 100644 index 0000000000..2167212ace --- /dev/null +++ b/unison-cli/src/Unison/Share/Sync/Types.hs @@ -0,0 +1,33 @@ +-- | Types used by the UCM client during sync. +module Unison.Share.Sync.Types where + +import Data.Set.NonEmpty (NESet) +import U.Util.Hash32 (Hash32) +import qualified Unison.Sync.Types as Share + +-- | Error used by the client when pushing code to Unison Share. +data CheckAndSetPushError + = CheckAndSetPushErrorHashMismatch Share.HashMismatch + | CheckAndSetPushErrorNoWritePermission Share.Path + | CheckAndSetPushErrorServerMissingDependencies (NESet Hash32) + +-- | An error occurred while fast-forward pushing code to Unison Share. +data FastForwardPushError + = FastForwardPushErrorNoHistory Share.Path + | FastForwardPushErrorNoReadPermission Share.Path + | FastForwardPushErrorNotFastForward Share.Path + | FastForwardPushErrorNoWritePermission Share.Path + | FastForwardPushErrorServerMissingDependencies (NESet Hash32) + | -- Parent Child + FastForwardPushInvalidParentage Hash32 Hash32 + +-- | An error occurred while pulling code from Unison Share. +data PullError + = -- | An error occurred while resolving a repo+path to a causal hash. + PullErrorGetCausalHashByPath GetCausalHashByPathError + | PullErrorNoHistoryAtPath Share.Path + +-- | An error occurred when getting causal hash by path. +data GetCausalHashByPathError + = -- | The user does not have permission to read this path. + GetCausalHashByPathErrorNoReadPermission Share.Path diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index d04b56ff22..4f441f5e76 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -62,6 +62,7 @@ library Unison.CommandLine.Welcome Unison.Share.Codeserver Unison.Share.Sync + Unison.Share.Sync.Types Unison.Util.HTTP hs-source-dirs: src From dbb42ba4a58cf44e339afdafd68eca2c5bdb33e2 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 11 Jun 2022 10:11:34 -0400 Subject: [PATCH 335/529] move hashjwt decoding up --- .../U/Codebase/Sqlite/Queries.hs | 23 ++++++++-------- unison-cli/src/Unison/Share/Sync.hs | 26 +++++++++++-------- 2 files changed, 27 insertions(+), 22 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 38db128efc..b60fb3d467 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -165,9 +165,9 @@ import qualified Data.Foldable as Foldable import qualified Data.List.Extra as List import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel +import Data.Map.NonEmpty (NEMap) +import qualified Data.Map.NonEmpty as NEMap import qualified Data.Set as Set -import Data.Set.NonEmpty (NESet) -import qualified Data.Set.NonEmpty as NESet import Data.String.Here.Uninterpolated (here, hereFile) import qualified Data.Vector as Vector import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) @@ -1522,12 +1522,13 @@ entityExists hash = do -- Preconditions: -- 1. The entity does not already exist in "main" storage (`object` / `causal`) -- 2. The entity does not already exist in `temp_entity`. -insertTempEntity :: Hash32 -> TempEntity -> NESet (Hash32, Text) -> Transaction () +insertTempEntity :: Hash32 -> TempEntity -> NEMap Hash32 Text -> Transaction () insertTempEntity entityHash entity missingDependencies = do execute [here| INSERT INTO temp_entity (hash, blob, type_id) VALUES (?, ?, ?) + ON CONFLICT DO NOTHING |] (entityHash, entityBlob, entityType) @@ -1536,7 +1537,7 @@ insertTempEntity entityHash entity missingDependencies = do INSERT INTO temp_entity_missing_dependency (dependent, dependency, dependencyJwt) VALUES (?, ?, ?) |] - (map (\(depHash, depHashJwt) -> (entityHash, depHash, depHashJwt)) (Foldable.toList missingDependencies)) + (map (\(depHash, depHashJwt) -> (entityHash, depHash, depHashJwt)) ((Foldable.toList . NEMap.toList) missingDependencies)) where entityBlob :: ByteString entityBlob = @@ -1616,21 +1617,21 @@ elaborateHashesClient hashes = do queryListColCheck_ [here| WITH RECURSIVE elaborated_dependency (hash, hashJwt) AS ( - SELECT dependency, dependencyJwt + SELECT temd.dependency, temd.dependencyJwt FROM new_temp_entity_dependents AS new - JOIN temp_entity_missing_dependency - ON new_temp_entity_dependents.dependent = new.hash + JOIN temp_entity_missing_dependency AS temd + ON temd.dependent = new.hash UNION SELECT temd.dependency, temd.dependencyJwt - FROM temp_entity_missing_dependency temd - JOIN elaborated_dependency ed + FROM temp_entity_missing_dependency AS temd + JOIN elaborated_dependency AS ed ON temd.dependent = ed.hash ) SELECT hashJwt FROM elaborated_dependency WHERE NOT EXISTS ( - SELECT FROM temp_entity - WHERE temp_entity.hash = elaborated_depdenency.hash + SELECT 1 FROM temp_entity + WHERE temp_entity.hash = elaborated_dependency.hash ) |] ( \case diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index b2be849e5c..7f68f06c4c 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -27,6 +27,7 @@ import Data.IORef (atomicModifyIORef', newIORef) import Data.List.NonEmpty (pattern (:|)) import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as List.NonEmpty +import qualified Data.Map as Map import Data.Map.NonEmpty (NEMap) import qualified Data.Map.NonEmpty as NEMap import Data.Proxy @@ -519,11 +520,16 @@ upsertEntitySomewhere hash entity = Q.entityLocation hash >>= \case Just location -> pure location Nothing -> do - missingDependencies0 <- - Set.filterM - (fmap not . Q.entityExists . Share.hashJWTHash) - (Share.entityDependencies entity) - case NESet.nonEmptySet missingDependencies0 of + missingDependencies1 :: Map Hash32 Share.HashJWT <- + Share.entityDependencies entity + & foldMapM + ( \hashJwt -> do + let hash = Share.hashJWTHash hashJwt + Q.entityExists hash <&> \case + True -> Map.empty + False -> Map.singleton hash hashJwt + ) + case NEMap.nonEmptyMap missingDependencies1 of Nothing -> do insertEntity hash entity pure Q.EntityInMainStorage @@ -542,17 +548,15 @@ insertEntity hash entity = do insertTempEntity :: Hash32 -> Share.Entity Text Hash32 Share.HashJWT -> - NESet Share.HashJWT -> + NEMap Hash32 Share.HashJWT -> Sqlite.Transaction () insertTempEntity hash entity missingDependencies = Q.insertTempEntity hash (entityToTempEntity Share.hashJWTHash entity) - ( NESet.map - ( \hashJwt -> - let Share.DecodedHashJWT {claims = Share.HashJWTClaims {hash}} = Share.decodeHashJWT hashJwt - in (hash, Share.unHashJWT hashJwt) - ) + ( coerce + @(NEMap Hash32 Share.HashJWT) + @(NEMap Hash32 Text) missingDependencies ) From 88ba24c102d1ee888ffdc82ba03dcd54d6621db7 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 11 Jun 2022 17:04:56 -0400 Subject: [PATCH 336/529] cleanup unused import --- unison-cli/src/Unison/Share/Sync.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 39a4075f28..838d5fad7d 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -53,7 +53,6 @@ import qualified Unison.Sync.API as Share (API) import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash) import qualified Unison.Sync.Types as Share import Unison.Util.Monoid (foldMapM) -import qualified Unison.Util.Set as Set ------------------------------------------------------------------------------------------------------------------------ -- Push From 2e003b1313b6eeab3498a4dc1e7bb55308fcdec8 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 11 Jun 2022 17:05:18 -0400 Subject: [PATCH 337/529] tweak sqlite package version comment --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 785e8974c1..e27aacd283 100644 --- a/stack.yaml +++ b/stack.yaml @@ -47,7 +47,7 @@ extra-deps: - fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 - monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 - NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 -# Older vers bundle sqlite without support for 'delete returning' +# 2.3.27 bundles sqlite >=3.35.0, needed for 'delete returning' - direct-sqlite-2.3.27 # not in lts-18.13 - recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 From dadadce745f8a3c046ab4dd1d9666b2c149eb23e Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Mon, 13 Jun 2022 10:50:10 -0400 Subject: [PATCH 338/529] indentation --- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 2be8d625d7..d701f0895c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -792,7 +792,7 @@ loop = do doDelete = do stepAt Branch.CompressHistory $ BranchUtil.makeDeleteBranch (resolveSplit' p) respond Success - -- Looks similar to the 'toDelete' above... investigate me! ;) + -- Looks similar to the 'toDelete' above... investigate me! ;) computeEndangerments :: Branch0 m1 -> Action' m v (Map LabeledDependency (NESet LabeledDependency)) computeEndangerments b0 = do let rootNames = Branch.toNames root0 From 65d735dc14c1f06877b8ca28897d8adebd8309c6 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Mon, 13 Jun 2022 10:54:37 -0400 Subject: [PATCH 339/529] merge trunk --- hie.yaml | 3 + parser-typechecker/package.yaml | 1 + .../unison-parser-typechecker.cabal | 20 +---- stack.yaml | 1 + unison-hashing-v2/package.yaml | 51 ++++++++++++ .../src/Unison/Hashing/V2/ABT.hs | 0 .../src/Unison/Hashing/V2/Branch.hs | 0 .../src/Unison/Hashing/V2/Causal.hs | 0 .../src/Unison/Hashing/V2/DataDeclaration.hs | 0 .../src/Unison/Hashing/V2/Hashable.hs | 0 .../src/Unison/Hashing/V2/Kind.hs | 0 .../src/Unison/Hashing/V2/Patch.hs | 0 .../src/Unison/Hashing/V2/Pattern.hs | 0 .../src/Unison/Hashing/V2/Reference.hs | 0 .../src/Unison/Hashing/V2/Reference/Util.hs | 0 .../src/Unison/Hashing/V2/Referent.hs | 0 .../src/Unison/Hashing/V2/Term.hs | 0 .../src/Unison/Hashing/V2/TermEdit.hs | 0 .../src/Unison/Hashing/V2/Tokenizable.hs | 0 .../src/Unison/Hashing/V2/Type.hs | 0 .../src/Unison/Hashing/V2/TypeEdit.hs | 0 unison-hashing-v2/unison-hashing-v2.cabal | 77 +++++++++++++++++++ 22 files changed, 136 insertions(+), 17 deletions(-) create mode 100644 unison-hashing-v2/package.yaml rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/ABT.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Branch.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Causal.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/DataDeclaration.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Hashable.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Kind.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Patch.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Pattern.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Reference.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Reference/Util.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Referent.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Term.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/TermEdit.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Tokenizable.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/Type.hs (100%) rename {parser-typechecker => unison-hashing-v2}/src/Unison/Hashing/V2/TypeEdit.hs (100%) create mode 100644 unison-hashing-v2/unison-hashing-v2.cabal diff --git a/hie.yaml b/hie.yaml index 91cc9aebad..b8d64de010 100644 --- a/hie.yaml +++ b/hie.yaml @@ -90,6 +90,9 @@ cradle: - path: "unison-core/src" component: "unison-core1:lib" + - path: "unison-hashing-v2/src" + component: "unison-hashing-v2:lib" + - path: "unison-share-api/src" component: "unison-share-api:lib" diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index b6bb5e95b4..a299927183 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -105,6 +105,7 @@ dependencies: - unison-codebase-sync - unison-core - unison-core1 + - unison-hashing-v2 - unison-prelude - unison-pretty-printer - unison-sqlite diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 5c78802761..3185b27d4b 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack @@ -87,23 +87,7 @@ library Unison.DeclPrinter Unison.FileParser Unison.FileParsers - Unison.Hashing.V2.ABT - Unison.Hashing.V2.Branch - Unison.Hashing.V2.Causal Unison.Hashing.V2.Convert - Unison.Hashing.V2.DataDeclaration - Unison.Hashing.V2.Hashable - Unison.Hashing.V2.Kind - Unison.Hashing.V2.Patch - Unison.Hashing.V2.Pattern - Unison.Hashing.V2.Reference - Unison.Hashing.V2.Reference.Util - Unison.Hashing.V2.Referent - Unison.Hashing.V2.Term - Unison.Hashing.V2.TermEdit - Unison.Hashing.V2.Tokenizable - Unison.Hashing.V2.Type - Unison.Hashing.V2.TypeEdit Unison.Lexer Unison.NamePrinter Unison.Parser @@ -287,6 +271,7 @@ library , unison-codebase-sync , unison-core , unison-core1 + , unison-hashing-v2 , unison-prelude , unison-pretty-printer , unison-sqlite @@ -467,6 +452,7 @@ test-suite parser-typechecker-tests , unison-codebase-sync , unison-core , unison-core1 + , unison-hashing-v2 , unison-parser-typechecker , unison-prelude , unison-pretty-printer diff --git a/stack.yaml b/stack.yaml index 785e8974c1..d479d739c0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -14,6 +14,7 @@ packages: - parser-typechecker - unison-core - unison-cli +- unison-hashing-v2 - unison-share-api - codebase2/codebase - codebase2/codebase-sqlite diff --git a/unison-hashing-v2/package.yaml b/unison-hashing-v2/package.yaml new file mode 100644 index 0000000000..f761b800ec --- /dev/null +++ b/unison-hashing-v2/package.yaml @@ -0,0 +1,51 @@ +name: unison-hashing-v2 +github: unisonweb/unison +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors + +ghc-options: -Wall + +dependencies: + - base + - bytestring + - containers + - cryptonite + - lens + - memory + - semialign + - text + - unison-core1 + - unison-prelude + - unison-util + - unison-util-base32hex + - unison-util-relation + +library: + source-dirs: src + when: + - condition: false + other-modules: Paths_unison_hashing_v2 + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveAnyClass + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - TupleSections + - TypeApplications + - ViewPatterns diff --git a/parser-typechecker/src/Unison/Hashing/V2/ABT.hs b/unison-hashing-v2/src/Unison/Hashing/V2/ABT.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/ABT.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/ABT.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Branch.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Branch.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Branch.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Branch.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Causal.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Causal.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Causal.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Causal.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs b/unison-hashing-v2/src/Unison/Hashing/V2/DataDeclaration.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/DataDeclaration.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/DataDeclaration.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Hashable.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Hashable.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Hashable.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Hashable.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Kind.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Kind.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Kind.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Kind.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Patch.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Patch.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Patch.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Patch.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Pattern.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Pattern.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Pattern.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Pattern.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Reference.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Reference.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Reference.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Reference.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Reference/Util.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Reference/Util.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Reference/Util.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Referent.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Referent.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Referent.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Referent.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Term.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Term.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Term.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Term.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/TermEdit.hs b/unison-hashing-v2/src/Unison/Hashing/V2/TermEdit.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/TermEdit.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/TermEdit.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Tokenizable.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Tokenizable.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Tokenizable.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Tokenizable.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Type.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/Type.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/Type.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/TypeEdit.hs b/unison-hashing-v2/src/Unison/Hashing/V2/TypeEdit.hs similarity index 100% rename from parser-typechecker/src/Unison/Hashing/V2/TypeEdit.hs rename to unison-hashing-v2/src/Unison/Hashing/V2/TypeEdit.hs diff --git a/unison-hashing-v2/unison-hashing-v2.cabal b/unison-hashing-v2/unison-hashing-v2.cabal new file mode 100644 index 0000000000..a302b8b554 --- /dev/null +++ b/unison-hashing-v2/unison-hashing-v2.cabal @@ -0,0 +1,77 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.7. +-- +-- see: https://github.com/sol/hpack + +name: unison-hashing-v2 +version: 0.0.0 +homepage: https://github.com/unisonweb/unison#readme +bug-reports: https://github.com/unisonweb/unison/issues +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors +build-type: Simple + +source-repository head + type: git + location: https://github.com/unisonweb/unison + +library + exposed-modules: + Unison.Hashing.V2.ABT + Unison.Hashing.V2.Branch + Unison.Hashing.V2.Causal + Unison.Hashing.V2.DataDeclaration + Unison.Hashing.V2.Hashable + Unison.Hashing.V2.Kind + Unison.Hashing.V2.Patch + Unison.Hashing.V2.Pattern + Unison.Hashing.V2.Reference + Unison.Hashing.V2.Reference.Util + Unison.Hashing.V2.Referent + Unison.Hashing.V2.Term + Unison.Hashing.V2.TermEdit + Unison.Hashing.V2.Tokenizable + Unison.Hashing.V2.Type + Unison.Hashing.V2.TypeEdit + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall + build-depends: + base + , bytestring + , containers + , cryptonite + , lens + , memory + , semialign + , text + , unison-core1 + , unison-prelude + , unison-util + , unison-util-base32hex + , unison-util-relation + default-language: Haskell2010 From 243f3633696a31ab3e08b59cd9cc367b46954887 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 13 Jun 2022 10:34:53 -0600 Subject: [PATCH 340/529] Skip all the extra claims on HashJWTs (#3107) * Simplify hashjwt claims * update json instances * Add jwt type to the hashjwt Co-authored-by: Mitchell Rosen --- unison-share-api/src/Unison/Sync/Types.hs | 37 +++++++++++++++-------- 1 file changed, 24 insertions(+), 13 deletions(-) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 6e842cc77a..6e8e12c638 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -70,7 +70,7 @@ module Unison.Sync.Types ) where -import Control.Lens (both, ix, traverseOf, (^?)) +import Control.Lens (both, folding, ix, traverseOf, (^?)) import qualified Crypto.JWT as Jose import Data.Aeson import qualified Data.Aeson as Aeson @@ -151,32 +151,43 @@ hashJWTHash = decodedHashJWTHash . decodeHashJWT data HashJWTClaims = HashJWTClaims - { hash :: Hash32 - -- Currently unused - -- entityType :: EntityType + { hash :: Hash32, + userId :: Text } deriving stock (Show, Eq, Ord) +-- | Adding a type tag to the jwt prevents users from using jwts we issue for other things +-- in this spot. All of our jwts should have a type parameter of some kind. +hashJWTType :: String +hashJWTType = "hj" + instance ToJWT HashJWTClaims where - encodeJWT (HashJWTClaims h) = - Jose.addClaim "h" (toJSON h) Jose.emptyClaimsSet + encodeJWT (HashJWTClaims h u) = + Jose.emptyClaimsSet + & Jose.addClaim "h" (toJSON h) + & Jose.addClaim "u" (toJSON u) + & Jose.addClaim "t" (toJSON hashJWTType) instance FromJWT HashJWTClaims where - decodeJWT claims = case claims ^? Jose.unregisteredClaims . ix "h" of - Nothing -> Left "Missing 'h' claim on HashJWT" - Just v - | Success hash <- fromJSON v -> Right $ HashJWTClaims hash - | otherwise -> Left "Invalid hash at 'h' claim in HashJWT" + decodeJWT claims = maybe (Left "Invalid HashJWTClaims") pure $ do + hash <- claims ^? Jose.unregisteredClaims . ix "h" . folding fromJSON + userId <- claims ^? Jose.unregisteredClaims . ix "u" . folding fromJSON + case claims ^? Jose.unregisteredClaims . ix "t" . folding fromJSON of + Just t | t == hashJWTType -> pure () + _ -> empty + pure $ HashJWTClaims {..} instance ToJSON HashJWTClaims where - toJSON (HashJWTClaims hash) = + toJSON (HashJWTClaims hash userId) = object - [ "h" .= hash + [ "h" .= hash, + "u" .= userId ] instance FromJSON HashJWTClaims where parseJSON = Aeson.withObject "HashJWTClaims" \obj -> do hash <- obj .: "h" + userId <- obj .: "u" pure HashJWTClaims {..} -- | A decoded hash JWT that retains the original encoded JWT. From 8c3ced61bcc4e279b699ed1e85d9786f57dd67ab Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 13 Jun 2022 21:35:03 -0400 Subject: [PATCH 341/529] Delete Unison.ABT.ABT and Unison.ABT.Term Replace with re-exports from U.Core.ABT --- codebase2/core/U/Core/ABT.hs | 28 +-- codebase2/core/package.yaml | 27 +++ codebase2/core/unison-core.cabal | 28 ++- parser-typechecker/package.yaml | 1 + parser-typechecker/src/Unison/PrintError.hs | 3 +- parser-typechecker/src/Unison/Runtime/ANF.hs | 7 +- parser-typechecker/src/Unison/TermParser.hs | 13 +- parser-typechecker/src/Unison/TermPrinter.hs | 7 +- .../src/Unison/Typechecker/Context.hs | 33 +-- .../unison-parser-typechecker.cabal | 1 + unison-core/package.yaml | 1 + unison-core/src/Unison/ABT.hs | 194 +++++------------- unison-core/src/Unison/Term.hs | 4 +- unison-core/src/Unison/Type.hs | 2 +- unison-core/unison-core1.cabal | 1 + 15 files changed, 151 insertions(+), 199 deletions(-) diff --git a/codebase2/core/U/Core/ABT.hs b/codebase2/core/U/Core/ABT.hs index 93fa8c3682..11e28d042d 100644 --- a/codebase2/core/U/Core/ABT.hs +++ b/codebase2/core/U/Core/ABT.hs @@ -1,15 +1,4 @@ -{-# LANGUAGE BlockArguments #-} -- Based on: http://semantic-domain.blogspot.com/2015/03/abstract-binding-trees.html -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE Rank2Types #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE ViewPatterns #-} module U.Core.ABT where @@ -19,6 +8,7 @@ import Data.Functor.Identity (Identity (runIdentity)) import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as Set +import GHC.Generics (Generic) import Prelude hiding (abs, cycle) data ABT f v r @@ -31,16 +21,12 @@ data ABT f v r -- | At each level in the tree, we store the set of free variables and -- a value of type `a`. Variables are of type `v`. data Term f v a = Term {freeVars :: Set v, annotation :: a, out :: ABT f v (Term f v a)} - deriving (Functor, Foldable, Traversable) + deriving (Functor, Foldable, Generic, Traversable) deriving instance (forall q. Show q => Show (f q), Show v, Show a) => Show (Term f v a) amap :: (Functor f, Foldable f) => (a -> a') -> Term f v a -> Term f v a' -amap f (Term fv a out) = Term fv (f a) $ case out of - Var v -> Var v - Tm fa -> Tm (amap f <$> fa) - Cycle r -> Cycle (amap f r) - Abs v body -> Abs v (amap f body) +amap = fmap vmap :: (Functor f, Foldable f, Ord v') => (v -> v') -> Term f v a -> Term f v' a vmap f (Term _ a out) = case out of @@ -104,7 +90,7 @@ visit f t = flip fromMaybe (f t) $ case out t of -- | Apply an effectful function to an ABT tree top down, sequencing the results. visit' :: - (Traversable f, Applicative g, Monad g, Ord v) => + (Traversable f, Monad g, Ord v) => (f (Term f v a) -> g (f (Term f v a))) -> Term f v a -> g (Term f v a) @@ -116,7 +102,7 @@ visit' f t = case out t of -- | Apply an effectful function to an ABT tree top down, sequencing the results. visit_ :: - (Traversable f, Applicative g, Monad g, Ord v) => + (Traversable f, Monad g, Ord v) => (f (Term f v a) -> g ()) -> Term f v a -> g (Term f v a) @@ -135,7 +121,7 @@ visitPure :: visitPure f = runIdentity . visit (fmap pure . f) foreachSubterm :: - (Traversable f, Applicative g, Ord v) => + (Traversable f, Applicative g) => (Term f v a -> g b) -> Term f v a -> g [b] @@ -162,6 +148,8 @@ pattern Cycle' vs t <- Term _ _ (Cycle (AbsN' vs t)) pattern AbsN' :: [v] -> Term f v a -> Term f v a pattern AbsN' vs body <- (unabs -> (vs, body)) +{-# COMPLETE AbsN' #-} + pattern Tm' :: f (Term f v a) -> Term f v a pattern Tm' f <- Term _ _ (Tm f) diff --git a/codebase2/core/package.yaml b/codebase2/core/package.yaml index db979d9664..35b511ae9a 100644 --- a/codebase2/core/package.yaml +++ b/codebase2/core/package.yaml @@ -12,3 +12,30 @@ dependencies: - containers - vector - unison-util + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveAnyClass + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - QuantifiedConstraints + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeApplications + - ViewPatterns diff --git a/codebase2/core/unison-core.cabal b/codebase2/core/unison-core.cabal index 82ba9672db..23e8ec6a6d 100644 --- a/codebase2/core/unison-core.cabal +++ b/codebase2/core/unison-core.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 7b810bbd4d380ccd76c363eac447c7233c7b0e9d968960547c00d20ac3edeb08 +-- hash: c95852b01c310af9965bbec9dfa7637e97148815d674788512bd1748a1858314 name: unison-core version: 0.0.0 @@ -22,6 +22,32 @@ library U.Core.ABT.Var hs-source-dirs: ./ + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + QuantifiedConstraints + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + ViewPatterns build-depends: base , containers diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 2183c4dfa5..f4c8bf9514 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -74,6 +74,7 @@ library: - primitive - random >= 1.2.0 - raw-strings-qq + - recover-rtti - regex-base - regex-tdfa - safe diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index b72c41b7d4..0c23268e25 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -17,6 +17,7 @@ import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NES import qualified Data.Text as Text +import Debug.RecoverRTTI (anythingToString) import qualified Text.Megaparsec as P import qualified Unison.ABT as ABT import Unison.Builtin.Decls (pattern TupleType') @@ -934,7 +935,7 @@ renderType env f t = renderType0 env f (0 :: Int) (Type.removePureEffects t) then go 0 body else "forall " <> spaces renderVar vs <> " . " <> go 1 body Type.Var' v -> renderVar v - _ -> error $ "pattern match failure in PrintError.renderType " ++ show t + _ -> error $ "pattern match failure in PrintError.renderType " ++ anythingToString t where go = renderType0 env f diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index befffdc9b2..55b73dab03 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -81,6 +81,7 @@ import Data.List hiding (and, or) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Data.Text +import Debug.RecoverRTTI (anythingToString) import GHC.Stack (CallStack, callStack) import qualified Unison.ABT as ABT import qualified Unison.ABT.Normalized as ABTN @@ -1083,7 +1084,7 @@ toSuperNormal :: Var v => Term v a -> ANFM v (SuperNormal v) toSuperNormal tm = do grp <- groupVars if not . Set.null . (Set.\\ grp) $ freeVars tm - then internalBug $ "free variables in supercombinator: " ++ show tm + then internalBug $ "free variables in supercombinator: " ++ anythingToString tm else Lambda (BX <$ vs) . ABTN.TAbss vs . snd <$> bindLocal vs (anfTerm body) @@ -1354,7 +1355,7 @@ anfBlock (TypeLink' r) = pure (mempty, pure . TLit $ LY r) anfBlock (List' as) = fmap (pure . TPrm BLDS) <$> anfArgs tms where tms = toList as -anfBlock t = internalBug $ "anf: unhandled term: " ++ show t +anfBlock t = internalBug $ "anf: unhandled term: " ++ anythingToString t -- Note: this assumes that patterns have already been translated -- to a state in which every case matches a single layer of data, @@ -1716,7 +1717,7 @@ prettyBranches ind bs = case bs of s (mapToList $ snd <$> m) ) - (prettyCase ind (prettyReq (0::Int) (0::Int)) df id) + (prettyCase ind (prettyReq (0 :: Int) (0 :: Int)) df id) (Map.toList bs) MatchSum bs -> foldr diff --git a/parser-typechecker/src/Unison/TermParser.hs b/parser-typechecker/src/Unison/TermParser.hs index 84c2802a85..b7cdc88b93 100644 --- a/parser-typechecker/src/Unison/TermParser.hs +++ b/parser-typechecker/src/Unison/TermParser.hs @@ -19,6 +19,7 @@ import qualified Data.Sequence as Sequence import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Tuple.Extra as TupleE +import Debug.RecoverRTTI (anythingToString) import qualified Text.Megaparsec as P import qualified Unison.ABT as ABT import qualified Unison.Builtin.Decls as DD @@ -656,7 +657,7 @@ docNormalize tm = case tm of (normalize seqs) where - _ -> error $ "unexpected doc structure: " ++ show tm + _ -> error $ "unexpected doc structure: " ++ anythingToString tm where normalize = Sequence.fromList . (map TupleE.fst3) @@ -804,7 +805,7 @@ docNormalize tm = case tm of -- See test2 in transcript doc-formatting.md for an example of how -- this looks when there is whitespace immediately following @[source] -- or @[evaluate]. - lastLines :: Show v => Sequence.Seq (Term v a) -> [Maybe UnbreakCase] + lastLines :: Sequence.Seq (Term v a) -> [Maybe UnbreakCase] lastLines tms = (flip fmap) (toList tms) $ \case DD.DocBlob txt -> unbreakCase txt DD.DocLink _ -> Nothing @@ -812,7 +813,7 @@ docNormalize tm = case tm of DD.DocSignature _ -> Nothing DD.DocEvaluate _ -> Nothing Term.Var' _ -> Nothing -- @[include] - e@_ -> error ("unexpected doc element: " ++ show e) + e@_ -> error ("unexpected doc element: " ++ anythingToString e) -- Work out whether the last line of this blob is indented (or maybe -- terminated by a newline.) unbreakCase :: Text -> Maybe UnbreakCase @@ -873,7 +874,7 @@ docNormalize tm = case tm of DD.DocSignature _ -> False DD.DocEvaluate _ -> False Term.Var' _ -> False -- @[include] - _ -> error ("unexpected doc element" ++ show tm) + _ -> error ("unexpected doc element" ++ anythingToString tm) -- A list whose entries match those of tms. Can the subsequent entry by a -- line continuation of this one? followingLines tms = drop 1 ((continuesLine tms) ++ [False]) @@ -882,9 +883,9 @@ docNormalize tm = case tm of [] -> [] x : rest -> (fFirst x) : (map fRest rest) mapExceptLast fRest fLast = reverse . (mapExceptFirst fRest fLast) . reverse - tracing :: Show a => [Char] -> a -> a + tracing :: [Char] -> a -> a tracing when x = - (const id $ trace ("at " ++ when ++ ": " ++ (show x) ++ "\n")) x + (const id $ trace ("at " ++ when ++ ": " ++ anythingToString x ++ "\n")) x blob aa ac at txt = Term.app aa (Term.constructor ac (ConstructorReference DD.docRef DD.docBlobId)) (Term.text at txt) join aa ac as segs = diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index 852dd116dc..b80dac688c 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -13,6 +13,7 @@ import qualified Data.Set as Set import Data.Text (unpack) import qualified Data.Text as Text import Data.Vector () +import Debug.RecoverRTTI (anythingToString) import qualified Text.Show.Unicode as U import Unison.ABT (annotation, reannotateUp, pattern AbsN') import qualified Unison.ABT as ABT @@ -785,7 +786,7 @@ prettyBinding0 env a@AmbientContext {imports = im, docContext = doc} v term = in PP.group $ PP.group (defnLhs v vs <> fmt S.BindingEquals " =") `hang` uses [pretty0 env (ac (-1) Block im' doc) body'] - t -> l "error: " <> l (show t) + t -> l "error: " <> l (anythingToString t) where defnLhs v vs | infix' = case vs of @@ -848,7 +849,7 @@ prettyDoc n im term = go (DD.DocEvaluate (TermLink' r)) = atKeyword "evaluate" <> fmtTerm r go (Ref' r) = atKeyword "include" <> fmtTerm (Referent.Ref r) - go _ = l $ "(invalid doc literal: " ++ show term ++ ")" + go _ = l $ "(invalid doc literal: " ++ anythingToString term ++ ")" fmtName s = styleHashQualified'' (fmt $ S.HashQualifier s) $ elideFQN im s fmtTerm r = fmtName $ PrettyPrintEnv.termName n r fmtType r = fmtName $ PrettyPrintEnv.typeName n r @@ -1353,7 +1354,7 @@ immediateChildBlockTerms = \case handleDelay _ = [] doLet (v, Ann' tm _) = doLet (v, tm) doLet (v, LamsNamedOpt' _ body) = [body | not (isBlank $ Var.nameStr v)] - doLet t = error (show t) [] + doLet t = error (anythingToString t) [] -- Matches with a single case, no variable shadowing, and where the pattern -- has no literals are treated as destructuring bind, for instance: diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 1c552407f3..30d015e4cc 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -63,6 +63,7 @@ import Data.Sequence.NonEmpty (NESeq) import qualified Data.Sequence.NonEmpty as NESeq import qualified Data.Set as Set import qualified Data.Text as Text +import Debug.RecoverRTTI (anythingToString) import qualified Unison.ABT as ABT import qualified Unison.Blank as B import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) @@ -623,7 +624,7 @@ wellformedType c t = case t of Type.Forall' t' -> let (v, ctx2) = extendUniversal c in wellformedType ctx2 (ABT.bind t' (universal' (ABT.annotation t) v)) - _ -> error $ "Match failure in wellformedType: " ++ show t + _ -> error $ "Match failure in wellformedType: " ++ anythingToString t where -- Extend this `Context` with a single variable, guaranteed fresh extendUniversal ctx = @@ -659,14 +660,14 @@ extend' e c@(Context ctx) = Context . (: ctx) . (e,) <$> i' -- SolvedEvarCtx - ensure `v` is fresh, and the solution is well-formed wrt the context Solved _ v sa@(Type.getPolytype -> t) | Set.member v vs -> crash $ "variable " <> show v <> " already defined in the context" - | not (wellformedType c t) -> crash $ "type " <> show t <> " is not well-formed wrt the context" + | not (wellformedType c t) -> crash $ "type " <> anythingToString t <> " is not well-formed wrt the context" | otherwise -> pure $ Info (Set.insert v es) (Map.insert v sa ses) us uas (Set.insert v vs) pvs -- VarCtx - ensure `v` is fresh, and annotation is well-formed wrt the context Ann v t | Set.member v vs -> crash $ "variable " <> show v <> " already defined in the context" - | not (wellformedType c t) -> crash $ "type " <> show t <> " is not well-formed wrt the context" + | not (wellformedType c t) -> crash $ "type " <> anythingToString t <> " is not well-formed wrt the context" | otherwise -> pure $ Info @@ -818,7 +819,7 @@ apply' solvedExistentials t = go t Type.Effects' es -> Type.effects a (map go es) Type.ForallNamed' v t' -> Type.forall a v (go t') Type.IntroOuterNamed' v t' -> Type.introOuter a v (go t') - _ -> error $ "Match error in Context.apply': " ++ show t + _ -> error $ "Match error in Context.apply': " ++ anythingToString t where a = ABT.annotation t @@ -863,7 +864,7 @@ synthesizeApp :: (Term v loc, Int) -> M v loc (Type v loc, Wanted v loc) synthesizeApp _ ft arg - | debugEnabled && traceShow ("synthesizeApp" :: String, ft, arg) False = + | debugEnabled && traceShow ("synthesizeApp" :: String, anythingToString ft, anythingToString arg) False = undefined synthesizeApp fun (Type.stripIntroOuters -> Type.Effect'' es ft) argp@(arg, argNum) = scope (InSynthesizeApp ft arg argNum) $ do @@ -978,7 +979,7 @@ synthesize :: Ord loc => Term v loc -> M v loc (Type v loc, Wanted v loc) -synthesize e | debugShow ("synthesize" :: String, e) = undefined +synthesize e | debugShow ("synthesize" :: String, anythingToString e) = undefined synthesize e = scope (InSynthesize e) $ case minimize' e of Left es -> failWith (DuplicateDefinitions es) @@ -1291,7 +1292,7 @@ checkPattern :: Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)] -checkPattern tx ty | (debugEnabled || debugPatternsEnabled) && traceShow ("checkPattern" :: String, tx, ty) False = undefined +checkPattern tx ty | (debugEnabled || debugPatternsEnabled) && traceShow ("checkPattern" :: String, anythingToString tx, anythingToString ty) False = undefined checkPattern scrutineeType p = case p of Pattern.Unbound _ -> pure [] @@ -1942,7 +1943,7 @@ defaultAbility _ = pure False -- Expects a fully substituted type, so that it is unnecessary to -- check if an existential in the type has been solved. discardCovariant :: Var v => Set v -> Type v loc -> Type v loc -discardCovariant _ ty | debugShow ("discardCovariant" :: Text, ty) = undefined +discardCovariant _ ty | debugShow ("discardCovariant" :: Text, anythingToString ty) = undefined discardCovariant gens ty = ABT.rewriteDown (strip $ keepVarsT True ty) ty where @@ -2117,7 +2118,7 @@ check :: Term v loc -> Type v loc -> M v loc (Wanted v loc) -check m t | debugShow ("check" :: String, m, t) = undefined +check m t | debugShow ("check" :: String, anythingToString m, anythingToString t) = undefined check m0 t0 = scope (InCheck m0 t0) $ do ctx <- getContext case minimize' m0 of @@ -2133,7 +2134,7 @@ check m0 t0 = scope (InCheck m0 t0) $ do -- | `subtype ctx t1 t2` returns successfully if `t1` is a subtype of `t2`. -- This may have the effect of altering the context. subtype :: forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> M v loc () -subtype tx ty | debugEnabled && traceShow ("subtype" :: String, tx, ty) False = undefined +subtype tx ty | debugEnabled && traceShow ("subtype" :: String, anythingToString tx, anythingToString ty) False = undefined subtype tx ty = scope (InSubtype tx ty) $ do ctx <- getContext go (ctx :: Context v loc) (Type.stripIntroOuters tx) (Type.stripIntroOuters ty) @@ -2286,7 +2287,7 @@ equate0 y1 y2 = do -- a subtype of the given type, updating the context -- in the process. instantiateL :: (Var v, Ord loc) => B.Blank loc -> v -> Type v loc -> M v loc () -instantiateL _ v t | debugEnabled && traceShow ("instantiateL" :: String, v, t) False = undefined +instantiateL _ v t | debugEnabled && traceShow ("instantiateL" :: String, v, anythingToString t) False = undefined instantiateL blank v (Type.stripIntroOuters -> t) = scope (InInstantiateL v t) $ getContext >>= \ctx -> case Type.monotype t of @@ -2385,7 +2386,7 @@ refineEffectVar :: Type v loc -> M v loc () refineEffectVar _ es _ v _ - | debugShow ("refineEffectVar" :: Text, es, v) = undefined + | debugShow ("refineEffectVar" :: Text, anythingToString es, v) = undefined refineEffectVar _ [] _ _ _ = pure () refineEffectVar l es blank v tv | ev <- TypeVar.Existential blank v, @@ -2407,7 +2408,7 @@ refineEffectVar l es blank v tv -- a supertype of the given type, updating the context -- in the process. instantiateR :: (Var v, Ord loc) => Type v loc -> B.Blank loc -> v -> M v loc () -instantiateR t _ v | debugEnabled && traceShow ("instantiateR" :: String, t, v) False = undefined +instantiateR t _ v | debugEnabled && traceShow ("instantiateR" :: String, anythingToString t, v) False = undefined instantiateR (Type.stripIntroOuters -> t) blank v = scope (InInstantiateR t v) $ getContext >>= \ctx -> case Type.monotype t of @@ -2595,7 +2596,7 @@ pruneAbilities :: [Type v loc] -> M v loc (Wanted v loc) pruneAbilities want0 have0 - | debugShow ("pruneAbilities" :: Text, want0, have0) = undefined + | debugShow ("pruneAbilities" :: Text, anythingToString want0, anythingToString have0) = undefined pruneAbilities want0 have0 = do pwant <- pruneConcrete missing [] want0 have0 if pwant /= want0 @@ -2645,7 +2646,7 @@ equateAbilities :: [Type v loc] -> M v loc () equateAbilities abs1 abs2 - | debugShow ("equateAbilities" :: Text, abs1, abs2) = undefined + | debugShow ("equateAbilities" :: Text, anythingToString abs1, anythingToString abs2) = undefined equateAbilities ls rs = matchAbilities ls rs >>= \(com, ls, rs) -> let (vls, cls) = partition isExistential ls @@ -2704,7 +2705,7 @@ subAbilities :: [Type v loc] -> M v loc () subAbilities want have - | debugShow ("subAbilities" :: Text, want, have) = undefined + | debugShow ("subAbilities" :: Text, anythingToString want, anythingToString have) = undefined subAbilities want have = do want <- expandWanted want have <- expandAbilities have diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 0e3fafe8a2..8d643473c9 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -239,6 +239,7 @@ library , process , random >=1.2.0 , raw-strings-qq + , recover-rtti , regex-base , regex-tdfa , safe diff --git a/unison-core/package.yaml b/unison-core/package.yaml index bd59e25667..97a7811719 100644 --- a/unison-core/package.yaml +++ b/unison-core/package.yaml @@ -26,6 +26,7 @@ library: - safe - text - transformers + - unison-core - unison-prelude - unison-util - unison-util-relation diff --git a/unison-core/src/Unison/ABT.hs b/unison-core/src/Unison/ABT.hs index 817423f86b..43b5ca626a 100644 --- a/unison-core/src/Unison/ABT.hs +++ b/unison-core/src/Unison/ABT.hs @@ -6,6 +6,7 @@ {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE QuantifiedConstraints #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} @@ -94,23 +95,28 @@ import qualified Data.Foldable as Foldable import Data.List hiding (cycle, find) import qualified Data.Map as Map import qualified Data.Set as Set -import Prelude.Extras (Eq1 (..), Ord1 (..), Show1 (..)) +import Prelude.Extras (Eq1 (..), Ord1 (..)) +import U.Core.ABT + ( ABT (..), + Term (..), + foreachSubterm, + subterms, + transform, + transformM, + unabs, + visit, + visit', + visitPure, + vmap, + pattern AbsN', + pattern Tm', + pattern Var', + ) +import qualified U.Core.ABT import Unison.Prelude import qualified Unison.Util.Components as Components import Prelude hiding (abs, cycle) -data ABT f v r - = Var v - | Cycle r - | Abs v r - | Tm (f r) - deriving (Functor, Foldable, Traversable, Generic) - --- | At each level in the tree, we store the set of free variables and --- a value of type `a`. Variables are of type `v`. -data Term f v a = Term {freeVars :: Set v, annotation :: a, out :: ABT f v (Term f v a)} - deriving (Generic) - abt_ :: Lens' (Term f v a) (ABT f v (Term f v a)) abt_ = lens out setter where @@ -179,13 +185,6 @@ isFreeIn v t = Set.member v (freeVars t) annotate :: a -> Term f v a -> Term f v a annotate a (Term fvs _ out) = Term fvs a out -vmap :: (Functor f, Foldable f, Ord v2) => (v -> v2) -> Term f v a -> Term f v2 a -vmap f (Term _ a out) = case out of - Var v -> annotatedVar a (f v) - Tm fa -> tm' a (fmap (vmap f) fa) - Cycle r -> cycle' a (vmap f r) - Abs v body -> abs' a (f v) (vmap f body) - vmapM :: (Applicative m, Traversable f, Foldable f, Ord v2) => (v -> m v2) -> Term f v a -> m (Term f v2 a) vmapM f (Term _ a out) = case out of Var v -> annotatedVar a <$> f v @@ -203,9 +202,12 @@ amap' f t@(Term _ a out) = case out of Cycle r -> cycle' (f t a) (amap' f r) Abs v body -> abs' (f t a) v (amap' f body) --- | Modifies the annotations in this tree -instance Functor f => Functor (Term f v) where - fmap f (Term fvs a sub) = Term fvs (f a) (fmap (fmap f) sub) +-- amap :: (Functor f, Foldable f) => (a -> a') -> Term f v a -> Term f v a' +-- amap f (Term fv a out) = Term fv (f a) $ case out of +-- Var v -> Var v +-- Tm fa -> Tm (amap f <$> fa) +-- Cycle r -> Cycle (amap f r) +-- Abs v body -> Abs v (amap f body) extraMap :: Functor g => (forall k. f k -> g k) -> Term f v a -> Term g v a extraMap p (Term fvs a sub) = Term fvs a (go p sub) @@ -217,20 +219,12 @@ extraMap p (Term fvs a sub) = Term fvs a (go p sub) Abs v r -> Abs v (extraMap p r) Tm x -> Tm (fmap (extraMap p) (p x)) -pattern Var' v <- Term _ _ (Var v) - pattern Cycle' vs t <- Term _ _ (Cycle (AbsN' vs (Tm' t))) pattern Abs'' v body <- Term _ _ (Abs v body) pattern Abs' subst <- (unabs1 -> Just subst) -pattern AbsN' vs body <- (unabs -> (vs, body)) - -{-# COMPLETE AbsN' #-} - -pattern Tm' f <- Term _ _ (Tm f) - pattern CycleA' a avs t <- Term _ a (Cycle (AbsNA' avs t)) pattern AbsNA' avs body <- (unabsA -> (avs, body)) @@ -246,13 +240,13 @@ var :: v -> Term f v () var = annotatedVar () annotatedVar :: a -> v -> Term f v a -annotatedVar a v = Term (Set.singleton v) a (Var v) +annotatedVar = U.Core.ABT.var abs :: Ord v => v -> Term f v () -> Term f v () abs = abs' () abs' :: Ord v => a -> v -> Term f v a -> Term f v a -abs' a v body = Term (Set.delete v (freeVars body)) a (Abs v body) +abs' = U.Core.ABT.abs absr :: (Functor f, Foldable f, Var v) => v -> Term f (V v) () -> Term f (V v) () absr = absr' () @@ -271,14 +265,13 @@ tm :: (Foldable f, Ord v) => f (Term f v ()) -> Term f v () tm = tm' () tm' :: (Foldable f, Ord v) => a -> f (Term f v a) -> Term f v a -tm' a t = - Term (Set.unions (fmap freeVars (Foldable.toList t))) a (Tm t) +tm' = U.Core.ABT.tm cycle :: Term f v () -> Term f v () cycle = cycle' () cycle' :: a -> Term f v a -> Term f v a -cycle' a t = Term (freeVars t) a (Cycle t) +cycle' = U.Core.ABT.cycle cycler' :: (Functor f, Foldable f, Var v) => a -> [v] -> Term f (V v) a -> Term f (V v) a cycler' a vs t = cycle' a $ foldr (absr' a) t vs @@ -319,17 +312,17 @@ renames rn0 t0@(Term fvs ann t) | Map.null rn = t0 | Var v <- t, Just u <- Map.lookup v rn = - annotatedVar ann u + annotatedVar ann u | Cycle body <- t = - cycle' ann (renames rn body) + cycle' ann (renames rn body) | Abs v t <- t, -- rename iterated variables all at once to avoid a capture issue AbsNA' (unzip -> (as, vs)) body <- t, (rn, us) <- mangle (freeVars body) rn (v : vs), not $ Map.null rn = - absChain' (zip (ann : as) us) (renames rn body) + absChain' (zip (ann : as) us) (renames rn body) | Tm body <- t = - tm' ann (renames rn <$> body) + tm' ann (renames rn <$> body) | otherwise = t0 where rn = Map.restrictKeys rn0 fvs @@ -339,7 +332,7 @@ renames rn0 t0@(Term fvs ann t) mangle1 avs m v | any (== v) vs, u <- freshIn (avs <> Set.fromList vs) v = - (Map.insert v u m, u) + (Map.insert v u m, u) | otherwise = (Map.delete v m, v) where vs = toList m @@ -403,20 +396,20 @@ subst' :: (Foldable f, Functor f, Var v) => (a -> Term f v a) -> v -> Set v -> T subst' replace v r t2@(Term fvs ann body) | Set.notMember v fvs = t2 -- subtrees not containing the var can be skipped | otherwise = case body of - Var v' - | v == v' -> replace ann -- var match; perform replacement - | otherwise -> t2 -- var did not match one being substituted; ignore - Cycle body -> cycle' ann (subst' replace v r body) - Abs x _ | x == v -> t2 -- x shadows v; ignore subtree - Abs x e -> abs' ann x' e' - where - x' = freshIn (fvs `Set.union` r) x - -- rename x to something that cannot be captured by `r` - e' = - if x /= x' - then subst' replace v r (rename x x' e) - else subst' replace v r e - Tm body -> tm' ann (fmap (subst' replace v r) body) + Var v' + | v == v' -> replace ann -- var match; perform replacement + | otherwise -> t2 -- var did not match one being substituted; ignore + Cycle body -> cycle' ann (subst' replace v r body) + Abs x _ | x == v -> t2 -- x shadows v; ignore subtree + Abs x e -> abs' ann x' e' + where + x' = freshIn (fvs `Set.union` r) x + -- rename x to something that cannot be captured by `r` + e' = + if x /= x' + then subst' replace v r (rename x x' e) + else subst' replace v r e + Tm body -> tm' ann (fmap (subst' replace v r) body) -- Like `subst`, but the annotation of the replacement is inherited from -- the previous annotation at each replacement point. @@ -490,66 +483,12 @@ freeVarOccurrences except t = Abs _ body -> go body Tm body -> foldMap go body -foreachSubterm :: - (Traversable f, Applicative g) => - (Term f v a -> g b) -> - Term f v a -> - g [b] -foreachSubterm f e = case out e of - Var _ -> pure <$> f e - Cycle body -> (:) <$> f e <*> foreachSubterm f body - Abs _ body -> (:) <$> f e <*> foreachSubterm f body - Tm body -> - (:) - <$> f e - <*> (join . Foldable.toList <$> traverse (foreachSubterm f) body) - -subterms :: (Traversable f) => Term f v a -> [Term f v a] -subterms t = runIdentity $ foreachSubterm pure t - -- subterms_ :: (Traversable f) => Fold (Term f v a) (Term f v a) -- subterms_ = folding subterms --- | `visit f t` applies an effectful function to each subtree of --- `t` and sequences the results. When `f` returns `Nothing`, `visit` --- descends into the children of the current subtree. When `f` returns --- `Just t2`, `visit` replaces the current subtree with `t2`. Thus: --- `visit (const Nothing) t == pure t` and --- `visit (const (Just (pure t2))) t == pure t2` -visit :: - (Traversable f, Applicative g, Ord v) => - (Term f v a -> Maybe (g (Term f v a))) -> - Term f v a -> - g (Term f v a) -visit f t = flip fromMaybe (f t) $ case out t of - Var _ -> pure t - Cycle body -> cycle' (annotation t) <$> visit f body - Abs x e -> abs' (annotation t) x <$> visit f e - Tm body -> tm' (annotation t) <$> traverse (visit f) body - -- subTermsSetter_ :: (Traversable f, Ord v) => Setter' (Term f v a) (Term f v a) -- subTermsSetter_ f tm = visit (Just . f) tm --- | Apply an effectful function to an ABT tree top down, sequencing the results. -visit' :: - (Traversable f, Monad g, Ord v) => - (f (Term f v a) -> g (f (Term f v a))) -> - Term f v a -> - g (Term f v a) -visit' f t = case out t of - Var _ -> pure t - Cycle body -> cycle' (annotation t) <$> visit' f body - Abs x e -> abs' (annotation t) x <$> visit' f e - Tm body -> f body >>= (fmap (tm' (annotation t)) . traverse (visit' f)) - --- | `visit` specialized to the `Identity` effect. -visitPure :: - (Traversable f, Ord v) => - (Term f v a -> Maybe (Term f v a)) -> - Term f v a -> - Term f v a -visitPure f = runIdentity . visit (fmap pure . f) - rewriteDown :: (Traversable f, Ord v) => (Term f v a -> Term f v a) -> @@ -589,35 +528,6 @@ unabs1 (Term _ _ (Abs v body)) = Just (Subst freshen bind bindInheritAnnotation bindInheritAnnotation x = substInheritAnnotation v x body unabs1 _ = Nothing -unabs :: Term f v a -> ([v], Term f v a) -unabs (Term _ _ (Abs hd body)) = - let (tl, body') = unabs body in (hd : tl, body') -unabs t = ([], t) - -transform :: - (Ord v, Foldable g, Functor f) => - (forall a. f a -> g a) -> - Term f v a -> - Term g v a -transform f tm = case out tm of - Var v -> annotatedVar (annotation tm) v - Abs v body -> abs' (annotation tm) v (transform f body) - Tm subterms -> - let subterms' = fmap (transform f) subterms - in tm' (annotation tm) (f subterms') - Cycle body -> cycle' (annotation tm) (transform f body) - -transformM :: - (Ord v, Monad m, Traversable g) => - (forall a. f a -> m (g a)) -> - Term f v a -> - m (Term g v a) -transformM f t = case out t of - Var v -> pure $ annotatedVar (annotation t) v - Abs v body -> abs' (annotation t) v <$> (transformM f body) - Tm subterms -> tm' (annotation t) <$> (traverse (transformM f) =<< f subterms) - Cycle body -> cycle' (annotation t) <$> (transformM f body) - -- Rebuild the tree annotations upward, starting from the leaves, -- using the Monoid to choose the annotation at intermediate nodes reannotateUp :: @@ -743,11 +653,3 @@ orderedComponents bs0 = tweak =<< orderedComponents' bs0 tweak bs = [bs] -- any cycle with < 2 bindings is left alone isCyclic [(v, b)] = Set.member v (freeVars b) isCyclic bs = length bs > 1 - -instance (Show1 f, Show v) => Show (Term f v a) where - -- annotations not shown - showsPrec p (Term _ _ out) = case out of - Var v -> showParen (p >= 9) $ \x -> "Var " ++ show v ++ x - Cycle body -> ("Cycle " ++) . showsPrec p body - Abs v body -> showParen True $ (show v ++) . showString ". " . showsPrec p body - Tm f -> showsPrec1 p f diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index c200a18fd8..c5eccfe497 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -1203,7 +1203,7 @@ fromReferent a = \case instance (Eq a, ABT.Var v) => Eq1 (F v a p) where (==#) = (==) -instance (Show v) => Show1 (F v a p) where showsPrec1 = showsPrec +instance (Show a, Show v) => Show1 (F v a p) where showsPrec1 = showsPrec instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where Int x == Int y = x == y @@ -1232,7 +1232,7 @@ instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where Match scrutinee cases == Match s2 cs2 = scrutinee == s2 && cases == cs2 _ == _ = False -instance (Show v, Show a) => Show (F v a0 p a) where +instance (Show v, Show ta, Show a) => Show (F v ta p a) where showsPrec = go where go _ (Int n) = (if n >= 0 then s "+" else s "") <> shows n diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index 21c91e39ee..7535b88d21 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -80,7 +80,7 @@ bindReferences keepFree ns t = newtype Monotype v a = Monotype {getPolytype :: Type v a} deriving (Eq) -instance (Show v) => Show (Monotype v a) where +instance (Show a, Show v) => Show (Monotype v a) where show = show . getPolytype -- Smart constructor which checks if a `Type` has no `Forall` quantifiers. diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index 0281f19dae..deaec5053b 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -101,6 +101,7 @@ library , safe , text , transformers + , unison-core , unison-prelude , unison-util , unison-util-relation From 815057febce30d081b83e337b6d824319d0b4b71 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 14 Jun 2022 17:26:32 -0600 Subject: [PATCH 342/529] Better messaging for transport errors during sync --- lib/unison-prelude/src/Unison/Debug.hs | 7 +++ .../src/Unison/Codebase/Editor/HandleInput.hs | 16 +++--- .../src/Unison/Codebase/Editor/Output.hs | 1 + .../src/Unison/CommandLine/OutputMessages.hs | 23 +++++++-- unison-cli/src/Unison/Share/Sync.hs | 50 ++++++++++++++++--- unison-cli/src/Unison/Share/Sync/Types.hs | 26 ++++++++++ 6 files changed, 105 insertions(+), 18 deletions(-) diff --git a/lib/unison-prelude/src/Unison/Debug.hs b/lib/unison-prelude/src/Unison/Debug.hs index abd947ddda..da1dfc337b 100644 --- a/lib/unison-prelude/src/Unison/Debug.hs +++ b/lib/unison-prelude/src/Unison/Debug.hs @@ -27,6 +27,7 @@ data DebugFlag | Auth | Migration | Integrity + | Sync deriving (Eq, Ord, Show, Bounded, Enum) debugFlags :: Set DebugFlag @@ -44,6 +45,7 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of "AUTH" -> pure Auth "MIGRATION" -> pure Migration "INTEGRITY" -> pure Integrity + "SYNC" -> pure Sync _ -> empty {-# NOINLINE debugFlags #-} @@ -71,6 +73,10 @@ debugIntegrity :: Bool debugIntegrity = Integrity `Set.member` debugFlags {-# NOINLINE debugIntegrity #-} +debugSync :: Bool +debugSync = Sync `Set.member` debugFlags +{-# NOINLINE debugSync #-} + -- | Use for trace-style selective debugging. -- E.g. 1 + (debug Git "The second number" 2) -- @@ -117,3 +123,4 @@ shouldDebug = \case Auth -> debugAuth Migration -> debugMigration Integrity -> debugIntegrity + Sync -> debugSync diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 2be8d625d7..a74c366da4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -174,6 +174,7 @@ import Unison.Util.TransitiveClosure (transitiveClosure) import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.WatchKind as WK +import qualified Unison.Share.Sync.Types as Sync defaultPatchNameSegment :: NameSegment defaultPatchNameSegment = "patch" @@ -1872,7 +1873,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l Just localCausalHash -> case behavior of PushBehavior.RequireEmpty -> do - let push :: IO (Either Share.CheckAndSetPushError ()) + let push :: IO (Either (Sync.SyncError Share.CheckAndSetPushError) ()) push = withEntitiesUploadedProgressCallback \entitiesUploadedProgressCallback -> Share.checkAndSetPush @@ -1884,10 +1885,11 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l localCausalHash entitiesUploadedProgressCallback liftIO push >>= \case - Left err -> respond (Output.ShareError (ShareErrorCheckAndSetPush err)) + Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorCheckAndSetPush err)) + Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err)) Right () -> pure () PushBehavior.RequireNonEmpty -> do - let push :: IO (Either Share.FastForwardPushError ()) + let push :: IO (Either (Sync.SyncError Share.FastForwardPushError) ()) push = do withEntitiesUploadedProgressCallback \entitiesUploadedProgressCallback -> Share.fastForwardPush @@ -1898,7 +1900,8 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l localCausalHash entitiesUploadedProgressCallback liftIO push >>= \case - Left err -> respond (Output.ShareError (ShareErrorFastForwardPush err)) + Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorFastForwardPush err)) + Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err)) Right () -> pure () where pathToSegments :: Path -> [Text] @@ -2317,7 +2320,7 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do mapLeft Output.ShareError <$> do let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask - let pull :: IO (Either Share.PullError CausalHash) + let pull :: IO (Either (Sync.SyncError Share.PullError) CausalHash) pull = withEntitiesDownloadedProgressCallback \entitiesDownloadedProgressCallback -> Share.pull @@ -2327,7 +2330,8 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do shareFlavoredPath entitiesDownloadedProgressCallback liftIO pull >>= \case - Left err -> pure (Left (Output.ShareErrorPull err)) + Left (Sync.SyncError err) -> pure (Left (Output.ShareErrorPull err)) + Left (Sync.TransportError err) -> pure (Left (Output.ShareErrorTransport err)) Right causalHash -> do (eval . Eval) (Codebase.getBranchForHash codebase (Cv.causalHash2to1 causalHash)) >>= \case Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 2196ec69f1..edaebc887d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -266,6 +266,7 @@ data ShareError | ShareErrorFastForwardPush Sync.FastForwardPushError | ShareErrorPull Sync.PullError | ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError + | ShareErrorTransport Sync.CodeserverTransportError data ReflogEntry = ReflogEntry {hash :: ShortBranchHash, reason :: Text} deriving (Show) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 36c8ed4eb2..6f2fb70d8e 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -128,6 +128,7 @@ import qualified Unison.Result as Result import Unison.Server.Backend (ShallowListEntry (..), TermEntry (..), TypeEntry (..)) import qualified Unison.Server.SearchResult' as SR' import qualified Unison.Share.Sync as Share +import Unison.Share.Sync.Types (CodeserverTransportError (..)) import qualified Unison.ShortHash as SH import qualified Unison.ShortHash as ShortHash import qualified Unison.Sync.Types as Share @@ -638,8 +639,8 @@ notifyUser dir o = case o of CachedTests 0 _ -> pure . P.callout "๐Ÿ˜ถ" $ "No tests to run." CachedTests n n' | n == n' -> - pure $ - P.lines [cache, "", displayTestResults True ppe oks fails] + pure $ + P.lines [cache, "", displayTestResults True ppe oks fails] CachedTests _n m -> pure $ if m == 0 @@ -648,7 +649,6 @@ notifyUser dir o = case o of P.indentN 2 $ P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "โœ… "] where - NewlyComputed -> do clearCurrentLine pure $ @@ -1628,6 +1628,21 @@ notifyUser dir o = case o of (Share.PullErrorNoHistoryAtPath sharePath) -> P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err + ShareErrorTransport te -> case te of + Unauthenticated -> + P.fatalCallout $ + P.wrap $ + "Authentication with this code server is missing or expired. Please run " <> makeExample' IP.authLogin <> "." + PermissionDenied msg -> P.fatalCallout $ P.hang "Permission denied:" (P.text msg) + UnreachableCodeserver -> + P.wrap . P.lines $ + [ "Unable to reach the code server.", + "Please check your network, ensure you've provided the correct location, or try again later" + ] + InvalidResponse resp -> P.fatalCallout $ P.hang "Invalid response received from codeserver:" (P.shown resp) + RateLimitExceeded -> P.warnCallout "Rate limit exceeded, please try again later." + InternalServerError -> P.fatalCallout "The code server encountered an error. Please try again later or report an issue if the problem persists." + Timeout -> P.fatalCallout "The code server timed-out when responding to your request. Please try again later or report an issue if the problem persists." where prettySharePath = prettyRelative @@ -2271,7 +2286,7 @@ showDiffNamespace :: (Pretty, NumberedArgs) showDiffNamespace _ _ _ _ diffOutput | OBD.isEmpty diffOutput = - ("The namespaces are identical.", mempty) + ("The namespaces are identical.", mempty) showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = (P.sepNonEmpty "\n\n" p, toList args) where diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 838d5fad7d..98aef7dab6 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -20,6 +20,7 @@ module Unison.Share.Sync ) where +import Control.Monad.Except import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader import qualified Data.Foldable as Foldable (find) @@ -36,16 +37,20 @@ import qualified Data.Sequence.NonEmpty as NESeq (fromList, nonEmptySeq, (><|)) import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet +import qualified Data.Text.Lazy as Text.Lazy +import qualified Data.Text.Lazy.Encoding as Text.Lazy import Data.These (These (..)) import qualified Network.HTTP.Client as Http.Client +import qualified Network.HTTP.Types as HTTP import qualified Servant.API as Servant ((:<|>) (..), (:>)) import Servant.Client (BaseUrl) -import qualified Servant.Client as Servant (ClientEnv (..), ClientM, client, defaultMakeClientRequest, hoistClient, mkClientEnv, runClientM) +import qualified Servant.Client as Servant import U.Codebase.HashTags (CausalHash) import qualified U.Codebase.Sqlite.Queries as Q import U.Util.Hash32 (Hash32) import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import qualified Unison.Auth.HTTPClient as Auth +import qualified Unison.Debug as Debug import Unison.Prelude import Unison.Share.Sync.Types import qualified Unison.Sqlite as Sqlite @@ -53,6 +58,7 @@ import qualified Unison.Sync.API as Share (API) import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, hash32ToCausalHash) import qualified Unison.Sync.Types as Share import Unison.Util.Monoid (foldMapM) +import qualified UnliftIO ------------------------------------------------------------------------------------------------------------------------ -- Push @@ -75,8 +81,8 @@ checkAndSetPush :: CausalHash -> -- | Callback that is given the total number of entities uploaded, and the number of outstanding entities to upload. (Int -> Int -> IO ()) -> - IO (Either CheckAndSetPushError ()) -checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash uploadProgressCallback = do + IO (Either (SyncError CheckAndSetPushError) ()) +checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash uploadProgressCallback = catchSyncErrors do -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs -- this causal (UpdatePathMissingDependencies). updatePath >>= \case @@ -127,8 +133,8 @@ fastForwardPush :: CausalHash -> -- | Callback that is given the total number of entities uploaded, and the number of outstanding entities to upload. (Int -> Int -> IO ()) -> - IO (Either FastForwardPushError ()) -fastForwardPush httpClient unisonShareUrl conn path localHeadHash uploadProgressCallback = + IO (Either (SyncError FastForwardPushError) ()) +fastForwardPush httpClient unisonShareUrl conn path localHeadHash uploadProgressCallback = catchSyncErrors do getCausalHashByPath httpClient unisonShareUrl path >>= \case Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path)) Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path)) @@ -309,8 +315,8 @@ pull :: Share.Path -> -- | Callback that is given the total number of entities downloaded. (Int -> IO ()) -> - IO (Either PullError CausalHash) -pull httpClient unisonShareUrl conn repoPath@(Share.pathRepoName -> repoName) downloadCountCallback = do + IO (Either (SyncError PullError) CausalHash) +pull httpClient unisonShareUrl conn repoPath@(Share.pathRepoName -> repoName) downloadCountCallback = catchSyncErrors do getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case Left err -> pure (Left (PullErrorGetCausalHashByPath err)) -- There's nothing at the remote path, so there's no causal to pull. @@ -567,7 +573,28 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt hoist :: Servant.ClientM a -> ReaderT Servant.ClientEnv IO a hoist m = do clientEnv <- Reader.ask - liftIO (throwEitherM (Servant.runClientM m clientEnv)) + throwEitherM $ + liftIO (Servant.runClientM m clientEnv) >>= \case + Right a -> pure $ Right a + Left err -> do + Debug.debugLogM Debug.Sync (show err) + pure . Left $ case err of + Servant.FailureResponse _req resp -> case HTTP.statusCode $ Servant.responseStatusCode resp of + 401 -> Unauthenticated + -- The server should provide semantically relevant permission-denied messages + -- when possible, but this should catch any we miss. + 403 -> PermissionDenied (Text.Lazy.toStrict . Text.Lazy.decodeUtf8 $ Servant.responseBody resp) + 408 -> Timeout + 429 -> RateLimitExceeded + 500 -> InternalServerError + 504 -> Timeout + code + | code >= 500 -> InternalServerError + | otherwise -> InvalidResponse resp + Servant.DecodeFailure _msg resp -> InvalidResponse resp + Servant.UnsupportedContentType _ct resp -> InvalidResponse resp + Servant.InvalidContentTypeHeader resp -> InvalidResponse resp + Servant.ConnectionError {} -> UnreachableCodeserver go :: (req -> ReaderT Servant.ClientEnv IO resp) -> @@ -586,3 +613,10 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt } } ) + +catchSyncErrors :: IO (Either e a) -> IO (Either (SyncError e) a) +catchSyncErrors action = + UnliftIO.try @_ @CodeserverTransportError action >>= \case + Left te -> pure (Left . TransportError $ te) + Right (Left e) -> pure . Left . SyncError $ e + Right (Right a) -> pure $ Right a diff --git a/unison-cli/src/Unison/Share/Sync/Types.hs b/unison-cli/src/Unison/Share/Sync/Types.hs index 2167212ace..78f4ff9168 100644 --- a/unison-cli/src/Unison/Share/Sync/Types.hs +++ b/unison-cli/src/Unison/Share/Sync/Types.hs @@ -1,8 +1,12 @@ +{-# LANGUAGE DeriveAnyClass #-} + -- | Types used by the UCM client during sync. module Unison.Share.Sync.Types where import Data.Set.NonEmpty (NESet) +import qualified Servant.Client as Servant import U.Util.Hash32 (Hash32) +import Unison.Prelude import qualified Unison.Sync.Types as Share -- | Error used by the client when pushing code to Unison Share. @@ -10,6 +14,7 @@ data CheckAndSetPushError = CheckAndSetPushErrorHashMismatch Share.HashMismatch | CheckAndSetPushErrorNoWritePermission Share.Path | CheckAndSetPushErrorServerMissingDependencies (NESet Hash32) + deriving (Show) -- | An error occurred while fast-forward pushing code to Unison Share. data FastForwardPushError @@ -20,14 +25,35 @@ data FastForwardPushError | FastForwardPushErrorServerMissingDependencies (NESet Hash32) | -- Parent Child FastForwardPushInvalidParentage Hash32 Hash32 + deriving (Show) -- | An error occurred while pulling code from Unison Share. data PullError = -- | An error occurred while resolving a repo+path to a causal hash. PullErrorGetCausalHashByPath GetCausalHashByPathError | PullErrorNoHistoryAtPath Share.Path + deriving (Show) -- | An error occurred when getting causal hash by path. data GetCausalHashByPathError = -- | The user does not have permission to read this path. GetCausalHashByPathErrorNoReadPermission Share.Path + deriving (Show) + +-- | Generic Codeserver transport errors +data CodeserverTransportError + = Unauthenticated + | -- We try to catch permission failures in the endpoint's response type, but if any slip + -- through they'll be translated as a PermissionDenied. + PermissionDenied Text + | UnreachableCodeserver + | InvalidResponse Servant.Response + | RateLimitExceeded + | InternalServerError + | Timeout + deriving stock (Show) + deriving anyclass (Exception) + +data SyncError e + = TransportError CodeserverTransportError + | SyncError e From 4e6e9e92cb4f7e3ec936786332d8ead4f166b881 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 14 Jun 2022 17:39:07 -0600 Subject: [PATCH 343/529] Use codeserver url in messages --- .../src/Unison/CommandLine/OutputMessages.hs | 15 +++++++++------ unison-cli/src/Unison/Share/Sync.hs | 13 +++++++------ unison-cli/src/Unison/Share/Sync/Types.hs | 4 ++-- 3 files changed, 18 insertions(+), 14 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 6f2fb70d8e..c5ce411081 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -23,6 +23,7 @@ import qualified Data.Text as Text import Data.Tuple (swap) import Data.Tuple.Extra (dupe) import Network.URI (URI) +import qualified Servant.Client as Servant import System.Directory ( canonicalizePath, doesFileExist, @@ -1629,15 +1630,17 @@ notifyUser dir o = case o of P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err ShareErrorTransport te -> case te of - Unauthenticated -> + Unauthenticated codeServerURL -> P.fatalCallout $ - P.wrap $ - "Authentication with this code server is missing or expired. Please run " <> makeExample' IP.authLogin <> "." + P.wrap . P.lines $ + [ "Authentication with this code server (" <> P.string (Servant.showBaseUrl codeServerURL) <> ") is missing or expired.", + "Please run " <> makeExample' IP.authLogin <> "." + ] PermissionDenied msg -> P.fatalCallout $ P.hang "Permission denied:" (P.text msg) - UnreachableCodeserver -> + UnreachableCodeserver codeServerURL -> P.wrap . P.lines $ - [ "Unable to reach the code server.", - "Please check your network, ensure you've provided the correct location, or try again later" + [ "Unable to reach the code server hosted at:" <> P.string (Servant.showBaseUrl codeServerURL), + "Please check your network, ensure you've provided the correct location, or try again later." ] InvalidResponse resp -> P.fatalCallout $ P.hang "Invalid response received from codeserver:" (P.shown resp) RateLimitExceeded -> P.warnCallout "Rate limit exceeded, please try again later." diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 98aef7dab6..4a5d3116a7 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -570,9 +570,9 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt go httpUploadEntities ) where - hoist :: Servant.ClientM a -> ReaderT Servant.ClientEnv IO a + hoist :: Servant.ClientM a -> ReaderT (BaseUrl, Servant.ClientEnv) IO a hoist m = do - clientEnv <- Reader.ask + (shareURL, clientEnv) <- Reader.ask throwEitherM $ liftIO (Servant.runClientM m clientEnv) >>= \case Right a -> pure $ Right a @@ -580,7 +580,7 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt Debug.debugLogM Debug.Sync (show err) pure . Left $ case err of Servant.FailureResponse _req resp -> case HTTP.statusCode $ Servant.responseStatusCode resp of - 401 -> Unauthenticated + 401 -> Unauthenticated shareURL -- The server should provide semantically relevant permission-denied messages -- when possible, but this should catch any we miss. 403 -> PermissionDenied (Text.Lazy.toStrict . Text.Lazy.decodeUtf8 $ Servant.responseBody resp) @@ -594,10 +594,10 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt Servant.DecodeFailure _msg resp -> InvalidResponse resp Servant.UnsupportedContentType _ct resp -> InvalidResponse resp Servant.InvalidContentTypeHeader resp -> InvalidResponse resp - Servant.ConnectionError {} -> UnreachableCodeserver + Servant.ConnectionError {} -> UnreachableCodeserver shareURL go :: - (req -> ReaderT Servant.ClientEnv IO resp) -> + (req -> ReaderT (BaseUrl, Servant.ClientEnv) IO resp) -> Auth.AuthenticatedHttpClient -> BaseUrl -> req -> @@ -605,7 +605,8 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt go f (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req = runReaderT (f req) - ( (Servant.mkClientEnv httpClient unisonShareUrl) + ( unisonShareUrl, + (Servant.mkClientEnv httpClient unisonShareUrl) { Servant.makeClientRequest = \url request -> -- Disable client-side timeouts (Servant.defaultMakeClientRequest url request) diff --git a/unison-cli/src/Unison/Share/Sync/Types.hs b/unison-cli/src/Unison/Share/Sync/Types.hs index 78f4ff9168..d596e2dcb7 100644 --- a/unison-cli/src/Unison/Share/Sync/Types.hs +++ b/unison-cli/src/Unison/Share/Sync/Types.hs @@ -42,11 +42,11 @@ data GetCausalHashByPathError -- | Generic Codeserver transport errors data CodeserverTransportError - = Unauthenticated + = Unauthenticated Servant.BaseUrl | -- We try to catch permission failures in the endpoint's response type, but if any slip -- through they'll be translated as a PermissionDenied. PermissionDenied Text - | UnreachableCodeserver + | UnreachableCodeserver Servant.BaseUrl | InvalidResponse Servant.Response | RateLimitExceeded | InternalServerError From 9b14cd4915023100572afecc2e4038d2cd981906 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 14 Jun 2022 17:44:18 -0600 Subject: [PATCH 344/529] Formatting fixes --- unison-cli/src/Unison/CommandLine/OutputMessages.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index c5ce411081..663814f7e1 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1638,9 +1638,9 @@ notifyUser dir o = case o of ] PermissionDenied msg -> P.fatalCallout $ P.hang "Permission denied:" (P.text msg) UnreachableCodeserver codeServerURL -> - P.wrap . P.lines $ - [ "Unable to reach the code server hosted at:" <> P.string (Servant.showBaseUrl codeServerURL), - "Please check your network, ensure you've provided the correct location, or try again later." + P.lines $ + [ P.wrap $ "Unable to reach the code server hosted at:" <> P.string (Servant.showBaseUrl codeServerURL), + P.wrap "Please check your network, ensure you've provided the correct location, or try again later." ] InvalidResponse resp -> P.fatalCallout $ P.hang "Invalid response received from codeserver:" (P.shown resp) RateLimitExceeded -> P.warnCallout "Rate limit exceeded, please try again later." From 2060276ac1578fd3ca42a9d36a6a4cfd40950b4c Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 15 Jun 2022 11:13:22 -0400 Subject: [PATCH 345/529] make pull from share download in smaller chunks --- unison-cli/src/Unison/Share/Sync.hs | 40 +++++++++++++++++++++-------- 1 file changed, 30 insertions(+), 10 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 838d5fad7d..afa0ce46de 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -362,11 +362,27 @@ completeTempEntities :: NESet Hash32 -> IO () completeTempEntities doDownload conn = - let loop :: NESet Hash32 -> IO () - loop tempEntityHashes = do - hashJwtsToDownload <- Sqlite.runTransaction conn (elaborateHashes tempEntityHashes) - whenJustM (downloadEntities doDownload conn hashJwtsToDownload) loop - in loop + let loop :: NESet Share.HashJWT -> IO () + loop allHashes = do + -- Each request only contains a certain maximum number of entities; split the set of hashes we need to download + -- into those we will download right now, and those we will begin downloading on the next iteration of the loop. + let (hashes, nextHashes0) = + case NESet.splitAt 50 allHashes of + This hs1 -> (hs1, Set.empty) + That hs2 -> (hs2, Set.empty) -- impossible, this only happens if we split at 0 + These hs1 hs2 -> (hs1, NESet.toSet hs2) + nextHashes <- + downloadEntities doDownload conn hashes >>= \case + Nothing -> pure (NESet.nonEmptySet nextHashes0) + Just newTempEntities -> do + newElaboratedHashes <- elaborate newTempEntities + pure (Just (union10 newElaboratedHashes nextHashes0)) + whenJust nextHashes loop + in \hashes0 -> elaborate hashes0 >>= loop + where + elaborate :: NESet Hash32 -> IO (NESet Share.HashJWT) + elaborate hashes = + Sqlite.runTransaction conn (elaborateHashes hashes) -- | Download a set of entities from Unison Share. Returns the subset of those entities that we stored in temp storage -- (`temp_entitiy`) instead of main storage (`object` / `causal`) due to missing dependencies. @@ -421,7 +437,7 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadProgressCal loop :: Int -> NESet Hash32 -> IO Bool loop uploadCount allHashesSet = do -- Each request only contains a certain maximum number of entities; split the set of hashes we need to upload into - -- those we will upload right now, and those we will begin uploading + -- those we will upload right now, and those we will begin uploading on the next iteration of the loop. let (hashesSet, nextHashes) = case NESet.splitAt 50 allHashesSet of This hs1 -> (hs1, Set.empty) @@ -448,10 +464,7 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadProgressCal uploadEntities >>= \case Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> do - let newAllHashesSet = - case NESet.nonEmptySet nextHashes of - Nothing -> moreHashes - Just nextHashes1 -> NESet.union moreHashes nextHashes1 + let newAllHashesSet = union10 moreHashes nextHashes uploadProgressCallback newUploadCount (NESet.size newAllHashesSet) loop newUploadCount newAllHashesSet Share.UploadEntitiesNoWritePermission _ -> pure False @@ -465,6 +478,13 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadProgressCal uploadProgressCallback newUploadCount (NESet.size nextHashes1) loop newUploadCount nextHashes1 +-- Union a non-empty set and a set. +union10 :: Ord a => NESet a -> Set a -> NESet a +union10 xs ys = + case NESet.nonEmptySet ys of + Nothing -> xs + Just zs -> NESet.union xs zs + ------------------------------------------------------------------------------------------------------------------------ -- Database operations From 0437ca0c74a5b58ab4f3d1128b4e4b9a9b323b24 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Wed, 15 Jun 2022 11:54:25 -0400 Subject: [PATCH 346/529] remove haskeline fork resolves https://github.com/unisonweb/unison/pull/1836 closes https://github.com/judah/haskeline/pull/115 --- stack.yaml | 2 -- stack.yaml.lock | 11 ----------- unison-cli/package.yaml | 1 + unison-cli/src/Unison/CommandLine/Main.hs | 3 ++- unison-cli/unison-cli.cabal | 7 ++++++- 5 files changed, 9 insertions(+), 15 deletions(-) diff --git a/stack.yaml b/stack.yaml index f6445f6f84..da7c4c57e7 100644 --- a/stack.yaml +++ b/stack.yaml @@ -34,8 +34,6 @@ resolver: lts-18.28 extra-deps: - github: unisonweb/configurator commit: e47e9e9fe1f576f8c835183b9def52d73c01327a -- github: unisonweb/haskeline - commit: 2944b11d19ee034c48276edc991736105c9d6143 - github: unisonweb/shellmet commit: 2fd348592c8f51bb4c0ca6ba4bc8e38668913746 - guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 diff --git a/stack.yaml.lock b/stack.yaml.lock index 99b4efacbb..bd03b27218 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -15,17 +15,6 @@ packages: sha256: 90547cd983fd15ebdc803e057d3ef8735fe93a75e29a00f8a74eadc13ee0f6e9 original: url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz -- completed: - size: 75098 - url: https://github.com/unisonweb/haskeline/archive/2944b11d19ee034c48276edc991736105c9d6143.tar.gz - name: haskeline - version: 0.7.5.0 - sha256: 6d44207a4e94a16bc99d13dccbbb79bf676190c0476436b03235eeeaf6c72f9d - pantry-tree: - size: 3717 - sha256: 878c7fb5801ec7418761a49b529ca3fdab274f22707c7d2759f2b3a2df06c3ea - original: - url: https://github.com/unisonweb/haskeline/archive/2944b11d19ee034c48276edc991736105c9d6143.tar.gz - completed: size: 10460 url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 96cec9a8fd..02d987735b 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -22,6 +22,7 @@ dependencies: - cryptonite - directory - errors + - exceptions - extra - filepath - haskeline diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 6d1d89d3e8..cbdc4f2545 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -12,6 +12,7 @@ import qualified Control.Concurrent.Async as Async import Control.Concurrent.STM (atomically) import Control.Exception (catch, finally) import Control.Lens (view) +import Control.Monad.Catch (MonadMask) import qualified Crypto.Random as Random import Data.Configurator.Types (Config) import Data.IORef @@ -53,7 +54,7 @@ import qualified UnliftIO getUserInput :: forall m v a. - (MonadIO m, Line.MonadException m) => + (MonadIO m, MonadMask m) => Map String InputPattern -> Codebase m v a -> Branch m -> diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 219579af76..d6e23bd9f4 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack @@ -101,6 +101,7 @@ library , directory , either , errors + , exceptions , extra , filepath , haskeline @@ -193,6 +194,7 @@ executable cli-integration-tests , easytest , either , errors + , exceptions , extra , filepath , haskeline @@ -280,6 +282,7 @@ executable transcripts , easytest , either , errors + , exceptions , extra , filepath , haskeline @@ -371,6 +374,7 @@ executable unison , directory , either , errors + , exceptions , extra , filepath , haskeline @@ -469,6 +473,7 @@ test-suite cli-tests , easytest , either , errors + , exceptions , extra , filepath , haskeline From 9ccafe2274bb16e3847a717808b7a0fb78dcbd9e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 15 Jun 2022 13:55:32 -0400 Subject: [PATCH 347/529] do only one transaction in `downloadEntities` --- unison-cli/src/Unison/Share/Sync.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 838d5fad7d..72e05affb9 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -378,10 +378,11 @@ downloadEntities :: downloadEntities doDownload conn hashes = do entities <- doDownload hashes fmap NESet.nonEmptySet do - NEMap.toList entities & foldMapM \(hash, entity) -> - Sqlite.runTransaction conn (upsertEntitySomewhere hash entity) <&> \case - Q.EntityInMainStorage -> Set.empty - Q.EntityInTempStorage -> Set.singleton hash + Sqlite.runTransaction conn do + NEMap.toList entities & foldMapM \(hash, entity) -> + upsertEntitySomewhere hash entity <&> \case + Q.EntityInMainStorage -> Set.empty + Q.EntityInTempStorage -> Set.singleton hash ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path From c862aa9cf8c0753cc5ea0ebd1215937f0f929ddc Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 15 Jun 2022 14:27:03 -0400 Subject: [PATCH 348/529] move elaborateHashesServer to enlil --- .../U/Codebase/Sqlite/Queries.hs | 22 ------------------- 1 file changed, 22 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index b60fb3d467..896b494fdc 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -146,7 +146,6 @@ module U.Codebase.Sqlite.Queries -- * elaborate hashes elaborateHashesClient, - elaborateHashesServer, -- * db misc createSchema, @@ -1558,27 +1557,6 @@ deleteTempEntity hash = |] (Only hash) -elaborateHashesServer :: [Hash32] -> Transaction [Hash32] -elaborateHashesServer hashes = do - execute_ [here|CREATE TABLE unelaborated_dependency (hash text)|] - executeMany [here|INSERT INTO unelaborated_dependency (hash) VALUES (?)|] (Only <$> hashes) - result <- - queryListCol_ - [here| - WITH RECURSIVE elaborated_dependency (hash) AS ( - SELECT hash FROM unelaborated_dependency - UNION - SELECT dependency - FROM temp_entity_missing_dependency - JOIN elaborated_dependency - ON temp_entity_missing_dependency.dependent = elaborated_dependency.hash - ) - SELECT hash FROM elaborated_dependency - EXCEPT SELECT hash FROM temp_entity; - |] - execute_ [here|DROP TABLE unelaborated_dependency|] - pure result - data EmptyTempEntityMissingDependencies = EmptyTempEntityMissingDependencies deriving stock (Show) From e941bae75518a735fb725fddcaf68b290226be18 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 15 Jun 2022 14:28:18 -0400 Subject: [PATCH 349/529] rename elaborateHashesClient to elaborateHashes --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 6 +++--- unison-cli/src/Unison/Share/Sync.hs | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 896b494fdc..fca934ec06 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -145,7 +145,7 @@ module U.Codebase.Sqlite.Queries saveSyncEntity, -- * elaborate hashes - elaborateHashesClient, + elaborateHashes, -- * db misc createSchema, @@ -1578,8 +1578,8 @@ data EmptyTempEntityMissingDependencies -- -- ... then `elaborateHashes {A}` would return the singleton set {C} (because we take the set of transitive -- dependencies {A,B,C} and subtract the set we already have, {A,B}). -elaborateHashesClient :: Nel.NonEmpty Hash32 -> Transaction (Nel.NonEmpty Text) -elaborateHashesClient hashes = do +elaborateHashes :: Nel.NonEmpty Hash32 -> Transaction (Nel.NonEmpty Text) +elaborateHashes hashes = do execute_ [here| CREATE TABLE new_temp_entity_dependents (hash text) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 72e05affb9..e30a465458 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -478,7 +478,7 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadProgressCal -- In the end, we return a set of hashes that correspond to entities we actually need to download. elaborateHashes :: NESet Hash32 -> Sqlite.Transaction (NESet Share.HashJWT) elaborateHashes hashes = - Q.elaborateHashesClient (NESet.toList hashes) + Q.elaborateHashes (NESet.toList hashes) <&> NESet.fromList . coerce @(List.NonEmpty Text) @(List.NonEmpty Share.HashJWT) -- | Upsert a downloaded entity "somewhere" - From 09ba84610255d16db21e5317fae5d31c6e7294d3 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Wed, 15 Jun 2022 18:28:30 -0400 Subject: [PATCH 350/529] Add more array builtins to flesh out the actual API --- parser-typechecker/src/Unison/Builtin.hs | 42 +- .../src/Unison/Runtime/Builtin.hs | 287 ++++++-- .../src/Unison/Runtime/Foreign/Function.hs | 24 + unison-src/transcripts/alias-many.output.md | 641 +++++++++--------- .../transcripts/builtins-merge.output.md | 95 ++- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- .../transcripts/name-selection.output.md | 631 +++++++++-------- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 10 files changed, 1030 insertions(+), 736 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index c2639773e2..5995c7ad95 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -528,6 +528,12 @@ builtinsSrc = reft g a --> Type.effect1 () g a, B "Ref.write" . forall2 "a" "g" $ \a g -> reft g a --> a --> Type.effect1 () g unit, + B "MutableArray.copyTo!" . forall2 "g" "a" $ \g a -> + marrayt g a --> nat --> marrayt g a --> nat --> nat + --> Type.effect () [g, DD.exceptionType ()] unit, + B "MutableByteArray.copyTo!" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> mbytearrayt g --> nat --> nat + --> Type.effect () [g, DD.exceptionType ()] unit, B "MutableArray.read" . forall2 "g" "a" $ \g a -> marrayt g a --> nat --> Type.effect () [g, DD.exceptionType ()] a, B "MutableByteArray.read8" . forall1 "g" $ \g -> @@ -548,6 +554,12 @@ builtinsSrc = mbytearrayt g --> nat --> nat --> Type.effect () [g, DD.exceptionType ()] unit, B "MutableByteArray.write64" . forall1 "g" $ \g -> mbytearrayt g --> nat --> nat --> Type.effect () [g, DD.exceptionType ()] unit, + B "ImmutableArray.copyTo!" . forall2 "g" "a" $ \g a -> + marrayt g a --> nat --> iarrayt a --> nat --> nat + --> Type.effect () [g, DD.exceptionType ()] unit, + B "ImmutableByteArray.copyTo!" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> ibytearrayt --> nat --> nat + --> Type.effect () [g, DD.exceptionType ()] unit, B "ImmutableArray.read" . forall1 "a" $ \a -> iarrayt a --> nat --> Type.effect1 () (DD.exceptionType ()) a, B "ImmutableByteArray.read8" $ @@ -562,12 +574,12 @@ builtinsSrc = marrayt g a --> Type.effect1 () g (iarrayt a), B "MutableByteArray.freeze!" . forall1 "g" $ \g -> mbytearrayt g --> Type.effect1 () g ibytearrayt, - B "IO.arrayOf" . forall1 "a" $ \a -> - a --> nat --> io (marrayt (Type.effects () [Type.builtinIO ()]) a), - B "IO.bytearray" $ - nat --> io (mbytearrayt (Type.effects () [Type.builtinIO ()])), - B "IO.bytearrayOf" $ - nat --> nat --> io (mbytearrayt (Type.effects () [Type.builtinIO ()])), + B "MutableArray.freeze" . forall2 "g" "a" $ \g a -> + marrayt g a --> nat --> nat --> Type.effect1 () g (iarrayt a), + B "MutableByteArray.freeze" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> nat --> Type.effect1 () g ibytearrayt, + B "Scope.array" . forall2 "s" "a" $ \s a -> + nat --> Type.effect1 () (scopet s) (marrayt (scopet s) a), B "Scope.arrayOf" . forall2 "s" "a" $ \s a -> a --> nat --> Type.effect1 () (scopet s) (marrayt (scopet s) a), B "Scope.bytearray" . forall1 "s" $ \s -> @@ -723,7 +735,21 @@ ioBuiltins = ("Clock.internals.threadCPUTime.v1", unit --> iof timeSpec), ("Clock.internals.realtime.v1", unit --> iof timeSpec), ("Clock.internals.sec.v1", timeSpec --> int), - ("Clock.internals.nsec.v1", timeSpec --> nat) + ("Clock.internals.nsec.v1", timeSpec --> nat), + ( "IO.array", + forall1 "a" $ \a -> + nat --> io (marrayt (Type.effects () [Type.builtinIO ()]) a) + ), + ( "IO.arrayOf", + forall1 "a" $ \a -> + a --> nat --> io (marrayt (Type.effects () [Type.builtinIO ()]) a) + ), + ( "IO.bytearray", + nat --> io (mbytearrayt (Type.effects () [Type.builtinIO ()])) + ), + ( "IO.bytearrayOf", + nat --> nat --> io (mbytearrayt (Type.effects () [Type.builtinIO ()])) + ) ] mvarBuiltins :: [(Text, Type)] @@ -848,7 +874,7 @@ ibytearrayt :: Type ibytearrayt = Type.ibytearrayType () mbytearrayt :: Type -> Type -mbytearrayt g = Type.ibytearrayType () `app` g +mbytearrayt g = Type.mbytearrayType () `app` g iarrayt :: Type -> Type iarrayt a = Type.iarrayType () `app` a diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index fd9d947576..961b01e250 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -135,6 +135,7 @@ import Unison.Symbol import qualified Unison.Type as Ty import qualified Unison.Util.Bytes as Bytes import Unison.Util.EnumContainers as EC +import Unison.Util.Text (Text) import qualified Unison.Util.Text as Util.Text import Unison.Var @@ -189,11 +190,21 @@ fresh9 = (v1, v2, v3, v4, v5, v6, v7, v8, v9) where [v1, v2, v3, v4, v5, v6, v7, v8, v9] = freshes 9 +fresh10 :: Var v => (v, v, v, v, v, v, v, v, v, v) +fresh10 = (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10) + where + [v1, v2, v3, v4, v5, v6, v7, v8, v9, v10] = freshes 10 + fresh11 :: Var v => (v, v, v, v, v, v, v, v, v, v, v) fresh11 = (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11) where [v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11] = freshes 11 +fresh13 :: Var v => (v, v, v, v, v, v, v, v, v, v, v, v, v) +fresh13 = (v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13) + where + [v1, v2, v3, v4, v5, v6, v7, v8, v9, v10, v11, v12, v13] = freshes 13 + fls, tru :: Var v => ANormal v fls = TCon Ty.booleanRef 0 [] tru = TCon Ty.booleanRef 1 [] @@ -1203,6 +1214,14 @@ outIoExnNat stack1 stack2 stack3 fail result = ) ] +outIoExnUnit :: forall v. Var v => v -> v -> v -> v -> v -> ANormal v +outIoExnUnit stack1 stack2 stack3 fail result = + TMatch result . MatchSum $ + mapFromList + [ exnCase stack1 stack2 stack3 fail, + (1, ([], TCon Ty.unitRef 0 [])) + ] + outIoExnBox :: Var v => v -> v -> v -> v -> v -> ANormal v outIoExnBox stack1 stack2 stack3 fail result = TMatch result . MatchSum $ @@ -1418,6 +1437,17 @@ wordBoxDirect wordType instr = where (b1, b2, ub1) = fresh3 +-- a -> Nat -> c +-- works for any second argument type that is packed into a word +boxWordDirect :: Reference -> ForeignOp +boxWordDirect wordType instr = + ([BX, BX],) + . TAbss [b1, b2] + . unbox b2 wordType ub2 + $ TFOp instr [b1, ub2] + where + (b1, b2, ub2) = fresh3 + -- a -> b -> c boxBoxDirect :: ForeignOp boxBoxDirect instr = @@ -1540,6 +1570,11 @@ natToBox = wordDirect Ty.natRef natNatToBox :: ForeignOp natNatToBox = wordWordDirect Ty.natRef Ty.natRef +-- a -> Nat -> c +-- Nat only +boxNatToBox :: ForeignOp +boxNatToBox = boxWordDirect Ty.natRef + -- a -> Nat -> Either Failure b boxNatToEFBox :: ForeignOp boxNatToEFBox = @@ -1559,18 +1594,8 @@ boxNatToExnBox = -- a -> Nat -> b ->{Exception} () boxNatBoxToExnUnit :: ForeignOp boxNatBoxToExnUnit = - inBxNatBx arg1 arg2 arg3 nat result - . TMatch result - . MatchSum - $ mapFromList - [ ( 0, - ([BX, BX],) - . TAbss [stack1, stack2, stack3] - . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2, stack3]) - $ TReq Ty.exceptionRef 1 [fail] - ), - (1, ([], TCon Ty.unitRef 0 [])) - ] + inBxNatBx arg1 arg2 arg3 nat result $ + outIoExnUnit stack1 stack2 stack3 fail result where (arg1, arg2, arg3, nat, stack1, stack2, stack3, fail, result) = fresh9 @@ -1585,20 +1610,31 @@ boxNatToExnNat = -- a -> Nat -> Nat ->{Exception} () boxNatNatToExnUnit :: ForeignOp boxNatNatToExnUnit = - inBxNatNat arg1 arg2 arg3 nat1 nat2 result - . TMatch result - . MatchSum - $ mapFromList - [ ( 0, - ([BX, BX],) - . TAbss [stack1, stack2] - . TLetD fail BX (TCon Ty.failureRef 0 [stack1, stack2]) - $ TReq Ty.exceptionRef 1 [fail] - ), - (1, ([], TCon Ty.unitRef 0 [])) - ] + inBxNatNat arg1 arg2 arg3 nat1 nat2 result $ + outIoExnUnit stack1 stack2 stack3 fail result + where + (arg1, arg2, arg3, nat1, nat2, result, stack1, stack2, stack3, fail) = fresh10 + +-- a -> Nat -> Nat ->{Exception} b +boxNatNatToExnBox :: ForeignOp +boxNatNatToExnBox = + inBxNatNat arg1 arg2 arg3 nat1 nat2 result $ + outIoExnBox stack1 stack2 stack3 fail result + where + (arg1, arg2, arg3, nat1, nat2, result, stack1, stack2, stack3, fail) = fresh10 + +-- a -> Nat -> b -> Nat -> Nat ->{Exception} () +boxNatBoxNatNatToExnUnit :: ForeignOp +boxNatBoxNatNatToExnUnit instr = + ([BX, BX, BX, BX, BX],) + . TAbss [a0, a1, a2, a3, a4] + . unbox a1 Ty.natRef ua1 + . unbox a3 Ty.natRef ua3 + . unbox a4 Ty.natRef ua4 + . TLetD result UN (TFOp instr [a0, ua1, a2, ua3, ua4]) + $ outIoExnUnit stack1 stack2 stack3 fail result where - (arg1, arg2, arg3, nat1, nat2, result, stack1, stack2, fail) = fresh9 + (a0, a1, a2, a3, a4, ua1, ua3, ua4, result, stack1, stack2, stack3, fail) = fresh13 -- Nat -> Either Failure b -- natToEFBox :: ForeignOp @@ -2354,63 +2390,160 @@ declareForeigns = do declareForeign Untracked "Bytes.encodeNat16be" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat16be declareForeign Untracked "Bytes.encodeNat16le" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat16le + declareForeign Tracked "MutableArray.copyTo!" boxNatBoxNatNatToExnUnit + . mkForeign + $ \(dst, doff, src, soff, l) -> + let name = "MutableArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ + checkBounds name (PA.sizeofMutableArray src) (soff + l - 1) $ + Right + <$> PA.copyMutableArray @IO @Closure + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + + declareForeign Tracked "MutableByteArray.copyTo!" boxNatBoxNatNatToExnUnit + . mkForeign + $ \(dst, doff, src, soff, l) -> + let name = "MutableByteArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l - 1) (0 :: Word8) $ + checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l - 1) (0 :: Word8) $ + Right + <$> PA.copyMutableByteArray @IO + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + + declareForeign Tracked "ImmutableArray.copyTo!" boxNatBoxNatNatToExnUnit + . mkForeign + $ \(dst, doff, src, soff, l) -> + let name = "ImmutableArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBounds name (PA.sizeofMutableArray dst) (doff + l - 1) $ + checkBounds name (PA.sizeofArray src) (soff + l - 1) $ + Right + <$> PA.copyArray @IO @Closure + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + + declareForeign Tracked "ImmutableByteArray.copyTo!" boxNatBoxNatNatToExnUnit + . mkForeign + $ \(dst, doff, src, soff, l) -> + let name = "ImmutableByteArray.copyTo!" + in if l == 0 + then pure (Right ()) + else + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l - 1) (0 :: Word8) $ + checkBoundsPrim name (PA.sizeofByteArray src) (soff + l - 1) (0 :: Word8) $ + Right + <$> PA.copyByteArray @IO + dst + (fromIntegral doff) + src + (fromIntegral soff) + (fromIntegral l) + declareForeign Tracked "MutableArray.read" boxNatToExnBox . mkForeign - $ checkedRead + $ checkedRead "MutableArray.read" declareForeign Tracked "MutableByteArray.read8" boxNatToExnNat . mkForeign - $ checkedReadPrim @Word8 + $ checkedReadPrim @Word8 "MutableByteArray.read8" declareForeign Tracked "MutableByteArray.read16" boxNatToExnNat . mkForeign - $ checkedReadPrim @Word16 + $ checkedReadPrim @Word16 "MutableByteArray.read16" declareForeign Tracked "MutableByteArray.read32" boxNatToExnNat . mkForeign - $ checkedReadPrim @Word32 + $ checkedReadPrim @Word32 "MutableByteArray.read32" declareForeign Tracked "MutableByteArray.read64" boxNatToExnNat . mkForeign - $ checkedReadPrim @Word64 + $ checkedReadPrim @Word64 "MutableByteArray.read64" declareForeign Tracked "MutableArray.write" boxNatBoxToExnUnit . mkForeign - $ checkedWrite + $ checkedWrite "MutableArray.write" declareForeign Tracked "MutableByteArray.write8" boxNatNatToExnUnit . mkForeign - $ checkedWritePrim @Word8 + $ checkedWritePrim @Word8 "MutableByteArray.write8" declareForeign Tracked "MutableByteArray.write16" boxNatNatToExnUnit . mkForeign - $ checkedWritePrim @Word16 + $ checkedWritePrim @Word16 "MutableByteArray.write16" declareForeign Tracked "MutableByteArray.write32" boxNatNatToExnUnit . mkForeign - $ checkedWritePrim @Word32 + $ checkedWritePrim @Word32 "MutableByteArray.write32" declareForeign Tracked "MutableByteArray.write64" boxNatNatToExnUnit . mkForeign - $ checkedWritePrim @Word64 + $ checkedWritePrim @Word64 "MutableByteArray.write64" declareForeign Untracked "ImmutableArray.read" boxNatToExnBox . mkForeign - $ checkedIndex + $ checkedIndex "ImmutableArray.read" declareForeign Untracked "ImmutableByteArray.read8" boxNatToExnNat . mkForeign - $ checkedIndexPrim @Word8 + $ checkedIndexPrim @Word8 "ImmutableByteArray.read8" declareForeign Untracked "ImmutableByteArray.read16" boxNatToExnNat . mkForeign - $ checkedIndexPrim @Word16 + $ checkedIndexPrim @Word16 "ImmutableByteArray.read16" declareForeign Untracked "ImmutableByteArray.read32" boxNatToExnNat . mkForeign - $ checkedIndexPrim @Word32 + $ checkedIndexPrim @Word32 "ImmutableByteArray.read32" declareForeign Untracked "ImmutableByteArray.read64" boxNatToExnNat . mkForeign - $ checkedIndexPrim @Word64 + $ checkedIndexPrim @Word64 "ImmutableByteArray.read64" declareForeign Tracked "MutableByteArray.freeze!" boxDirect . mkForeign $ PA.unsafeFreezeByteArray + declareForeign Tracked "MutableArray.freeze!" boxDirect . mkForeign $ + PA.unsafeFreezeArray @IO @Closure + + declareForeign Tracked "MutableByteArray.freeze" boxNatNatToExnBox . mkForeign $ + \(src, off, len) -> + if len == 0 + then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 + else + checkBoundsPrim + "MutableByteArray.freeze" + (PA.sizeofMutableByteArray src) + (off + len - 1) + (0 :: Word8) + $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) + + declareForeign Tracked "MutableArray.freeze" boxNatNatToExnBox . mkForeign $ + \(src, off, len) -> + if len == 0 + then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 Closure.BlackHole + else + checkBounds + "MutableArray.freeze" + (PA.sizeofMutableArray src) + (off + len - 1) + $ Right <$> PA.freezeArray src (fromIntegral off) (fromIntegral len) declareForeign Untracked "MutableByteArray.length" boxToNat . mkForeign $ - pure . PA.sizeofMutableByteArray + pure . PA.sizeofMutableByteArray @PA.RealWorld declareForeign Untracked "ImmutableByteArray.length" boxToNat . mkForeign $ pure . PA.sizeofByteArray + declareForeign Tracked "IO.array" natToBox . mkForeign $ + \n -> PA.newArray n Closure.BlackHole + declareForeign Tracked "IO.arrayOf" boxNatToBox . mkForeign $ + \(v :: Closure, n) -> PA.newArray n v declareForeign Tracked "IO.bytearray" natToBox . mkForeign $ PA.newByteArray declareForeign Tracked "IO.bytearrayOf" natNatToBox . mkForeign @@ -2419,6 +2552,10 @@ declareForeigns = do PA.fillByteArray arr 0 sz init pure arr + declareForeign Tracked "Scope.array" natToBox . mkForeign $ + \n -> PA.newArray n Closure.BlackHole + declareForeign Tracked "Scope.arrayOf" boxNatToBox . mkForeign $ + \(v :: Closure, n) -> PA.newArray n v declareForeign Tracked "Scope.bytearray" natToBox . mkForeign $ PA.newByteArray declareForeign Tracked "Scope.bytearrayOf" natNatToBox . mkForeign @@ -2429,59 +2566,78 @@ declareForeigns = do type RW = PA.PrimState IO -checkedRead :: (PA.MutableArray RW Closure, Word64) -> IO (Either Failure Closure) -checkedRead (arr, w) = - checkBounds (PA.sizeofMutableArray arr) w (PA.readArray arr (fromIntegral w)) +checkedRead :: + Text -> (PA.MutableArray RW Closure, Word64) -> IO (Either Failure Closure) +checkedRead name (arr, w) = + checkBounds + name + (PA.sizeofMutableArray arr) + w + (Right <$> PA.readArray arr (fromIntegral w)) checkedWrite :: - (PA.MutableArray RW Closure, Word64, Closure) -> IO (Either Failure ()) -checkedWrite (arr, w, v) = - checkBounds (PA.sizeofMutableArray arr) w (PA.writeArray arr (fromIntegral w) v) + Text -> (PA.MutableArray RW Closure, Word64, Closure) -> IO (Either Failure ()) +checkedWrite name (arr, w, v) = + checkBounds + name + (PA.sizeofMutableArray arr) + w + (Right <$> PA.writeArray arr (fromIntegral w) v) checkedIndex :: - (PA.Array Closure, Word64) -> IO (Either Failure Closure) -checkedIndex (arr, w) = - checkBounds (PA.sizeofArray arr) w (PA.indexArrayM arr (fromIntegral w)) + Text -> (PA.Array Closure, Word64) -> IO (Either Failure Closure) +checkedIndex name (arr, w) = + checkBounds + name + (PA.sizeofArray arr) + w + (Right <$> PA.indexArrayM arr (fromIntegral w)) checkedReadPrim :: forall a. PA.Prim a => + Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure a) -checkedReadPrim (arr, i) = +checkedReadPrim name (arr, i) = checkBoundsPrim + name (PA.sizeofMutableByteArray arr) i (undefined :: a) - (PA.readByteArray arr (fromIntegral i)) + (Right <$> PA.readByteArray arr (fromIntegral i)) checkedWritePrim :: forall a. PA.Prim a => + Text -> (PA.MutableByteArray RW, Word64, a) -> IO (Either Failure ()) -checkedWritePrim (arr, i, v) = +checkedWritePrim name (arr, i, v) = checkBoundsPrim + name (PA.sizeofMutableByteArray arr) i v - (PA.writeByteArray arr (fromIntegral i) v) + (Right <$> PA.writeByteArray arr (fromIntegral i) v) checkedIndexPrim :: - forall a. PA.Prim a => (PA.ByteArray, Word64) -> IO (Either Failure a) -checkedIndexPrim (arr, i) = + forall a. PA.Prim a => Text -> (PA.ByteArray, Word64) -> IO (Either Failure a) +checkedIndexPrim name (arr, i) = checkBoundsPrim + name (PA.sizeofByteArray arr) i (undefined :: a) - (pure $ PA.indexByteArray arr (fromIntegral i)) + (pure . Right $ PA.indexByteArray arr (fromIntegral i)) -checkBounds :: Int -> Word64 -> IO b -> IO (Either Failure b) -checkBounds l w act - | w < fromIntegral l = Right <$> act +checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) +checkBounds name l w act + | w < fromIntegral l = act | otherwise = pure $ Left err where - err = Failure Ty.arrayFailureRef "array index out of bounds" (natValue w) + msg = name <> ": array index out of bounds" + err = Failure Ty.arrayFailureRef msg (natValue w) -- Performs a bounds check on a byte array. Strategy is as follows: -- @@ -2492,12 +2648,13 @@ checkBounds l w act -- -- This should avoid having to worry about overflows. checkBoundsPrim :: - PA.Prim a => Int -> Word64 -> a -> IO b -> IO (Either Failure b) -checkBoundsPrim isz w a act + PA.Prim a => Text -> Int -> Word64 -> a -> IO (Either Failure b) -> IO (Either Failure b) +checkBoundsPrim name isz w a act | w >= asz = pure $ Left err - | otherwise = Right <$> act + | otherwise = act where - err = Failure Ty.arrayFailureRef "array index out of bounds" (natValue w) + msg = name <> ": array index out of bounds" + err = Failure Ty.arrayFailureRef msg (natValue w) bsz = fromIntegral isz sz = fromIntegral $ PA.sizeOf a diff --git a/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs b/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs index 3a5937f542..39cc29e6d8 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign/Function.hs @@ -350,6 +350,30 @@ instance (ustk, bstk) <- writeForeign ustk bstk b writeForeign ustk bstk a +instance + ( ForeignConvention a, + ForeignConvention b, + ForeignConvention c, + ForeignConvention d, + ForeignConvention e + ) => + ForeignConvention (a, b, c, d, e) + where + readForeign us bs ustk bstk = do + (us, bs, a) <- readForeign us bs ustk bstk + (us, bs, b) <- readForeign us bs ustk bstk + (us, bs, c) <- readForeign us bs ustk bstk + (us, bs, d) <- readForeign us bs ustk bstk + (us, bs, e) <- readForeign us bs ustk bstk + pure (us, bs, (a, b, c, d, e)) + + writeForeign ustk bstk (a, b, c, d, e) = do + (ustk, bstk) <- writeForeign ustk bstk e + (ustk, bstk) <- writeForeign ustk bstk d + (ustk, bstk) <- writeForeign ustk bstk c + (ustk, bstk) <- writeForeign ustk bstk b + writeForeign ustk bstk a + no'buf, line'buf, block'buf, sblock'buf :: Int no'buf = fromIntegral Ty.bufferModeNoBufferingId line'buf = fromIntegral Ty.bufferModeLineBufferingId diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index ed41e104ae..097c377585 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -141,424 +141,457 @@ Let's try it! 118. Float.truncate : Float -> Int 119. Handle.toText : Handle -> Text 120. builtin type ImmutableArray - 121. ImmutableArray.read : ImmutableArray a + 121. ImmutableArray.copyTo! : MutableArray g a + -> Nat + -> ImmutableArray a + -> Nat + -> Nat + ->{g, Exception} () + 122. ImmutableArray.read : ImmutableArray a -> Nat ->{Exception} a - 122. builtin type ImmutableByteArray - 123. ImmutableByteArray.read16 : ImmutableByteArray + 123. builtin type ImmutableByteArray + 124. ImmutableByteArray.copyTo! : MutableByteArray g + -> Nat + -> ImmutableByteArray + -> Nat + -> Nat + ->{g, Exception} () + 125. ImmutableByteArray.read16 : ImmutableByteArray -> Nat ->{Exception} Nat - 124. ImmutableByteArray.read32 : ImmutableByteArray + 126. ImmutableByteArray.read32 : ImmutableByteArray -> Nat ->{Exception} Nat - 125. ImmutableByteArray.read64 : ImmutableByteArray + 127. ImmutableByteArray.read64 : ImmutableByteArray -> Nat ->{Exception} Nat - 126. ImmutableByteArray.read8 : ImmutableByteArray + 128. ImmutableByteArray.read8 : ImmutableByteArray -> Nat ->{Exception} Nat - 127. builtin type Int - 128. Int.* : Int -> Int -> Int - 129. Int.+ : Int -> Int -> Int - 130. Int.- : Int -> Int -> Int - 131. Int./ : Int -> Int -> Int - 132. Int.and : Int -> Int -> Int - 133. Int.complement : Int -> Int - 134. Int.eq : Int -> Int -> Boolean - 135. Int.fromRepresentation : Nat -> Int - 136. Int.fromText : Text -> Optional Int - 137. Int.gt : Int -> Int -> Boolean - 138. Int.gteq : Int -> Int -> Boolean - 139. Int.increment : Int -> Int - 140. Int.isEven : Int -> Boolean - 141. Int.isOdd : Int -> Boolean - 142. Int.leadingZeros : Int -> Nat - 143. Int.lt : Int -> Int -> Boolean - 144. Int.lteq : Int -> Int -> Boolean - 145. Int.mod : Int -> Int -> Int - 146. Int.negate : Int -> Int - 147. Int.or : Int -> Int -> Int - 148. Int.popCount : Int -> Nat - 149. Int.pow : Int -> Nat -> Int - 150. Int.shiftLeft : Int -> Nat -> Int - 151. Int.shiftRight : Int -> Nat -> Int - 152. Int.signum : Int -> Int - 153. Int.toFloat : Int -> Float - 154. Int.toRepresentation : Int -> Nat - 155. Int.toText : Int -> Text - 156. Int.trailingZeros : Int -> Nat - 157. Int.truncate0 : Int -> Nat - 158. Int.xor : Int -> Int -> Int - 159. IO.arrayOf : a -> Nat ->{IO} MutableArray {IO} a - 160. IO.bytearray : Nat ->{IO} ImmutableByteArray {IO} - 161. IO.bytearrayOf : Nat - -> Nat - ->{IO} ImmutableByteArray {IO} - 162. unique type io2.ArrayFailure - 163. unique type io2.BufferMode - 164. io2.BufferMode.BlockBuffering : BufferMode - 165. io2.BufferMode.LineBuffering : BufferMode - 166. io2.BufferMode.NoBuffering : BufferMode - 167. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 168. io2.Clock.internals.monotonic : '{IO} Either + 129. builtin type Int + 130. Int.* : Int -> Int -> Int + 131. Int.+ : Int -> Int -> Int + 132. Int.- : Int -> Int -> Int + 133. Int./ : Int -> Int -> Int + 134. Int.and : Int -> Int -> Int + 135. Int.complement : Int -> Int + 136. Int.eq : Int -> Int -> Boolean + 137. Int.fromRepresentation : Nat -> Int + 138. Int.fromText : Text -> Optional Int + 139. Int.gt : Int -> Int -> Boolean + 140. Int.gteq : Int -> Int -> Boolean + 141. Int.increment : Int -> Int + 142. Int.isEven : Int -> Boolean + 143. Int.isOdd : Int -> Boolean + 144. Int.leadingZeros : Int -> Nat + 145. Int.lt : Int -> Int -> Boolean + 146. Int.lteq : Int -> Int -> Boolean + 147. Int.mod : Int -> Int -> Int + 148. Int.negate : Int -> Int + 149. Int.or : Int -> Int -> Int + 150. Int.popCount : Int -> Nat + 151. Int.pow : Int -> Nat -> Int + 152. Int.shiftLeft : Int -> Nat -> Int + 153. Int.shiftRight : Int -> Nat -> Int + 154. Int.signum : Int -> Int + 155. Int.toFloat : Int -> Float + 156. Int.toRepresentation : Int -> Nat + 157. Int.toText : Int -> Text + 158. Int.trailingZeros : Int -> Nat + 159. Int.truncate0 : Int -> Nat + 160. Int.xor : Int -> Int -> Int + 161. unique type io2.ArrayFailure + 162. unique type io2.BufferMode + 163. io2.BufferMode.BlockBuffering : BufferMode + 164. io2.BufferMode.LineBuffering : BufferMode + 165. io2.BufferMode.NoBuffering : BufferMode + 166. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 167. io2.Clock.internals.monotonic : '{IO} Either Failure TimeSpec - 169. io2.Clock.internals.nsec : TimeSpec -> Nat - 170. io2.Clock.internals.processCPUTime : '{IO} Either + 168. io2.Clock.internals.nsec : TimeSpec -> Nat + 169. io2.Clock.internals.processCPUTime : '{IO} Either Failure TimeSpec - 171. io2.Clock.internals.realtime : '{IO} Either + 170. io2.Clock.internals.realtime : '{IO} Either Failure TimeSpec - 172. io2.Clock.internals.sec : TimeSpec -> Int - 173. io2.Clock.internals.threadCPUTime : '{IO} Either + 171. io2.Clock.internals.sec : TimeSpec -> Int + 172. io2.Clock.internals.threadCPUTime : '{IO} Either Failure TimeSpec - 174. builtin type io2.Clock.internals.TimeSpec - 175. unique type io2.Failure - 176. io2.Failure.Failure : Type -> Text -> Any -> Failure - 177. unique type io2.FileMode - 178. io2.FileMode.Append : FileMode - 179. io2.FileMode.Read : FileMode - 180. io2.FileMode.ReadWrite : FileMode - 181. io2.FileMode.Write : FileMode - 182. builtin type io2.Handle - 183. builtin type io2.IO - 184. io2.IO.clientSocket.impl : Text + 173. builtin type io2.Clock.internals.TimeSpec + 174. unique type io2.Failure + 175. io2.Failure.Failure : Type -> Text -> Any -> Failure + 176. unique type io2.FileMode + 177. io2.FileMode.Append : FileMode + 178. io2.FileMode.Read : FileMode + 179. io2.FileMode.ReadWrite : FileMode + 180. io2.FileMode.Write : FileMode + 181. builtin type io2.Handle + 182. builtin type io2.IO + 183. io2.IO.array : Nat ->{IO} MutableArray {IO} a + 184. io2.IO.arrayOf : a -> Nat ->{IO} MutableArray {IO} a + 185. io2.IO.bytearray : Nat ->{IO} MutableByteArray {IO} + 186. io2.IO.bytearrayOf : Nat + -> Nat + ->{IO} MutableByteArray {IO} + 187. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 185. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 186. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 187. io2.IO.createDirectory.impl : Text + 188. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 189. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 190. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 188. io2.IO.createTempDirectory.impl : Text + 191. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 189. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 190. io2.IO.directoryContents.impl : Text + 192. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 193. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 191. io2.IO.fileExists.impl : Text + 194. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 192. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 193. io2.IO.getArgs.impl : '{IO} Either Failure [Text] - 194. io2.IO.getBuffering.impl : Handle + 195. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 196. io2.IO.getArgs.impl : '{IO} Either Failure [Text] + 197. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 195. io2.IO.getBytes.impl : Handle + 198. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 196. io2.IO.getCurrentDirectory.impl : '{IO} Either + 199. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 197. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 198. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 199. io2.IO.getFileTimestamp.impl : Text + 200. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 201. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 202. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 200. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 201. io2.IO.getSomeBytes.impl : Handle + 203. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 204. io2.IO.getSomeBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 202. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 203. io2.IO.handlePosition.impl : Handle + 205. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 206. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 204. io2.IO.isDirectory.impl : Text + 207. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 205. io2.IO.isFileEOF.impl : Handle + 208. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 206. io2.IO.isFileOpen.impl : Handle + 209. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 207. io2.IO.isSeekable.impl : Handle + 210. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 208. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 209. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 210. io2.IO.openFile.impl : Text + 211. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 212. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 213. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 211. io2.IO.putBytes.impl : Handle + 214. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 212. io2.IO.ref : a ->{IO} Ref {IO} a - 213. io2.IO.removeDirectory.impl : Text + 215. io2.IO.ref : a ->{IO} Ref {IO} a + 216. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 214. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 215. io2.IO.renameDirectory.impl : Text + 217. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 218. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 216. io2.IO.renameFile.impl : Text + 219. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 217. io2.IO.seekHandle.impl : Handle + 220. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 218. io2.IO.serverSocket.impl : Optional Text + 221. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 219. io2.IO.setBuffering.impl : Handle + 222. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 220. io2.IO.setCurrentDirectory.impl : Text + 223. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 221. io2.IO.socketAccept.impl : Socket + 224. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 222. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 223. io2.IO.socketReceive.impl : Socket + 225. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 226. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 224. io2.IO.socketSend.impl : Socket + 227. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 225. io2.IO.stdHandle : StdHandle -> Handle - 226. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 227. io2.IO.systemTimeMicroseconds : '{IO} Int - 228. unique type io2.IOError - 229. io2.IOError.AlreadyExists : IOError - 230. io2.IOError.EOF : IOError - 231. io2.IOError.IllegalOperation : IOError - 232. io2.IOError.NoSuchThing : IOError - 233. io2.IOError.PermissionDenied : IOError - 234. io2.IOError.ResourceBusy : IOError - 235. io2.IOError.ResourceExhausted : IOError - 236. io2.IOError.UserError : IOError - 237. unique type io2.IOFailure - 238. builtin type io2.MVar - 239. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 240. io2.MVar.new : a ->{IO} MVar a - 241. io2.MVar.newEmpty : '{IO} MVar a - 242. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 243. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 244. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 245. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 246. io2.MVar.tryPut.impl : MVar a + 228. io2.IO.stdHandle : StdHandle -> Handle + 229. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 230. io2.IO.systemTimeMicroseconds : '{IO} Int + 231. unique type io2.IOError + 232. io2.IOError.AlreadyExists : IOError + 233. io2.IOError.EOF : IOError + 234. io2.IOError.IllegalOperation : IOError + 235. io2.IOError.NoSuchThing : IOError + 236. io2.IOError.PermissionDenied : IOError + 237. io2.IOError.ResourceBusy : IOError + 238. io2.IOError.ResourceExhausted : IOError + 239. io2.IOError.UserError : IOError + 240. unique type io2.IOFailure + 241. builtin type io2.MVar + 242. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 243. io2.MVar.new : a ->{IO} MVar a + 244. io2.MVar.newEmpty : '{IO} MVar a + 245. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 246. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 247. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 248. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 249. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 247. io2.MVar.tryRead.impl : MVar a + 250. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 248. io2.MVar.tryTake : MVar a ->{IO} Optional a - 249. unique type io2.SeekMode - 250. io2.SeekMode.AbsoluteSeek : SeekMode - 251. io2.SeekMode.RelativeSeek : SeekMode - 252. io2.SeekMode.SeekFromEnd : SeekMode - 253. builtin type io2.Socket - 254. unique type io2.StdHandle - 255. io2.StdHandle.StdErr : StdHandle - 256. io2.StdHandle.StdIn : StdHandle - 257. io2.StdHandle.StdOut : StdHandle - 258. builtin type io2.STM - 259. io2.STM.atomically : '{STM} a ->{IO} a - 260. io2.STM.retry : '{STM} a - 261. builtin type io2.ThreadId - 262. builtin type io2.Tls - 263. builtin type io2.Tls.Cipher - 264. builtin type io2.Tls.ClientConfig - 265. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 251. io2.MVar.tryTake : MVar a ->{IO} Optional a + 252. unique type io2.SeekMode + 253. io2.SeekMode.AbsoluteSeek : SeekMode + 254. io2.SeekMode.RelativeSeek : SeekMode + 255. io2.SeekMode.SeekFromEnd : SeekMode + 256. builtin type io2.Socket + 257. unique type io2.StdHandle + 258. io2.StdHandle.StdErr : StdHandle + 259. io2.StdHandle.StdIn : StdHandle + 260. io2.StdHandle.StdOut : StdHandle + 261. builtin type io2.STM + 262. io2.STM.atomically : '{STM} a ->{IO} a + 263. io2.STM.retry : '{STM} a + 264. builtin type io2.ThreadId + 265. builtin type io2.Tls + 266. builtin type io2.Tls.Cipher + 267. builtin type io2.Tls.ClientConfig + 268. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 266. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 269. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 267. io2.Tls.ClientConfig.default : Text + 270. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 268. io2.Tls.ClientConfig.versions.set : [Version] + 271. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 269. io2.Tls.decodeCert.impl : Bytes + 272. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 270. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 271. io2.Tls.encodeCert : SignedCert -> Bytes - 272. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 273. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 274. io2.Tls.newClient.impl : ClientConfig + 273. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 274. io2.Tls.encodeCert : SignedCert -> Bytes + 275. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 276. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 277. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 275. io2.Tls.newServer.impl : ServerConfig + 278. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 276. builtin type io2.Tls.PrivateKey - 277. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 278. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 279. builtin type io2.Tls.ServerConfig - 280. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 279. builtin type io2.Tls.PrivateKey + 280. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 281. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 282. builtin type io2.Tls.ServerConfig + 283. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 281. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 284. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 282. io2.Tls.ServerConfig.default : [SignedCert] + 285. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 283. io2.Tls.ServerConfig.versions.set : [Version] + 286. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 284. builtin type io2.Tls.SignedCert - 285. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 286. builtin type io2.Tls.Version - 287. unique type io2.TlsFailure - 288. builtin type io2.TVar - 289. io2.TVar.new : a ->{STM} TVar a - 290. io2.TVar.newIO : a ->{IO} TVar a - 291. io2.TVar.read : TVar a ->{STM} a - 292. io2.TVar.readIO : TVar a ->{IO} a - 293. io2.TVar.swap : TVar a -> a ->{STM} a - 294. io2.TVar.write : TVar a -> a ->{STM} () - 295. io2.validateSandboxed : [Term] -> a -> Boolean - 296. unique type IsPropagated - 297. IsPropagated.IsPropagated : IsPropagated - 298. unique type IsTest - 299. IsTest.IsTest : IsTest - 300. unique type Link - 301. builtin type Link.Term - 302. Link.Term : Term -> Link - 303. Link.Term.toText : Term -> Text - 304. builtin type Link.Type - 305. Link.Type : Type -> Link - 306. builtin type List - 307. List.++ : [a] -> [a] -> [a] - 308. List.+: : a -> [a] -> [a] - 309. List.:+ : [a] -> a -> [a] - 310. List.at : Nat -> [a] -> Optional a - 311. List.cons : a -> [a] -> [a] - 312. List.drop : Nat -> [a] -> [a] - 313. List.empty : [a] - 314. List.size : [a] -> Nat - 315. List.snoc : [a] -> a -> [a] - 316. List.take : Nat -> [a] -> [a] - 317. metadata.isPropagated : IsPropagated - 318. metadata.isTest : IsTest - 319. builtin type MutableArray - 320. MutableArray.freeze! : MutableArray g a + 287. builtin type io2.Tls.SignedCert + 288. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 289. builtin type io2.Tls.Version + 290. unique type io2.TlsFailure + 291. builtin type io2.TVar + 292. io2.TVar.new : a ->{STM} TVar a + 293. io2.TVar.newIO : a ->{IO} TVar a + 294. io2.TVar.read : TVar a ->{STM} a + 295. io2.TVar.readIO : TVar a ->{IO} a + 296. io2.TVar.swap : TVar a -> a ->{STM} a + 297. io2.TVar.write : TVar a -> a ->{STM} () + 298. io2.validateSandboxed : [Term] -> a -> Boolean + 299. unique type IsPropagated + 300. IsPropagated.IsPropagated : IsPropagated + 301. unique type IsTest + 302. IsTest.IsTest : IsTest + 303. unique type Link + 304. builtin type Link.Term + 305. Link.Term : Term -> Link + 306. Link.Term.toText : Term -> Text + 307. builtin type Link.Type + 308. Link.Type : Type -> Link + 309. builtin type List + 310. List.++ : [a] -> [a] -> [a] + 311. List.+: : a -> [a] -> [a] + 312. List.:+ : [a] -> a -> [a] + 313. List.at : Nat -> [a] -> Optional a + 314. List.cons : a -> [a] -> [a] + 315. List.drop : Nat -> [a] -> [a] + 316. List.empty : [a] + 317. List.size : [a] -> Nat + 318. List.snoc : [a] -> a -> [a] + 319. List.take : Nat -> [a] -> [a] + 320. metadata.isPropagated : IsPropagated + 321. metadata.isTest : IsTest + 322. builtin type MutableArray + 323. MutableArray.copyTo! : MutableArray g a + -> Nat + -> MutableArray g a + -> Nat + -> Nat + ->{g, Exception} () + 324. MutableArray.freeze : MutableArray g a + -> Nat + -> Nat + ->{g} ImmutableArray a + 325. MutableArray.freeze! : MutableArray g a ->{g} ImmutableArray a - 321. MutableArray.read : MutableArray g a + 326. MutableArray.read : MutableArray g a -> Nat ->{g, Exception} a - 322. MutableArray.write : MutableArray g a + 327. MutableArray.write : MutableArray g a -> Nat -> a ->{g, Exception} () - 323. builtin type MutableByteArray - 324. MutableByteArray.freeze! : ImmutableByteArray g + 328. builtin type MutableByteArray + 329. MutableByteArray.copyTo! : MutableByteArray g + -> Nat + -> MutableByteArray g + -> Nat + -> Nat + ->{g, Exception} () + 330. MutableByteArray.freeze : MutableByteArray g + -> Nat + -> Nat + ->{g} ImmutableByteArray + 331. MutableByteArray.freeze! : MutableByteArray g ->{g} ImmutableByteArray - 325. MutableByteArray.read16 : ImmutableByteArray g + 332. MutableByteArray.read16 : MutableByteArray g -> Nat ->{g, Exception} Nat - 326. MutableByteArray.read32 : ImmutableByteArray g + 333. MutableByteArray.read32 : MutableByteArray g -> Nat ->{g, Exception} Nat - 327. MutableByteArray.read64 : ImmutableByteArray g + 334. MutableByteArray.read64 : MutableByteArray g -> Nat ->{g, Exception} Nat - 328. MutableByteArray.read8 : ImmutableByteArray g + 335. MutableByteArray.read8 : MutableByteArray g -> Nat ->{g, Exception} Nat - 329. MutableByteArray.write16 : ImmutableByteArray g + 336. MutableByteArray.write16 : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 330. MutableByteArray.write32 : ImmutableByteArray g + 337. MutableByteArray.write32 : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 331. MutableByteArray.write64 : ImmutableByteArray g + 338. MutableByteArray.write64 : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 332. MutableByteArray.write8 : ImmutableByteArray g + 339. MutableByteArray.write8 : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 333. builtin type Nat - 334. Nat.* : Nat -> Nat -> Nat - 335. Nat.+ : Nat -> Nat -> Nat - 336. Nat./ : Nat -> Nat -> Nat - 337. Nat.and : Nat -> Nat -> Nat - 338. Nat.complement : Nat -> Nat - 339. Nat.drop : Nat -> Nat -> Nat - 340. Nat.eq : Nat -> Nat -> Boolean - 341. Nat.fromText : Text -> Optional Nat - 342. Nat.gt : Nat -> Nat -> Boolean - 343. Nat.gteq : Nat -> Nat -> Boolean - 344. Nat.increment : Nat -> Nat - 345. Nat.isEven : Nat -> Boolean - 346. Nat.isOdd : Nat -> Boolean - 347. Nat.leadingZeros : Nat -> Nat - 348. Nat.lt : Nat -> Nat -> Boolean - 349. Nat.lteq : Nat -> Nat -> Boolean - 350. Nat.mod : Nat -> Nat -> Nat - 351. Nat.or : Nat -> Nat -> Nat - 352. Nat.popCount : Nat -> Nat - 353. Nat.pow : Nat -> Nat -> Nat - 354. Nat.shiftLeft : Nat -> Nat -> Nat - 355. Nat.shiftRight : Nat -> Nat -> Nat - 356. Nat.sub : Nat -> Nat -> Int - 357. Nat.toFloat : Nat -> Float - 358. Nat.toInt : Nat -> Int - 359. Nat.toText : Nat -> Text - 360. Nat.trailingZeros : Nat -> Nat - 361. Nat.xor : Nat -> Nat -> Nat - 362. structural type Optional a - 363. Optional.None : Optional a - 364. Optional.Some : a -> Optional a - 365. builtin type Ref - 366. Ref.read : Ref g a ->{g} a - 367. Ref.write : Ref g a -> a ->{g} () - 368. builtin type Request - 369. builtin type Scope - 370. Scope.arrayOf : a + 340. builtin type Nat + 341. Nat.* : Nat -> Nat -> Nat + 342. Nat.+ : Nat -> Nat -> Nat + 343. Nat./ : Nat -> Nat -> Nat + 344. Nat.and : Nat -> Nat -> Nat + 345. Nat.complement : Nat -> Nat + 346. Nat.drop : Nat -> Nat -> Nat + 347. Nat.eq : Nat -> Nat -> Boolean + 348. Nat.fromText : Text -> Optional Nat + 349. Nat.gt : Nat -> Nat -> Boolean + 350. Nat.gteq : Nat -> Nat -> Boolean + 351. Nat.increment : Nat -> Nat + 352. Nat.isEven : Nat -> Boolean + 353. Nat.isOdd : Nat -> Boolean + 354. Nat.leadingZeros : Nat -> Nat + 355. Nat.lt : Nat -> Nat -> Boolean + 356. Nat.lteq : Nat -> Nat -> Boolean + 357. Nat.mod : Nat -> Nat -> Nat + 358. Nat.or : Nat -> Nat -> Nat + 359. Nat.popCount : Nat -> Nat + 360. Nat.pow : Nat -> Nat -> Nat + 361. Nat.shiftLeft : Nat -> Nat -> Nat + 362. Nat.shiftRight : Nat -> Nat -> Nat + 363. Nat.sub : Nat -> Nat -> Int + 364. Nat.toFloat : Nat -> Float + 365. Nat.toInt : Nat -> Int + 366. Nat.toText : Nat -> Text + 367. Nat.trailingZeros : Nat -> Nat + 368. Nat.xor : Nat -> Nat -> Nat + 369. structural type Optional a + 370. Optional.None : Optional a + 371. Optional.Some : a -> Optional a + 372. builtin type Ref + 373. Ref.read : Ref g a ->{g} a + 374. Ref.write : Ref g a -> a ->{g} () + 375. builtin type Request + 376. builtin type Scope + 377. Scope.array : Nat ->{Scope s} MutableArray (Scope s) a + 378. Scope.arrayOf : a -> Nat ->{Scope s} MutableArray (Scope s) a - 371. Scope.bytearray : Nat - ->{Scope s} ImmutableByteArray - (Scope s) - 372. Scope.bytearrayOf : Nat + 379. Scope.bytearray : Nat + ->{Scope s} MutableByteArray (Scope s) + 380. Scope.bytearrayOf : Nat -> Nat - ->{Scope s} ImmutableByteArray + ->{Scope s} MutableByteArray (Scope s) - 373. Scope.ref : a ->{Scope s} Ref {Scope s} a - 374. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 375. structural type SeqView a b - 376. SeqView.VElem : a -> b -> SeqView a b - 377. SeqView.VEmpty : SeqView a b - 378. Socket.toText : Socket -> Text - 379. unique type Test.Result - 380. Test.Result.Fail : Text -> Result - 381. Test.Result.Ok : Text -> Result - 382. builtin type Text - 383. Text.!= : Text -> Text -> Boolean - 384. Text.++ : Text -> Text -> Text - 385. Text.drop : Nat -> Text -> Text - 386. Text.empty : Text - 387. Text.eq : Text -> Text -> Boolean - 388. Text.fromCharList : [Char] -> Text - 389. Text.fromUtf8.impl : Bytes -> Either Failure Text - 390. Text.gt : Text -> Text -> Boolean - 391. Text.gteq : Text -> Text -> Boolean - 392. Text.lt : Text -> Text -> Boolean - 393. Text.lteq : Text -> Text -> Boolean - 394. Text.repeat : Nat -> Text -> Text - 395. Text.size : Text -> Nat - 396. Text.take : Nat -> Text -> Text - 397. Text.toCharList : Text -> [Char] - 398. Text.toUtf8 : Text -> Bytes - 399. Text.uncons : Text -> Optional (Char, Text) - 400. Text.unsnoc : Text -> Optional (Text, Char) - 401. ThreadId.toText : ThreadId -> Text - 402. todo : a -> b - 403. structural type Tuple a b - 404. Tuple.Cons : a -> b -> Tuple a b - 405. structural type Unit - 406. Unit.Unit : () - 407. Universal.< : a -> a -> Boolean - 408. Universal.<= : a -> a -> Boolean - 409. Universal.== : a -> a -> Boolean - 410. Universal.> : a -> a -> Boolean - 411. Universal.>= : a -> a -> Boolean - 412. Universal.compare : a -> a -> Int - 413. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 414. builtin type Value - 415. Value.dependencies : Value -> [Term] - 416. Value.deserialize : Bytes -> Either Text Value - 417. Value.load : Value ->{IO} Either [Term] a - 418. Value.serialize : Value -> Bytes - 419. Value.value : a -> Value + 381. Scope.ref : a ->{Scope s} Ref {Scope s} a + 382. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r + 383. structural type SeqView a b + 384. SeqView.VElem : a -> b -> SeqView a b + 385. SeqView.VEmpty : SeqView a b + 386. Socket.toText : Socket -> Text + 387. unique type Test.Result + 388. Test.Result.Fail : Text -> Result + 389. Test.Result.Ok : Text -> Result + 390. builtin type Text + 391. Text.!= : Text -> Text -> Boolean + 392. Text.++ : Text -> Text -> Text + 393. Text.drop : Nat -> Text -> Text + 394. Text.empty : Text + 395. Text.eq : Text -> Text -> Boolean + 396. Text.fromCharList : [Char] -> Text + 397. Text.fromUtf8.impl : Bytes -> Either Failure Text + 398. Text.gt : Text -> Text -> Boolean + 399. Text.gteq : Text -> Text -> Boolean + 400. Text.lt : Text -> Text -> Boolean + 401. Text.lteq : Text -> Text -> Boolean + 402. Text.repeat : Nat -> Text -> Text + 403. Text.size : Text -> Nat + 404. Text.take : Nat -> Text -> Text + 405. Text.toCharList : Text -> [Char] + 406. Text.toUtf8 : Text -> Bytes + 407. Text.uncons : Text -> Optional (Char, Text) + 408. Text.unsnoc : Text -> Optional (Text, Char) + 409. ThreadId.toText : ThreadId -> Text + 410. todo : a -> b + 411. structural type Tuple a b + 412. Tuple.Cons : a -> b -> Tuple a b + 413. structural type Unit + 414. Unit.Unit : () + 415. Universal.< : a -> a -> Boolean + 416. Universal.<= : a -> a -> Boolean + 417. Universal.== : a -> a -> Boolean + 418. Universal.> : a -> a -> Boolean + 419. Universal.>= : a -> a -> Boolean + 420. Universal.compare : a -> a -> Int + 421. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 422. builtin type Value + 423. Value.dependencies : Value -> [Term] + 424. Value.deserialize : Bytes -> Either Text Value + 425. Value.load : Value ->{IO} Either [Term] a + 426. Value.serialize : Value -> Bytes + 427. Value.value : a -> Value .builtin> alias.many 94-104 .mylib diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index df210f5abd..d478fd83e8 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -29,53 +29,52 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 18. Float (builtin type) 19. Float/ (38 definitions) 20. Handle/ (1 definition) - 21. IO/ (3 definitions) - 22. ImmutableArray (builtin type) - 23. ImmutableArray/ (1 definition) - 24. ImmutableByteArray (builtin type) - 25. ImmutableByteArray/ (4 definitions) - 26. Int (builtin type) - 27. Int/ (31 definitions) - 28. IsPropagated (type) - 29. IsPropagated/ (1 definition) - 30. IsTest (type) - 31. IsTest/ (1 definition) - 32. Link (type) - 33. Link/ (5 definitions) - 34. List (builtin type) - 35. List/ (10 definitions) - 36. MutableArray (builtin type) - 37. MutableArray/ (3 definitions) - 38. MutableByteArray (builtin type) - 39. MutableByteArray/ (9 definitions) - 40. Nat (builtin type) - 41. Nat/ (28 definitions) - 42. Optional (type) - 43. Optional/ (2 definitions) - 44. Ref (builtin type) - 45. Ref/ (2 definitions) - 46. Request (builtin type) - 47. Scope (builtin type) - 48. Scope/ (5 definitions) - 49. SeqView (type) - 50. SeqView/ (2 definitions) - 51. Socket/ (1 definition) - 52. Test/ (3 definitions) - 53. Text (builtin type) - 54. Text/ (18 definitions) - 55. ThreadId/ (1 definition) - 56. Tuple (type) - 57. Tuple/ (1 definition) - 58. Unit (type) - 59. Unit/ (1 definition) - 60. Universal/ (6 definitions) - 61. Value (builtin type) - 62. Value/ (5 definitions) - 63. bug (a -> b) - 64. crypto/ (12 definitions) - 65. io2/ (134 definitions) - 66. metadata/ (2 definitions) - 67. todo (a -> b) - 68. unsafe/ (1 definition) + 21. ImmutableArray (builtin type) + 22. ImmutableArray/ (2 definitions) + 23. ImmutableByteArray (builtin type) + 24. ImmutableByteArray/ (5 definitions) + 25. Int (builtin type) + 26. Int/ (31 definitions) + 27. IsPropagated (type) + 28. IsPropagated/ (1 definition) + 29. IsTest (type) + 30. IsTest/ (1 definition) + 31. Link (type) + 32. Link/ (5 definitions) + 33. List (builtin type) + 34. List/ (10 definitions) + 35. MutableArray (builtin type) + 36. MutableArray/ (5 definitions) + 37. MutableByteArray (builtin type) + 38. MutableByteArray/ (11 definitions) + 39. Nat (builtin type) + 40. Nat/ (28 definitions) + 41. Optional (type) + 42. Optional/ (2 definitions) + 43. Ref (builtin type) + 44. Ref/ (2 definitions) + 45. Request (builtin type) + 46. Scope (builtin type) + 47. Scope/ (6 definitions) + 48. SeqView (type) + 49. SeqView/ (2 definitions) + 50. Socket/ (1 definition) + 51. Test/ (3 definitions) + 52. Text (builtin type) + 53. Text/ (18 definitions) + 54. ThreadId/ (1 definition) + 55. Tuple (type) + 56. Tuple/ (1 definition) + 57. Unit (type) + 58. Unit/ (1 definition) + 59. Universal/ (6 definitions) + 60. Value (builtin type) + 61. Value/ (5 definitions) + 62. bug (a -> b) + 63. crypto/ (12 definitions) + 64. io2/ (138 definitions) + 65. metadata/ (2 definitions) + 66. todo (a -> b) + 67. unsafe/ (1 definition) ``` diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index 2bb4365a82..fc4caea930 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (419 definitions) + 1. builtin/ (427 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (605 definitions) + 1. builtin/ (613 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 6146191c21..b797063ede 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -121,13 +121,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #1s8a7bk9ta + โŠ™ 1. #abf3t3skdj - Deletes: feature1.y - โŠ™ 2. #1c6m7928vs + โŠ™ 2. #7u7981fggg + Adds / updates: @@ -138,26 +138,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - โŠ™ 3. #j0qoj3r276 + โŠ™ 3. #n3thhc4ija + Adds / updates: feature1.y - โŠ™ 4. #h3kqn9af5i + โŠ™ 4. #emlkep058v > Moves: Original name New name x master.x - โŠ™ 5. #argto4qqhg + โŠ™ 5. #eh2rm2mt08 + Adds / updates: x - โ–ก 6. #ou466aob20 (start of history) + โ–ก 6. #84g32tb0ov (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md index e60359ca54..022eb242fc 100644 --- a/unison-src/transcripts/name-selection.output.md +++ b/unison-src/transcripts/name-selection.output.md @@ -314,877 +314,932 @@ d = c + 10 143. builtin.Nat.and : Nat -> Nat -> Nat - 144. builtin.IO.arrayOf : a + 144. builtin.io2.IO.array : Nat + ->{IO} MutableArray + {IO} a + 145. builtin.Scope.array : Nat + ->{Scope + s} MutableArray + (Scope + s) + a + 146. builtin.io2.IO.arrayOf : a -> Nat ->{IO} MutableArray {IO} a - 145. builtin.Scope.arrayOf : a + 147. builtin.Scope.arrayOf : a -> Nat ->{Scope s} MutableArray (Scope s) a - 146. builtin.Float.asin : Float + 148. builtin.Float.asin : Float -> Float - 147. builtin.Float.asinh : Float + 149. builtin.Float.asinh : Float -> Float - 148. builtin.Bytes.at : Nat + 150. builtin.Bytes.at : Nat -> Bytes -> Optional Nat - 149. builtin.List.at : Nat + 151. builtin.List.at : Nat -> [a] -> Optional a - 150. builtin.Float.atan : Float + 152. builtin.Float.atan : Float -> Float - 151. builtin.Float.atan2 : Float + 153. builtin.Float.atan2 : Float -> Float -> Float - 152. builtin.Float.atanh : Float + 154. builtin.Float.atanh : Float -> Float - 153. builtin.io2.STM.atomically : '{STM} a + 155. builtin.io2.STM.atomically : '{STM} a ->{IO} a - 154. builtin.bug : a -> b - 155. builtin.IO.bytearray : Nat - ->{IO} ImmutableByteArray + 156. builtin.bug : a -> b + 157. builtin.io2.IO.bytearray : Nat + ->{IO} MutableByteArray {IO} - 156. builtin.Scope.bytearray : Nat + 158. builtin.Scope.bytearray : Nat ->{Scope - s} ImmutableByteArray + s} MutableByteArray (Scope s) - 157. builtin.IO.bytearrayOf : Nat + 159. builtin.io2.IO.bytearrayOf : Nat -> Nat - ->{IO} ImmutableByteArray + ->{IO} MutableByteArray {IO} - 158. builtin.Scope.bytearrayOf : Nat + 160. builtin.Scope.bytearrayOf : Nat -> Nat ->{Scope - s} ImmutableByteArray + s} MutableByteArray (Scope s) - 159. โ”Œ c#gjmq673r1v : Nat - 160. โ”” aaaa.tooManySegments : Nat - 161. builtin.Code.cache_ : [( Term, + 161. โ”Œ c#gjmq673r1v : Nat + 162. โ”” aaaa.tooManySegments : Nat + 163. builtin.Code.cache_ : [( Term, Code)] ->{IO} [Term] - 162. builtin.Float.ceiling : Float + 164. builtin.Float.ceiling : Float -> Int - 163. builtin.unsafe.coerceAbilities : (a + 165. builtin.unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 164. builtin.Universal.compare : a + 166. builtin.Universal.compare : a -> a -> Int - 165. builtin.Int.complement : Int + 167. builtin.Int.complement : Int -> Int - 166. builtin.Nat.complement : Nat + 168. builtin.Nat.complement : Nat -> Nat - 167. builtin.Bytes.gzip.compress : Bytes + 169. builtin.Bytes.gzip.compress : Bytes -> Bytes - 168. builtin.Bytes.zlib.compress : Bytes + 170. builtin.Bytes.zlib.compress : Bytes -> Bytes - 169. builtin.Float.cos : Float + 171. builtin.ImmutableArray.copyTo! : MutableArray + g a + -> Nat + -> ImmutableArray + a + -> Nat + -> Nat + ->{g, + Exception} () + 172. builtin.ImmutableByteArray.copyTo! : MutableByteArray + g + -> Nat + -> ImmutableByteArray + -> Nat + -> Nat + ->{g, + Exception} () + 173. builtin.MutableArray.copyTo! : MutableArray + g a + -> Nat + -> MutableArray + g a + -> Nat + -> Nat + ->{g, + Exception} () + 174. builtin.MutableByteArray.copyTo! : MutableByteArray + g + -> Nat + -> MutableByteArray + g + -> Nat + -> Nat + ->{g, + Exception} () + 175. builtin.Float.cos : Float -> Float - 170. builtin.Float.cosh : Float + 176. builtin.Float.cosh : Float -> Float - 171. builtin.Bytes.decodeNat16be : Bytes + 177. builtin.Bytes.decodeNat16be : Bytes -> Optional ( Nat, Bytes) - 172. builtin.Bytes.decodeNat16le : Bytes + 178. builtin.Bytes.decodeNat16le : Bytes -> Optional ( Nat, Bytes) - 173. builtin.Bytes.decodeNat32be : Bytes + 179. builtin.Bytes.decodeNat32be : Bytes -> Optional ( Nat, Bytes) - 174. builtin.Bytes.decodeNat32le : Bytes + 180. builtin.Bytes.decodeNat32le : Bytes -> Optional ( Nat, Bytes) - 175. builtin.Bytes.decodeNat64be : Bytes + 181. builtin.Bytes.decodeNat64be : Bytes -> Optional ( Nat, Bytes) - 176. builtin.Bytes.decodeNat64le : Bytes + 182. builtin.Bytes.decodeNat64le : Bytes -> Optional ( Nat, Bytes) - 177. builtin.io2.Tls.decodePrivateKey : Bytes + 183. builtin.io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 178. builtin.Bytes.gzip.decompress : Bytes + 184. builtin.Bytes.gzip.decompress : Bytes -> Either Text Bytes - 179. builtin.Bytes.zlib.decompress : Bytes + 185. builtin.Bytes.zlib.decompress : Bytes -> Either Text Bytes - 180. builtin.io2.Tls.ClientConfig.default : Text + 186. builtin.io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 181. builtin.io2.Tls.ServerConfig.default : [SignedCert] + 187. builtin.io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 182. builtin.Code.dependencies : Code + 188. builtin.Code.dependencies : Code -> [Term] - 183. builtin.Value.dependencies : Value + 189. builtin.Value.dependencies : Value -> [Term] - 184. builtin.Code.deserialize : Bytes + 190. builtin.Code.deserialize : Bytes -> Either Text Code - 185. builtin.Value.deserialize : Bytes + 191. builtin.Value.deserialize : Bytes -> Either Text Value - 186. builtin.Code.display : Text + 192. builtin.Code.display : Text -> Code -> Text - 187. builtin.Bytes.drop : Nat + 193. builtin.Bytes.drop : Nat -> Bytes -> Bytes - 188. builtin.List.drop : Nat + 194. builtin.List.drop : Nat -> [a] -> [a] - 189. builtin.Nat.drop : Nat + 195. builtin.Nat.drop : Nat -> Nat -> Nat - 190. builtin.Text.drop : Nat + 196. builtin.Text.drop : Nat -> Text -> Text - 191. builtin.Bytes.empty : Bytes - 192. builtin.List.empty : [a] - 193. builtin.Text.empty : Text - 194. builtin.io2.Tls.encodeCert : SignedCert + 197. builtin.Bytes.empty : Bytes + 198. builtin.List.empty : [a] + 199. builtin.Text.empty : Text + 200. builtin.io2.Tls.encodeCert : SignedCert -> Bytes - 195. builtin.Bytes.encodeNat16be : Nat + 201. builtin.Bytes.encodeNat16be : Nat -> Bytes - 196. builtin.Bytes.encodeNat16le : Nat + 202. builtin.Bytes.encodeNat16le : Nat -> Bytes - 197. builtin.Bytes.encodeNat32be : Nat + 203. builtin.Bytes.encodeNat32be : Nat -> Bytes - 198. builtin.Bytes.encodeNat32le : Nat + 204. builtin.Bytes.encodeNat32le : Nat -> Bytes - 199. builtin.Bytes.encodeNat64be : Nat + 205. builtin.Bytes.encodeNat64be : Nat -> Bytes - 200. builtin.Bytes.encodeNat64le : Nat + 206. builtin.Bytes.encodeNat64le : Nat -> Bytes - 201. builtin.io2.Tls.encodePrivateKey : PrivateKey + 207. builtin.io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 202. builtin.Float.eq : Float + 208. builtin.Float.eq : Float -> Float -> Boolean - 203. builtin.Int.eq : Int + 209. builtin.Int.eq : Int -> Int -> Boolean - 204. builtin.Nat.eq : Nat + 210. builtin.Nat.eq : Nat -> Nat -> Boolean - 205. builtin.Text.eq : Text + 211. builtin.Text.eq : Text -> Text -> Boolean - 206. builtin.Float.exp : Float + 212. builtin.Float.exp : Float -> Float - 207. builtin.Bytes.flatten : Bytes + 213. builtin.Bytes.flatten : Bytes -> Bytes - 208. builtin.Float.floor : Float + 214. builtin.Float.floor : Float -> Int - 209. builtin.io2.IO.forkComp : '{IO} a + 215. builtin.io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 210. builtin.MutableArray.freeze! : MutableArray + 216. builtin.MutableArray.freeze : MutableArray + g a + -> Nat + -> Nat + ->{g} ImmutableArray + a + 217. builtin.MutableByteArray.freeze : MutableByteArray + g + -> Nat + -> Nat + ->{g} ImmutableByteArray + 218. builtin.MutableArray.freeze! : MutableArray g a ->{g} ImmutableArray a - 211. builtin.MutableByteArray.freeze! : ImmutableByteArray + 219. builtin.MutableByteArray.freeze! : MutableByteArray g ->{g} ImmutableByteArray - 212. builtin.Bytes.fromBase16 : Bytes + 220. builtin.Bytes.fromBase16 : Bytes -> Either Text Bytes - 213. builtin.Bytes.fromBase32 : Bytes + 221. builtin.Bytes.fromBase32 : Bytes -> Either Text Bytes - 214. builtin.Bytes.fromBase64 : Bytes + 222. builtin.Bytes.fromBase64 : Bytes -> Either Text Bytes - 215. builtin.Bytes.fromBase64UrlUnpadded : Bytes + 223. builtin.Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes - 216. builtin.Text.fromCharList : [Char] + 224. builtin.Text.fromCharList : [Char] -> Text - 217. builtin.Bytes.fromList : [Nat] + 225. builtin.Bytes.fromList : [Nat] -> Bytes - 218. builtin.Char.fromNat : Nat + 226. builtin.Char.fromNat : Nat -> Char - 219. builtin.Float.fromRepresentation : Nat + 227. builtin.Float.fromRepresentation : Nat -> Float - 220. builtin.Int.fromRepresentation : Nat + 228. builtin.Int.fromRepresentation : Nat -> Int - 221. builtin.Float.fromText : Text + 229. builtin.Float.fromText : Text -> Optional Float - 222. builtin.Int.fromText : Text + 230. builtin.Int.fromText : Text -> Optional Int - 223. builtin.Nat.fromText : Text + 231. builtin.Nat.fromText : Text -> Optional Nat - 224. builtin.Float.gt : Float + 232. builtin.Float.gt : Float -> Float -> Boolean - 225. builtin.Int.gt : Int + 233. builtin.Int.gt : Int -> Int -> Boolean - 226. builtin.Nat.gt : Nat + 234. builtin.Nat.gt : Nat -> Nat -> Boolean - 227. builtin.Text.gt : Text + 235. builtin.Text.gt : Text -> Text -> Boolean - 228. builtin.Float.gteq : Float + 236. builtin.Float.gteq : Float -> Float -> Boolean - 229. builtin.Int.gteq : Int + 237. builtin.Int.gteq : Int -> Int -> Boolean - 230. builtin.Nat.gteq : Nat + 238. builtin.Nat.gteq : Nat -> Nat -> Boolean - 231. builtin.Text.gteq : Text + 239. builtin.Text.gteq : Text -> Text -> Boolean - 232. builtin.crypto.hash : HashAlgorithm + 240. builtin.crypto.hash : HashAlgorithm -> a -> Bytes - 233. builtin.crypto.hashBytes : HashAlgorithm + 241. builtin.crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 234. builtin.crypto.hmac : HashAlgorithm + 242. builtin.crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 235. builtin.crypto.hmacBytes : HashAlgorithm + 243. builtin.crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 236. builtin.io2.IO.clientSocket.impl : Text + 244. builtin.io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 237. builtin.io2.IO.closeFile.impl : Handle + 245. builtin.io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 238. builtin.io2.IO.closeSocket.impl : Socket + 246. builtin.io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 239. builtin.io2.IO.createDirectory.impl : Text + 247. builtin.io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 240. builtin.io2.IO.createTempDirectory.impl : Text + 248. builtin.io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 241. builtin.io2.Tls.decodeCert.impl : Bytes + 249. builtin.io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 242. builtin.io2.IO.delay.impl : Nat + 250. builtin.io2.IO.delay.impl : Nat ->{IO} Either Failure () - 243. builtin.io2.IO.directoryContents.impl : Text + 251. builtin.io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 244. builtin.io2.IO.fileExists.impl : Text + 252. builtin.io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 245. builtin.Text.fromUtf8.impl : Bytes + 253. builtin.Text.fromUtf8.impl : Bytes -> Either Failure Text - 246. builtin.io2.IO.getArgs.impl : '{IO} Either + 254. builtin.io2.IO.getArgs.impl : '{IO} Either Failure [Text] - 247. builtin.io2.IO.getBuffering.impl : Handle + 255. builtin.io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 248. builtin.io2.IO.getBytes.impl : Handle + 256. builtin.io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 249. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either + 257. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 250. builtin.io2.IO.getEnv.impl : Text + 258. builtin.io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 251. builtin.io2.IO.getFileSize.impl : Text + 259. builtin.io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 252. builtin.io2.IO.getFileTimestamp.impl : Text + 260. builtin.io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 253. builtin.io2.IO.getLine.impl : Handle + 261. builtin.io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 254. builtin.io2.IO.getSomeBytes.impl : Handle + 262. builtin.io2.IO.getSomeBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 255. builtin.io2.IO.getTempDirectory.impl : '{IO} Either + 263. builtin.io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 256. builtin.io2.IO.handlePosition.impl : Handle + 264. builtin.io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 257. builtin.io2.Tls.handshake.impl : Tls + 265. builtin.io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 258. builtin.io2.IO.isDirectory.impl : Text + 266. builtin.io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 259. builtin.io2.IO.isFileEOF.impl : Handle + 267. builtin.io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 260. builtin.io2.IO.isFileOpen.impl : Handle + 268. builtin.io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 261. builtin.io2.IO.isSeekable.impl : Handle + 269. builtin.io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 262. builtin.io2.IO.kill.impl : ThreadId + 270. builtin.io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 263. builtin.io2.IO.listen.impl : Socket + 271. builtin.io2.IO.listen.impl : Socket ->{IO} Either Failure () - 264. builtin.io2.Tls.newClient.impl : ClientConfig + 272. builtin.io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 265. builtin.io2.Tls.newServer.impl : ServerConfig + 273. builtin.io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 266. builtin.io2.IO.openFile.impl : Text + 274. builtin.io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 267. builtin.io2.MVar.put.impl : MVar a + 275. builtin.io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 268. builtin.io2.IO.putBytes.impl : Handle + 276. builtin.io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 269. builtin.io2.MVar.read.impl : MVar a + 277. builtin.io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 270. builtin.io2.Tls.receive.impl : Tls + 278. builtin.io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 271. builtin.io2.IO.removeDirectory.impl : Text + 279. builtin.io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 272. builtin.io2.IO.removeFile.impl : Text + 280. builtin.io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 273. builtin.io2.IO.renameDirectory.impl : Text + 281. builtin.io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 274. builtin.io2.IO.renameFile.impl : Text + 282. builtin.io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 275. builtin.io2.IO.seekHandle.impl : Handle + 283. builtin.io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 276. builtin.io2.Tls.send.impl : Tls + 284. builtin.io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 277. builtin.io2.IO.serverSocket.impl : Optional + 285. builtin.io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 278. builtin.io2.IO.setBuffering.impl : Handle + 286. builtin.io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 279. builtin.io2.IO.setCurrentDirectory.impl : Text + 287. builtin.io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 280. builtin.io2.IO.socketAccept.impl : Socket + 288. builtin.io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 281. builtin.io2.IO.socketPort.impl : Socket + 289. builtin.io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 282. builtin.io2.IO.socketReceive.impl : Socket + 290. builtin.io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 283. builtin.io2.IO.socketSend.impl : Socket + 291. builtin.io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 284. builtin.io2.MVar.swap.impl : MVar a + 292. builtin.io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 285. builtin.io2.IO.systemTime.impl : '{IO} Either + 293. builtin.io2.IO.systemTime.impl : '{IO} Either Failure Nat - 286. builtin.io2.MVar.take.impl : MVar a + 294. builtin.io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 287. builtin.io2.Tls.terminate.impl : Tls + 295. builtin.io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 288. builtin.io2.MVar.tryPut.impl : MVar a + 296. builtin.io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 289. builtin.io2.MVar.tryRead.impl : MVar a + 297. builtin.io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 290. builtin.Int.increment : Int + 298. builtin.Int.increment : Int -> Int - 291. builtin.Nat.increment : Nat + 299. builtin.Nat.increment : Nat -> Nat - 292. builtin.io2.MVar.isEmpty : MVar a + 300. builtin.io2.MVar.isEmpty : MVar a ->{IO} Boolean - 293. builtin.Int.isEven : Int + 301. builtin.Int.isEven : Int -> Boolean - 294. builtin.Nat.isEven : Nat + 302. builtin.Nat.isEven : Nat -> Boolean - 295. builtin.Code.isMissing : Term + 303. builtin.Code.isMissing : Term ->{IO} Boolean - 296. builtin.Int.isOdd : Int + 304. builtin.Int.isOdd : Int -> Boolean - 297. builtin.Nat.isOdd : Nat + 305. builtin.Nat.isOdd : Nat -> Boolean - 298. builtin.metadata.isPropagated : IsPropagated - 299. builtin.metadata.isTest : IsTest - 300. builtin.Int.leadingZeros : Int + 306. builtin.metadata.isPropagated : IsPropagated + 307. builtin.metadata.isTest : IsTest + 308. builtin.Int.leadingZeros : Int -> Nat - 301. builtin.Nat.leadingZeros : Nat + 309. builtin.Nat.leadingZeros : Nat -> Nat - 302. builtin.Value.load : Value + 310. builtin.Value.load : Value ->{IO} Either [Term] a - 303. builtin.Float.log : Float + 311. builtin.Float.log : Float -> Float - 304. builtin.Float.logBase : Float + 312. builtin.Float.logBase : Float -> Float -> Float - 305. builtin.Code.lookup : Term + 313. builtin.Code.lookup : Term ->{IO} Optional Code - 306. builtin.Float.lt : Float + 314. builtin.Float.lt : Float -> Float -> Boolean - 307. builtin.Int.lt : Int + 315. builtin.Int.lt : Int -> Int -> Boolean - 308. builtin.Nat.lt : Nat + 316. builtin.Nat.lt : Nat -> Nat -> Boolean - 309. builtin.Text.lt : Text + 317. builtin.Text.lt : Text -> Text -> Boolean - 310. builtin.Float.lteq : Float + 318. builtin.Float.lteq : Float -> Float -> Boolean - 311. builtin.Int.lteq : Int + 319. builtin.Int.lteq : Int -> Int -> Boolean - 312. builtin.Nat.lteq : Nat + 320. builtin.Nat.lteq : Nat -> Nat -> Boolean - 313. builtin.Text.lteq : Text + 321. builtin.Text.lteq : Text -> Text -> Boolean - 314. builtin.Float.max : Float + 322. builtin.Float.max : Float -> Float -> Float - 315. builtin.Float.min : Float + 323. builtin.Float.min : Float -> Float -> Float - 316. builtin.Int.mod : Int + 324. builtin.Int.mod : Int -> Int -> Int - 317. builtin.Nat.mod : Nat + 325. builtin.Nat.mod : Nat -> Nat -> Nat - 318. builtin.io2.Clock.internals.monotonic : '{IO} Either + 326. builtin.io2.Clock.internals.monotonic : '{IO} Either Failure TimeSpec - 319. builtin.Int.negate : Int + 327. builtin.Int.negate : Int -> Int - 320. builtin.io2.MVar.new : a + 328. builtin.io2.MVar.new : a ->{IO} MVar a - 321. builtin.io2.TVar.new : a + 329. builtin.io2.TVar.new : a ->{STM} TVar a - 322. builtin.io2.MVar.newEmpty : '{IO} MVar + 330. builtin.io2.MVar.newEmpty : '{IO} MVar a - 323. builtin.io2.TVar.newIO : a + 331. builtin.io2.TVar.newIO : a ->{IO} TVar a - 324. builtin.Boolean.not : Boolean + 332. builtin.Boolean.not : Boolean -> Boolean - 325. builtin.io2.Clock.internals.nsec : TimeSpec + 333. builtin.io2.Clock.internals.nsec : TimeSpec -> Nat - 326. builtin.Int.or : Int + 334. builtin.Int.or : Int -> Int -> Int - 327. builtin.Nat.or : Nat + 335. builtin.Nat.or : Nat -> Nat -> Nat - 328. builtin.Int.popCount : Int + 336. builtin.Int.popCount : Int -> Nat - 329. builtin.Nat.popCount : Nat + 337. builtin.Nat.popCount : Nat -> Nat - 330. builtin.Float.pow : Float + 338. builtin.Float.pow : Float -> Float -> Float - 331. builtin.Int.pow : Int + 339. builtin.Int.pow : Int -> Nat -> Int - 332. builtin.Nat.pow : Nat + 340. builtin.Nat.pow : Nat -> Nat -> Nat - 333. builtin.io2.Clock.internals.processCPUTime : '{IO} Either + 341. builtin.io2.Clock.internals.processCPUTime : '{IO} Either Failure TimeSpec - 334. builtin.ImmutableArray.read : ImmutableArray + 342. builtin.ImmutableArray.read : ImmutableArray a -> Nat ->{Exception} a - 335. builtin.MutableArray.read : MutableArray + 343. builtin.MutableArray.read : MutableArray g a -> Nat ->{g, Exception} a - 336. builtin.Ref.read : Ref g a + 344. builtin.Ref.read : Ref g a ->{g} a - 337. builtin.io2.TVar.read : TVar a + 345. builtin.io2.TVar.read : TVar a ->{STM} a - 338. builtin.ImmutableByteArray.read16 : ImmutableByteArray + 346. builtin.ImmutableByteArray.read16 : ImmutableByteArray -> Nat ->{Exception} Nat - 339. builtin.MutableByteArray.read16 : ImmutableByteArray + 347. builtin.MutableByteArray.read16 : MutableByteArray g -> Nat ->{g, Exception} Nat - 340. builtin.ImmutableByteArray.read32 : ImmutableByteArray + 348. builtin.ImmutableByteArray.read32 : ImmutableByteArray -> Nat ->{Exception} Nat - 341. builtin.MutableByteArray.read32 : ImmutableByteArray + 349. builtin.MutableByteArray.read32 : MutableByteArray g -> Nat ->{g, Exception} Nat - 342. builtin.ImmutableByteArray.read64 : ImmutableByteArray + 350. builtin.ImmutableByteArray.read64 : ImmutableByteArray -> Nat ->{Exception} Nat - 343. builtin.MutableByteArray.read64 : ImmutableByteArray + 351. builtin.MutableByteArray.read64 : MutableByteArray g -> Nat ->{g, Exception} Nat - 344. builtin.ImmutableByteArray.read8 : ImmutableByteArray + 352. builtin.ImmutableByteArray.read8 : ImmutableByteArray -> Nat ->{Exception} Nat - 345. builtin.MutableByteArray.read8 : ImmutableByteArray + 353. builtin.MutableByteArray.read8 : MutableByteArray g -> Nat ->{g, Exception} Nat - 346. builtin.io2.TVar.readIO : TVar a + 354. builtin.io2.TVar.readIO : TVar a ->{IO} a - 347. builtin.io2.Clock.internals.realtime : '{IO} Either + 355. builtin.io2.Clock.internals.realtime : '{IO} Either Failure TimeSpec - 348. builtin.io2.IO.ref : a + 356. builtin.io2.IO.ref : a ->{IO} Ref {IO} a - 349. builtin.Scope.ref : a + 357. builtin.Scope.ref : a ->{Scope s} Ref {Scope s} a - 350. builtin.Text.repeat : Nat + 358. builtin.Text.repeat : Nat -> Text -> Text - 351. builtin.io2.STM.retry : '{STM} a - 352. builtin.Float.round : Float + 359. builtin.io2.STM.retry : '{STM} a + 360. builtin.Float.round : Float -> Int - 353. builtin.Scope.run : (โˆ€ s. + 361. builtin.Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 354. builtin.io2.Clock.internals.sec : TimeSpec + 362. builtin.io2.Clock.internals.sec : TimeSpec -> Int - 355. builtin.Code.serialize : Code + 363. builtin.Code.serialize : Code -> Bytes - 356. builtin.Value.serialize : Value + 364. builtin.Value.serialize : Value -> Bytes - 357. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] + 365. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 358. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] + 366. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 359. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] + 367. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 360. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] + 368. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 361. builtin.io2.Tls.ClientConfig.versions.set : [Version] + 369. builtin.io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 362. builtin.io2.Tls.ServerConfig.versions.set : [Version] + 370. builtin.io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 363. builtin.Int.shiftLeft : Int + 371. builtin.Int.shiftLeft : Int -> Nat -> Int - 364. builtin.Nat.shiftLeft : Nat + 372. builtin.Nat.shiftLeft : Nat -> Nat -> Nat - 365. builtin.Int.shiftRight : Int + 373. builtin.Int.shiftRight : Int -> Nat -> Int - 366. builtin.Nat.shiftRight : Nat + 374. builtin.Nat.shiftRight : Nat -> Nat -> Nat - 367. builtin.Int.signum : Int + 375. builtin.Int.signum : Int -> Int - 368. builtin.Float.sin : Float + 376. builtin.Float.sin : Float -> Float - 369. builtin.Float.sinh : Float + 377. builtin.Float.sinh : Float -> Float - 370. builtin.Bytes.size : Bytes + 378. builtin.Bytes.size : Bytes -> Nat - 371. builtin.List.size : [a] + 379. builtin.List.size : [a] -> Nat - 372. builtin.Text.size : Text + 380. builtin.Text.size : Text -> Nat - 373. builtin.Float.sqrt : Float + 381. builtin.Float.sqrt : Float -> Float - 374. builtin.io2.IO.stdHandle : StdHandle + 382. builtin.io2.IO.stdHandle : StdHandle -> Handle - 375. builtin.Nat.sub : Nat + 383. builtin.Nat.sub : Nat -> Nat -> Int - 376. builtin.io2.TVar.swap : TVar a + 384. builtin.io2.TVar.swap : TVar a -> a ->{STM} a - 377. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int - 378. builtin.Bytes.take : Nat + 385. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int + 386. builtin.Bytes.take : Nat -> Bytes -> Bytes - 379. builtin.List.take : Nat + 387. builtin.List.take : Nat -> [a] -> [a] - 380. builtin.Text.take : Nat + 388. builtin.Text.take : Nat -> Text -> Text - 381. builtin.Float.tan : Float + 389. builtin.Float.tan : Float -> Float - 382. builtin.Float.tanh : Float + 390. builtin.Float.tanh : Float -> Float - 383. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either + 391. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either Failure TimeSpec - 384. builtin.Bytes.toBase16 : Bytes + 392. builtin.Bytes.toBase16 : Bytes -> Bytes - 385. builtin.Bytes.toBase32 : Bytes + 393. builtin.Bytes.toBase32 : Bytes -> Bytes - 386. builtin.Bytes.toBase64 : Bytes + 394. builtin.Bytes.toBase64 : Bytes -> Bytes - 387. builtin.Bytes.toBase64UrlUnpadded : Bytes + 395. builtin.Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 388. builtin.Text.toCharList : Text + 396. builtin.Text.toCharList : Text -> [Char] - 389. builtin.Int.toFloat : Int + 397. builtin.Int.toFloat : Int -> Float - 390. builtin.Nat.toFloat : Nat + 398. builtin.Nat.toFloat : Nat -> Float - 391. builtin.Nat.toInt : Nat + 399. builtin.Nat.toInt : Nat -> Int - 392. builtin.Bytes.toList : Bytes + 400. builtin.Bytes.toList : Bytes -> [Nat] - 393. builtin.Char.toNat : Char + 401. builtin.Char.toNat : Char -> Nat - 394. builtin.Float.toRepresentation : Float + 402. builtin.Float.toRepresentation : Float -> Nat - 395. builtin.Int.toRepresentation : Int + 403. builtin.Int.toRepresentation : Int -> Nat - 396. builtin.Char.toText : Char + 404. builtin.Char.toText : Char -> Text - 397. builtin.Float.toText : Float + 405. builtin.Float.toText : Float -> Text - 398. builtin.Handle.toText : Handle + 406. builtin.Handle.toText : Handle -> Text - 399. builtin.Int.toText : Int + 407. builtin.Int.toText : Int -> Text - 400. builtin.Nat.toText : Nat + 408. builtin.Nat.toText : Nat -> Text - 401. builtin.Socket.toText : Socket + 409. builtin.Socket.toText : Socket -> Text - 402. builtin.Link.Term.toText : Term + 410. builtin.Link.Term.toText : Term -> Text - 403. builtin.ThreadId.toText : ThreadId + 411. builtin.ThreadId.toText : ThreadId -> Text - 404. builtin.Text.toUtf8 : Text + 412. builtin.Text.toUtf8 : Text -> Bytes - 405. builtin.todo : a -> b - 406. builtin.Debug.trace : Text + 413. builtin.todo : a -> b + 414. builtin.Debug.trace : Text -> a -> () - 407. builtin.Int.trailingZeros : Int + 415. builtin.Int.trailingZeros : Int -> Nat - 408. builtin.Nat.trailingZeros : Nat + 416. builtin.Nat.trailingZeros : Nat -> Nat - 409. builtin.Float.truncate : Float + 417. builtin.Float.truncate : Float -> Int - 410. builtin.Int.truncate0 : Int + 418. builtin.Int.truncate0 : Int -> Nat - 411. builtin.io2.MVar.tryTake : MVar a + 419. builtin.io2.MVar.tryTake : MVar a ->{IO} Optional a - 412. builtin.Text.uncons : Text + 420. builtin.Text.uncons : Text -> Optional ( Char, Text) - 413. builtin.Any.unsafeExtract : Any + 421. builtin.Any.unsafeExtract : Any -> a - 414. builtin.Text.unsnoc : Text + 422. builtin.Text.unsnoc : Text -> Optional ( Text, Char) - 415. builtin.Code.validate : [( Term, + 423. builtin.Code.validate : [( Term, Code)] ->{IO} Optional Failure - 416. builtin.io2.validateSandboxed : [Term] + 424. builtin.io2.validateSandboxed : [Term] -> a -> Boolean - 417. builtin.Value.value : a + 425. builtin.Value.value : a -> Value - 418. builtin.Debug.watch : Text + 426. builtin.Debug.watch : Text -> a -> a - 419. builtin.MutableArray.write : MutableArray + 427. builtin.MutableArray.write : MutableArray g a -> Nat -> a ->{g, Exception} () - 420. builtin.Ref.write : Ref g a + 428. builtin.Ref.write : Ref g a -> a ->{g} () - 421. builtin.io2.TVar.write : TVar a + 429. builtin.io2.TVar.write : TVar a -> a ->{STM} () - 422. builtin.MutableByteArray.write16 : ImmutableByteArray + 430. builtin.MutableByteArray.write16 : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 423. builtin.MutableByteArray.write32 : ImmutableByteArray + 431. builtin.MutableByteArray.write32 : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 424. builtin.MutableByteArray.write64 : ImmutableByteArray + 432. builtin.MutableByteArray.write64 : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 425. builtin.MutableByteArray.write8 : ImmutableByteArray + 433. builtin.MutableByteArray.write8 : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 426. builtin.Int.xor : Int + 434. builtin.Int.xor : Int -> Int -> Int - 427. builtin.Nat.xor : Nat + 435. builtin.Nat.xor : Nat -> Nat -> Nat diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index c51ef7fbb5..b3d1c15b90 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #8e6k8q9nsu .old` to make an old namespace + `fork #rca6hfi0r8 .old` to make an old namespace accessible again, - `reset-root #8e6k8q9nsu` to reset the root namespace and + `reset-root #rca6hfi0r8` to reset the root namespace and its history to that of the specified namespace. - 1. #r2injt702j : add - 2. #8e6k8q9nsu : add - 3. #tgct85ingr : builtins.merge + 1. #lr7nj9g3hf : add + 2. #rca6hfi0r8 : add + 3. #eioje18gql : builtins.merge 4. #sg60bvjo91 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index fae0bf6e4f..3a838002d9 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - โ–ก 1. #svtklo709a (start of history) + โ–ก 1. #6df7la2hva (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #k7oo4v3lfh + โŠ™ 1. #0krh277ege > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #cvqfq5n5g8 + โŠ™ 2. #togjet5r88 > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #svtklo709a (start of history) + โ–ก 3. #6df7la2hva (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #k7oo4v3lfh + โŠ™ 1. #0krh277ege > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #cvqfq5n5g8 + โŠ™ 2. #togjet5r88 > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #svtklo709a (start of history) + โ–ก 3. #6df7la2hva (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - โ–ก 1. #svtklo709a (start of history) + โ–ก 1. #6df7la2hva (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #feds6g84di + โŠ™ 1. #h7cl4aka6v - Deletes: Nat.* Nat.+ - โ–ก 2. #svtklo709a (start of history) + โ–ก 2. #6df7la2hva (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From 64542b1f56dbaa9376b2c401d0602f28648b6c88 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 16 Jun 2022 12:08:09 -0400 Subject: [PATCH 351/529] expose a saveTempEntityInMain instead of saveSyncEntity --- .../U/Codebase/Sqlite/Queries.hs | 13 +++++-- unison-cli/src/Unison/Share/Sync.hs | 34 +++++-------------- 2 files changed, 19 insertions(+), 28 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index fca934ec06..164df4607c 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -142,7 +142,7 @@ module U.Codebase.Sqlite.Queries tempToSyncEntity, syncToTempEntity, insertTempEntity, - saveSyncEntity, + saveTempEntityInMain, -- * elaborate hashes elaborateHashes, @@ -731,10 +731,17 @@ moveTempEntityToMain :: Hash32 -> Transaction () moveTempEntityToMain hash = do entity <- expectTempEntity hash deleteTempEntity hash - entity' <- tempToSyncEntity entity - _ <- saveSyncEntity hash entity' + _ <- saveTempEntityInMain hash entity pure () +-- | Save a temp entity in main storage. +-- +-- Precondition: all of its dependencies are already in main storage. +saveTempEntityInMain :: Hash32 -> TempEntity -> Transaction (Either CausalHashId ObjectId) +saveTempEntityInMain hash entity = do + entity' <- tempToSyncEntity entity + saveSyncEntity hash entity' + -- | Read an entity out of temp storage. expectTempEntity :: Hash32 -> Transaction TempEntity expectTempEntity hash = do diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 0071027bdf..434e457bb6 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -525,35 +525,19 @@ upsertEntitySomewhere hash entity = ) case NEMap.nonEmptyMap missingDependencies1 of Nothing -> do - insertEntity hash entity + _id <- Q.saveTempEntityInMain hash (entityToTempEntity Share.hashJWTHash entity) pure Q.EntityInMainStorage Just missingDependencies -> do - insertTempEntity hash entity missingDependencies + Q.insertTempEntity + hash + (entityToTempEntity Share.hashJWTHash entity) + ( coerce + @(NEMap Hash32 Share.HashJWT) + @(NEMap Hash32 Text) + missingDependencies + ) pure Q.EntityInTempStorage --- | Insert an entity that doesn't have any missing dependencies. -insertEntity :: Hash32 -> Share.Entity Text Hash32 Share.HashJWT -> Sqlite.Transaction () -insertEntity hash entity = do - syncEntity <- Q.tempToSyncEntity (entityToTempEntity Share.hashJWTHash entity) - _id <- Q.saveSyncEntity hash syncEntity - pure () - --- | Insert an entity and its missing dependencies. -insertTempEntity :: - Hash32 -> - Share.Entity Text Hash32 Share.HashJWT -> - NEMap Hash32 Share.HashJWT -> - Sqlite.Transaction () -insertTempEntity hash entity missingDependencies = - Q.insertTempEntity - hash - (entityToTempEntity Share.hashJWTHash entity) - ( coerce - @(NEMap Hash32 Share.HashJWT) - @(NEMap Hash32 Text) - missingDependencies - ) - ------------------------------------------------------------------------------------------------------------------------ -- HTTP calls From d042d0ccb9ce3b8d7583647b842880c33585bcf1 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 16 Jun 2022 12:22:57 -0400 Subject: [PATCH 352/529] don't export tempToSyncEntity now that there are no external callers anymore --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 164df4607c..860ba6ede5 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -139,7 +139,6 @@ module U.Codebase.Sqlite.Queries entityExists, entityLocation, expectEntity, - tempToSyncEntity, syncToTempEntity, insertTempEntity, saveTempEntityInMain, From 9d758aa84932f486664a04efae5c237344615536 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 16 Jun 2022 13:19:34 -0400 Subject: [PATCH 353/529] do some documentation and cleanup --- unison-cli/src/Unison/Share/Sync.hs | 132 ++++++++++++++++------------ 1 file changed, 77 insertions(+), 55 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 434e457bb6..cdbb65f7a7 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -57,8 +57,11 @@ import Unison.Util.Monoid (foldMapM) ------------------------------------------------------------------------------------------------------------------------ -- Push --- | Push a causal to Unison Share. --- FIXME reword this +-- | Perform a check-and-set push (initially of just a causal hash, but ultimately all of its dependencies that the +-- server is missing, too) to Unison Share. +-- +-- This flavor of push takes the expected state of the server, and the desired state we want to set; if our expectation +-- is off, we won't proceed with the push. checkAndSetPush :: -- | The HTTP client to use for Unison Share requests. AuthenticatedHttpClient -> @@ -112,8 +115,11 @@ checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash uplo newHash = causalHashToHash32 causalHash } --- | Push a causal to Unison Share. --- FIXME reword this +-- | Perform a fast-forward push (initially of just a causal hash, but ultimately all of its dependencies that the +-- server is missing, too) to Unison Share. +-- +-- This flavor of push provides the server with a chain of causal hashes leading from its current state to our desired +-- state. fastForwardPush :: -- | The HTTP client to use for Unison Share requests. AuthenticatedHttpClient -> @@ -133,38 +139,39 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash uploadProgress Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path)) Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path)) Right (Just (Share.hashJWTHash -> remoteHeadHash)) -> - if localHeadHash == hash32ToCausalHash remoteHeadHash - then pure (Right ()) - else do - Sqlite.runTransaction conn (fancyBfs localHeadHash remoteHeadHash) >>= \case - -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a - -- fast-forward push, so we don't bother trying - just report the error now. - Nothing -> pure (Left (FastForwardPushErrorNotFastForward path)) - Just localInnerHashes -> do - doUpload (localHeadHash :| localInnerHashes) >>= \case - False -> pure (Left (FastForwardPushErrorNoWritePermission path)) - True -> do - let doFastForwardPath = - httpFastForwardPath - httpClient - unisonShareUrl - Share.FastForwardPathRequest - { expectedHash = remoteHeadHash, - hashes = - causalHashToHash32 <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), - path - } - doFastForwardPath <&> \case - Share.FastForwardPathSuccess -> Right () - Share.FastForwardPathMissingDependencies (Share.NeedDependencies dependencies) -> - Left (FastForwardPushErrorServerMissingDependencies dependencies) - -- Weird: someone must have force-pushed no history here, or something. We observed a history at - -- this path but moments ago! - Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory path) - Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission path) - Share.FastForwardPathNotFastForward _ -> Left (FastForwardPushErrorNotFastForward path) - Share.FastForwardPathInvalidParentage (Share.InvalidParentage parent child) -> - Left (FastForwardPushInvalidParentage parent child) + Sqlite.runTransaction conn (loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash)) >>= \case + -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a + -- fast-forward push, so we don't bother trying - just report the error now. + Nothing -> pure (Left (FastForwardPushErrorNotFastForward path)) + -- The path from remote-to-local, excluding local, was empty. So, remote == local; there's nothing to push. + Just [] -> pure (Right ()) + Just (_ : localInnerHashes0) -> do + -- drop remote hash + let localInnerHashes = map hash32ToCausalHash localInnerHashes0 + doUpload (localHeadHash :| localInnerHashes) >>= \case + False -> pure (Left (FastForwardPushErrorNoWritePermission path)) + True -> do + let doFastForwardPath = + httpFastForwardPath + httpClient + unisonShareUrl + Share.FastForwardPathRequest + { expectedHash = remoteHeadHash, + hashes = + causalHashToHash32 <$> List.NonEmpty.fromList (localInnerHashes ++ [localHeadHash]), + path + } + doFastForwardPath <&> \case + Share.FastForwardPathSuccess -> Right () + Share.FastForwardPathMissingDependencies (Share.NeedDependencies dependencies) -> + Left (FastForwardPushErrorServerMissingDependencies dependencies) + -- Weird: someone must have force-pushed no history here, or something. We observed a history at + -- this path but moments ago! + Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory path) + Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission path) + Share.FastForwardPathNotFastForward _ -> Left (FastForwardPushErrorNotFastForward path) + Share.FastForwardPathInvalidParentage (Share.InvalidParentage parent child) -> + Left (FastForwardPushInvalidParentage parent child) where doUpload :: List.NonEmpty CausalHash -> IO Bool -- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes", but we @@ -179,31 +186,46 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash uploadProgress (NESet.singleton (causalHashToHash32 headHash)) uploadProgressCallback - -- Return a list from oldest to newst of the ancestors between (excluding) the latest local and the current remote - -- hash. - -- note: seems like we /should/ cut this short, with another command to go longer? :grimace: - fancyBfs :: CausalHash -> Hash32 -> Sqlite.Transaction (Maybe [CausalHash]) - fancyBfs h0 h1 = - tweak <$> dagbfs (== h1) Q.loadCausalParentsByHash (causalHashToHash32 h0) - where - -- Drop 1 (under a Maybe, and twddling hash types): - -- - -- tweak Nothing = Nothing - -- tweak (Just []) = Just [] - -- tweak (Just [C,B,A]) = Just [B,A] - -- - -- The drop 1 is because dagbfs returns the goal at the head of the returned list, but we know what the goal is - -- already (the remote head hash). - tweak :: Maybe [Hash32] -> Maybe [CausalHash] - tweak = - fmap (map hash32ToCausalHash . drop 1) +-- Return a list (in oldest-to-newest order) of hashes along the causal spine that connects the given arguments, +-- excluding the newest hash (second argument). +loadCausalSpineBetween :: Hash32 -> Hash32 -> Sqlite.Transaction (Maybe [Hash32]) +loadCausalSpineBetween earlierHash laterHash = + dagbfs (== earlierHash) Q.loadCausalParentsByHash laterHash data Step a = DeadEnd | KeepSearching (List.NonEmpty a) | FoundGoal a --- FIXME: document +-- | @dagbfs goal children root@ searches breadth-first through the monadic tree formed by applying @chilred@ to each +-- node (initially @root@), until it finds a goal node (i.e. when @goal@ returns True). +-- +-- Returns the nodes along a path from root to goal in bottom-up or goal-to-root order, excluding the root node (because +-- it was provided as an input ;)) +-- +-- For example, when searching a tree that looks like +-- +-- 1 +-- / \ +-- 2 3 +-- / \ \ +-- 4 [5] 6 +-- +-- (where the goal is marked [5]), we'd return +-- +-- Just [5,2] +-- +-- And (as another example), if the root node is the goal, +-- +-- [1] +-- / \ +-- 2 3 +-- / \ \ +-- 4 5 6 +-- +-- we'd return +-- +-- Just [] dagbfs :: forall a m. Monad m => (a -> Bool) -> (a -> m [a]) -> a -> m (Maybe [a]) dagbfs goal children = let -- The loop state: all distinct paths from the root to the frontier (not including the root, because it's implied, From 7bee79fe731c1e4850cab872f99a45a112ab4601 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 16 Jun 2022 14:08:26 -0400 Subject: [PATCH 354/529] unison-core1 doesn't need util --- unison-core/package.yaml | 1 - unison-core/unison-core1.cabal | 1 - 2 files changed, 2 deletions(-) diff --git a/unison-core/package.yaml b/unison-core/package.yaml index 1fd7ca73b6..399d8fee57 100644 --- a/unison-core/package.yaml +++ b/unison-core/package.yaml @@ -30,7 +30,6 @@ library: - unison-util - unison-util-base32hex - unison-util-relation - - util - vector default-extensions: diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index 564994ec63..59dd377747 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -104,7 +104,6 @@ library , unison-util , unison-util-base32hex , unison-util-relation - , util , vector if flag(optimized) ghc-options: -O2 -funbox-strict-fields From 3dcb952b3cb72ffceb9d9b7af4189533dc4547d6 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Wed, 8 Jun 2022 11:31:10 -0400 Subject: [PATCH 355/529] convert2 --- .../src/Unison/Hashing/V2/Convert.hs | 9 +- .../src/Unison/Hashing/V2/Convert2.hs | 117 ++++++++++++++++++ .../unison-parser-typechecker.cabal | 1 + .../src/Unison/Hashing/V2/Term.hs | 10 +- 4 files changed, 127 insertions(+), 10 deletions(-) create mode 100644 parser-typechecker/src/Unison/Hashing/V2/Convert2.hs diff --git a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs index 184ff626f9..b3baa07cde 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/Convert.hs +++ b/parser-typechecker/src/Unison/Hashing/V2/Convert.hs @@ -1,6 +1,7 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE ViewPatterns #-} +-- | Description: Converts V1 types to the V2 hashing types module Unison.Hashing.V2.Convert ( ResolutionResult, hashBranch0, @@ -130,8 +131,8 @@ m2hTerm = ABT.transformM \case Memory.Term.If c t f -> pure (Hashing.Term.If c t f) Memory.Term.Or p q -> pure (Hashing.Term.Or p q) Memory.Term.Lam a -> pure (Hashing.Term.Lam a) - Memory.Term.LetRec isTop bs body -> pure (Hashing.Term.LetRec isTop bs body) - Memory.Term.Let isTop b body -> pure (Hashing.Term.Let isTop b body) + Memory.Term.LetRec _isTop bs body -> pure (Hashing.Term.LetRec bs body) + Memory.Term.Let _isTop b body -> pure (Hashing.Term.Let b body) Memory.Term.Match scr cases -> pure (Hashing.Term.Match scr (fmap m2hMatchCase cases)) Memory.Term.TermLink r -> Hashing.Term.TermLink <$> m2hReferent r Memory.Term.TypeLink r -> pure (Hashing.Term.TypeLink (m2hReference r)) @@ -191,8 +192,8 @@ h2mTerm getCT = ABT.transform \case Hashing.Term.And p q -> Memory.Term.And p q Hashing.Term.Or p q -> Memory.Term.Or p q Hashing.Term.Lam a -> Memory.Term.Lam a - Hashing.Term.LetRec isTop bs body -> Memory.Term.LetRec isTop bs body - Hashing.Term.Let isTop b body -> Memory.Term.Let isTop b body + Hashing.Term.LetRec bs body -> Memory.Term.LetRec False bs body + Hashing.Term.Let b body -> Memory.Term.Let False b body Hashing.Term.Match scr cases -> Memory.Term.Match scr (h2mMatchCase <$> cases) Hashing.Term.TermLink r -> Memory.Term.TermLink (h2mReferent getCT r) Hashing.Term.TypeLink r -> Memory.Term.TypeLink (h2mReference r) diff --git a/parser-typechecker/src/Unison/Hashing/V2/Convert2.hs b/parser-typechecker/src/Unison/Hashing/V2/Convert2.hs new file mode 100644 index 0000000000..86bc5fcdd8 --- /dev/null +++ b/parser-typechecker/src/Unison/Hashing/V2/Convert2.hs @@ -0,0 +1,117 @@ +-- | Description: Converts V2 types to the V2 hashing types +module Unison.Hashing.V2.Convert2 + ( convertTerm, + ) +where + +import qualified U.Codebase.Kind as V2 +import qualified U.Codebase.Reference as V2 +import qualified U.Codebase.Referent as V2.Referent +import qualified U.Codebase.Term as V2 (F, F' (..), MatchCase (..), Pattern (..), SeqOp (..), TermRef, TypeRef) +import qualified U.Codebase.Type as V2.Type +import qualified U.Core.ABT as V2 +import qualified U.Util.Hash as V2 (Hash) +import qualified Unison.ABT as H2 (transform) +import Unison.Codebase.SqliteCodebase.Conversions (abt2to1) +import qualified Unison.Hashing.V2.Kind as H2 +import qualified Unison.Hashing.V2.Pattern as H2.Pattern +import qualified Unison.Hashing.V2.Reference as H2 +import qualified Unison.Hashing.V2.Referent as H2.Referent +import qualified Unison.Hashing.V2.Term as H2 +import qualified Unison.Hashing.V2.Type as H2.Type +import Unison.Prelude + +convertTerm :: forall v. Ord v => V2.Hash -> V2.Term (V2.F v) v () -> H2.Term v () +convertTerm thisTermComponentHash = H2.transform convertF . abt2to1 + where + convertF :: forall x. V2.F v x -> H2.F v () () x + convertF = \case + V2.Int x -> H2.Int x + V2.Nat x -> H2.Nat x + V2.Float x -> H2.Float x + V2.Boolean x -> H2.Boolean x + V2.Text x -> H2.Text x + V2.Char x -> H2.Char x + V2.Ref x -> H2.Ref (convertTermRef thisTermComponentHash x) + V2.Constructor a b -> H2.Constructor (convertReference a) b + V2.Request a b -> H2.Request (convertReference a) b + V2.Handle a b -> H2.Handle a b + V2.App a b -> H2.App a b + V2.Ann a b -> H2.Ann a (convertType b) + V2.List a -> H2.List a + V2.If a b c -> H2.If a b c + V2.And a b -> H2.And a b + V2.Or a b -> H2.Or a b + V2.Lam a -> H2.Lam a + V2.LetRec a b -> H2.LetRec a b + V2.Let a b -> H2.Let a b + V2.Match a b -> H2.Match a (map convertMatchCase b) + V2.TermLink a -> H2.TermLink (convertReferent thisTermComponentHash a) + V2.TypeLink a -> H2.TypeLink (convertReference a) + +convertMatchCase :: V2.MatchCase Text V2.TypeRef x -> H2.MatchCase () x +convertMatchCase (V2.MatchCase pat a b) = H2.MatchCase (convertPattern pat) a b + +convertPattern :: V2.Pattern Text V2.TypeRef -> H2.Pattern.Pattern () +convertPattern = \case + V2.PUnbound -> H2.Pattern.Unbound () + V2.PVar -> H2.Pattern.Var () + V2.PBoolean a -> H2.Pattern.Boolean () a + V2.PInt a -> H2.Pattern.Int () a + V2.PNat a -> H2.Pattern.Nat () a + V2.PFloat a -> H2.Pattern.Float () a + V2.PText a -> H2.Pattern.Text () a + V2.PChar a -> H2.Pattern.Char () a + V2.PConstructor a b c -> H2.Pattern.Constructor () (convertReference a) b (map convertPattern c) + V2.PAs a -> H2.Pattern.As () (convertPattern a) + V2.PEffectPure a -> H2.Pattern.EffectPure () (convertPattern a) + V2.PEffectBind a b c d -> H2.Pattern.EffectBind () (convertReference a) b (map convertPattern c) (convertPattern d) + V2.PSequenceLiteral a -> H2.Pattern.SequenceLiteral () (map convertPattern a) + V2.PSequenceOp a b c -> H2.Pattern.SequenceOp () (convertPattern a) (convertSeqOp b) (convertPattern c) + where + convertSeqOp = \case + V2.PCons -> H2.Pattern.Cons + V2.PSnoc -> H2.Pattern.Snoc + V2.PConcat -> H2.Pattern.Concat + +convertReferent :: + V2.Hash -> + V2.Referent.Referent' (V2.Reference' Text (Maybe V2.Hash)) (V2.Reference' Text V2.Hash) -> + H2.Referent.Referent +convertReferent defaultHash = \case + V2.Referent.Ref x -> H2.Referent.Ref (convertTermRef defaultHash x) + V2.Referent.Con x cid -> H2.Referent.Con (convertReference x) cid + +convertId :: V2.Hash -> V2.Id' (Maybe V2.Hash) -> H2.Id +convertId defaultHash = \case + V2.Id m p -> H2.Id (fromMaybe defaultHash m) p + +convertReference :: V2.Reference -> H2.Reference +convertReference = convertReference' (\(V2.Id a b) -> H2.Id a b) + +convertTermRef :: V2.Hash -> V2.TermRef -> H2.Reference +convertTermRef = convertReference' . convertId + +convertReference' :: (V2.Id' hash -> H2.Id) -> V2.Reference' Text hash -> H2.Reference +convertReference' idConv = \case + V2.ReferenceBuiltin x -> H2.Builtin x + V2.ReferenceDerived x -> H2.DerivedId (idConv x) + +convertType :: forall v. Ord v => V2.Type.TypeR V2.TypeRef v -> H2.Type.Type v () +convertType = H2.transform convertF . abt2to1 + where + convertF :: forall a. V2.Type.F' V2.TypeRef a -> H2.Type.F a + convertF = \case + V2.Type.Ref x -> H2.Type.Ref (convertReference x) + V2.Type.Arrow a b -> H2.Type.Arrow a b + V2.Type.Ann a k -> H2.Type.Ann a (convertKind k) + V2.Type.App a b -> H2.Type.App a b + V2.Type.Effect a b -> H2.Type.Effect a b + V2.Type.Effects a -> H2.Type.Effects a + V2.Type.Forall a -> H2.Type.Forall a + V2.Type.IntroOuter a -> H2.Type.IntroOuter a + +convertKind :: V2.Kind -> H2.Kind +convertKind = \case + V2.Star -> H2.Star + V2.Arrow a b -> H2.Arrow (convertKind a) (convertKind b) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 3185b27d4b..46e9af6cac 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -88,6 +88,7 @@ library Unison.FileParser Unison.FileParsers Unison.Hashing.V2.Convert + Unison.Hashing.V2.Convert2 Unison.Lexer Unison.NamePrinter Unison.Parser diff --git a/unison-hashing-v2/src/Unison/Hashing/V2/Term.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Term.hs index 7a543a4416..b2427f1e76 100644 --- a/unison-hashing-v2/src/Unison/Hashing/V2/Term.hs +++ b/unison-hashing-v2/src/Unison/Hashing/V2/Term.hs @@ -67,10 +67,10 @@ data F typeVar typeAnn patternAnn a | Lam a | -- Note: let rec blocks have an outer ABT.Cycle which introduces as many -- variables as there are bindings - LetRec IsTop [a] a + LetRec [a] a | -- Note: first parameter is the binding, second is the expression which may refer -- to this let bound variable. Constructed as `Let b (abs v e)` - Let IsTop a a + Let a a | -- Pattern matching / eliminating data types, example: -- case x of -- Just n -> rhs1 @@ -86,8 +86,6 @@ data F typeVar typeAnn patternAnn a | TypeLink Reference deriving (Foldable, Functor, Generic, Generic1, Traversable) -type IsTop = Bool - -- | Like `Term v`, but with an annotation of type `a` at every level in the tree type Term v a = Term2 v a a v a @@ -189,10 +187,10 @@ instance Var v => Hashable1 (F v a p) where Lam a -> [tag 6, hashed (hash a)] -- note: we use `hashCycle` to ensure result is independent of -- let binding order - LetRec _ as a -> case hashCycle as of + LetRec as a -> case hashCycle as of (hs, hash) -> tag 7 : hashed (hash a) : map hashed hs -- here, order is significant, so don't use hashCycle - Let _ b a -> [tag 8, hashed $ hash b, hashed $ hash a] + Let b a -> [tag 8, hashed $ hash b, hashed $ hash a] If b t f -> [tag 9, hashed $ hash b, hashed $ hash t, hashed $ hash f] Request r n -> [tag 10, accumulateToken r, varint n] From 535eaf98a95d35ed50708532e343dd86c7c135da Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Mon, 13 Jun 2022 10:13:00 -0400 Subject: [PATCH 356/529] Add unison-codebase-sqlite-hashing-v2 package unison-codebase-sqlite is now parameterized by the hashing functions --- .../codebase-sqlite-hashing-v2/package.yaml | 56 ++ .../src/U/Codebase/Sqlite/V2/Decl.hs | 24 + .../src/U/Codebase/Sqlite/V2/HashHandle.hs | 19 + .../src/U/Codebase/Sqlite/V2/SyncEntity.hs | 11 + .../src/U/Codebase/Sqlite/V2/Term.hs | 24 + .../src/Unison/Hashing/V2/Convert2.hs | 43 +- .../unison-codebase-sqlite-hashing-v2.cabal | 71 +++ .../U/Codebase/Sqlite/Decl/Format.hs | 4 +- .../U/Codebase/Sqlite/Decode.hs | 41 +- .../U/Codebase/Sqlite/HashHandle.hs | 22 + .../U/Codebase/Sqlite/Operations.hs | 443 +++------------ .../U/Codebase/Sqlite/Queries.hs | 533 ++++++++++++++++-- .../U/Codebase/Sqlite/Serialization.hs | 3 + .../U/Codebase/Sqlite/Sync22.hs | 23 +- .../U/Codebase/Sqlite/Term/Format.hs | 4 +- .../unison-codebase-sqlite.cabal | 3 +- parser-typechecker/package.yaml | 1 + .../src/Unison/Codebase/SqliteCodebase.hs | 5 +- .../Migrations/MigrateSchema1To2.hs | 7 +- .../Codebase/SqliteCodebase/Operations.hs | 38 +- .../unison-parser-typechecker.cabal | 3 +- stack.yaml | 1 + unison-cli/package.yaml | 1 + unison-cli/src/Unison/Share/Sync.hs | 1 + unison-cli/unison-cli.cabal | 7 +- unison-core/package.yaml | 1 + unison-core/src/Unison/ABT.hs | 38 +- unison-core/unison-core1.cabal | 3 +- .../src/Unison/Hashing/V2/Type.hs | 4 +- 29 files changed, 939 insertions(+), 495 deletions(-) create mode 100644 codebase2/codebase-sqlite-hashing-v2/package.yaml create mode 100644 codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/Decl.hs create mode 100644 codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/HashHandle.hs create mode 100644 codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/SyncEntity.hs create mode 100644 codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/Term.hs rename {parser-typechecker => codebase2/codebase-sqlite-hashing-v2}/src/Unison/Hashing/V2/Convert2.hs (75%) create mode 100644 codebase2/codebase-sqlite-hashing-v2/unison-codebase-sqlite-hashing-v2.cabal create mode 100644 codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs diff --git a/codebase2/codebase-sqlite-hashing-v2/package.yaml b/codebase2/codebase-sqlite-hashing-v2/package.yaml new file mode 100644 index 0000000000..f205c201aa --- /dev/null +++ b/codebase2/codebase-sqlite-hashing-v2/package.yaml @@ -0,0 +1,56 @@ +name: unison-codebase-sqlite-hashing-v2 +github: unisonweb/unison +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors + +ghc-options: -Wall + +dependencies: + - base + - bytes + - bytestring + - containers + - lens + - text + - unison-codebase + - unison-codebase-sqlite + - unison-core + - unison-core1 + - unison-hashing-v2 + - unison-prelude + - unison-sqlite + - unison-util + - unison-util-base32hex + - unison-util-term + - vector + +library: + source-dirs: src + when: + - condition: false + other-modules: Paths_unison_codebase_sqlite_hashing_v2 + +default-extensions: + - ApplicativeDo + - BangPatterns + - BlockArguments + - DeriveAnyClass + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable + - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedStrings + - PatternSynonyms + - RecordWildCards + - RankNTypes + - ScopedTypeVariables + - TupleSections + - TypeApplications + - ViewPatterns diff --git a/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/Decl.hs b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/Decl.hs new file mode 100644 index 0000000000..cf27314a60 --- /dev/null +++ b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/Decl.hs @@ -0,0 +1,24 @@ +module U.Codebase.Sqlite.V2.Decl + ( saveDeclComponent, + ) +where + +import qualified U.Codebase.Decl as V2 +import U.Codebase.Sqlite.DbId (ObjectId) +import qualified U.Codebase.Sqlite.Queries as U.Sqlite +import U.Codebase.Sqlite.Symbol (Symbol) +import U.Codebase.Sqlite.V2.HashHandle +import U.Util.Hash (Hash) +import Unison.Prelude +import Unison.Sqlite + +saveDeclComponent :: + -- | The serialized decl component if we already have it e.g. via sync + Maybe ByteString -> + -- | decl component hash + Hash -> + -- | decl component + [V2.Decl Symbol] -> + Transaction ObjectId +saveDeclComponent = + U.Sqlite.saveDeclComponent v2HashHandle diff --git a/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/HashHandle.hs b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/HashHandle.hs new file mode 100644 index 0000000000..359dd078dc --- /dev/null +++ b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/HashHandle.hs @@ -0,0 +1,19 @@ +module U.Codebase.Sqlite.V2.HashHandle + ( v2HashHandle, + ) +where + +import qualified Data.Set as Set +import U.Codebase.Sqlite.HashHandle +import U.Util.Type (removeAllEffectVars) +import Unison.Hashing.V2.Convert2 (h2ToV2Reference, v2ToH2Type, v2ToH2TypeD) +import qualified Unison.Hashing.V2.Type as H2 + +v2HashHandle :: HashHandle +v2HashHandle = + HashHandle + { toReference = h2ToV2Reference . H2.toReference . v2ToH2Type, + toReferenceMentions = Set.map h2ToV2Reference . H2.toReferenceMentions . v2ToH2Type . removeAllEffectVars, + toReferenceDecl = \h -> h2ToV2Reference . H2.toReference . v2ToH2TypeD h, + toReferenceDeclMentions = \h -> Set.map h2ToV2Reference . H2.toReferenceMentions . v2ToH2TypeD h . removeAllEffectVars + } diff --git a/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/SyncEntity.hs b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/SyncEntity.hs new file mode 100644 index 0000000000..fd868f0839 --- /dev/null +++ b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/SyncEntity.hs @@ -0,0 +1,11 @@ +module U.Codebase.Sqlite.V2.SyncEntity where + +import qualified U.Codebase.Sqlite.DbId as Db +import U.Codebase.Sqlite.Entity (SyncEntity) +import qualified U.Codebase.Sqlite.Queries as Q +import U.Codebase.Sqlite.V2.HashHandle +import U.Util.Hash32 (Hash32) +import Unison.Sqlite + +saveSyncEntity :: Hash32 -> SyncEntity -> Transaction (Either Db.CausalHashId Db.ObjectId) +saveSyncEntity = Q.saveSyncEntity v2HashHandle diff --git a/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/Term.hs b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/Term.hs new file mode 100644 index 0000000000..0cc8bb2137 --- /dev/null +++ b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/Term.hs @@ -0,0 +1,24 @@ +module U.Codebase.Sqlite.V2.Term + ( saveTermComponent, + ) +where + +import U.Codebase.Sqlite.DbId (ObjectId) +import qualified U.Codebase.Sqlite.Queries as U.Sqlite +import U.Codebase.Sqlite.Symbol (Symbol) +import U.Codebase.Sqlite.V2.HashHandle +import qualified U.Codebase.Term as V2 +import U.Util.Hash (Hash) +import Unison.Prelude +import Unison.Sqlite + +saveTermComponent :: + -- | The serialized term component if we already have it e.g. via sync + Maybe ByteString -> + -- | term component hash + Hash -> + -- | term component + [(V2.Term Symbol, V2.Type Symbol)] -> + Transaction ObjectId +saveTermComponent = + U.Sqlite.saveTermComponent v2HashHandle diff --git a/parser-typechecker/src/Unison/Hashing/V2/Convert2.hs b/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs similarity index 75% rename from parser-typechecker/src/Unison/Hashing/V2/Convert2.hs rename to codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs index 86bc5fcdd8..d7ca2f9ba1 100644 --- a/parser-typechecker/src/Unison/Hashing/V2/Convert2.hs +++ b/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs @@ -1,6 +1,9 @@ -- | Description: Converts V2 types to the V2 hashing types module Unison.Hashing.V2.Convert2 - ( convertTerm, + ( v2ToH2Term, + v2ToH2Type, + v2ToH2TypeD, + h2ToV2Reference, ) where @@ -10,9 +13,10 @@ import qualified U.Codebase.Referent as V2.Referent import qualified U.Codebase.Term as V2 (F, F' (..), MatchCase (..), Pattern (..), SeqOp (..), TermRef, TypeRef) import qualified U.Codebase.Type as V2.Type import qualified U.Core.ABT as V2 +import qualified U.Core.ABT as V2.ABT import qualified U.Util.Hash as V2 (Hash) import qualified Unison.ABT as H2 (transform) -import Unison.Codebase.SqliteCodebase.Conversions (abt2to1) +import qualified Unison.ABT as V1.ABT import qualified Unison.Hashing.V2.Kind as H2 import qualified Unison.Hashing.V2.Pattern as H2.Pattern import qualified Unison.Hashing.V2.Reference as H2 @@ -21,8 +25,18 @@ import qualified Unison.Hashing.V2.Term as H2 import qualified Unison.Hashing.V2.Type as H2.Type import Unison.Prelude -convertTerm :: forall v. Ord v => V2.Hash -> V2.Term (V2.F v) v () -> H2.Term v () -convertTerm thisTermComponentHash = H2.transform convertF . abt2to1 +-- | Delete me ASAP. I am defined elsewhere. +abt2to1 :: Functor f => V2.ABT.Term f v a -> V1.ABT.Term f v a +abt2to1 (V2.ABT.Term fv a out) = V1.ABT.Term fv a (go out) + where + go = \case + V2.ABT.Cycle body -> V1.ABT.Cycle (abt2to1 body) + V2.ABT.Abs v body -> V1.ABT.Abs v (abt2to1 body) + V2.ABT.Var v -> V1.ABT.Var v + V2.ABT.Tm tm -> V1.ABT.Tm (abt2to1 <$> tm) + +v2ToH2Term :: forall v. Ord v => V2.Hash -> V2.Term (V2.F v) v () -> H2.Term v () +v2ToH2Term thisTermComponentHash = H2.transform convertF . abt2to1 where convertF :: forall x. V2.F v x -> H2.F v () () x convertF = \case @@ -37,7 +51,7 @@ convertTerm thisTermComponentHash = H2.transform convertF . abt2to1 V2.Request a b -> H2.Request (convertReference a) b V2.Handle a b -> H2.Handle a b V2.App a b -> H2.App a b - V2.Ann a b -> H2.Ann a (convertType b) + V2.Ann a b -> H2.Ann a (v2ToH2Type b) V2.List a -> H2.List a V2.If a b c -> H2.If a b c V2.And a b -> H2.And a b @@ -97,12 +111,18 @@ convertReference' idConv = \case V2.ReferenceBuiltin x -> H2.Builtin x V2.ReferenceDerived x -> H2.DerivedId (idConv x) -convertType :: forall v. Ord v => V2.Type.TypeR V2.TypeRef v -> H2.Type.Type v () -convertType = H2.transform convertF . abt2to1 +v2ToH2Type :: forall v. Ord v => V2.Type.TypeR V2.TypeRef v -> H2.Type.Type v () +v2ToH2Type = v2ToH2Type' convertReference + +v2ToH2TypeD :: forall v. Ord v => V2.Hash -> V2.Type.TypeD v -> H2.Type.Type v () +v2ToH2TypeD defaultHash = v2ToH2Type' (convertReference' (convertId defaultHash)) + +v2ToH2Type' :: forall r v. Ord v => (r -> H2.Reference) -> V2.Type.TypeR r v -> H2.Type.Type v () +v2ToH2Type' mkReference = H2.transform convertF . abt2to1 where - convertF :: forall a. V2.Type.F' V2.TypeRef a -> H2.Type.F a + convertF :: forall a. V2.Type.F' r a -> H2.Type.F a convertF = \case - V2.Type.Ref x -> H2.Type.Ref (convertReference x) + V2.Type.Ref x -> H2.Type.Ref (mkReference x) V2.Type.Arrow a b -> H2.Type.Arrow a b V2.Type.Ann a k -> H2.Type.Ann a (convertKind k) V2.Type.App a b -> H2.Type.App a b @@ -115,3 +135,8 @@ convertKind :: V2.Kind -> H2.Kind convertKind = \case V2.Star -> H2.Star V2.Arrow a b -> H2.Arrow (convertKind a) (convertKind b) + +h2ToV2Reference :: H2.Reference -> V2.Reference +h2ToV2Reference = \case + H2.Builtin txt -> V2.ReferenceBuiltin txt + H2.DerivedId (H2.Id x y) -> V2.ReferenceDerived (V2.Id x y) diff --git a/codebase2/codebase-sqlite-hashing-v2/unison-codebase-sqlite-hashing-v2.cabal b/codebase2/codebase-sqlite-hashing-v2/unison-codebase-sqlite-hashing-v2.cabal new file mode 100644 index 0000000000..02a4542cb2 --- /dev/null +++ b/codebase2/codebase-sqlite-hashing-v2/unison-codebase-sqlite-hashing-v2.cabal @@ -0,0 +1,71 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.7. +-- +-- see: https://github.com/sol/hpack + +name: unison-codebase-sqlite-hashing-v2 +version: 0.0.0 +homepage: https://github.com/unisonweb/unison#readme +bug-reports: https://github.com/unisonweb/unison/issues +copyright: Copyright (C) 2013-2021 Unison Computing, PBC and contributors +build-type: Simple + +source-repository head + type: git + location: https://github.com/unisonweb/unison + +library + exposed-modules: + U.Codebase.Sqlite.V2.Decl + U.Codebase.Sqlite.V2.HashHandle + U.Codebase.Sqlite.V2.SyncEntity + U.Codebase.Sqlite.V2.Term + Unison.Hashing.V2.Convert2 + hs-source-dirs: + src + default-extensions: + ApplicativeDo + BangPatterns + BlockArguments + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingStrategies + DerivingVia + DoAndIfThenElse + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedStrings + PatternSynonyms + RecordWildCards + RankNTypes + ScopedTypeVariables + TupleSections + TypeApplications + ViewPatterns + ghc-options: -Wall + build-depends: + base + , bytes + , bytestring + , containers + , lens + , text + , unison-codebase + , unison-codebase-sqlite + , unison-core + , unison-core1 + , unison-hashing-v2 + , unison-prelude + , unison-sqlite + , unison-util + , unison-util-base32hex + , unison-util-term + , vector + default-language: Haskell2010 diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs index b055f42495..0b07d1bd4b 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs @@ -21,8 +21,8 @@ data DeclFormat = Decl LocallyIndexedComponent type LocallyIndexedComponent = LocallyIndexedComponent' TextId ObjectId -newtype LocallyIndexedComponent' t d - = LocallyIndexedComponent (Vector (LocalIds' t d, Decl Symbol)) +newtype LocallyIndexedComponent' t d = LocallyIndexedComponent + {unLocallyIndexedComponent :: Vector (LocalIds' t d, Decl Symbol)} deriving (Show) type SyncDeclFormat = diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs index cad34d552f..98e5a39d16 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs @@ -12,6 +12,7 @@ module U.Codebase.Sqlite.Decode decodeSyncNamespaceFormat, decodeSyncPatchFormat, decodeSyncTermFormat, + decodeSyncTermAndType, decodeTermElementDiscardingTerm, decodeTermElementDiscardingType, decodeTermElementWithType, @@ -26,9 +27,14 @@ module U.Codebase.Sqlite.Decode -- * @watch_result.result@ decodeWatchResultFormat, + + -- * unsyncs + unsyncTermComponent, + unsyncDeclComponent, ) where +import Control.Exception (throwIO) import Data.Bytes.Get (runGetS) import qualified Data.Bytes.Get as Get import qualified U.Codebase.Reference as C.Reference @@ -53,7 +59,7 @@ data DecodeError = DecodeError err :: String -- the error message } deriving stock (Show) - deriving anyclass (SqliteExceptionReason) + deriving anyclass (SqliteExceptionReason, Exception) getFromBytesOr :: Text -> Get a -> ByteString -> Either DecodeError a getFromBytesOr decoder get bs = case runGetS get bs of @@ -99,6 +105,18 @@ decodeSyncTermFormat :: ByteString -> Either DecodeError TermFormat.SyncTermForm decodeSyncTermFormat = getFromBytesOr "decomposeTermFormat" Serialization.decomposeTermFormat +-- | N.B. The bytestring here is not the entire object.bytes column -- +-- it's just the serialized term and type from 'TermFormat.SyncTermFormat'. +decodeSyncTermAndType :: ByteString -> Either DecodeError (TermFormat.Term, TermFormat.Type) +decodeSyncTermAndType = + getFromBytesOr "getTermAndType" Serialization.getTermAndType + +-- | N.B. The bytestring here is not the entire object.bytes column -- +-- it's just the serialized decl from 'DeclFormat.SyncDeclFormat'. +decodeDecl :: ByteString -> Either DecodeError (DeclFormat.Decl Symbol) +decodeDecl = + getFromBytesOr "getDeclElement" Serialization.getDeclElement + decodeTermFormat :: ByteString -> Either DecodeError TermFormat.TermFormat decodeTermFormat = getFromBytesOr "getTermFormat" Serialization.getTermFormat @@ -147,3 +165,24 @@ decodeTempTermFormat = decodeWatchResultFormat :: ByteString -> Either DecodeError TermFormat.WatchResultFormat decodeWatchResultFormat = getFromBytesOr "getWatchResultFormat" Serialization.getWatchResultFormat + +------------------------------------------------------------------------------------------------------------------------ +-- unsyncs + +unsyncTermComponent :: TermFormat.SyncLocallyIndexedComponent' t d -> IO (TermFormat.LocallyIndexedComponent' t d) +unsyncTermComponent (TermFormat.SyncLocallyIndexedComponent terms) = do + let phi (localIds, bs) = do + (a, b) <- decodeSyncTermAndType bs + pure (localIds, a, b) + case traverse phi terms of + Left err -> throwIO err + Right x -> pure (TermFormat.LocallyIndexedComponent x) + +unsyncDeclComponent :: DeclFormat.SyncLocallyIndexedComponent' t d -> IO (DeclFormat.LocallyIndexedComponent' t d) +unsyncDeclComponent (DeclFormat.SyncLocallyIndexedComponent decls) = do + let phi (localIds, bs) = do + decl <- decodeDecl bs + pure (localIds, decl) + case traverse phi decls of + Left err -> throwIO err + Right x -> pure (DeclFormat.LocallyIndexedComponent x) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs new file mode 100644 index 0000000000..b7fb067575 --- /dev/null +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs @@ -0,0 +1,22 @@ +module U.Codebase.Sqlite.HashHandle + ( HashHandle (..), + ) +where + +import qualified U.Codebase.Reference as C +import U.Codebase.Sqlite.Symbol (Symbol) +import qualified U.Codebase.Term as C.Term +import qualified U.Codebase.Type as C.Type +import U.Util.Hash (Hash) +import Unison.Prelude + +data HashHandle = HashHandle + { -- | Hash type + toReference :: C.Term.Type Symbol -> C.Reference, + -- | Hash type's mentions + toReferenceMentions :: C.Term.Type Symbol -> Set C.Reference, + -- | Hash decl + toReferenceDecl :: Hash -> C.Type.TypeD Symbol -> C.Reference, + -- | Hash decl's mentions + toReferenceDeclMentions :: Hash -> C.Type.TypeD Symbol -> Set C.Reference + } diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 4a37c108e2..67d89e62df 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -11,13 +11,13 @@ module U.Codebase.Sqlite.Operations expectCausalBranchByCausalHash, -- * terms - saveTermComponent, + Q.saveTermComponent, loadTermComponent, loadTermByReference, loadTypeOfTermByTermReference, -- * decls - saveDeclComponent, + Q.saveDeclComponent, loadDeclComponent, loadDeclByReference, expectDeclTypeById, @@ -55,11 +55,11 @@ module U.Codebase.Sqlite.Operations dependentsOfComponent, -- ** type index - addTypeToIndexForTerm, + Q.addTypeToIndexForTerm, termsHavingType, -- ** type mentions index - addTypeMentionsToIndexForTerm, + Q.addTypeMentionsToIndexForTerm, termsMentioningType, -- ** name lookup index @@ -80,29 +80,23 @@ module U.Codebase.Sqlite.Operations diffPatch, decodeTermElementWithType, loadTermWithTypeByReference, - s2cTermWithType, + Q.s2cTermWithType, + Q.s2cDecl, declReferencesByPrefix, branchHashesByPrefix, derivedDependencies, ) where -import Control.Lens (Lens') -import qualified Control.Lens as Lens import qualified Control.Monad.Extra as Monad -import Control.Monad.State (MonadState, evalStateT) -import Control.Monad.Writer (MonadWriter, runWriterT) -import qualified Control.Monad.Writer as Writer import Data.Bifunctor (Bifunctor (bimap)) import Data.Bitraversable (Bitraversable (bitraverse)) import qualified Data.Foldable as Foldable import qualified Data.Map as Map import qualified Data.Map.Merge.Lazy as Map -import qualified Data.Sequence as Seq import qualified Data.Set as Set import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3, (***)) -import qualified Data.Vector as Vector import qualified U.Codebase.Branch as C.Branch import qualified U.Codebase.Causal as C import U.Codebase.Decl (ConstructorId) @@ -125,17 +119,14 @@ import qualified U.Codebase.Sqlite.Branch.Full as S.MetadataSet import qualified U.Codebase.Sqlite.DbId as Db import qualified U.Codebase.Sqlite.Decl.Format as S.Decl import U.Codebase.Sqlite.Decode +import U.Codebase.Sqlite.HashHandle (HashHandle (..)) import U.Codebase.Sqlite.LocalIds - ( LocalDefnId (..), - LocalIds, - LocalIds' (..), - LocalTextId (..), + ( LocalIds, WatchLocalIds, ) -import qualified U.Codebase.Sqlite.LocalIds as LocalIds import qualified U.Codebase.Sqlite.LocalizeObject as LocalizeObject import qualified U.Codebase.Sqlite.NamedRef as S -import qualified U.Codebase.Sqlite.ObjectType as OT +import qualified U.Codebase.Sqlite.ObjectType as ObjectType import qualified U.Codebase.Sqlite.Patch.Diff as S import qualified U.Codebase.Sqlite.Patch.Format as S import qualified U.Codebase.Sqlite.Patch.Format as S.Patch.Format @@ -156,17 +147,13 @@ import qualified U.Codebase.Term as C import qualified U.Codebase.Term as C.Term import qualified U.Codebase.TermEdit as C import qualified U.Codebase.TermEdit as C.TermEdit -import qualified U.Codebase.Type as C.Type import qualified U.Codebase.TypeEdit as C import qualified U.Codebase.TypeEdit as C.TypeEdit import U.Codebase.WatchKind (WatchKind) -import qualified U.Core.ABT as ABT import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as H import qualified U.Util.Hash32 as Hash32 -import qualified U.Util.Lens as Lens import qualified U.Util.Serialization as S -import qualified U.Util.Term as TermUtil import Unison.Prelude import Unison.Sqlite import qualified Unison.Util.Map as Map @@ -305,12 +292,8 @@ h2cReferent = bitraverse h2cReference h2cReference -- ** convert and save references --- | Save the text and hash parts of a Reference to the database and substitute their ids. -saveReferenceH :: C.Reference -> Transaction S.ReferenceH -saveReferenceH = bitraverse Q.saveText Q.saveHashHash - saveReferentH :: C.Referent -> Transaction S.ReferentH -saveReferentH = bitraverse saveReferenceH saveReferenceH +saveReferentH = bitraverse Q.saveReferenceH Q.saveReferenceH -- ** Edits transformations @@ -341,7 +324,7 @@ c2sPatch :: C.Branch.Patch -> Transaction S.Patch c2sPatch (C.Branch.Patch termEdits typeEdits) = S.Patch <$> Map.bitraverse saveReferentH (Set.traverse c2sTermEdit) termEdits - <*> Map.bitraverse saveReferenceH (Set.traverse c2sTypeEdit) typeEdits + <*> Map.bitraverse Q.saveReferenceH (Set.traverse c2sTypeEdit) typeEdits where c2sTermEdit = \case C.TermEdit.Replace r t -> S.TermEdit.Replace <$> c2sReferent r <*> pure (c2sTyping t) @@ -402,163 +385,14 @@ loadTermComponent :: H.Hash -> MaybeT Transaction [(C.Term Symbol, C.Term.Type S loadTermComponent h = do oid <- MaybeT (Q.loadObjectIdForAnyHash h) S.Term.Term (S.Term.LocallyIndexedComponent elements) <- MaybeT (Q.loadTermObject oid decodeTermFormat) - lift . traverse (uncurry3 s2cTermWithType) $ Foldable.toList elements - -saveTermComponent :: H.Hash -> [(C.Term Symbol, C.Term.Type Symbol)] -> Transaction Db.ObjectId -saveTermComponent h terms = do - when debug . traceM $ "Operations.saveTermComponent " ++ show h - sTermElements <- traverse (uncurry c2sTerm) terms - hashId <- Q.saveHashHash h - let li = S.Term.LocallyIndexedComponent $ Vector.fromList sTermElements - bytes = S.putBytes S.putTermFormat $ S.Term.Term li - oId <- Q.saveObject hashId OT.TermComponent bytes - -- populate dependents index - let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sTermElements `zip` [0 ..]) - unlocalizeRefs :: ((LocalIds, S.Term.Term, S.Term.Type), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id) - unlocalizeRefs ((LocalIds tIds oIds, tm, tp), i) = - let self = C.Reference.Id oId i - dependencies :: Set S.Reference = - let (tmRefs, tpRefs, tmLinks, tpLinks) = TermUtil.dependencies tm - tpRefs' = Foldable.toList $ C.Type.dependencies tp - getTermSRef :: S.Term.TermRef -> S.Reference - getTermSRef = \case - C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t) - C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references - C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i - getTypeSRef :: S.Term.TypeRef -> S.Reference - getTypeSRef = \case - C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t) - C.Reference.Derived h i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i - getSTypeLink = getTypeSRef - getSTermLink :: S.Term.TermLink -> S.Reference - getSTermLink = \case - C.Referent.Con ref _conId -> getTypeSRef ref - C.Referent.Ref ref -> getTermSRef ref - in Set.fromList $ - map getTermSRef tmRefs - ++ map getSTermLink tmLinks - ++ map getTypeSRef (tpRefs ++ tpRefs') - ++ map getSTypeLink tpLinks - in Set.map (,self) dependencies - traverse_ (uncurry Q.addToDependentsIndex) dependencies - - pure oId - --- | implementation detail of c2{s,w}Term --- The Type is optional, because we don't store them for watch expression results. -c2xTerm :: forall m t d. Monad m => (Text -> m t) -> (H.Hash -> m d) -> C.Term Symbol -> Maybe (C.Term.Type Symbol) -> m (LocalIds' t d, S.Term.Term, Maybe (S.Term.Type)) -c2xTerm saveText saveDefn tm tp = - done =<< (runWriterT . flip evalStateT mempty) do - sterm <- ABT.transformM go tm - stype <- traverse (ABT.transformM goType) tp - pure (sterm, stype) - where - go :: forall m a. (MonadWriter (Seq Text, Seq H.Hash) m, MonadState (Map Text LocalTextId, Map H.Hash LocalDefnId) m) => C.Term.F Symbol a -> m (S.Term.F a) - go = \case - C.Term.Int n -> pure $ C.Term.Int n - C.Term.Nat n -> pure $ C.Term.Nat n - C.Term.Float n -> pure $ C.Term.Float n - C.Term.Boolean b -> pure $ C.Term.Boolean b - C.Term.Text t -> C.Term.Text <$> lookupText t - C.Term.Char ch -> pure $ C.Term.Char ch - C.Term.Ref r -> - C.Term.Ref <$> bitraverse lookupText (traverse lookupDefn) r - C.Term.Constructor typeRef cid -> - C.Term.Constructor - <$> bitraverse lookupText lookupDefn typeRef - <*> pure cid - C.Term.Request typeRef cid -> - C.Term.Request <$> bitraverse lookupText lookupDefn typeRef <*> pure cid - C.Term.Handle a a2 -> pure $ C.Term.Handle a a2 - C.Term.App a a2 -> pure $ C.Term.App a a2 - C.Term.Ann a typ -> C.Term.Ann a <$> ABT.transformM goType typ - C.Term.List as -> pure $ C.Term.List as - C.Term.If c t f -> pure $ C.Term.If c t f - C.Term.And a a2 -> pure $ C.Term.And a a2 - C.Term.Or a a2 -> pure $ C.Term.Or a a2 - C.Term.Lam a -> pure $ C.Term.Lam a - C.Term.LetRec bs a -> pure $ C.Term.LetRec bs a - C.Term.Let a a2 -> pure $ C.Term.Let a a2 - C.Term.Match a cs -> C.Term.Match a <$> traverse goCase cs - C.Term.TermLink r -> - C.Term.TermLink - <$> bitraverse - (bitraverse lookupText (traverse lookupDefn)) - (bitraverse lookupText lookupDefn) - r - C.Term.TypeLink r -> - C.Term.TypeLink <$> bitraverse lookupText lookupDefn r - goType :: - forall m a. - (MonadWriter (Seq Text, Seq H.Hash) m, MonadState (Map Text LocalTextId, Map H.Hash LocalDefnId) m) => - C.Type.FT a -> - m (S.Term.FT a) - goType = \case - C.Type.Ref r -> C.Type.Ref <$> bitraverse lookupText lookupDefn r - C.Type.Arrow i o -> pure $ C.Type.Arrow i o - C.Type.Ann a k -> pure $ C.Type.Ann a k - C.Type.App f a -> pure $ C.Type.App f a - C.Type.Effect e a -> pure $ C.Type.Effect e a - C.Type.Effects es -> pure $ C.Type.Effects es - C.Type.Forall a -> pure $ C.Type.Forall a - C.Type.IntroOuter a -> pure $ C.Type.IntroOuter a - goCase :: - forall m w s a. - ( MonadState s m, - MonadWriter w m, - Lens.Field1' s (Map Text LocalTextId), - Lens.Field1' w (Seq Text), - Lens.Field2' s (Map H.Hash LocalDefnId), - Lens.Field2' w (Seq H.Hash) - ) => - C.Term.MatchCase Text C.Term.TypeRef a -> - m (C.Term.MatchCase LocalTextId S.Term.TypeRef a) - goCase = \case - C.Term.MatchCase pat guard body -> - C.Term.MatchCase <$> goPat pat <*> pure guard <*> pure body - goPat :: - forall m s w. - ( MonadState s m, - MonadWriter w m, - Lens.Field1' s (Map Text LocalTextId), - Lens.Field1' w (Seq Text), - Lens.Field2' s (Map H.Hash LocalDefnId), - Lens.Field2' w (Seq H.Hash) - ) => - C.Term.Pattern Text C.Term.TypeRef -> - m (C.Term.Pattern LocalTextId S.Term.TypeRef) - goPat = \case - C.Term.PUnbound -> pure $ C.Term.PUnbound - C.Term.PVar -> pure $ C.Term.PVar - C.Term.PBoolean b -> pure $ C.Term.PBoolean b - C.Term.PInt i -> pure $ C.Term.PInt i - C.Term.PNat n -> pure $ C.Term.PNat n - C.Term.PFloat d -> pure $ C.Term.PFloat d - C.Term.PText t -> C.Term.PText <$> lookupText t - C.Term.PChar c -> pure $ C.Term.PChar c - C.Term.PConstructor r i ps -> C.Term.PConstructor <$> bitraverse lookupText lookupDefn r <*> pure i <*> traverse goPat ps - C.Term.PAs p -> C.Term.PAs <$> goPat p - C.Term.PEffectPure p -> C.Term.PEffectPure <$> goPat p - C.Term.PEffectBind r i bindings k -> C.Term.PEffectBind <$> bitraverse lookupText lookupDefn r <*> pure i <*> traverse goPat bindings <*> goPat k - C.Term.PSequenceLiteral ps -> C.Term.PSequenceLiteral <$> traverse goPat ps - C.Term.PSequenceOp l op r -> C.Term.PSequenceOp <$> goPat l <*> pure op <*> goPat r - - done :: ((S.Term.Term, Maybe S.Term.Type), (Seq Text, Seq H.Hash)) -> m (LocalIds' t d, S.Term.Term, Maybe S.Term.Type) - done ((tm, tp), (localTextValues, localDefnValues)) = do - textIds <- traverse saveText localTextValues - defnIds <- traverse saveDefn localDefnValues - let ids = - LocalIds - (Vector.fromList (Foldable.toList textIds)) - (Vector.fromList (Foldable.toList defnIds)) - pure (ids, void tm, void <$> tp) + lift . traverse (uncurry3 Q.s2cTermWithType) $ Foldable.toList elements loadTermWithTypeByReference :: C.Reference.Id -> MaybeT Transaction (C.Term Symbol, C.Term.Type Symbol) loadTermWithTypeByReference (C.Reference.Id h i) = do oid <- MaybeT (Q.loadObjectIdForPrimaryHash h) -- retrieve and deserialize the blob (localIds, term, typ) <- MaybeT (Q.loadTermObject oid (decodeTermElementWithType i)) - lift (s2cTermWithType localIds term typ) + lift (Q.s2cTermWithType localIds term typ) loadTermByReference :: C.Reference.Id -> MaybeT Transaction (C.Term Symbol) loadTermByReference r@(C.Reference.Id h i) = do @@ -576,95 +410,15 @@ loadTypeOfTermByTermReference id@(C.Reference.Id h i) = do (localIds, typ) <- MaybeT (Q.loadTermObject oid (decodeTermElementDiscardingTerm i)) lift (s2cTypeOfTerm localIds typ) -s2cTermWithType :: LocalIds -> S.Term.Term -> S.Term.Type -> Transaction (C.Term Symbol, C.Term.Type Symbol) -s2cTermWithType ids tm tp = do - (substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids - pure (x2cTerm substText substHash tm, x2cTType substText substHash tp) - s2cTerm :: LocalIds -> S.Term.Term -> Transaction (C.Term Symbol) s2cTerm ids tm = do - (substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids - pure $ x2cTerm substText substHash tm + (substText, substHash) <- Q.localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids + pure $ Q.x2cTerm substText substHash tm s2cTypeOfTerm :: LocalIds -> S.Term.Type -> Transaction (C.Term.Type Symbol) s2cTypeOfTerm ids tp = do - (substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids - pure $ x2cTType substText substHash tp - --- | implementation detail of {s,w}2c*Term* & s2cDecl -localIdsToLookups :: Monad m => (t -> m Text) -> (d -> m H.Hash) -> LocalIds' t d -> m (LocalTextId -> Text, LocalDefnId -> H.Hash) -localIdsToLookups loadText loadHash localIds = do - texts <- traverse loadText $ LocalIds.textLookup localIds - hashes <- traverse loadHash $ LocalIds.defnLookup localIds - let substText (LocalTextId w) = texts Vector.! fromIntegral w - substHash (LocalDefnId w) = hashes Vector.! fromIntegral w - pure (substText, substHash) - -localIdsToTypeRefLookup :: LocalIds -> Transaction (S.Decl.TypeRef -> C.Decl.TypeRef) -localIdsToTypeRefLookup localIds = do - (substText, substHash) <- localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId localIds - pure $ bimap substText (fmap substHash) - --- | implementation detail of {s,w}2c*Term* -x2cTerm :: (LocalTextId -> Text) -> (LocalDefnId -> H.Hash) -> S.Term.Term -> C.Term Symbol -x2cTerm substText substHash = - -- substitute the text and hashes back into the term - C.Term.extraMap substText substTermRef substTypeRef substTermLink substTypeLink id - where - substTermRef = bimap substText (fmap substHash) - substTypeRef = bimap substText substHash - substTermLink = bimap substTermRef substTypeRef - substTypeLink = substTypeRef - --- | implementation detail of {s,w}2c*Term* -x2cTType :: (LocalTextId -> Text) -> (LocalDefnId -> H.Hash) -> S.Term.Type -> C.Term.Type Symbol -x2cTType substText substHash = C.Type.rmap (bimap substText substHash) - -lookupText :: - forall m s w t. - ( MonadState s m, - MonadWriter w m, - Lens.Field1' s (Map t LocalTextId), - Lens.Field1' w (Seq t), - Ord t - ) => - t -> - m LocalTextId -lookupText = lookup_ Lens._1 Lens._1 LocalTextId - -lookupDefn :: - forall m s w d. - ( MonadState s m, - MonadWriter w m, - Lens.Field2' s (Map d LocalDefnId), - Lens.Field2' w (Seq d), - Ord d - ) => - d -> - m LocalDefnId -lookupDefn = lookup_ Lens._2 Lens._2 LocalDefnId - --- | shared implementation of lookupTextHelper and lookupDefnHelper --- Look up a value in the LUT, or append it. -lookup_ :: - (MonadState s m, MonadWriter w m, Ord t) => - Lens' s (Map t t') -> - Lens' w (Seq t) -> - (Word64 -> t') -> - t -> - m t' -lookup_ stateLens writerLens mk t = do - map <- Lens.use stateLens - case Map.lookup t map of - Nothing -> do - let id = mk . fromIntegral $ Map.size map - stateLens Lens.%= Map.insert t id - Writer.tell $ Lens.set writerLens (Seq.singleton t) mempty - pure id - Just t' -> pure t' - -c2sTerm :: C.Term Symbol -> C.Term.Type Symbol -> Transaction (LocalIds, S.Term.Term, S.Term.Type) -c2sTerm tm tp = c2xTerm Q.saveText Q.expectObjectIdForPrimaryHash tm (Just tp) <&> \(w, tm, Just tp) -> (w, tm, tp) + (substText, substHash) <- Q.localIdsToLookups Q.expectText Q.expectPrimaryHashByObjectId ids + pure $ Q.x2cTType substText substHash tp -- *** Watch expressions @@ -689,12 +443,12 @@ clearWatches :: Transaction () clearWatches = Q.clearWatches c2wTerm :: C.Term Symbol -> Transaction (WatchLocalIds, S.Term.Term) -c2wTerm tm = c2xTerm Q.saveText Q.saveHashHash tm Nothing <&> \(w, tm, _) -> (w, tm) +c2wTerm tm = Q.c2xTerm Q.saveText Q.saveHashHash tm Nothing <&> \(w, tm, _) -> (w, tm) w2cTerm :: WatchLocalIds -> S.Term.Term -> Transaction (C.Term Symbol) w2cTerm ids tm = do - (substText, substHash) <- localIdsToLookups Q.expectText Q.expectHash ids - pure $ x2cTerm substText substHash tm + (substText, substHash) <- Q.localIdsToLookups Q.expectText Q.expectHash ids + pure $ Q.x2cTerm substText substHash tm -- ** Saving & loading type decls @@ -702,80 +456,14 @@ loadDeclComponent :: H.Hash -> MaybeT Transaction [C.Decl Symbol] loadDeclComponent h = do oid <- MaybeT (Q.loadObjectIdForAnyHash h) S.Decl.Decl (S.Decl.LocallyIndexedComponent elements) <- MaybeT (Q.loadDeclObject oid decodeDeclFormat) - lift . traverse (uncurry s2cDecl) $ Foldable.toList elements - -saveDeclComponent :: H.Hash -> [C.Decl Symbol] -> Transaction Db.ObjectId -saveDeclComponent h decls = do - when debug . traceM $ "Operations.saveDeclComponent " ++ show h - sDeclElements <- traverse (c2sDecl Q.saveText Q.expectObjectIdForPrimaryHash) decls - hashId <- Q.saveHashHash h - let li = S.Decl.LocallyIndexedComponent $ Vector.fromList sDeclElements - bytes = S.putBytes S.putDeclFormat $ S.Decl.Decl li - oId <- Q.saveObject hashId OT.DeclComponent bytes - -- populate dependents index - let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sDeclElements `zip` [0 ..]) - unlocalizeRefs :: ((LocalIds, S.Decl.Decl Symbol), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id) - unlocalizeRefs ((LocalIds tIds oIds, decl), i) = - let self = C.Reference.Id oId i - dependencies :: Set S.Decl.TypeRef = C.Decl.dependencies decl - getSRef :: C.Reference.Reference' LocalTextId (Maybe LocalDefnId) -> S.Reference.Reference - getSRef = \case - C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t) - C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references - C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i - in Set.map ((,self) . getSRef) dependencies - traverse_ (uncurry Q.addToDependentsIndex) dependencies - - pure oId - -c2sDecl :: - forall m t d. - Monad m => - (Text -> m t) -> - (H.Hash -> m d) -> - C.Decl Symbol -> - m (LocalIds' t d, S.Decl.Decl Symbol) -c2sDecl saveText saveDefn (C.Decl.DataDeclaration dt m b cts) = do - done =<< (runWriterT . flip evalStateT mempty) do - cts' <- traverse (ABT.transformM goType) cts - pure (C.Decl.DataDeclaration dt m b cts') - where - goType :: - forall m a. - (MonadWriter (Seq Text, Seq H.Hash) m, MonadState (Map Text LocalTextId, Map H.Hash LocalDefnId) m) => - C.Type.FD a -> - m (S.Decl.F a) - goType = \case - C.Type.Ref r -> C.Type.Ref <$> bitraverse lookupText (traverse lookupDefn) r - C.Type.Arrow i o -> pure $ C.Type.Arrow i o - C.Type.Ann a k -> pure $ C.Type.Ann a k - C.Type.App f a -> pure $ C.Type.App f a - C.Type.Effect e a -> pure $ C.Type.Effect e a - C.Type.Effects es -> pure $ C.Type.Effects es - C.Type.Forall a -> pure $ C.Type.Forall a - C.Type.IntroOuter a -> pure $ C.Type.IntroOuter a - done :: (S.Decl.Decl Symbol, (Seq Text, Seq H.Hash)) -> m (LocalIds' t d, S.Decl.Decl Symbol) - done (decl, (localTextValues, localDefnValues)) = do - textIds <- traverse saveText localTextValues - defnIds <- traverse saveDefn localDefnValues - let ids = - LocalIds - (Vector.fromList (Foldable.toList textIds)) - (Vector.fromList (Foldable.toList defnIds)) - pure (ids, decl) - --- | Unlocalize a decl. -s2cDecl :: LocalIds -> S.Decl.Decl Symbol -> Transaction (C.Decl Symbol) -s2cDecl ids (C.Decl.DataDeclaration dt m b ct) = do - substTypeRef <- localIdsToTypeRefLookup ids - pure (C.Decl.DataDeclaration dt m b (C.Type.rmap substTypeRef <$> ct)) + lift . traverse (uncurry Q.s2cDecl) $ Foldable.toList elements loadDeclByReference :: C.Reference.Id -> MaybeT Transaction (C.Decl Symbol) loadDeclByReference r@(C.Reference.Id h i) = do when debug . traceM $ "loadDeclByReference " ++ show r oid <- MaybeT (Q.loadObjectIdForPrimaryHash h) (localIds, decl) <- MaybeT (Q.loadDeclObject oid (decodeDeclElement i)) - lift (s2cDecl localIds decl) + lift (Q.s2cDecl localIds decl) expectDeclByReference :: C.Reference.Id -> Transaction (C.Decl Symbol) expectDeclByReference r@(C.Reference.Id h i) = do @@ -783,7 +471,7 @@ expectDeclByReference r@(C.Reference.Id h i) = do -- retrieve the blob Q.expectObjectIdForPrimaryHash h >>= (\oid -> Q.expectDeclObject oid (decodeDeclElement i)) - >>= uncurry s2cDecl + >>= uncurry Q.s2cDecl -- * Branch transformation @@ -877,10 +565,13 @@ s2cBranch (S.Branch.Full.Branch tms tps patches children) = boId <- Q.expectBranchObjectIdByCausalHashId chId expectBranch boId -saveRootBranch :: C.Branch.CausalBranch Transaction -> Transaction (Db.BranchObjectId, Db.CausalHashId) -saveRootBranch c = do +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 c + (boId, chId) <- saveBranch hh c Q.setNamespaceRoot chId pure (boId, chId) @@ -923,8 +614,11 @@ saveRootBranch c = do -- References, but also values -- Shallow - Hash? representation of the database relationships -saveBranch :: C.Branch.CausalBranch Transaction -> Transaction (Db.BranchObjectId, Db.CausalHashId) -saveBranch (C.Causal hc he parents me) = do +saveBranch :: + HashHandle -> + C.Branch.CausalBranch Transaction -> + Transaction (Db.BranchObjectId, Db.CausalHashId) +saveBranch hh (C.Causal hc he parents me) = do when debug $ traceM $ "\nOperations.saveBranch \n hc = " ++ show hc ++ ",\n he = " ++ show he ++ ",\n parents = " ++ show (Map.keys parents) (chId, bhId) <- flip Monad.fromMaybeM (Q.loadCausalByCausalHash hc) do @@ -939,14 +633,14 @@ saveBranch (C.Causal hc he parents me) = do -- by checking if there are causal parents associated with hc (flip Monad.fromMaybeM) (Q.loadCausalHashIdByCausalHash parentHash) - (mcausal >>= fmap snd . saveBranch) + (mcausal >>= fmap snd . saveBranch hh) -- Save these CausalHashIds to the causal_parents table, - Q.saveCausal chId bhId parentCausalHashIds + Q.saveCausal hh chId bhId parentCausalHashIds pure (chId, bhId) boId <- flip Monad.fromMaybeM (Q.loadBranchObjectIdByCausalHashId chId) do branch <- c2sBranch =<< me - saveDbBranchUnderHashId bhId branch + saveDbBranchUnderHashId hh bhId branch pure (boId, chId) where c2sBranch :: C.Branch.Branch Transaction -> Transaction S.DbBranch @@ -955,7 +649,7 @@ saveBranch (C.Causal hc he parents me) = do <$> Map.bitraverse saveNameSegment (Map.bitraverse c2sReferent c2sMetadata) terms <*> Map.bitraverse saveNameSegment (Map.bitraverse c2sReference c2sMetadata) types <*> Map.bitraverse saveNameSegment savePatchObjectId patches - <*> Map.bitraverse saveNameSegment saveBranch children + <*> Map.bitraverse saveNameSegment (saveBranch hh) children saveNameSegment :: C.Branch.NameSegment -> Transaction Db.TextId saveNameSegment = Q.saveText . C.Branch.unNameSegment @@ -971,7 +665,7 @@ saveBranch (C.Causal hc he parents me) = do Just patchOID -> pure patchOID Nothing -> do patch <- mp - savePatch h patch + savePatch hh h patch expectRootCausal :: Transaction (C.Branch.CausalBranch Transaction) expectRootCausal = Q.expectNamespaceRoot >>= expectCausalBranchByCausalHashId @@ -1125,14 +819,22 @@ expectDbBranch id = -- -- Note: long-standing question: should this package depend on the hashing package? (If so, we would only need to take -- the DbBranch, and hash internally). -saveDbBranch :: BranchHash -> S.DbBranch -> Transaction Db.BranchObjectId -saveDbBranch hash branch = do +saveDbBranch :: + HashHandle -> + BranchHash -> + S.DbBranch -> + Transaction Db.BranchObjectId +saveDbBranch hh hash branch = do hashId <- Q.saveBranchHash hash - saveDbBranchUnderHashId hashId branch + saveDbBranchUnderHashId hh hashId branch -- | Variant of 'saveDbBranch' that might be preferred by callers that already have a hash id, not a hash. -saveDbBranchUnderHashId :: Db.BranchHashId -> S.DbBranch -> Transaction Db.BranchObjectId -saveDbBranchUnderHashId id@(Db.unBranchHashId -> hashId) branch = do +saveDbBranchUnderHashId :: + HashHandle -> + Db.BranchHashId -> + S.DbBranch -> + Transaction Db.BranchObjectId +saveDbBranchUnderHashId hh id@(Db.unBranchHashId -> hashId) branch = do let (localBranchIds, localBranch) = LocalizeObject.localizeBranch branch when debug $ traceM $ @@ -1140,7 +842,7 @@ saveDbBranchUnderHashId id@(Db.unBranchHashId -> hashId) branch = do ++ "\n\tlBranch = " ++ show localBranch let bytes = S.putBytes S.putBranchFormat $ S.BranchFormat.Full localBranchIds localBranch - oId <- Q.saveObject hashId OT.Namespace bytes + oId <- Q.saveObject hh hashId ObjectType.Namespace bytes pure $ Db.BranchObjectId oId expectBranch :: Db.BranchObjectId -> Transaction (C.Branch.Branch Transaction) @@ -1165,16 +867,24 @@ expectDbPatch patchId = S.Patch.Format.Full li f -> pure (S.Patch.Format.applyPatchDiffs (S.Patch.Format.localPatchToPatch li f) ds) S.Patch.Format.Diff ref' li' d' -> doDiff ref' (S.Patch.Format.localPatchDiffToPatchDiff li' d' : ds) -savePatch :: PatchHash -> C.Branch.Patch -> Transaction Db.PatchObjectId -savePatch h c = do +savePatch :: + HashHandle -> + PatchHash -> + C.Branch.Patch -> + Transaction Db.PatchObjectId +savePatch hh h c = do (li, lPatch) <- LocalizeObject.localizePatch <$> c2sPatch c - saveDbPatch h (S.Patch.Format.Full li lPatch) - -saveDbPatch :: PatchHash -> S.PatchFormat -> Transaction Db.PatchObjectId -saveDbPatch hash patch = do + saveDbPatch hh h (S.Patch.Format.Full li lPatch) + +saveDbPatch :: + HashHandle -> + PatchHash -> + S.PatchFormat -> + Transaction Db.PatchObjectId +saveDbPatch hh hash patch = do hashId <- Q.saveHashHash (unPatchHash hash) let bytes = S.putBytes S.putPatchFormat patch - Db.PatchObjectId <$> Q.saveObject hashId OT.Patch bytes + Db.PatchObjectId <$> Q.saveObject hh hashId ObjectType.Patch bytes s2cPatch :: S.Patch -> Transaction C.Branch.Patch s2cPatch (S.Patch termEdits typeEdits) = @@ -1224,19 +934,10 @@ termsMentioningType cTypeRef = set <- traverse s2cReferentId sIds pure (Set.fromList set) -addTypeToIndexForTerm :: S.Referent.Id -> C.Reference -> Transaction () -addTypeToIndexForTerm sTermId cTypeRef = do - sTypeRef <- saveReferenceH cTypeRef - Q.addToTypeIndex sTypeRef sTermId - -addTypeMentionsToIndexForTerm :: S.Referent.Id -> Set C.Reference -> Transaction () -addTypeMentionsToIndexForTerm sTermId cTypeMentionRefs = do - traverse_ (flip Q.addToTypeMentionsIndex sTermId <=< saveReferenceH) cTypeMentionRefs - -- something kind of funny here. first, we don't need to enumerate all the reference pos if we're just picking one -- second, it would be nice if we could leave these as S.References a little longer -- so that we remember how to blow up if they're missing -componentReferencesByPrefix :: OT.ObjectType -> Text -> Maybe C.Reference.Pos -> Transaction [S.Reference.Id] +componentReferencesByPrefix :: ObjectType.ObjectType -> Text -> Maybe C.Reference.Pos -> Transaction [S.Reference.Id] componentReferencesByPrefix ot b32prefix pos = do oIds :: [Db.ObjectId] <- Q.objectIdByBase32Prefix ot b32prefix let test = maybe (const True) (==) pos @@ -1245,12 +946,12 @@ componentReferencesByPrefix ot b32prefix pos = do termReferencesByPrefix :: Text -> Maybe Word64 -> Transaction [C.Reference.Id] termReferencesByPrefix t w = - componentReferencesByPrefix OT.TermComponent t w + componentReferencesByPrefix ObjectType.TermComponent t w >>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId) declReferencesByPrefix :: Text -> Maybe Word64 -> Transaction [C.Reference.Id] declReferencesByPrefix t w = - componentReferencesByPrefix OT.DeclComponent t w + componentReferencesByPrefix ObjectType.DeclComponent t w >>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId) termReferentsByPrefix :: Text -> Maybe Word64 -> Transaction [C.Referent.Id] @@ -1265,7 +966,7 @@ declReferentsByPrefix :: Maybe ConstructorId -> Transaction [(H.Hash, C.Reference.Pos, C.DeclType, [C.Decl.ConstructorId])] declReferentsByPrefix b32prefix pos cid = do - componentReferencesByPrefix OT.DeclComponent b32prefix pos + componentReferencesByPrefix ObjectType.DeclComponent b32prefix pos >>= traverse (loadConstructors cid) where loadConstructors :: diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 860ba6ede5..2e41cff70f 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + -- | Some naming conventions used in this module: -- -- * @32@: the base32 representation of a hash @@ -142,35 +144,60 @@ module U.Codebase.Sqlite.Queries syncToTempEntity, insertTempEntity, saveTempEntityInMain, + expectTempEntity, + deleteTempEntity, -- * elaborate hashes elaborateHashes, -- * db misc - createSchema, addTempEntityTables, - schemaVersion, + addTypeMentionsToIndexForTerm, + addTypeToIndexForTerm, + c2xTerm, + createSchema, expectSchemaVersion, + localIdsToLookups, + s2cDecl, + s2cTermWithType, + saveDeclComponent, + saveReferenceH, + saveSyncEntity, + saveTermComponent, + schemaVersion, setSchemaVersion, + x2cTType, + x2cTerm, ) where +import Control.Lens (Lens') import qualified Control.Lens as Lens import Control.Monad.Extra ((||^)) +import Control.Monad.State (MonadState, evalStateT) +import Control.Monad.Writer (MonadWriter, runWriterT) +import qualified Control.Monad.Writer as Writer +import Data.Bifunctor (Bifunctor (bimap)) import Data.Bitraversable (bitraverse) import Data.Bytes.Put (runPutS) import qualified Data.Foldable as Foldable import qualified Data.List.Extra as List import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel +import qualified Data.Map as Map import Data.Map.NonEmpty (NEMap) import qualified Data.Map.NonEmpty as NEMap +import qualified Data.Sequence as Seq import qualified Data.Set as Set import Data.String.Here.Uninterpolated (here, hereFile) import qualified Data.Vector as Vector +import qualified U.Codebase.Decl as C +import qualified U.Codebase.Decl as C.Decl import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) import U.Codebase.Reference (Reference' (..)) +import qualified U.Codebase.Reference as C import qualified U.Codebase.Reference as C.Reference +import qualified U.Codebase.Referent as C.Referent import qualified U.Codebase.Sqlite.Branch.Format as NamespaceFormat import qualified U.Codebase.Sqlite.Causal as Causal import qualified U.Codebase.Sqlite.Causal as Sqlite.Causal @@ -186,9 +213,17 @@ import U.Codebase.Sqlite.DbId TextId, ) import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat +import qualified U.Codebase.Sqlite.Decl.Format as S.Decl import U.Codebase.Sqlite.Decode import U.Codebase.Sqlite.Entity (SyncEntity) import qualified U.Codebase.Sqlite.Entity as Entity +import U.Codebase.Sqlite.HashHandle (HashHandle (..)) +import U.Codebase.Sqlite.LocalIds + ( LocalDefnId (..), + LocalIds, + LocalIds' (..), + LocalTextId (..), + ) import qualified U.Codebase.Sqlite.LocalIds as LocalIds import qualified U.Codebase.Sqlite.NamedRef as S import U.Codebase.Sqlite.ObjectType (ObjectType (DeclComponent, Namespace, Patch, TermComponent)) @@ -196,20 +231,32 @@ import qualified U.Codebase.Sqlite.ObjectType as ObjectType import U.Codebase.Sqlite.Orphans () import qualified U.Codebase.Sqlite.Patch.Format as PatchFormat import qualified U.Codebase.Sqlite.Reference as Reference +import qualified U.Codebase.Sqlite.Reference as S +import qualified U.Codebase.Sqlite.Reference as S.Reference import qualified U.Codebase.Sqlite.Referent as Referent +import qualified U.Codebase.Sqlite.Referent as S.Referent import U.Codebase.Sqlite.Serialization as Serialization +import U.Codebase.Sqlite.Symbol (Symbol) import U.Codebase.Sqlite.TempEntity (TempEntity) import qualified U.Codebase.Sqlite.TempEntity as TempEntity import U.Codebase.Sqlite.TempEntityType (TempEntityType) import qualified U.Codebase.Sqlite.TempEntityType as TempEntityType +import qualified U.Codebase.Sqlite.Term.Format as S.Term import qualified U.Codebase.Sqlite.Term.Format as TermFormat +import qualified U.Codebase.Term as C +import qualified U.Codebase.Term as C.Term +import qualified U.Codebase.Type as C.Type import U.Codebase.WatchKind (WatchKind) +import qualified U.Core.ABT as ABT import qualified U.Util.Alternative as Alternative import U.Util.Hash (Hash) import qualified U.Util.Hash as Hash import U.Util.Hash32 (Hash32) import qualified U.Util.Hash32 as Hash32 import U.Util.Hash32.Orphans.Sqlite () +import qualified U.Util.Lens as Lens +import qualified U.Util.Serialization as S +import qualified U.Util.Term as TermUtil import Unison.Prelude import Unison.Sqlite @@ -383,15 +430,20 @@ saveHashObject hId oId version = execute sql (hId, oId, version) where ON CONFLICT DO NOTHING |] -saveObject :: HashId -> ObjectType -> ByteString -> Transaction ObjectId -saveObject h t blob = do +saveObject :: + HashHandle -> + HashId -> + ObjectType -> + ByteString -> + Transaction ObjectId +saveObject hh h t blob = do oId <- execute sql (h, t, blob) >> expectObjectIdForPrimaryHashId h saveHashObject h oId 2 -- todo: remove this from here, and add it to other relevant places once there are v1 and v2 hashes rowsModified >>= \case 0 -> pure () _ -> do hash <- expectHash32 h - tryMoveTempEntityDependents hash + tryMoveTempEntityDependents hh hash pure oId where sql = [here| @@ -629,14 +681,19 @@ recordObjectRehash old new = -- |Maybe we would generalize this to something other than NamespaceHash if we -- end up wanting to store other kinds of Causals here too. -saveCausal :: CausalHashId -> BranchHashId -> [CausalHashId] -> Transaction () -saveCausal self value parents = do +saveCausal :: + HashHandle -> + CausalHashId -> + BranchHashId -> + [CausalHashId] -> + Transaction () +saveCausal hh self value parents = do execute insertCausalSql (self, value) rowsModified >>= \case 0 -> pure () _ -> do executeMany insertCausalParentsSql (fmap (self,) parents) - flushCausalDependents self + flushCausalDependents hh self where insertCausalSql = [here| INSERT INTO causal (self_hash_id, value_hash_id) @@ -647,10 +704,13 @@ saveCausal self value parents = do INSERT INTO causal_parent (causal_id, parent_id) VALUES (?, ?) |] -flushCausalDependents :: CausalHashId -> Transaction () -flushCausalDependents chId = do +flushCausalDependents :: + HashHandle -> + CausalHashId -> + Transaction () +flushCausalDependents hh chId = do hash <- expectHash32 (unCausalHashId chId) - tryMoveTempEntityDependents hash + tryMoveTempEntityDependents hh hash -- | `tryMoveTempEntityDependents #foo` does this: -- 0. Precondition: We just inserted object #foo. @@ -658,8 +718,12 @@ flushCausalDependents chId = do -- 2. Delete #foo as dependency from temp_entity_missing_dependency. e.g. (#bar, #foo), (#baz, #foo) -- 3. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, -- insert_entity them. -tryMoveTempEntityDependents :: Hash32 -> Transaction () -tryMoveTempEntityDependents dependency = do +tryMoveTempEntityDependents :: + -- | Move TempEntity to main + HashHandle -> + Hash32 -> + Transaction () +tryMoveTempEntityDependents hh dependency = do dependents <- queryListCol [here| @@ -673,7 +737,7 @@ tryMoveTempEntityDependents dependency = do flushIfReadyToFlush :: Hash32 -> Transaction () flushIfReadyToFlush dependent = do readyToFlush dependent >>= \case - True -> moveTempEntityToMain dependent + True -> moveTempEntityToMain hh dependent False -> pure () readyToFlush :: Hash32 -> Transaction Bool @@ -726,21 +790,6 @@ expectEntity hash = do Namespace -> Entity.N <$> decodeSyncNamespaceFormat bytes Patch -> Entity.P <$> decodeSyncPatchFormat bytes -moveTempEntityToMain :: Hash32 -> Transaction () -moveTempEntityToMain hash = do - entity <- expectTempEntity hash - deleteTempEntity hash - _ <- saveTempEntityInMain hash entity - pure () - --- | Save a temp entity in main storage. --- --- Precondition: all of its dependencies are already in main storage. -saveTempEntityInMain :: Hash32 -> TempEntity -> Transaction (Either CausalHashId ObjectId) -saveTempEntityInMain hash entity = do - entity' <- tempToSyncEntity entity - saveSyncEntity hash entity' - -- | Read an entity out of temp storage. expectTempEntity :: Hash32 -> Transaction TempEntity expectTempEntity hash = do @@ -907,28 +956,6 @@ syncToTempEntity = \case TermFormat.SyncTerm . TermFormat.SyncLocallyIndexedComponent <$> Lens.traverseOf (traverse . Lens._1) (bitraverse expectText expectPrimaryHash32ByObjectId) terms -saveSyncEntity :: Hash32 -> SyncEntity -> Transaction (Either CausalHashId ObjectId) -saveSyncEntity hash entity = do - hashId <- saveHash hash - case entity of - Entity.TC stf -> do - let bytes = runPutS (Serialization.recomposeTermFormat stf) - Right <$> saveObject hashId ObjectType.TermComponent bytes - Entity.DC sdf -> do - let bytes = runPutS (Serialization.recomposeDeclFormat sdf) - Right <$> saveObject hashId ObjectType.DeclComponent bytes - Entity.N sbf -> do - let bytes = runPutS (Serialization.recomposeBranchFormat sbf) - Right <$> saveObject hashId ObjectType.Namespace bytes - Entity.P spf -> do - let bytes = runPutS (Serialization.recomposePatchFormat spf) - Right <$> saveObject hashId ObjectType.Patch bytes - Entity.C scf -> case scf of - Sqlite.Causal.SyncCausalFormat{valueHash, parents} -> do - let causalHashId = CausalHashId hashId - saveCausal causalHashId valueHash (Foldable.toList parents) - pure $ Left causalHashId - -- -- maybe: look at whether parent causal is "committed"; if so, then increment; -- -- otherwise, don't. -- getNurseryGeneration :: DB m => m Generation @@ -1624,3 +1651,407 @@ elaborateHashes hashes = do ) execute_ [here|DROP TABLE new_temp_entity_dependents|] pure result + +moveTempEntityToMain :: + HashHandle -> + Hash32 -> + Transaction () +moveTempEntityToMain hh hash = do + entity <- expectTempEntity hash + deleteTempEntity hash + _ <- saveTempEntityInMain hh hash entity + pure () + +-- | Save a temp entity in main storage. +-- +-- Precondition: all of its dependencies are already in main storage. +saveTempEntityInMain :: HashHandle -> Hash32 -> TempEntity -> Transaction (Either CausalHashId ObjectId) +saveTempEntityInMain hh hash entity = do + entity' <- tempToSyncEntity entity + saveSyncEntity hh hash entity' + +saveSyncEntity :: + HashHandle -> + Hash32 -> + SyncEntity -> + Transaction (Either CausalHashId ObjectId) +saveSyncEntity hh hash entity = do + case entity of + Entity.TC stf -> do + lic :: TermFormat.LocallyIndexedComponent <- do + let TermFormat.SyncTerm x = stf + unsafeIO (unsyncTermComponent x) + + tc :: [(C.Term Symbol, C.Term.Type Symbol)] <- + traverse + (\(a, b, c) -> s2cTermWithType a b c) + (toList $ TermFormat.unLocallyIndexedComponent lic) + let bytes = runPutS (Serialization.recomposeTermFormat stf) + objId <- saveTermComponent hh (Just bytes) (Hash32.toHash hash) tc + pure (Right objId) + Entity.DC sdf -> do + lic :: S.Decl.LocallyIndexedComponent <- do + let S.Decl.SyncDecl xs = sdf + unsafeIO (unsyncDeclComponent xs) + + dc :: [C.Decl.Decl Symbol] <- + traverse + (\(localIds, decl) -> s2cDecl localIds decl) + (toList $ S.Decl.unLocallyIndexedComponent lic) + + let bytes = runPutS (Serialization.recomposeDeclFormat sdf) + objId <- saveDeclComponent hh (Just bytes) (Hash32.toHash hash) dc + + pure (Right objId) + Entity.N sbf -> do + hashId <- saveHash hash + let bytes = runPutS (Serialization.recomposeBranchFormat sbf) + Right <$> saveObject hh hashId ObjectType.Namespace bytes + Entity.P spf -> do + hashId <- saveHash hash + let bytes = runPutS (Serialization.recomposePatchFormat spf) + Right <$> saveObject hh hashId ObjectType.Patch bytes + Entity.C scf -> case scf of + Sqlite.Causal.SyncCausalFormat {valueHash, parents} -> do + hashId <- saveHash hash + let causalHashId = CausalHashId hashId + saveCausal hh causalHashId valueHash (toList parents) + pure $ Left causalHashId + +s2cTermWithType :: LocalIds.LocalIds -> S.Term.Term -> S.Term.Type -> Transaction (C.Term Symbol, C.Term.Type Symbol) +s2cTermWithType ids tm tp = do + (substText, substHash) <- localIdsToLookups expectText expectPrimaryHashByObjectId ids + pure (x2cTerm substText substHash tm, x2cTType substText substHash tp) + +saveTermComponent :: + HashHandle -> + -- | The serialized term component if we already have it e.g. via sync + Maybe ByteString -> + -- | term component hash + Hash -> + -- | term component + [(C.Term Symbol, C.Term.Type Symbol)] -> + Transaction ObjectId +saveTermComponent hh@HashHandle {..} maybeEncodedTerms h terms = do + when debug . traceM $ "Operations.saveTermComponent " ++ show h + sTermElements <- traverse (uncurry c2sTerm) terms + hashId <- saveHashHash h + let bytes = fromMaybe mkByteString maybeEncodedTerms + mkByteString = + let li = S.Term.LocallyIndexedComponent $ Vector.fromList sTermElements + in S.putBytes Serialization.putTermFormat $ S.Term.Term li + oId <- saveObject hh hashId ObjectType.TermComponent bytes + -- populate dependents index + let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sTermElements `zip` [0 ..]) + unlocalizeRefs :: ((LocalIds, S.Term.Term, S.Term.Type), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id) + unlocalizeRefs ((LocalIds tIds oIds, tm, tp), i) = + let self = C.Reference.Id oId i + dependencies :: Set S.Reference = + let (tmRefs, tpRefs, tmLinks, tpLinks) = TermUtil.dependencies tm + tpRefs' = Foldable.toList $ C.Type.dependencies tp + getTermSRef :: S.Term.TermRef -> S.Reference + getTermSRef = \case + C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t) + C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references + C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i + getTypeSRef :: S.Term.TypeRef -> S.Reference + getTypeSRef = \case + C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t) + C.Reference.Derived h i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i + getSTypeLink = getTypeSRef + getSTermLink :: S.Term.TermLink -> S.Reference + getSTermLink = \case + C.Referent.Con ref _conId -> getTypeSRef ref + C.Referent.Ref ref -> getTermSRef ref + in Set.fromList $ + map getTermSRef tmRefs + ++ map getSTermLink tmLinks + ++ map getTypeSRef (tpRefs ++ tpRefs') + ++ map getSTypeLink tpLinks + in Set.map (,self) dependencies + traverse_ (uncurry addToDependentsIndex) dependencies + for_ ((snd <$> terms) `zip` [0 ..]) \(tp, i) -> do + let self = C.Referent.RefId (C.Reference.Id oId i) + typeForIndexing = toReference tp + typeMentionsForIndexing = toReferenceMentions tp + addTypeToIndexForTerm self typeForIndexing + addTypeMentionsToIndexForTerm self typeMentionsForIndexing + + pure oId + +-- | Unlocalize a decl. +s2cDecl :: LocalIds -> S.Decl.Decl Symbol -> Transaction (C.Decl Symbol) +s2cDecl ids (C.Decl.DataDeclaration dt m b ct) = do + substTypeRef <- localIdsToTypeRefLookup ids + pure (C.Decl.DataDeclaration dt m b (C.Type.rmap substTypeRef <$> ct)) + +saveDeclComponent :: + HashHandle -> + Maybe ByteString -> + Hash -> + [C.Decl Symbol] -> + Transaction ObjectId +saveDeclComponent hh@HashHandle {..} maybeEncodedDecls h decls = do + when debug . traceM $ "Operations.saveDeclComponent " ++ show h + sDeclElements <- traverse (c2sDecl saveText expectObjectIdForPrimaryHash) decls + hashId <- saveHashHash h + let bytes = fromMaybe mkByteString maybeEncodedDecls + mkByteString = + let li = S.Decl.LocallyIndexedComponent $ Vector.fromList sDeclElements + in S.putBytes Serialization.putDeclFormat $ S.Decl.Decl li + oId <- saveObject hh hashId ObjectType.DeclComponent bytes + -- populate dependents index + let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sDeclElements `zip` [0 ..]) + unlocalizeRefs :: ((LocalIds, S.Decl.Decl Symbol), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id) + unlocalizeRefs ((LocalIds tIds oIds, decl), i) = + let self = C.Reference.Id oId i + dependencies :: Set S.Decl.TypeRef = C.Decl.dependencies decl + getSRef :: C.Reference.Reference' LocalTextId (Maybe LocalDefnId) -> S.Reference.Reference + getSRef = \case + C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t) + C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references + C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i + in Set.map ((,self) . getSRef) dependencies + traverse_ (uncurry addToDependentsIndex) dependencies + for_ ((fmap C.Decl.constructorTypes decls) `zip` [0 ..]) \(ctors, i) -> + for_ (ctors `zip` [0 ..]) \(tp, j) -> do + let self = C.Referent.ConId (C.Reference.Id oId i) j + typeForIndexing = toReferenceDecl h tp + typeMentionsForIndexing = toReferenceDeclMentions h tp + addTypeToIndexForTerm self typeForIndexing + addTypeMentionsToIndexForTerm self typeMentionsForIndexing + + pure oId + +-- | implementation detail of {s,w}2c*Term* & s2cDecl +localIdsToLookups :: Monad m => (t -> m Text) -> (d -> m Hash) -> LocalIds' t d -> m (LocalTextId -> Text, LocalDefnId -> Hash) +localIdsToLookups loadText loadHash localIds = do + texts <- traverse loadText $ LocalIds.textLookup localIds + hashes <- traverse loadHash $ LocalIds.defnLookup localIds + let substText (LocalTextId w) = texts Vector.! fromIntegral w + substHash (LocalDefnId w) = hashes Vector.! fromIntegral w + pure (substText, substHash) + +-- | implementation detail of {s,w}2c*Term* +x2cTerm :: (LocalTextId -> Text) -> (LocalDefnId -> Hash) -> S.Term.Term -> C.Term Symbol +x2cTerm substText substHash = + -- substitute the text and hashes back into the term + C.Term.extraMap substText substTermRef substTypeRef substTermLink substTypeLink id + where + substTermRef = bimap substText (fmap substHash) + substTypeRef = bimap substText substHash + substTermLink = bimap substTermRef substTypeRef + substTypeLink = substTypeRef + +-- | implementation detail of {s,w}2c*Term* +x2cTType :: (LocalTextId -> Text) -> (LocalDefnId -> Hash) -> S.Term.Type -> C.Term.Type Symbol +x2cTType substText substHash = C.Type.rmap (bimap substText substHash) + +c2sTerm :: C.Term Symbol -> C.Term.Type Symbol -> Transaction (LocalIds, S.Term.Term, S.Term.Type) +c2sTerm tm tp = c2xTerm saveText expectObjectIdForPrimaryHash tm (Just tp) <&> \(w, tm, Just tp) -> (w, tm, tp) + +addTypeToIndexForTerm :: S.Referent.Id -> C.Reference -> Transaction () +addTypeToIndexForTerm sTermId cTypeRef = do + sTypeRef <- saveReferenceH cTypeRef + addToTypeIndex sTypeRef sTermId + +addTypeMentionsToIndexForTerm :: S.Referent.Id -> Set C.Reference -> Transaction () +addTypeMentionsToIndexForTerm sTermId cTypeMentionRefs = do + traverse_ (flip addToTypeMentionsIndex sTermId <=< saveReferenceH) cTypeMentionRefs + +localIdsToTypeRefLookup :: LocalIds -> Transaction (S.Decl.TypeRef -> C.Decl.TypeRef) +localIdsToTypeRefLookup localIds = do + (substText, substHash) <- localIdsToLookups expectText expectPrimaryHashByObjectId localIds + pure $ bimap substText (fmap substHash) + +c2sDecl :: + forall m t d. + Monad m => + (Text -> m t) -> + (Hash -> m d) -> + C.Decl Symbol -> + m (LocalIds' t d, S.Decl.Decl Symbol) +c2sDecl saveText saveDefn (C.Decl.DataDeclaration dt m b cts) = do + done =<< (runWriterT . flip evalStateT mempty) do + cts' <- traverse (ABT.transformM goType) cts + pure (C.Decl.DataDeclaration dt m b cts') + where + goType :: + forall m a. + (MonadWriter (Seq Text, Seq Hash) m, MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) => + C.Type.FD a -> + m (S.Decl.F a) + goType = \case + C.Type.Ref r -> C.Type.Ref <$> bitraverse lookupText (traverse lookupDefn) r + C.Type.Arrow i o -> pure $ C.Type.Arrow i o + C.Type.Ann a k -> pure $ C.Type.Ann a k + C.Type.App f a -> pure $ C.Type.App f a + C.Type.Effect e a -> pure $ C.Type.Effect e a + C.Type.Effects es -> pure $ C.Type.Effects es + C.Type.Forall a -> pure $ C.Type.Forall a + C.Type.IntroOuter a -> pure $ C.Type.IntroOuter a + done :: (S.Decl.Decl Symbol, (Seq Text, Seq Hash)) -> m (LocalIds' t d, S.Decl.Decl Symbol) + done (decl, (localTextValues, localDefnValues)) = do + textIds <- traverse saveText localTextValues + defnIds <- traverse saveDefn localDefnValues + let ids = + LocalIds + (Vector.fromList (Foldable.toList textIds)) + (Vector.fromList (Foldable.toList defnIds)) + pure (ids, decl) + +-- | implementation detail of c2{s,w}Term +-- The Type is optional, because we don't store them for watch expression results. +c2xTerm :: forall m t d. Monad m => (Text -> m t) -> (Hash -> m d) -> C.Term Symbol -> Maybe (C.Term.Type Symbol) -> m (LocalIds' t d, S.Term.Term, Maybe (S.Term.Type)) +c2xTerm saveText saveDefn tm tp = + done =<< (runWriterT . flip evalStateT mempty) do + sterm <- ABT.transformM go tm + stype <- traverse (ABT.transformM goType) tp + pure (sterm, stype) + where + go :: forall m a. (MonadWriter (Seq Text, Seq Hash) m, MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) => C.Term.F Symbol a -> m (S.Term.F a) + go = \case + C.Term.Int n -> pure $ C.Term.Int n + C.Term.Nat n -> pure $ C.Term.Nat n + C.Term.Float n -> pure $ C.Term.Float n + C.Term.Boolean b -> pure $ C.Term.Boolean b + C.Term.Text t -> C.Term.Text <$> lookupText t + C.Term.Char ch -> pure $ C.Term.Char ch + C.Term.Ref r -> + C.Term.Ref <$> bitraverse lookupText (traverse lookupDefn) r + C.Term.Constructor typeRef cid -> + C.Term.Constructor + <$> bitraverse lookupText lookupDefn typeRef + <*> pure cid + C.Term.Request typeRef cid -> + C.Term.Request <$> bitraverse lookupText lookupDefn typeRef <*> pure cid + C.Term.Handle a a2 -> pure $ C.Term.Handle a a2 + C.Term.App a a2 -> pure $ C.Term.App a a2 + C.Term.Ann a typ -> C.Term.Ann a <$> ABT.transformM goType typ + C.Term.List as -> pure $ C.Term.List as + C.Term.If c t f -> pure $ C.Term.If c t f + C.Term.And a a2 -> pure $ C.Term.And a a2 + C.Term.Or a a2 -> pure $ C.Term.Or a a2 + C.Term.Lam a -> pure $ C.Term.Lam a + C.Term.LetRec bs a -> pure $ C.Term.LetRec bs a + C.Term.Let a a2 -> pure $ C.Term.Let a a2 + C.Term.Match a cs -> C.Term.Match a <$> traverse goCase cs + C.Term.TermLink r -> + C.Term.TermLink + <$> bitraverse + (bitraverse lookupText (traverse lookupDefn)) + (bitraverse lookupText lookupDefn) + r + C.Term.TypeLink r -> + C.Term.TypeLink <$> bitraverse lookupText lookupDefn r + goType :: + forall m a. + (MonadWriter (Seq Text, Seq Hash) m, MonadState (Map Text LocalTextId, Map Hash LocalDefnId) m) => + C.Type.FT a -> + m (S.Term.FT a) + goType = \case + C.Type.Ref r -> C.Type.Ref <$> bitraverse lookupText lookupDefn r + C.Type.Arrow i o -> pure $ C.Type.Arrow i o + C.Type.Ann a k -> pure $ C.Type.Ann a k + C.Type.App f a -> pure $ C.Type.App f a + C.Type.Effect e a -> pure $ C.Type.Effect e a + C.Type.Effects es -> pure $ C.Type.Effects es + C.Type.Forall a -> pure $ C.Type.Forall a + C.Type.IntroOuter a -> pure $ C.Type.IntroOuter a + goCase :: + forall m w s a. + ( MonadState s m, + MonadWriter w m, + Lens.Field1' s (Map Text LocalTextId), + Lens.Field1' w (Seq Text), + Lens.Field2' s (Map Hash LocalDefnId), + Lens.Field2' w (Seq Hash) + ) => + C.Term.MatchCase Text C.Term.TypeRef a -> + m (C.Term.MatchCase LocalTextId S.Term.TypeRef a) + goCase = \case + C.Term.MatchCase pat guard body -> + C.Term.MatchCase <$> goPat pat <*> pure guard <*> pure body + goPat :: + forall m s w. + ( MonadState s m, + MonadWriter w m, + Lens.Field1' s (Map Text LocalTextId), + Lens.Field1' w (Seq Text), + Lens.Field2' s (Map Hash LocalDefnId), + Lens.Field2' w (Seq Hash) + ) => + C.Term.Pattern Text C.Term.TypeRef -> + m (C.Term.Pattern LocalTextId S.Term.TypeRef) + goPat = \case + C.Term.PUnbound -> pure $ C.Term.PUnbound + C.Term.PVar -> pure $ C.Term.PVar + C.Term.PBoolean b -> pure $ C.Term.PBoolean b + C.Term.PInt i -> pure $ C.Term.PInt i + C.Term.PNat n -> pure $ C.Term.PNat n + C.Term.PFloat d -> pure $ C.Term.PFloat d + C.Term.PText t -> C.Term.PText <$> lookupText t + C.Term.PChar c -> pure $ C.Term.PChar c + C.Term.PConstructor r i ps -> C.Term.PConstructor <$> bitraverse lookupText lookupDefn r <*> pure i <*> traverse goPat ps + C.Term.PAs p -> C.Term.PAs <$> goPat p + C.Term.PEffectPure p -> C.Term.PEffectPure <$> goPat p + C.Term.PEffectBind r i bindings k -> C.Term.PEffectBind <$> bitraverse lookupText lookupDefn r <*> pure i <*> traverse goPat bindings <*> goPat k + C.Term.PSequenceLiteral ps -> C.Term.PSequenceLiteral <$> traverse goPat ps + C.Term.PSequenceOp l op r -> C.Term.PSequenceOp <$> goPat l <*> pure op <*> goPat r + + done :: ((S.Term.Term, Maybe S.Term.Type), (Seq Text, Seq Hash)) -> m (LocalIds' t d, S.Term.Term, Maybe S.Term.Type) + done ((tm, tp), (localTextValues, localDefnValues)) = do + textIds <- traverse saveText localTextValues + defnIds <- traverse saveDefn localDefnValues + let ids = + LocalIds + (Vector.fromList (Foldable.toList textIds)) + (Vector.fromList (Foldable.toList defnIds)) + pure (ids, void tm, void <$> tp) + +-- | Save the text and hash parts of a Reference to the database and substitute their ids. +saveReferenceH :: C.Reference -> Transaction S.ReferenceH +saveReferenceH = bitraverse saveText saveHashHash + +lookupText :: + forall m s w t. + ( MonadState s m, + MonadWriter w m, + Lens.Field1' s (Map t LocalTextId), + Lens.Field1' w (Seq t), + Ord t + ) => + t -> + m LocalTextId +lookupText = lookup_ Lens._1 Lens._1 LocalTextId + +lookupDefn :: + forall m s w d. + ( MonadState s m, + MonadWriter w m, + Lens.Field2' s (Map d LocalDefnId), + Lens.Field2' w (Seq d), + Ord d + ) => + d -> + m LocalDefnId +lookupDefn = lookup_ Lens._2 Lens._2 LocalDefnId + +-- | shared implementation of lookupTextHelper and lookupDefnHelper +-- Look up a value in the LUT, or append it. +lookup_ :: + (MonadState s m, MonadWriter w m, Ord t) => + Lens' s (Map t t') -> + Lens' w (Seq t) -> + (Word64 -> t') -> + t -> + m t' +lookup_ stateLens writerLens mk t = do + map <- Lens.use stateLens + case Map.lookup t map of + Nothing -> do + let id = mk . fromIntegral $ Map.size map + stateLens Lens.%= Map.insert t id + Writer.tell $ Lens.set writerLens (Seq.singleton t) mempty + pure id + Just t' -> pure t' diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index 6880913567..6d6a056119 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -265,6 +265,9 @@ getTermComponent = TermFormat.LocallyIndexedComponent <$> getFramedArray (getTuple3 getLocalIds (getFramed getTerm) getTType) +getTermAndType :: MonadGet m => m (TermFormat.Term, TermFormat.Type) +getTermAndType = (,) <$> getFramed getTerm <*> getTType + getTerm :: MonadGet m => m TermFormat.Term getTerm = getABT getSymbol getUnit getF where diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs index b599371587..0a76da97c1 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Sync22.hs @@ -24,6 +24,7 @@ import qualified U.Codebase.Reference as Reference import qualified U.Codebase.Sqlite.Branch.Format as BL import U.Codebase.Sqlite.DbId import qualified U.Codebase.Sqlite.Decl.Format as DeclFormat +import U.Codebase.Sqlite.HashHandle (HashHandle) import qualified U.Codebase.Sqlite.LocalIds as L import qualified U.Codebase.Sqlite.ObjectType as OT import qualified U.Codebase.Sqlite.Patch.Format as PL @@ -89,18 +90,20 @@ sync22 :: ( MonadIO m, MonadError Error m ) => + HashHandle -> Env m -> IO (Sync m Entity) -sync22 Env {runSrc, runDest, idCacheSize = size} = do +sync22 hh Env {runSrc, runDest, idCacheSize = size} = do tCache <- Cache.semispaceCache size hCache <- Cache.semispaceCache size oCache <- Cache.semispaceCache size cCache <- Cache.semispaceCache size - pure $ Sync (trySync runSrc runDest tCache hCache oCache cCache) + pure $ Sync (trySync hh runSrc runDest tCache hCache oCache cCache) trySync :: forall m. (MonadIO m, MonadError Error m) => + HashHandle -> (forall a. Transaction a -> m a) -> (forall a. Transaction a -> m a) -> Cache TextId TextId -> @@ -109,7 +112,7 @@ trySync :: Cache CausalHashId CausalHashId -> Entity -> m (TrySyncResult Entity) -trySync runSrc runDest tCache hCache oCache cCache = \case +trySync hh runSrc runDest tCache hCache oCache cCache = \case -- for causals, we need to get the value_hash_id of the thingo -- - maybe enqueue their parents -- - enqueue the self_ and value_ hashes @@ -126,7 +129,7 @@ trySync runSrc runDest tCache hCache oCache cCache = \case parents' :: [CausalHashId] <- findParents' chId bhId' <- lift $ syncBranchHashId bhId chId' <- lift $ syncCausalHashId chId - lift (runDest (Q.saveCausal chId' bhId' parents')) + lift (runDest (Q.saveCausal hh chId' bhId' parents')) case result of Left deps -> pure . Sync.Missing $ toList deps @@ -164,7 +167,7 @@ trySync runSrc runDest tCache hCache oCache cCache = \case . TermFormat.SyncLocallyIndexedComponent $ Vector.zip localIds' bytes lift do - oId' <- runDest $ Q.saveObject hId' objType bytes' + oId' <- runDest $ Q.saveObject hh hId' objType bytes' -- copy reference-specific stuff for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do let ref = Reference.Id oId idx @@ -197,7 +200,7 @@ trySync runSrc runDest tCache hCache oCache cCache = \case . DeclFormat.SyncLocallyIndexedComponent $ Vector.zip localIds' declBytes lift do - oId' <- runDest $ Q.saveObject hId' objType bytes' + oId' <- runDest $ Q.saveObject hh hId' objType bytes' -- copy per-element-of-the-component stuff for_ [0 .. length localIds - 1] \(fromIntegral -> idx) -> do let ref = Reference.Id oId idx @@ -210,26 +213,26 @@ trySync runSrc runDest tCache hCache oCache cCache = \case Right (BL.SyncFull ids body) -> do ids' <- syncBranchLocalIds ids let bytes' = runPutS $ S.recomposeBranchFormat (BL.SyncFull ids' body) - oId' <- lift . runDest $ Q.saveObject hId' objType bytes' + oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes' pure oId' Right (BL.SyncDiff boId ids body) -> do boId' <- syncBranchObjectId boId ids' <- syncBranchLocalIds ids let bytes' = runPutS $ S.recomposeBranchFormat (BL.SyncDiff boId' ids' body) - oId' <- lift . runDest $ Q.saveObject hId' objType bytes' + oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes' pure oId' Left s -> throwError $ DecodeError ErrBranchFormat bytes s OT.Patch -> case flip runGetS bytes S.decomposePatchFormat of Right (PL.SyncFull ids body) -> do ids' <- syncPatchLocalIds ids let bytes' = runPutS $ S.recomposePatchFormat (PL.SyncFull ids' body) - oId' <- lift . runDest $ Q.saveObject hId' objType bytes' + oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes' pure oId' Right (PL.SyncDiff poId ids body) -> do poId' <- syncPatchObjectId poId ids' <- syncPatchLocalIds ids let bytes' = runPutS $ S.recomposePatchFormat (PL.SyncDiff poId' ids' body) - oId' <- lift . runDest $ Q.saveObject hId' objType bytes' + oId' <- lift . runDest $ Q.saveObject hh hId' objType bytes' pure oId' Left s -> throwError $ DecodeError ErrPatchFormat bytes s case result of diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs index dd2d086ffe..d588c12227 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs @@ -38,8 +38,8 @@ type TypeLink = TypeRef -- * The term's type, also with internal references to local id. type LocallyIndexedComponent = LocallyIndexedComponent' TextId ObjectId -newtype LocallyIndexedComponent' t d - = LocallyIndexedComponent (Vector (LocalIds' t d, Term, Type)) +newtype LocallyIndexedComponent' t d = LocallyIndexedComponent + {unLocallyIndexedComponent :: Vector (LocalIds' t d, Term, Type)} deriving (Show) newtype SyncLocallyIndexedComponent' t d diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 3f827edf02..b9681bf479 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack @@ -27,6 +27,7 @@ library U.Codebase.Sqlite.Decl.Format U.Codebase.Sqlite.Decode U.Codebase.Sqlite.Entity + U.Codebase.Sqlite.HashHandle U.Codebase.Sqlite.LocalIds U.Codebase.Sqlite.LocalizeObject U.Codebase.Sqlite.NamedRef diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index a299927183..6bf659ccb2 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -102,6 +102,7 @@ dependencies: - unicode-show - unison-codebase - unison-codebase-sqlite + - unison-codebase-sqlite-hashing-v2 - unison-codebase-sync - unison-core - unison-core1 diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index aee7379340..89632f7135 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -32,6 +32,7 @@ import U.Codebase.HashTags (CausalHash (CausalHash)) import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Q import qualified U.Codebase.Sqlite.Sync22 as Sync22 +import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) import qualified U.Codebase.Sync as Sync import qualified U.Util.Cache as Cache import qualified U.Util.Hash as H2 @@ -138,7 +139,7 @@ createCodebaseOrError debugName path action = do Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL Sqlite.runTransaction conn do Q.createSchema - void . Ops.saveRootBranch $ Cv.causalbranch1to2 Branch.empty + void . Ops.saveRootBranch v2HashHandle $ Cv.causalbranch1to2 Branch.empty sqliteCodebase debugName path Local action >>= \case Left schemaVersion -> error ("Failed to open codebase with schema version: " ++ show schemaVersion ++ ", which is unexpected because I just created this codebase.") @@ -526,7 +527,7 @@ syncInternal progress runSrc runDest b = time "syncInternal" do -- or if it exists in the source codebase, then we can sync22 it -- if it doesn't exist in the dest or source branch, -- then just use putBranch to the dest - sync <- liftIO (Sync22.sync22 (Sync22.hoistEnv lift syncEnv)) + sync <- liftIO (Sync22.sync22 v2HashHandle (Sync22.hoistEnv lift syncEnv)) let doSync :: [Sync22.Entity] -> m () doSync = throwExceptT diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 1ea391eb21..a8cca465b1 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -50,6 +50,7 @@ import qualified U.Codebase.Sqlite.Patch.Full as S import qualified U.Codebase.Sqlite.Patch.TermEdit as TermEdit import qualified U.Codebase.Sqlite.Patch.TypeEdit as TypeEdit import qualified U.Codebase.Sqlite.Queries as Q +import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) import U.Codebase.Sync (Sync (Sync)) import qualified U.Codebase.Sync as Sync import U.Codebase.WatchKind (WatchKind) @@ -257,6 +258,7 @@ migrateCausal oldCausalHashId = fmap (either id id) . runExceptT $ do } (lift . lift) do Q.saveCausal + v2HashHandle (SC.DbCausal.selfHash newCausal) (SC.DbCausal.valueHash newCausal) (Set.toList $ SC.DbCausal.parents newCausal) @@ -335,7 +337,7 @@ migrateBranch oldObjectId = fmap (either id id) . runExceptT $ do newHash <- lift . lift $ Hashing.dbBranchHash newBranch newHashId <- lift . lift $ Q.saveBranchHash (coerce Cv.hash1to2 newHash) - newObjectId <- lift . lift $ Ops.saveDbBranchUnderHashId newHashId newBranch + newObjectId <- lift . lift $ Ops.saveDbBranchUnderHashId v2HashHandle newHashId newBranch field @"objLookup" %= Map.insert oldObjectId @@ -398,6 +400,7 @@ migratePatch oldObjectId = fmap (either id id) . runExceptT $ do newObjectId <- lift . lift $ Ops.saveDbPatch + v2HashHandle (coerce Cv.hash1to2 newHash) (S.Patch.Format.Full localPatchIds localPatch) newHashId <- lift . lift $ Q.expectHashIdByHash (coerce Cv.hash1to2 newHash) @@ -868,5 +871,5 @@ saveV2EmptyBranch = do let branch = S.emptyBranch newHash <- Hashing.dbBranchHash branch newHashId <- Q.saveBranchHash (coerce Cv.hash1to2 newHash) - _ <- Ops.saveDbBranchUnderHashId newHashId branch + _ <- Ops.saveDbBranchUnderHashId v2HashHandle newHashId branch pure (newHashId, newHash) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 8e4e20f3b1..168846a257 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -23,6 +23,9 @@ import qualified U.Codebase.Sqlite.NamedRef as S import qualified U.Codebase.Sqlite.ObjectType as OT import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Q +import U.Codebase.Sqlite.V2.Decl (saveDeclComponent) +import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) +import U.Codebase.Sqlite.V2.Term (saveTermComponent) import qualified U.Util.Cache as Cache import qualified U.Util.Hash as H2 import qualified Unison.Builtin as Builtins @@ -267,24 +270,17 @@ tryFlushTermBuffer termBuffer = let loop h = tryFlushBuffer termBuffer - ( \h2 component -> do - oId <- - Ops.saveTermComponent h2 $ - fmap (bimap (Cv.term1to2 h) Cv.ttype1to2) component - addTermComponentTypeIndex oId (fmap snd component) + ( \h2 component -> + void $ + saveTermComponent + Nothing + h2 + (fmap (bimap (Cv.term1to2 h) Cv.ttype1to2) component) ) loop h in loop -addTermComponentTypeIndex :: ObjectId -> [Type Symbol Ann] -> Transaction () -addTermComponentTypeIndex oId types = for_ (types `zip` [0 ..]) \(tp, i) -> do - let self = C.Referent.RefId (C.Reference.Id oId i) - typeForIndexing = Hashing.typeToReference tp - typeMentionsForIndexing = Hashing.typeToReferenceMentions tp - Ops.addTypeToIndexForTerm self (Cv.reference1to2 typeForIndexing) - Ops.addTypeMentionsToIndexForTerm self (Set.map Cv.reference1to2 typeMentionsForIndexing) - addDeclComponentTypeIndex :: ObjectId -> [[Type Symbol Ann]] -> Transaction () addDeclComponentTypeIndex oId ctorss = for_ (ctorss `zip` [0 ..]) \(ctors, i) -> @@ -329,10 +325,12 @@ tryFlushDeclBuffer termBuffer declBuffer = let loop h = tryFlushBuffer declBuffer - ( \h2 component -> do - oId <- Ops.saveDeclComponent h2 $ fmap (Cv.decl1to2 h) component - addDeclComponentTypeIndex oId $ - fmap (map snd . Decl.constructors . Decl.asDataDecl) component + ( \h2 component -> + void $ + saveDeclComponent + Nothing + h2 + (fmap (Cv.decl1to2 h) component) ) (\h -> tryFlushTermBuffer termBuffer h >> loop h) h @@ -382,7 +380,7 @@ putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Transaction)) -> Branch putRootBranch rootBranchCache branch1 = do -- todo: check to see if root namespace hash has been externally modified -- and do something (merge?) it if necessary. But for now, we just overwrite it. - void (Ops.saveRootBranch (Cv.causalbranch1to2 branch1)) + void (Ops.saveRootBranch v2HashHandle (Cv.causalbranch1to2 branch1)) Sqlite.unsafeIO (atomically $ modifyTVar' rootBranchCache (fmap . second $ const branch1)) -- if this blows up on cromulent hashes, then switch from `hashToHashId` @@ -401,7 +399,7 @@ getBranchForHash doGetDeclType h = do putBranch :: Branch Transaction -> Transaction () putBranch = - void . Ops.saveBranch . Cv.causalbranch1to2 + void . Ops.saveBranch v2HashHandle . Cv.causalbranch1to2 isCausalHash :: Branch.CausalHash -> Transaction Bool isCausalHash (Causal.CausalHash h) = @@ -418,7 +416,7 @@ getPatch h = putPatch :: Branch.EditHash -> Patch -> Transaction () putPatch h p = - void $ Ops.savePatch (Cv.patchHash1to2 h) (Cv.patch1to2 p) + void $ Ops.savePatch v2HashHandle (Cv.patchHash1to2 h) (Cv.patch1to2 p) patchExists :: Branch.EditHash -> Transaction Bool patchExists h = fmap isJust $ Q.loadPatchObjectIdForPrimaryHash (Cv.patchHash1to2 h) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 46e9af6cac..195c675886 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -88,7 +88,6 @@ library Unison.FileParser Unison.FileParsers Unison.Hashing.V2.Convert - Unison.Hashing.V2.Convert2 Unison.Lexer Unison.NamePrinter Unison.Parser @@ -269,6 +268,7 @@ library , unicode-show , unison-codebase , unison-codebase-sqlite + , unison-codebase-sqlite-hashing-v2 , unison-codebase-sync , unison-core , unison-core1 @@ -450,6 +450,7 @@ test-suite parser-typechecker-tests , unicode-show , unison-codebase , unison-codebase-sqlite + , unison-codebase-sqlite-hashing-v2 , unison-codebase-sync , unison-core , unison-core1 diff --git a/stack.yaml b/stack.yaml index ac2bc4e68e..4f02f61e15 100644 --- a/stack.yaml +++ b/stack.yaml @@ -18,6 +18,7 @@ packages: - unison-share-api - codebase2/codebase - codebase2/codebase-sqlite +- codebase2/codebase-sqlite-hashing-v2 - codebase2/codebase-sync - codebase2/core - codebase2/util diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index f0231909a2..786f21c130 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -53,6 +53,7 @@ dependencies: - transformers - unison-codebase - unison-codebase-sqlite + - unison-codebase-sqlite-hashing-v2 - unison-sqlite - unison-core1 - unison-parser-typechecker diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index cdbb65f7a7..891549b6f7 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -43,6 +43,7 @@ import Servant.Client (BaseUrl) import qualified Servant.Client as Servant (ClientEnv (..), ClientM, client, defaultMakeClientRequest, hoistClient, mkClientEnv, runClientM) import U.Codebase.HashTags (CausalHash) import qualified U.Codebase.Sqlite.Queries as Q +import U.Codebase.Sqlite.V2.SyncEntity (saveSyncEntity) import U.Util.Hash32 (Hash32) import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import qualified Unison.Auth.HTTPClient as Auth diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 4f441f5e76..cc4d379b2d 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack @@ -136,6 +136,7 @@ library , transformers , unison-codebase , unison-codebase-sqlite + , unison-codebase-sqlite-hashing-v2 , unison-core1 , unison-parser-typechecker , unison-prelude @@ -238,6 +239,7 @@ executable cli-integration-tests , transformers , unison-codebase , unison-codebase-sqlite + , unison-codebase-sqlite-hashing-v2 , unison-core1 , unison-parser-typechecker , unison-prelude @@ -334,6 +336,7 @@ executable transcripts , unison-cli , unison-codebase , unison-codebase-sqlite + , unison-codebase-sqlite-hashing-v2 , unison-core1 , unison-parser-typechecker , unison-prelude @@ -435,6 +438,7 @@ executable unison , unison-cli , unison-codebase , unison-codebase-sqlite + , unison-codebase-sqlite-hashing-v2 , unison-core1 , unison-parser-typechecker , unison-prelude @@ -540,6 +544,7 @@ test-suite cli-tests , unison-cli , unison-codebase , unison-codebase-sqlite + , unison-codebase-sqlite-hashing-v2 , unison-core1 , unison-parser-typechecker , unison-prelude diff --git a/unison-core/package.yaml b/unison-core/package.yaml index 399d8fee57..205b65e2fd 100644 --- a/unison-core/package.yaml +++ b/unison-core/package.yaml @@ -26,6 +26,7 @@ library: - safe - text - transformers + - unison-core - unison-prelude - unison-util - unison-util-base32hex diff --git a/unison-core/src/Unison/ABT.hs b/unison-core/src/Unison/ABT.hs index 817423f86b..3dcb6148c3 100644 --- a/unison-core/src/Unison/ABT.hs +++ b/unison-core/src/Unison/ABT.hs @@ -319,17 +319,17 @@ renames rn0 t0@(Term fvs ann t) | Map.null rn = t0 | Var v <- t, Just u <- Map.lookup v rn = - annotatedVar ann u + annotatedVar ann u | Cycle body <- t = - cycle' ann (renames rn body) + cycle' ann (renames rn body) | Abs v t <- t, -- rename iterated variables all at once to avoid a capture issue AbsNA' (unzip -> (as, vs)) body <- t, (rn, us) <- mangle (freeVars body) rn (v : vs), not $ Map.null rn = - absChain' (zip (ann : as) us) (renames rn body) + absChain' (zip (ann : as) us) (renames rn body) | Tm body <- t = - tm' ann (renames rn <$> body) + tm' ann (renames rn <$> body) | otherwise = t0 where rn = Map.restrictKeys rn0 fvs @@ -339,7 +339,7 @@ renames rn0 t0@(Term fvs ann t) mangle1 avs m v | any (== v) vs, u <- freshIn (avs <> Set.fromList vs) v = - (Map.insert v u m, u) + (Map.insert v u m, u) | otherwise = (Map.delete v m, v) where vs = toList m @@ -403,20 +403,20 @@ subst' :: (Foldable f, Functor f, Var v) => (a -> Term f v a) -> v -> Set v -> T subst' replace v r t2@(Term fvs ann body) | Set.notMember v fvs = t2 -- subtrees not containing the var can be skipped | otherwise = case body of - Var v' - | v == v' -> replace ann -- var match; perform replacement - | otherwise -> t2 -- var did not match one being substituted; ignore - Cycle body -> cycle' ann (subst' replace v r body) - Abs x _ | x == v -> t2 -- x shadows v; ignore subtree - Abs x e -> abs' ann x' e' - where - x' = freshIn (fvs `Set.union` r) x - -- rename x to something that cannot be captured by `r` - e' = - if x /= x' - then subst' replace v r (rename x x' e) - else subst' replace v r e - Tm body -> tm' ann (fmap (subst' replace v r) body) + Var v' + | v == v' -> replace ann -- var match; perform replacement + | otherwise -> t2 -- var did not match one being substituted; ignore + Cycle body -> cycle' ann (subst' replace v r body) + Abs x _ | x == v -> t2 -- x shadows v; ignore subtree + Abs x e -> abs' ann x' e' + where + x' = freshIn (fvs `Set.union` r) x + -- rename x to something that cannot be captured by `r` + e' = + if x /= x' + then subst' replace v r (rename x x' e) + else subst' replace v r e + Tm body -> tm' ann (fmap (subst' replace v r) body) -- Like `subst`, but the annotation of the replacement is inherited from -- the previous annotation at each replacement point. diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index 59dd377747..de4a63fdcc 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.7. -- -- see: https://github.com/sol/hpack @@ -100,6 +100,7 @@ library , safe , text , transformers + , unison-core , unison-prelude , unison-util , unison-util-base32hex diff --git a/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs index 7375700c8b..520705c20b 100644 --- a/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs +++ b/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs @@ -121,13 +121,13 @@ unforall' :: Type v a -> ([v], Type v a) unforall' (ForallsNamed' vs t) = (vs, t) unforall' t = ([], t) -toReference :: (ABT.Var v, Show v) => Type v a -> Reference +toReference :: (Ord v, Show v) => Type v a -> Reference toReference (Ref' r) = r -- a bit of normalization - any unused type parameters aren't part of the hash toReference (ForallNamed' v body) | not (Set.member v (ABT.freeVars body)) = toReference body toReference t = Reference.Derived (ABT.hash t) 0 -toReferenceMentions :: (ABT.Var v, Show v) => Type v a -> Set Reference +toReferenceMentions :: (Ord v, Show v) => Type v a -> Set Reference toReferenceMentions ty = let (vs, _) = unforall' ty gen ty = generalize (Set.toList (freeVars ty)) $ generalize vs ty From bdbca9db35b3d8d557fc30890d96e13f2f618954 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Thu, 16 Jun 2022 15:43:22 -0400 Subject: [PATCH 357/529] Fix error from arya/ooo-sync rebase --- unison-cli/src/Unison/Share/Sync.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 891549b6f7..ece75cde60 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -43,7 +43,7 @@ import Servant.Client (BaseUrl) import qualified Servant.Client as Servant (ClientEnv (..), ClientM, client, defaultMakeClientRequest, hoistClient, mkClientEnv, runClientM) import U.Codebase.HashTags (CausalHash) import qualified U.Codebase.Sqlite.Queries as Q -import U.Codebase.Sqlite.V2.SyncEntity (saveSyncEntity) +import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) import U.Util.Hash32 (Hash32) import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import qualified Unison.Auth.HTTPClient as Auth @@ -548,7 +548,7 @@ upsertEntitySomewhere hash entity = ) case NEMap.nonEmptyMap missingDependencies1 of Nothing -> do - _id <- Q.saveTempEntityInMain hash (entityToTempEntity Share.hashJWTHash entity) + _id <- Q.saveTempEntityInMain v2HashHandle hash (entityToTempEntity Share.hashJWTHash entity) pure Q.EntityInMainStorage Just missingDependencies -> do Q.insertTempEntity From 40b7dd2f7ca6d386bca03c9ddbeacb57178dfa90 Mon Sep 17 00:00:00 2001 From: Dan Freeman Date: Sat, 11 Jun 2022 20:08:36 +0200 Subject: [PATCH 358/529] Add `Sha1` builtin --- parser-typechecker/src/Unison/Builtin.hs | 2 +- .../src/Unison/Runtime/Builtin.hs | 1 + unison-src/transcripts-using-base/hashing.md | 20 ++++++++ .../transcripts-using-base/hashing.output.md | 47 +++++++++++++++---- 4 files changed, 60 insertions(+), 10 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 7fa998f52d..bd6f88073d 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -593,7 +593,7 @@ hashBuiltins = B "crypto.hmac" $ forall1 "a" (\a -> hashAlgo --> bytes --> a --> bytes), B "crypto.hmacBytes" $ hashAlgo --> bytes --> bytes --> bytes ] - ++ map h ["Sha3_512", "Sha3_256", "Sha2_512", "Sha2_256", "Blake2b_512", "Blake2b_256", "Blake2s_256"] + ++ map h ["Sha3_512", "Sha3_256", "Sha2_512", "Sha2_256", "Sha1", "Blake2b_512", "Blake2b_256", "Blake2s_256"] where hashAlgo = Type.ref () Type.hashAlgorithmRef h name = B ("crypto.HashAlgorithm." <> name) hashAlgo diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 14749ef283..f1b47da6a2 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -2148,6 +2148,7 @@ declareForeigns = do declareHashAlgorithm "Sha3_256" Hash.SHA3_256 declareHashAlgorithm "Sha2_512" Hash.SHA512 declareHashAlgorithm "Sha2_256" Hash.SHA256 + declareHashAlgorithm "Sha1" Hash.SHA1 declareHashAlgorithm "Blake2b_512" Hash.Blake2b_512 declareHashAlgorithm "Blake2b_256" Hash.Blake2b_256 declareHashAlgorithm "Blake2s_256" Hash.Blake2s_256 diff --git a/unison-src/transcripts-using-base/hashing.md b/unison-src/transcripts-using-base/hashing.md index 46ef915886..123b5ae5af 100644 --- a/unison-src/transcripts-using-base/hashing.md +++ b/unison-src/transcripts-using-base/hashing.md @@ -145,6 +145,26 @@ test> sha2_256.tests.ex4 = "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" "cf5b16a778af8380036ce59e7b0492370b249b11e8f07a51afac45037afee9d1" +test> sha1.tests.ex1 = + ex Sha1 + "abc" + "a9993e364706816aba3e25717850c26c9cd0d89d" + +test> sha1.tests.ex2 = + ex Sha1 + "" + "da39a3ee5e6b4b0d3255bfef95601890afd80709" + +test> sha1.tests.ex3 = + ex Sha1 + "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" + "84983e441c3bd26ebaae4aa1f95129e5e54670f1" + +test> sha1.tests.ex4 = + ex Sha1 + "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" + "a49b2446a02c645bf419f995b67091253a04a259" + test> blake2s_256.tests.ex1 = ex Blake2s_256 "" diff --git a/unison-src/transcripts-using-base/hashing.output.md b/unison-src/transcripts-using-base/hashing.output.md index 7706681c5a..7d7d9065e3 100644 --- a/unison-src/transcripts-using-base/hashing.output.md +++ b/unison-src/transcripts-using-base/hashing.output.md @@ -124,13 +124,14 @@ And here's the full API: 3. HashAlgorithm.Blake2b_256 : HashAlgorithm 4. HashAlgorithm.Blake2b_512 : HashAlgorithm 5. HashAlgorithm.Blake2s_256 : HashAlgorithm - 6. HashAlgorithm.Sha2_256 : HashAlgorithm - 7. HashAlgorithm.Sha2_512 : HashAlgorithm - 8. HashAlgorithm.Sha3_256 : HashAlgorithm - 9. HashAlgorithm.Sha3_512 : HashAlgorithm - 10. hashBytes : HashAlgorithm -> Bytes -> Bytes - 11. hmac : HashAlgorithm -> Bytes -> a -> Bytes - 12. hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes + 6. HashAlgorithm.Sha1 : HashAlgorithm + 7. HashAlgorithm.Sha2_256 : HashAlgorithm + 8. HashAlgorithm.Sha2_512 : HashAlgorithm + 9. HashAlgorithm.Sha3_256 : HashAlgorithm + 10. HashAlgorithm.Sha3_512 : HashAlgorithm + 11. hashBytes : HashAlgorithm -> Bytes -> Bytes + 12. hmac : HashAlgorithm -> Bytes -> a -> Bytes + 13. hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes .> cd . @@ -243,6 +244,26 @@ test> sha2_256.tests.ex4 = "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" "cf5b16a778af8380036ce59e7b0492370b249b11e8f07a51afac45037afee9d1" +test> sha1.tests.ex1 = + ex Sha1 + "abc" + "a9993e364706816aba3e25717850c26c9cd0d89d" + +test> sha1.tests.ex2 = + ex Sha1 + "" + "da39a3ee5e6b4b0d3255bfef95601890afd80709" + +test> sha1.tests.ex3 = + ex Sha1 + "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" + "84983e441c3bd26ebaae4aa1f95129e5e54670f1" + +test> sha1.tests.ex4 = + ex Sha1 + "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" + "a49b2446a02c645bf419f995b67091253a04a259" + test> blake2s_256.tests.ex1 = ex Blake2s_256 "" @@ -273,6 +294,10 @@ test> blake2b_512.tests.ex3 = โ—‰ blake2b_512.tests.ex2 Passed โ—‰ blake2b_512.tests.ex3 Passed โ—‰ blake2s_256.tests.ex1 Passed + โ—‰ sha1.tests.ex1 Passed + โ—‰ sha1.tests.ex2 Passed + โ—‰ sha1.tests.ex3 Passed + โ—‰ sha1.tests.ex4 Passed โ—‰ sha2_256.tests.ex1 Passed โ—‰ sha2_256.tests.ex2 Passed โ—‰ sha2_256.tests.ex3 Passed @@ -290,7 +315,7 @@ test> blake2b_512.tests.ex3 = โ—‰ sha3_512.tests.ex3 Passed โ—‰ sha3_512.tests.ex4 Passed - โœ… 20 test(s) passing + โœ… 24 test(s) passing Tip: Use view blake2b_512.tests.ex1 to view the source of a test. @@ -378,6 +403,10 @@ test> hmac_sha2_512.tests.ex2 = โ—‰ hmac_sha2_256.tests.ex2 Passed โ—‰ hmac_sha2_512.tests.ex1 Passed โ—‰ hmac_sha2_512.tests.ex2 Passed + โ—‰ sha1.tests.ex1 Passed + โ—‰ sha1.tests.ex2 Passed + โ—‰ sha1.tests.ex3 Passed + โ—‰ sha1.tests.ex4 Passed โ—‰ sha2_256.tests.ex1 Passed โ—‰ sha2_256.tests.ex2 Passed โ—‰ sha2_256.tests.ex3 Passed @@ -395,7 +424,7 @@ test> hmac_sha2_512.tests.ex2 = โ—‰ sha3_512.tests.ex3 Passed โ—‰ sha3_512.tests.ex4 Passed - โœ… 24 test(s) passing + โœ… 28 test(s) passing Tip: Use view blake2b_512.tests.ex1 to view the source of a test. From c5f429fc3f1b68a53defb3f6175fa14a42dcf72d Mon Sep 17 00:00:00 2001 From: Dan Freeman Date: Sat, 11 Jun 2022 20:18:03 +0200 Subject: [PATCH 359/529] Refresh transcripts --- unison-src/transcripts/alias-many.output.md | 711 +++++++++--------- .../transcripts/builtins-merge.output.md | 2 +- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- .../transcripts/name-selection.output.md | 541 ++++++------- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 7 files changed, 651 insertions(+), 649 deletions(-) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 2dad53a332..250f3d252b 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -76,415 +76,416 @@ Let's try it! 56. crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm 57. crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm 58. crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm - 59. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm - 60. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm - 61. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm - 62. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm - 63. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 64. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 65. crypto.hmacBytes : HashAlgorithm + 59. crypto.HashAlgorithm.Sha1 : HashAlgorithm + 60. crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 61. crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 62. crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 63. crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 64. crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes + 65. crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes + 66. crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 66. Debug.trace : Text -> a -> () - 67. Debug.watch : Text -> a -> a - 68. unique type Doc - 69. Doc.Blob : Text -> Doc - 70. Doc.Evaluate : Term -> Doc - 71. Doc.Join : [Doc] -> Doc - 72. Doc.Link : Link -> Doc - 73. Doc.Signature : Term -> Doc - 74. Doc.Source : Link -> Doc - 75. structural type Either a b - 76. Either.Left : a -> Either a b - 77. Either.Right : b -> Either a b - 78. structural ability Exception - 79. Exception.raise : Failure ->{Exception} x - 80. builtin type Float - 81. Float.* : Float -> Float -> Float - 82. Float.+ : Float -> Float -> Float - 83. Float.- : Float -> Float -> Float - 84. Float./ : Float -> Float -> Float - 85. Float.abs : Float -> Float - 86. Float.acos : Float -> Float - 87. Float.acosh : Float -> Float - 88. Float.asin : Float -> Float - 89. Float.asinh : Float -> Float - 90. Float.atan : Float -> Float - 91. Float.atan2 : Float -> Float -> Float - 92. Float.atanh : Float -> Float - 93. Float.ceiling : Float -> Int - 94. Float.cos : Float -> Float - 95. Float.cosh : Float -> Float - 96. Float.eq : Float -> Float -> Boolean - 97. Float.exp : Float -> Float - 98. Float.floor : Float -> Int - 99. Float.fromRepresentation : Nat -> Float - 100. Float.fromText : Text -> Optional Float - 101. Float.gt : Float -> Float -> Boolean - 102. Float.gteq : Float -> Float -> Boolean - 103. Float.log : Float -> Float - 104. Float.logBase : Float -> Float -> Float - 105. Float.lt : Float -> Float -> Boolean - 106. Float.lteq : Float -> Float -> Boolean - 107. Float.max : Float -> Float -> Float - 108. Float.min : Float -> Float -> Float - 109. Float.pow : Float -> Float -> Float - 110. Float.round : Float -> Int - 111. Float.sin : Float -> Float - 112. Float.sinh : Float -> Float - 113. Float.sqrt : Float -> Float - 114. Float.tan : Float -> Float - 115. Float.tanh : Float -> Float - 116. Float.toRepresentation : Float -> Nat - 117. Float.toText : Float -> Text - 118. Float.truncate : Float -> Int - 119. Handle.toText : Handle -> Text - 120. builtin type Int - 121. Int.* : Int -> Int -> Int - 122. Int.+ : Int -> Int -> Int - 123. Int.- : Int -> Int -> Int - 124. Int./ : Int -> Int -> Int - 125. Int.and : Int -> Int -> Int - 126. Int.complement : Int -> Int - 127. Int.eq : Int -> Int -> Boolean - 128. Int.fromRepresentation : Nat -> Int - 129. Int.fromText : Text -> Optional Int - 130. Int.gt : Int -> Int -> Boolean - 131. Int.gteq : Int -> Int -> Boolean - 132. Int.increment : Int -> Int - 133. Int.isEven : Int -> Boolean - 134. Int.isOdd : Int -> Boolean - 135. Int.leadingZeros : Int -> Nat - 136. Int.lt : Int -> Int -> Boolean - 137. Int.lteq : Int -> Int -> Boolean - 138. Int.mod : Int -> Int -> Int - 139. Int.negate : Int -> Int - 140. Int.or : Int -> Int -> Int - 141. Int.popCount : Int -> Nat - 142. Int.pow : Int -> Nat -> Int - 143. Int.shiftLeft : Int -> Nat -> Int - 144. Int.shiftRight : Int -> Nat -> Int - 145. Int.signum : Int -> Int - 146. Int.toFloat : Int -> Float - 147. Int.toRepresentation : Int -> Nat - 148. Int.toText : Int -> Text - 149. Int.trailingZeros : Int -> Nat - 150. Int.truncate0 : Int -> Nat - 151. Int.xor : Int -> Int -> Int - 152. unique type io2.BufferMode - 153. io2.BufferMode.BlockBuffering : BufferMode - 154. io2.BufferMode.LineBuffering : BufferMode - 155. io2.BufferMode.NoBuffering : BufferMode - 156. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 157. io2.Clock.internals.monotonic : '{IO} Either + 67. Debug.trace : Text -> a -> () + 68. Debug.watch : Text -> a -> a + 69. unique type Doc + 70. Doc.Blob : Text -> Doc + 71. Doc.Evaluate : Term -> Doc + 72. Doc.Join : [Doc] -> Doc + 73. Doc.Link : Link -> Doc + 74. Doc.Signature : Term -> Doc + 75. Doc.Source : Link -> Doc + 76. structural type Either a b + 77. Either.Left : a -> Either a b + 78. Either.Right : b -> Either a b + 79. structural ability Exception + 80. Exception.raise : Failure ->{Exception} x + 81. builtin type Float + 82. Float.* : Float -> Float -> Float + 83. Float.+ : Float -> Float -> Float + 84. Float.- : Float -> Float -> Float + 85. Float./ : Float -> Float -> Float + 86. Float.abs : Float -> Float + 87. Float.acos : Float -> Float + 88. Float.acosh : Float -> Float + 89. Float.asin : Float -> Float + 90. Float.asinh : Float -> Float + 91. Float.atan : Float -> Float + 92. Float.atan2 : Float -> Float -> Float + 93. Float.atanh : Float -> Float + 94. Float.ceiling : Float -> Int + 95. Float.cos : Float -> Float + 96. Float.cosh : Float -> Float + 97. Float.eq : Float -> Float -> Boolean + 98. Float.exp : Float -> Float + 99. Float.floor : Float -> Int + 100. Float.fromRepresentation : Nat -> Float + 101. Float.fromText : Text -> Optional Float + 102. Float.gt : Float -> Float -> Boolean + 103. Float.gteq : Float -> Float -> Boolean + 104. Float.log : Float -> Float + 105. Float.logBase : Float -> Float -> Float + 106. Float.lt : Float -> Float -> Boolean + 107. Float.lteq : Float -> Float -> Boolean + 108. Float.max : Float -> Float -> Float + 109. Float.min : Float -> Float -> Float + 110. Float.pow : Float -> Float -> Float + 111. Float.round : Float -> Int + 112. Float.sin : Float -> Float + 113. Float.sinh : Float -> Float + 114. Float.sqrt : Float -> Float + 115. Float.tan : Float -> Float + 116. Float.tanh : Float -> Float + 117. Float.toRepresentation : Float -> Nat + 118. Float.toText : Float -> Text + 119. Float.truncate : Float -> Int + 120. Handle.toText : Handle -> Text + 121. builtin type Int + 122. Int.* : Int -> Int -> Int + 123. Int.+ : Int -> Int -> Int + 124. Int.- : Int -> Int -> Int + 125. Int./ : Int -> Int -> Int + 126. Int.and : Int -> Int -> Int + 127. Int.complement : Int -> Int + 128. Int.eq : Int -> Int -> Boolean + 129. Int.fromRepresentation : Nat -> Int + 130. Int.fromText : Text -> Optional Int + 131. Int.gt : Int -> Int -> Boolean + 132. Int.gteq : Int -> Int -> Boolean + 133. Int.increment : Int -> Int + 134. Int.isEven : Int -> Boolean + 135. Int.isOdd : Int -> Boolean + 136. Int.leadingZeros : Int -> Nat + 137. Int.lt : Int -> Int -> Boolean + 138. Int.lteq : Int -> Int -> Boolean + 139. Int.mod : Int -> Int -> Int + 140. Int.negate : Int -> Int + 141. Int.or : Int -> Int -> Int + 142. Int.popCount : Int -> Nat + 143. Int.pow : Int -> Nat -> Int + 144. Int.shiftLeft : Int -> Nat -> Int + 145. Int.shiftRight : Int -> Nat -> Int + 146. Int.signum : Int -> Int + 147. Int.toFloat : Int -> Float + 148. Int.toRepresentation : Int -> Nat + 149. Int.toText : Int -> Text + 150. Int.trailingZeros : Int -> Nat + 151. Int.truncate0 : Int -> Nat + 152. Int.xor : Int -> Int -> Int + 153. unique type io2.BufferMode + 154. io2.BufferMode.BlockBuffering : BufferMode + 155. io2.BufferMode.LineBuffering : BufferMode + 156. io2.BufferMode.NoBuffering : BufferMode + 157. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 158. io2.Clock.internals.monotonic : '{IO} Either Failure TimeSpec - 158. io2.Clock.internals.nsec : TimeSpec -> Nat - 159. io2.Clock.internals.processCPUTime : '{IO} Either + 159. io2.Clock.internals.nsec : TimeSpec -> Nat + 160. io2.Clock.internals.processCPUTime : '{IO} Either Failure TimeSpec - 160. io2.Clock.internals.realtime : '{IO} Either + 161. io2.Clock.internals.realtime : '{IO} Either Failure TimeSpec - 161. io2.Clock.internals.sec : TimeSpec -> Int - 162. io2.Clock.internals.threadCPUTime : '{IO} Either + 162. io2.Clock.internals.sec : TimeSpec -> Int + 163. io2.Clock.internals.threadCPUTime : '{IO} Either Failure TimeSpec - 163. builtin type io2.Clock.internals.TimeSpec - 164. unique type io2.Failure - 165. io2.Failure.Failure : Type -> Text -> Any -> Failure - 166. unique type io2.FileMode - 167. io2.FileMode.Append : FileMode - 168. io2.FileMode.Read : FileMode - 169. io2.FileMode.ReadWrite : FileMode - 170. io2.FileMode.Write : FileMode - 171. builtin type io2.Handle - 172. builtin type io2.IO - 173. io2.IO.clientSocket.impl : Text + 164. builtin type io2.Clock.internals.TimeSpec + 165. unique type io2.Failure + 166. io2.Failure.Failure : Type -> Text -> Any -> Failure + 167. unique type io2.FileMode + 168. io2.FileMode.Append : FileMode + 169. io2.FileMode.Read : FileMode + 170. io2.FileMode.ReadWrite : FileMode + 171. io2.FileMode.Write : FileMode + 172. builtin type io2.Handle + 173. builtin type io2.IO + 174. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 174. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 175. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 176. io2.IO.createDirectory.impl : Text + 175. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 176. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 177. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 177. io2.IO.createTempDirectory.impl : Text + 178. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 178. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 179. io2.IO.directoryContents.impl : Text + 179. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 180. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 180. io2.IO.fileExists.impl : Text + 181. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 181. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 182. io2.IO.getArgs.impl : '{IO} Either Failure [Text] - 183. io2.IO.getBuffering.impl : Handle + 182. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 183. io2.IO.getArgs.impl : '{IO} Either Failure [Text] + 184. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 184. io2.IO.getBytes.impl : Handle + 185. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 185. io2.IO.getCurrentDirectory.impl : '{IO} Either + 186. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 186. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 187. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 188. io2.IO.getFileTimestamp.impl : Text + 187. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 188. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 189. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 189. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 190. io2.IO.getSomeBytes.impl : Handle + 190. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 191. io2.IO.getSomeBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 191. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 192. io2.IO.handlePosition.impl : Handle + 192. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 193. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 193. io2.IO.isDirectory.impl : Text + 194. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 194. io2.IO.isFileEOF.impl : Handle + 195. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 195. io2.IO.isFileOpen.impl : Handle + 196. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 196. io2.IO.isSeekable.impl : Handle + 197. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 197. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 198. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 199. io2.IO.openFile.impl : Text + 198. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 199. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 200. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 200. io2.IO.putBytes.impl : Handle + 201. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 201. io2.IO.ref : a ->{IO} Ref {IO} a - 202. io2.IO.removeDirectory.impl : Text + 202. io2.IO.ref : a ->{IO} Ref {IO} a + 203. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 203. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 204. io2.IO.renameDirectory.impl : Text + 204. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 205. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 205. io2.IO.renameFile.impl : Text + 206. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 206. io2.IO.seekHandle.impl : Handle + 207. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 207. io2.IO.serverSocket.impl : Optional Text + 208. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 208. io2.IO.setBuffering.impl : Handle + 209. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 209. io2.IO.setCurrentDirectory.impl : Text + 210. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 210. io2.IO.socketAccept.impl : Socket + 211. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 211. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 212. io2.IO.socketReceive.impl : Socket + 212. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 213. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 213. io2.IO.socketSend.impl : Socket + 214. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 214. io2.IO.stdHandle : StdHandle -> Handle - 215. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 216. io2.IO.systemTimeMicroseconds : '{IO} Int - 217. unique type io2.IOError - 218. io2.IOError.AlreadyExists : IOError - 219. io2.IOError.EOF : IOError - 220. io2.IOError.IllegalOperation : IOError - 221. io2.IOError.NoSuchThing : IOError - 222. io2.IOError.PermissionDenied : IOError - 223. io2.IOError.ResourceBusy : IOError - 224. io2.IOError.ResourceExhausted : IOError - 225. io2.IOError.UserError : IOError - 226. unique type io2.IOFailure - 227. builtin type io2.MVar - 228. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 229. io2.MVar.new : a ->{IO} MVar a - 230. io2.MVar.newEmpty : '{IO} MVar a - 231. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 232. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 233. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 234. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 235. io2.MVar.tryPut.impl : MVar a + 215. io2.IO.stdHandle : StdHandle -> Handle + 216. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 217. io2.IO.systemTimeMicroseconds : '{IO} Int + 218. unique type io2.IOError + 219. io2.IOError.AlreadyExists : IOError + 220. io2.IOError.EOF : IOError + 221. io2.IOError.IllegalOperation : IOError + 222. io2.IOError.NoSuchThing : IOError + 223. io2.IOError.PermissionDenied : IOError + 224. io2.IOError.ResourceBusy : IOError + 225. io2.IOError.ResourceExhausted : IOError + 226. io2.IOError.UserError : IOError + 227. unique type io2.IOFailure + 228. builtin type io2.MVar + 229. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 230. io2.MVar.new : a ->{IO} MVar a + 231. io2.MVar.newEmpty : '{IO} MVar a + 232. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 233. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 234. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 235. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 236. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 236. io2.MVar.tryRead.impl : MVar a + 237. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 237. io2.MVar.tryTake : MVar a ->{IO} Optional a - 238. unique type io2.SeekMode - 239. io2.SeekMode.AbsoluteSeek : SeekMode - 240. io2.SeekMode.RelativeSeek : SeekMode - 241. io2.SeekMode.SeekFromEnd : SeekMode - 242. builtin type io2.Socket - 243. unique type io2.StdHandle - 244. io2.StdHandle.StdErr : StdHandle - 245. io2.StdHandle.StdIn : StdHandle - 246. io2.StdHandle.StdOut : StdHandle - 247. builtin type io2.STM - 248. io2.STM.atomically : '{STM} a ->{IO} a - 249. io2.STM.retry : '{STM} a - 250. builtin type io2.ThreadId - 251. builtin type io2.Tls - 252. builtin type io2.Tls.Cipher - 253. builtin type io2.Tls.ClientConfig - 254. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 238. io2.MVar.tryTake : MVar a ->{IO} Optional a + 239. unique type io2.SeekMode + 240. io2.SeekMode.AbsoluteSeek : SeekMode + 241. io2.SeekMode.RelativeSeek : SeekMode + 242. io2.SeekMode.SeekFromEnd : SeekMode + 243. builtin type io2.Socket + 244. unique type io2.StdHandle + 245. io2.StdHandle.StdErr : StdHandle + 246. io2.StdHandle.StdIn : StdHandle + 247. io2.StdHandle.StdOut : StdHandle + 248. builtin type io2.STM + 249. io2.STM.atomically : '{STM} a ->{IO} a + 250. io2.STM.retry : '{STM} a + 251. builtin type io2.ThreadId + 252. builtin type io2.Tls + 253. builtin type io2.Tls.Cipher + 254. builtin type io2.Tls.ClientConfig + 255. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 255. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 256. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 256. io2.Tls.ClientConfig.default : Text + 257. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 257. io2.Tls.ClientConfig.versions.set : [Version] + 258. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 258. io2.Tls.decodeCert.impl : Bytes + 259. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 259. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 260. io2.Tls.encodeCert : SignedCert -> Bytes - 261. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 262. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 263. io2.Tls.newClient.impl : ClientConfig + 260. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 261. io2.Tls.encodeCert : SignedCert -> Bytes + 262. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 263. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 264. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 264. io2.Tls.newServer.impl : ServerConfig + 265. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 265. builtin type io2.Tls.PrivateKey - 266. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 267. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 268. builtin type io2.Tls.ServerConfig - 269. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 266. builtin type io2.Tls.PrivateKey + 267. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 268. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 269. builtin type io2.Tls.ServerConfig + 270. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 270. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 271. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 271. io2.Tls.ServerConfig.default : [SignedCert] + 272. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 272. io2.Tls.ServerConfig.versions.set : [Version] + 273. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 273. builtin type io2.Tls.SignedCert - 274. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 275. builtin type io2.Tls.Version - 276. unique type io2.TlsFailure - 277. builtin type io2.TVar - 278. io2.TVar.new : a ->{STM} TVar a - 279. io2.TVar.newIO : a ->{IO} TVar a - 280. io2.TVar.read : TVar a ->{STM} a - 281. io2.TVar.readIO : TVar a ->{IO} a - 282. io2.TVar.swap : TVar a -> a ->{STM} a - 283. io2.TVar.write : TVar a -> a ->{STM} () - 284. io2.validateSandboxed : [Term] -> a -> Boolean - 285. unique type IsPropagated - 286. IsPropagated.IsPropagated : IsPropagated - 287. unique type IsTest - 288. IsTest.IsTest : IsTest - 289. unique type Link - 290. builtin type Link.Term - 291. Link.Term : Term -> Link - 292. Link.Term.toText : Term -> Text - 293. builtin type Link.Type - 294. Link.Type : Type -> Link - 295. builtin type List - 296. List.++ : [a] -> [a] -> [a] - 297. List.+: : a -> [a] -> [a] - 298. List.:+ : [a] -> a -> [a] - 299. List.at : Nat -> [a] -> Optional a - 300. List.cons : a -> [a] -> [a] - 301. List.drop : Nat -> [a] -> [a] - 302. List.empty : [a] - 303. List.size : [a] -> Nat - 304. List.snoc : [a] -> a -> [a] - 305. List.take : Nat -> [a] -> [a] - 306. metadata.isPropagated : IsPropagated - 307. metadata.isTest : IsTest - 308. builtin type Nat - 309. Nat.* : Nat -> Nat -> Nat - 310. Nat.+ : Nat -> Nat -> Nat - 311. Nat./ : Nat -> Nat -> Nat - 312. Nat.and : Nat -> Nat -> Nat - 313. Nat.complement : Nat -> Nat - 314. Nat.drop : Nat -> Nat -> Nat - 315. Nat.eq : Nat -> Nat -> Boolean - 316. Nat.fromText : Text -> Optional Nat - 317. Nat.gt : Nat -> Nat -> Boolean - 318. Nat.gteq : Nat -> Nat -> Boolean - 319. Nat.increment : Nat -> Nat - 320. Nat.isEven : Nat -> Boolean - 321. Nat.isOdd : Nat -> Boolean - 322. Nat.leadingZeros : Nat -> Nat - 323. Nat.lt : Nat -> Nat -> Boolean - 324. Nat.lteq : Nat -> Nat -> Boolean - 325. Nat.mod : Nat -> Nat -> Nat - 326. Nat.or : Nat -> Nat -> Nat - 327. Nat.popCount : Nat -> Nat - 328. Nat.pow : Nat -> Nat -> Nat - 329. Nat.shiftLeft : Nat -> Nat -> Nat - 330. Nat.shiftRight : Nat -> Nat -> Nat - 331. Nat.sub : Nat -> Nat -> Int - 332. Nat.toFloat : Nat -> Float - 333. Nat.toInt : Nat -> Int - 334. Nat.toText : Nat -> Text - 335. Nat.trailingZeros : Nat -> Nat - 336. Nat.xor : Nat -> Nat -> Nat - 337. structural type Optional a - 338. Optional.None : Optional a - 339. Optional.Some : a -> Optional a - 340. builtin type Ref - 341. Ref.read : Ref g a ->{g} a - 342. Ref.write : Ref g a -> a ->{g} () - 343. builtin type Request - 344. builtin type Scope - 345. Scope.ref : a ->{Scope s} Ref {Scope s} a - 346. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 347. structural type SeqView a b - 348. SeqView.VElem : a -> b -> SeqView a b - 349. SeqView.VEmpty : SeqView a b - 350. Socket.toText : Socket -> Text - 351. unique type Test.Result - 352. Test.Result.Fail : Text -> Result - 353. Test.Result.Ok : Text -> Result - 354. builtin type Text - 355. Text.!= : Text -> Text -> Boolean - 356. Text.++ : Text -> Text -> Text - 357. Text.drop : Nat -> Text -> Text - 358. Text.empty : Text - 359. Text.eq : Text -> Text -> Boolean - 360. Text.fromCharList : [Char] -> Text - 361. Text.fromUtf8.impl : Bytes -> Either Failure Text - 362. Text.gt : Text -> Text -> Boolean - 363. Text.gteq : Text -> Text -> Boolean - 364. Text.lt : Text -> Text -> Boolean - 365. Text.lteq : Text -> Text -> Boolean - 366. Text.repeat : Nat -> Text -> Text - 367. Text.size : Text -> Nat - 368. Text.take : Nat -> Text -> Text - 369. Text.toCharList : Text -> [Char] - 370. Text.toUtf8 : Text -> Bytes - 371. Text.uncons : Text -> Optional (Char, Text) - 372. Text.unsnoc : Text -> Optional (Text, Char) - 373. ThreadId.toText : ThreadId -> Text - 374. todo : a -> b - 375. structural type Tuple a b - 376. Tuple.Cons : a -> b -> Tuple a b - 377. structural type Unit - 378. Unit.Unit : () - 379. Universal.< : a -> a -> Boolean - 380. Universal.<= : a -> a -> Boolean - 381. Universal.== : a -> a -> Boolean - 382. Universal.> : a -> a -> Boolean - 383. Universal.>= : a -> a -> Boolean - 384. Universal.compare : a -> a -> Int - 385. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 386. builtin type Value - 387. Value.dependencies : Value -> [Term] - 388. Value.deserialize : Bytes -> Either Text Value - 389. Value.load : Value ->{IO} Either [Term] a - 390. Value.serialize : Value -> Bytes - 391. Value.value : a -> Value + 274. builtin type io2.Tls.SignedCert + 275. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 276. builtin type io2.Tls.Version + 277. unique type io2.TlsFailure + 278. builtin type io2.TVar + 279. io2.TVar.new : a ->{STM} TVar a + 280. io2.TVar.newIO : a ->{IO} TVar a + 281. io2.TVar.read : TVar a ->{STM} a + 282. io2.TVar.readIO : TVar a ->{IO} a + 283. io2.TVar.swap : TVar a -> a ->{STM} a + 284. io2.TVar.write : TVar a -> a ->{STM} () + 285. io2.validateSandboxed : [Term] -> a -> Boolean + 286. unique type IsPropagated + 287. IsPropagated.IsPropagated : IsPropagated + 288. unique type IsTest + 289. IsTest.IsTest : IsTest + 290. unique type Link + 291. builtin type Link.Term + 292. Link.Term : Term -> Link + 293. Link.Term.toText : Term -> Text + 294. builtin type Link.Type + 295. Link.Type : Type -> Link + 296. builtin type List + 297. List.++ : [a] -> [a] -> [a] + 298. List.+: : a -> [a] -> [a] + 299. List.:+ : [a] -> a -> [a] + 300. List.at : Nat -> [a] -> Optional a + 301. List.cons : a -> [a] -> [a] + 302. List.drop : Nat -> [a] -> [a] + 303. List.empty : [a] + 304. List.size : [a] -> Nat + 305. List.snoc : [a] -> a -> [a] + 306. List.take : Nat -> [a] -> [a] + 307. metadata.isPropagated : IsPropagated + 308. metadata.isTest : IsTest + 309. builtin type Nat + 310. Nat.* : Nat -> Nat -> Nat + 311. Nat.+ : Nat -> Nat -> Nat + 312. Nat./ : Nat -> Nat -> Nat + 313. Nat.and : Nat -> Nat -> Nat + 314. Nat.complement : Nat -> Nat + 315. Nat.drop : Nat -> Nat -> Nat + 316. Nat.eq : Nat -> Nat -> Boolean + 317. Nat.fromText : Text -> Optional Nat + 318. Nat.gt : Nat -> Nat -> Boolean + 319. Nat.gteq : Nat -> Nat -> Boolean + 320. Nat.increment : Nat -> Nat + 321. Nat.isEven : Nat -> Boolean + 322. Nat.isOdd : Nat -> Boolean + 323. Nat.leadingZeros : Nat -> Nat + 324. Nat.lt : Nat -> Nat -> Boolean + 325. Nat.lteq : Nat -> Nat -> Boolean + 326. Nat.mod : Nat -> Nat -> Nat + 327. Nat.or : Nat -> Nat -> Nat + 328. Nat.popCount : Nat -> Nat + 329. Nat.pow : Nat -> Nat -> Nat + 330. Nat.shiftLeft : Nat -> Nat -> Nat + 331. Nat.shiftRight : Nat -> Nat -> Nat + 332. Nat.sub : Nat -> Nat -> Int + 333. Nat.toFloat : Nat -> Float + 334. Nat.toInt : Nat -> Int + 335. Nat.toText : Nat -> Text + 336. Nat.trailingZeros : Nat -> Nat + 337. Nat.xor : Nat -> Nat -> Nat + 338. structural type Optional a + 339. Optional.None : Optional a + 340. Optional.Some : a -> Optional a + 341. builtin type Ref + 342. Ref.read : Ref g a ->{g} a + 343. Ref.write : Ref g a -> a ->{g} () + 344. builtin type Request + 345. builtin type Scope + 346. Scope.ref : a ->{Scope s} Ref {Scope s} a + 347. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r + 348. structural type SeqView a b + 349. SeqView.VElem : a -> b -> SeqView a b + 350. SeqView.VEmpty : SeqView a b + 351. Socket.toText : Socket -> Text + 352. unique type Test.Result + 353. Test.Result.Fail : Text -> Result + 354. Test.Result.Ok : Text -> Result + 355. builtin type Text + 356. Text.!= : Text -> Text -> Boolean + 357. Text.++ : Text -> Text -> Text + 358. Text.drop : Nat -> Text -> Text + 359. Text.empty : Text + 360. Text.eq : Text -> Text -> Boolean + 361. Text.fromCharList : [Char] -> Text + 362. Text.fromUtf8.impl : Bytes -> Either Failure Text + 363. Text.gt : Text -> Text -> Boolean + 364. Text.gteq : Text -> Text -> Boolean + 365. Text.lt : Text -> Text -> Boolean + 366. Text.lteq : Text -> Text -> Boolean + 367. Text.repeat : Nat -> Text -> Text + 368. Text.size : Text -> Nat + 369. Text.take : Nat -> Text -> Text + 370. Text.toCharList : Text -> [Char] + 371. Text.toUtf8 : Text -> Bytes + 372. Text.uncons : Text -> Optional (Char, Text) + 373. Text.unsnoc : Text -> Optional (Text, Char) + 374. ThreadId.toText : ThreadId -> Text + 375. todo : a -> b + 376. structural type Tuple a b + 377. Tuple.Cons : a -> b -> Tuple a b + 378. structural type Unit + 379. Unit.Unit : () + 380. Universal.< : a -> a -> Boolean + 381. Universal.<= : a -> a -> Boolean + 382. Universal.== : a -> a -> Boolean + 383. Universal.> : a -> a -> Boolean + 384. Universal.>= : a -> a -> Boolean + 385. Universal.compare : a -> a -> Int + 386. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 387. builtin type Value + 388. Value.dependencies : Value -> [Term] + 389. Value.deserialize : Bytes -> Either Text Value + 390. Value.load : Value ->{IO} Either [Term] a + 391. Value.serialize : Value -> Bytes + 392. Value.value : a -> Value .builtin> alias.many 94-104 .mylib @@ -493,17 +494,17 @@ Let's try it! Added definitions: - 1. Float.cos : Float -> Float - 2. Float.cosh : Float -> Float - 3. Float.eq : Float -> Float -> Boolean - 4. Float.exp : Float -> Float - 5. Float.floor : Float -> Int - 6. Float.fromRepresentation : Nat -> Float - 7. Float.fromText : Text -> Optional Float - 8. Float.gt : Float -> Float -> Boolean - 9. Float.gteq : Float -> Float -> Boolean - 10. Float.log : Float -> Float - 11. Float.logBase : Float -> Float -> Float + 1. Float.ceiling : Float -> Int + 2. Float.cos : Float -> Float + 3. Float.cosh : Float -> Float + 4. Float.eq : Float -> Float -> Boolean + 5. Float.exp : Float -> Float + 6. Float.floor : Float -> Int + 7. Float.fromRepresentation : Nat -> Float + 8. Float.fromText : Text -> Optional Float + 9. Float.gt : Float -> Float -> Boolean + 10. Float.gteq : Float -> Float -> Boolean + 11. Float.log : Float -> Float Tip: You can use `undo` or `reflog` to undo this change. @@ -563,17 +564,17 @@ I want to incorporate a few more from another namespace: .mylib> find - 1. Float.cos : Float -> Float - 2. Float.cosh : Float -> Float - 3. Float.eq : Float -> Float -> Boolean - 4. Float.exp : Float -> Float - 5. Float.floor : Float -> Int - 6. Float.fromRepresentation : Nat -> Float - 7. Float.fromText : Text -> Optional Float - 8. Float.gt : Float -> Float -> Boolean - 9. Float.gteq : Float -> Float -> Boolean - 10. Float.log : Float -> Float - 11. Float.logBase : Float -> Float -> Float + 1. Float.ceiling : Float -> Int + 2. Float.cos : Float -> Float + 3. Float.cosh : Float -> Float + 4. Float.eq : Float -> Float -> Boolean + 5. Float.exp : Float -> Float + 6. Float.floor : Float -> Int + 7. Float.fromRepresentation : Nat -> Float + 8. Float.fromText : Text -> Optional Float + 9. Float.gt : Float -> Float -> Boolean + 10. Float.gteq : Float -> Float -> Boolean + 11. Float.log : Float -> Float 12. List.adjacentPairs : [a] -> [(a, a)] 13. List.all : (a ->{g} Boolean) -> [a] ->{g} Boolean 14. List.any : (a ->{g} Boolean) -> [a] ->{g} Boolean diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index 719d7a5f5a..54dea4ea51 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -63,7 +63,7 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 52. Value (builtin type) 53. Value/ (5 definitions) 54. bug (a -> b) - 55. crypto/ (12 definitions) + 55. crypto/ (13 definitions) 56. io2/ (133 definitions) 57. metadata/ (2 definitions) 58. todo (a -> b) diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index b11235a4eb..83d6a54746 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (391 definitions) + 1. builtin/ (392 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (577 definitions) + 1. builtin/ (578 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 09685e42b8..46b4ac2880 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -121,13 +121,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #1q6g6u3m73 + โŠ™ 1. #0mhdtddb80 - Deletes: feature1.y - โŠ™ 2. #9e4kqo72l2 + โŠ™ 2. #leu63g3bpn + Adds / updates: @@ -138,26 +138,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - โŠ™ 3. #n59irrs1fe + โŠ™ 3. #qsefehkn4s + Adds / updates: feature1.y - โŠ™ 4. #7qstntsn5f + โŠ™ 4. #5vssi6fg86 > Moves: Original name New name x master.x - โŠ™ 5. #4360t4806a + โŠ™ 5. #g3lmsiv8ui + Adds / updates: x - โ–ก 6. #n38tt1aodo (start of history) + โ–ก 6. #jnr0fqsfop (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md index d8cb9c264e..3a2b3c9315 100644 --- a/unison-src/transcripts/name-selection.output.md +++ b/unison-src/transcripts/name-selection.output.md @@ -293,786 +293,787 @@ d = c + 10 127. builtin.crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm 128. builtin.crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm 129. builtin.crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm - 130. builtin.crypto.HashAlgorithm.Sha2_256 : HashAlgorithm - 131. builtin.crypto.HashAlgorithm.Sha2_512 : HashAlgorithm - 132. builtin.crypto.HashAlgorithm.Sha3_256 : HashAlgorithm - 133. builtin.crypto.HashAlgorithm.Sha3_512 : HashAlgorithm - 134. builtin.Float.abs : Float + 130. builtin.crypto.HashAlgorithm.Sha1 : HashAlgorithm + 131. builtin.crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 132. builtin.crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 133. builtin.crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 134. builtin.crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 135. builtin.Float.abs : Float -> Float - 135. builtin.Float.acos : Float + 136. builtin.Float.acos : Float -> Float - 136. builtin.Float.acosh : Float + 137. builtin.Float.acosh : Float -> Float - 137. builtin.Int.and : Int + 138. builtin.Int.and : Int -> Int -> Int - 138. builtin.Nat.and : Nat + 139. builtin.Nat.and : Nat -> Nat -> Nat - 139. builtin.Float.asin : Float + 140. builtin.Float.asin : Float -> Float - 140. builtin.Float.asinh : Float + 141. builtin.Float.asinh : Float -> Float - 141. builtin.Bytes.at : Nat + 142. builtin.Bytes.at : Nat -> Bytes -> Optional Nat - 142. builtin.List.at : Nat + 143. builtin.List.at : Nat -> [a] -> Optional a - 143. builtin.Float.atan : Float + 144. builtin.Float.atan : Float -> Float - 144. builtin.Float.atan2 : Float + 145. builtin.Float.atan2 : Float -> Float -> Float - 145. builtin.Float.atanh : Float + 146. builtin.Float.atanh : Float -> Float - 146. builtin.io2.STM.atomically : '{STM} a + 147. builtin.io2.STM.atomically : '{STM} a ->{IO} a - 147. builtin.bug : a -> b - 148. โ”Œ c#gjmq673r1v : Nat - 149. โ”” aaaa.tooManySegments : Nat - 150. builtin.Code.cache_ : [( Term, + 148. builtin.bug : a -> b + 149. โ”Œ c#gjmq673r1v : Nat + 150. โ”” aaaa.tooManySegments : Nat + 151. builtin.Code.cache_ : [( Term, Code)] ->{IO} [Term] - 151. builtin.Float.ceiling : Float + 152. builtin.Float.ceiling : Float -> Int - 152. builtin.unsafe.coerceAbilities : (a + 153. builtin.unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 153. builtin.Universal.compare : a + 154. builtin.Universal.compare : a -> a -> Int - 154. builtin.Int.complement : Int + 155. builtin.Int.complement : Int -> Int - 155. builtin.Nat.complement : Nat + 156. builtin.Nat.complement : Nat -> Nat - 156. builtin.Bytes.gzip.compress : Bytes + 157. builtin.Bytes.gzip.compress : Bytes -> Bytes - 157. builtin.Bytes.zlib.compress : Bytes + 158. builtin.Bytes.zlib.compress : Bytes -> Bytes - 158. builtin.Float.cos : Float + 159. builtin.Float.cos : Float -> Float - 159. builtin.Float.cosh : Float + 160. builtin.Float.cosh : Float -> Float - 160. builtin.Bytes.decodeNat16be : Bytes + 161. builtin.Bytes.decodeNat16be : Bytes -> Optional ( Nat, Bytes) - 161. builtin.Bytes.decodeNat16le : Bytes + 162. builtin.Bytes.decodeNat16le : Bytes -> Optional ( Nat, Bytes) - 162. builtin.Bytes.decodeNat32be : Bytes + 163. builtin.Bytes.decodeNat32be : Bytes -> Optional ( Nat, Bytes) - 163. builtin.Bytes.decodeNat32le : Bytes + 164. builtin.Bytes.decodeNat32le : Bytes -> Optional ( Nat, Bytes) - 164. builtin.Bytes.decodeNat64be : Bytes + 165. builtin.Bytes.decodeNat64be : Bytes -> Optional ( Nat, Bytes) - 165. builtin.Bytes.decodeNat64le : Bytes + 166. builtin.Bytes.decodeNat64le : Bytes -> Optional ( Nat, Bytes) - 166. builtin.io2.Tls.decodePrivateKey : Bytes + 167. builtin.io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 167. builtin.Bytes.gzip.decompress : Bytes + 168. builtin.Bytes.gzip.decompress : Bytes -> Either Text Bytes - 168. builtin.Bytes.zlib.decompress : Bytes + 169. builtin.Bytes.zlib.decompress : Bytes -> Either Text Bytes - 169. builtin.io2.Tls.ClientConfig.default : Text + 170. builtin.io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 170. builtin.io2.Tls.ServerConfig.default : [SignedCert] + 171. builtin.io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 171. builtin.Code.dependencies : Code + 172. builtin.Code.dependencies : Code -> [Term] - 172. builtin.Value.dependencies : Value + 173. builtin.Value.dependencies : Value -> [Term] - 173. builtin.Code.deserialize : Bytes + 174. builtin.Code.deserialize : Bytes -> Either Text Code - 174. builtin.Value.deserialize : Bytes + 175. builtin.Value.deserialize : Bytes -> Either Text Value - 175. builtin.Code.display : Text + 176. builtin.Code.display : Text -> Code -> Text - 176. builtin.Bytes.drop : Nat + 177. builtin.Bytes.drop : Nat -> Bytes -> Bytes - 177. builtin.List.drop : Nat + 178. builtin.List.drop : Nat -> [a] -> [a] - 178. builtin.Nat.drop : Nat + 179. builtin.Nat.drop : Nat -> Nat -> Nat - 179. builtin.Text.drop : Nat + 180. builtin.Text.drop : Nat -> Text -> Text - 180. builtin.Bytes.empty : Bytes - 181. builtin.List.empty : [a] - 182. builtin.Text.empty : Text - 183. builtin.io2.Tls.encodeCert : SignedCert + 181. builtin.Bytes.empty : Bytes + 182. builtin.List.empty : [a] + 183. builtin.Text.empty : Text + 184. builtin.io2.Tls.encodeCert : SignedCert -> Bytes - 184. builtin.Bytes.encodeNat16be : Nat + 185. builtin.Bytes.encodeNat16be : Nat -> Bytes - 185. builtin.Bytes.encodeNat16le : Nat + 186. builtin.Bytes.encodeNat16le : Nat -> Bytes - 186. builtin.Bytes.encodeNat32be : Nat + 187. builtin.Bytes.encodeNat32be : Nat -> Bytes - 187. builtin.Bytes.encodeNat32le : Nat + 188. builtin.Bytes.encodeNat32le : Nat -> Bytes - 188. builtin.Bytes.encodeNat64be : Nat + 189. builtin.Bytes.encodeNat64be : Nat -> Bytes - 189. builtin.Bytes.encodeNat64le : Nat + 190. builtin.Bytes.encodeNat64le : Nat -> Bytes - 190. builtin.io2.Tls.encodePrivateKey : PrivateKey + 191. builtin.io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 191. builtin.Float.eq : Float + 192. builtin.Float.eq : Float -> Float -> Boolean - 192. builtin.Int.eq : Int + 193. builtin.Int.eq : Int -> Int -> Boolean - 193. builtin.Nat.eq : Nat + 194. builtin.Nat.eq : Nat -> Nat -> Boolean - 194. builtin.Text.eq : Text + 195. builtin.Text.eq : Text -> Text -> Boolean - 195. builtin.Float.exp : Float + 196. builtin.Float.exp : Float -> Float - 196. builtin.Bytes.flatten : Bytes + 197. builtin.Bytes.flatten : Bytes -> Bytes - 197. builtin.Float.floor : Float + 198. builtin.Float.floor : Float -> Int - 198. builtin.io2.IO.forkComp : '{IO} a + 199. builtin.io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 199. builtin.Bytes.fromBase16 : Bytes + 200. builtin.Bytes.fromBase16 : Bytes -> Either Text Bytes - 200. builtin.Bytes.fromBase32 : Bytes + 201. builtin.Bytes.fromBase32 : Bytes -> Either Text Bytes - 201. builtin.Bytes.fromBase64 : Bytes + 202. builtin.Bytes.fromBase64 : Bytes -> Either Text Bytes - 202. builtin.Bytes.fromBase64UrlUnpadded : Bytes + 203. builtin.Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes - 203. builtin.Text.fromCharList : [Char] + 204. builtin.Text.fromCharList : [Char] -> Text - 204. builtin.Bytes.fromList : [Nat] + 205. builtin.Bytes.fromList : [Nat] -> Bytes - 205. builtin.Char.fromNat : Nat + 206. builtin.Char.fromNat : Nat -> Char - 206. builtin.Float.fromRepresentation : Nat + 207. builtin.Float.fromRepresentation : Nat -> Float - 207. builtin.Int.fromRepresentation : Nat + 208. builtin.Int.fromRepresentation : Nat -> Int - 208. builtin.Float.fromText : Text + 209. builtin.Float.fromText : Text -> Optional Float - 209. builtin.Int.fromText : Text + 210. builtin.Int.fromText : Text -> Optional Int - 210. builtin.Nat.fromText : Text + 211. builtin.Nat.fromText : Text -> Optional Nat - 211. builtin.Float.gt : Float + 212. builtin.Float.gt : Float -> Float -> Boolean - 212. builtin.Int.gt : Int + 213. builtin.Int.gt : Int -> Int -> Boolean - 213. builtin.Nat.gt : Nat + 214. builtin.Nat.gt : Nat -> Nat -> Boolean - 214. builtin.Text.gt : Text + 215. builtin.Text.gt : Text -> Text -> Boolean - 215. builtin.Float.gteq : Float + 216. builtin.Float.gteq : Float -> Float -> Boolean - 216. builtin.Int.gteq : Int + 217. builtin.Int.gteq : Int -> Int -> Boolean - 217. builtin.Nat.gteq : Nat + 218. builtin.Nat.gteq : Nat -> Nat -> Boolean - 218. builtin.Text.gteq : Text + 219. builtin.Text.gteq : Text -> Text -> Boolean - 219. builtin.crypto.hash : HashAlgorithm + 220. builtin.crypto.hash : HashAlgorithm -> a -> Bytes - 220. builtin.crypto.hashBytes : HashAlgorithm + 221. builtin.crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 221. builtin.crypto.hmac : HashAlgorithm + 222. builtin.crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 222. builtin.crypto.hmacBytes : HashAlgorithm + 223. builtin.crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 223. builtin.io2.IO.clientSocket.impl : Text + 224. builtin.io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 224. builtin.io2.IO.closeFile.impl : Handle + 225. builtin.io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 225. builtin.io2.IO.closeSocket.impl : Socket + 226. builtin.io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 226. builtin.io2.IO.createDirectory.impl : Text + 227. builtin.io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 227. builtin.io2.IO.createTempDirectory.impl : Text + 228. builtin.io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 228. builtin.io2.Tls.decodeCert.impl : Bytes + 229. builtin.io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 229. builtin.io2.IO.delay.impl : Nat + 230. builtin.io2.IO.delay.impl : Nat ->{IO} Either Failure () - 230. builtin.io2.IO.directoryContents.impl : Text + 231. builtin.io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 231. builtin.io2.IO.fileExists.impl : Text + 232. builtin.io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 232. builtin.Text.fromUtf8.impl : Bytes + 233. builtin.Text.fromUtf8.impl : Bytes -> Either Failure Text - 233. builtin.io2.IO.getArgs.impl : '{IO} Either + 234. builtin.io2.IO.getArgs.impl : '{IO} Either Failure [Text] - 234. builtin.io2.IO.getBuffering.impl : Handle + 235. builtin.io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 235. builtin.io2.IO.getBytes.impl : Handle + 236. builtin.io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 236. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either + 237. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 237. builtin.io2.IO.getEnv.impl : Text + 238. builtin.io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 238. builtin.io2.IO.getFileSize.impl : Text + 239. builtin.io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 239. builtin.io2.IO.getFileTimestamp.impl : Text + 240. builtin.io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 240. builtin.io2.IO.getLine.impl : Handle + 241. builtin.io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 241. builtin.io2.IO.getSomeBytes.impl : Handle + 242. builtin.io2.IO.getSomeBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 242. builtin.io2.IO.getTempDirectory.impl : '{IO} Either + 243. builtin.io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 243. builtin.io2.IO.handlePosition.impl : Handle + 244. builtin.io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 244. builtin.io2.Tls.handshake.impl : Tls + 245. builtin.io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 245. builtin.io2.IO.isDirectory.impl : Text + 246. builtin.io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 246. builtin.io2.IO.isFileEOF.impl : Handle + 247. builtin.io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 247. builtin.io2.IO.isFileOpen.impl : Handle + 248. builtin.io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 248. builtin.io2.IO.isSeekable.impl : Handle + 249. builtin.io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 249. builtin.io2.IO.kill.impl : ThreadId + 250. builtin.io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 250. builtin.io2.IO.listen.impl : Socket + 251. builtin.io2.IO.listen.impl : Socket ->{IO} Either Failure () - 251. builtin.io2.Tls.newClient.impl : ClientConfig + 252. builtin.io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 252. builtin.io2.Tls.newServer.impl : ServerConfig + 253. builtin.io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 253. builtin.io2.IO.openFile.impl : Text + 254. builtin.io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 254. builtin.io2.MVar.put.impl : MVar a + 255. builtin.io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 255. builtin.io2.IO.putBytes.impl : Handle + 256. builtin.io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 256. builtin.io2.MVar.read.impl : MVar a + 257. builtin.io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 257. builtin.io2.Tls.receive.impl : Tls + 258. builtin.io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 258. builtin.io2.IO.removeDirectory.impl : Text + 259. builtin.io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 259. builtin.io2.IO.removeFile.impl : Text + 260. builtin.io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 260. builtin.io2.IO.renameDirectory.impl : Text + 261. builtin.io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 261. builtin.io2.IO.renameFile.impl : Text + 262. builtin.io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 262. builtin.io2.IO.seekHandle.impl : Handle + 263. builtin.io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 263. builtin.io2.Tls.send.impl : Tls + 264. builtin.io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 264. builtin.io2.IO.serverSocket.impl : Optional + 265. builtin.io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 265. builtin.io2.IO.setBuffering.impl : Handle + 266. builtin.io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 266. builtin.io2.IO.setCurrentDirectory.impl : Text + 267. builtin.io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 267. builtin.io2.IO.socketAccept.impl : Socket + 268. builtin.io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 268. builtin.io2.IO.socketPort.impl : Socket + 269. builtin.io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 269. builtin.io2.IO.socketReceive.impl : Socket + 270. builtin.io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 270. builtin.io2.IO.socketSend.impl : Socket + 271. builtin.io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 271. builtin.io2.MVar.swap.impl : MVar a + 272. builtin.io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 272. builtin.io2.IO.systemTime.impl : '{IO} Either + 273. builtin.io2.IO.systemTime.impl : '{IO} Either Failure Nat - 273. builtin.io2.MVar.take.impl : MVar a + 274. builtin.io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 274. builtin.io2.Tls.terminate.impl : Tls + 275. builtin.io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 275. builtin.io2.MVar.tryPut.impl : MVar a + 276. builtin.io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 276. builtin.io2.MVar.tryRead.impl : MVar a + 277. builtin.io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 277. builtin.Int.increment : Int + 278. builtin.Int.increment : Int -> Int - 278. builtin.Nat.increment : Nat + 279. builtin.Nat.increment : Nat -> Nat - 279. builtin.io2.MVar.isEmpty : MVar a + 280. builtin.io2.MVar.isEmpty : MVar a ->{IO} Boolean - 280. builtin.Int.isEven : Int + 281. builtin.Int.isEven : Int -> Boolean - 281. builtin.Nat.isEven : Nat + 282. builtin.Nat.isEven : Nat -> Boolean - 282. builtin.Code.isMissing : Term + 283. builtin.Code.isMissing : Term ->{IO} Boolean - 283. builtin.Int.isOdd : Int + 284. builtin.Int.isOdd : Int -> Boolean - 284. builtin.Nat.isOdd : Nat + 285. builtin.Nat.isOdd : Nat -> Boolean - 285. builtin.metadata.isPropagated : IsPropagated - 286. builtin.metadata.isTest : IsTest - 287. builtin.Int.leadingZeros : Int + 286. builtin.metadata.isPropagated : IsPropagated + 287. builtin.metadata.isTest : IsTest + 288. builtin.Int.leadingZeros : Int -> Nat - 288. builtin.Nat.leadingZeros : Nat + 289. builtin.Nat.leadingZeros : Nat -> Nat - 289. builtin.Value.load : Value + 290. builtin.Value.load : Value ->{IO} Either [Term] a - 290. builtin.Float.log : Float + 291. builtin.Float.log : Float -> Float - 291. builtin.Float.logBase : Float + 292. builtin.Float.logBase : Float -> Float -> Float - 292. builtin.Code.lookup : Term + 293. builtin.Code.lookup : Term ->{IO} Optional Code - 293. builtin.Float.lt : Float + 294. builtin.Float.lt : Float -> Float -> Boolean - 294. builtin.Int.lt : Int + 295. builtin.Int.lt : Int -> Int -> Boolean - 295. builtin.Nat.lt : Nat + 296. builtin.Nat.lt : Nat -> Nat -> Boolean - 296. builtin.Text.lt : Text + 297. builtin.Text.lt : Text -> Text -> Boolean - 297. builtin.Float.lteq : Float + 298. builtin.Float.lteq : Float -> Float -> Boolean - 298. builtin.Int.lteq : Int + 299. builtin.Int.lteq : Int -> Int -> Boolean - 299. builtin.Nat.lteq : Nat + 300. builtin.Nat.lteq : Nat -> Nat -> Boolean - 300. builtin.Text.lteq : Text + 301. builtin.Text.lteq : Text -> Text -> Boolean - 301. builtin.Float.max : Float + 302. builtin.Float.max : Float -> Float -> Float - 302. builtin.Float.min : Float + 303. builtin.Float.min : Float -> Float -> Float - 303. builtin.Int.mod : Int + 304. builtin.Int.mod : Int -> Int -> Int - 304. builtin.Nat.mod : Nat + 305. builtin.Nat.mod : Nat -> Nat -> Nat - 305. builtin.io2.Clock.internals.monotonic : '{IO} Either + 306. builtin.io2.Clock.internals.monotonic : '{IO} Either Failure TimeSpec - 306. builtin.Int.negate : Int + 307. builtin.Int.negate : Int -> Int - 307. builtin.io2.MVar.new : a + 308. builtin.io2.MVar.new : a ->{IO} MVar a - 308. builtin.io2.TVar.new : a + 309. builtin.io2.TVar.new : a ->{STM} TVar a - 309. builtin.io2.MVar.newEmpty : '{IO} MVar + 310. builtin.io2.MVar.newEmpty : '{IO} MVar a - 310. builtin.io2.TVar.newIO : a + 311. builtin.io2.TVar.newIO : a ->{IO} TVar a - 311. builtin.Boolean.not : Boolean + 312. builtin.Boolean.not : Boolean -> Boolean - 312. builtin.io2.Clock.internals.nsec : TimeSpec + 313. builtin.io2.Clock.internals.nsec : TimeSpec -> Nat - 313. builtin.Int.or : Int + 314. builtin.Int.or : Int -> Int -> Int - 314. builtin.Nat.or : Nat + 315. builtin.Nat.or : Nat -> Nat -> Nat - 315. builtin.Int.popCount : Int + 316. builtin.Int.popCount : Int -> Nat - 316. builtin.Nat.popCount : Nat + 317. builtin.Nat.popCount : Nat -> Nat - 317. builtin.Float.pow : Float + 318. builtin.Float.pow : Float -> Float -> Float - 318. builtin.Int.pow : Int + 319. builtin.Int.pow : Int -> Nat -> Int - 319. builtin.Nat.pow : Nat + 320. builtin.Nat.pow : Nat -> Nat -> Nat - 320. builtin.io2.Clock.internals.processCPUTime : '{IO} Either + 321. builtin.io2.Clock.internals.processCPUTime : '{IO} Either Failure TimeSpec - 321. builtin.Ref.read : Ref g a + 322. builtin.Ref.read : Ref g a ->{g} a - 322. builtin.io2.TVar.read : TVar a + 323. builtin.io2.TVar.read : TVar a ->{STM} a - 323. builtin.io2.TVar.readIO : TVar a + 324. builtin.io2.TVar.readIO : TVar a ->{IO} a - 324. builtin.io2.Clock.internals.realtime : '{IO} Either + 325. builtin.io2.Clock.internals.realtime : '{IO} Either Failure TimeSpec - 325. builtin.io2.IO.ref : a + 326. builtin.io2.IO.ref : a ->{IO} Ref {IO} a - 326. builtin.Scope.ref : a + 327. builtin.Scope.ref : a ->{Scope s} Ref {Scope s} a - 327. builtin.Text.repeat : Nat + 328. builtin.Text.repeat : Nat -> Text -> Text - 328. builtin.io2.STM.retry : '{STM} a - 329. builtin.Float.round : Float + 329. builtin.io2.STM.retry : '{STM} a + 330. builtin.Float.round : Float -> Int - 330. builtin.Scope.run : (โˆ€ s. + 331. builtin.Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 331. builtin.io2.Clock.internals.sec : TimeSpec + 332. builtin.io2.Clock.internals.sec : TimeSpec -> Int - 332. builtin.Code.serialize : Code + 333. builtin.Code.serialize : Code -> Bytes - 333. builtin.Value.serialize : Value + 334. builtin.Value.serialize : Value -> Bytes - 334. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] + 335. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 335. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] + 336. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 336. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] + 337. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 337. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] + 338. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 338. builtin.io2.Tls.ClientConfig.versions.set : [Version] + 339. builtin.io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 339. builtin.io2.Tls.ServerConfig.versions.set : [Version] + 340. builtin.io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 340. builtin.Int.shiftLeft : Int + 341. builtin.Int.shiftLeft : Int -> Nat -> Int - 341. builtin.Nat.shiftLeft : Nat + 342. builtin.Nat.shiftLeft : Nat -> Nat -> Nat - 342. builtin.Int.shiftRight : Int + 343. builtin.Int.shiftRight : Int -> Nat -> Int - 343. builtin.Nat.shiftRight : Nat + 344. builtin.Nat.shiftRight : Nat -> Nat -> Nat - 344. builtin.Int.signum : Int + 345. builtin.Int.signum : Int -> Int - 345. builtin.Float.sin : Float + 346. builtin.Float.sin : Float -> Float - 346. builtin.Float.sinh : Float + 347. builtin.Float.sinh : Float -> Float - 347. builtin.Bytes.size : Bytes + 348. builtin.Bytes.size : Bytes -> Nat - 348. builtin.List.size : [a] + 349. builtin.List.size : [a] -> Nat - 349. builtin.Text.size : Text + 350. builtin.Text.size : Text -> Nat - 350. builtin.Float.sqrt : Float + 351. builtin.Float.sqrt : Float -> Float - 351. builtin.io2.IO.stdHandle : StdHandle + 352. builtin.io2.IO.stdHandle : StdHandle -> Handle - 352. builtin.Nat.sub : Nat + 353. builtin.Nat.sub : Nat -> Nat -> Int - 353. builtin.io2.TVar.swap : TVar a + 354. builtin.io2.TVar.swap : TVar a -> a ->{STM} a - 354. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int - 355. builtin.Bytes.take : Nat + 355. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int + 356. builtin.Bytes.take : Nat -> Bytes -> Bytes - 356. builtin.List.take : Nat + 357. builtin.List.take : Nat -> [a] -> [a] - 357. builtin.Text.take : Nat + 358. builtin.Text.take : Nat -> Text -> Text - 358. builtin.Float.tan : Float + 359. builtin.Float.tan : Float -> Float - 359. builtin.Float.tanh : Float + 360. builtin.Float.tanh : Float -> Float - 360. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either + 361. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either Failure TimeSpec - 361. builtin.Bytes.toBase16 : Bytes + 362. builtin.Bytes.toBase16 : Bytes -> Bytes - 362. builtin.Bytes.toBase32 : Bytes + 363. builtin.Bytes.toBase32 : Bytes -> Bytes - 363. builtin.Bytes.toBase64 : Bytes + 364. builtin.Bytes.toBase64 : Bytes -> Bytes - 364. builtin.Bytes.toBase64UrlUnpadded : Bytes + 365. builtin.Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 365. builtin.Text.toCharList : Text + 366. builtin.Text.toCharList : Text -> [Char] - 366. builtin.Int.toFloat : Int + 367. builtin.Int.toFloat : Int -> Float - 367. builtin.Nat.toFloat : Nat + 368. builtin.Nat.toFloat : Nat -> Float - 368. builtin.Nat.toInt : Nat + 369. builtin.Nat.toInt : Nat -> Int - 369. builtin.Bytes.toList : Bytes + 370. builtin.Bytes.toList : Bytes -> [Nat] - 370. builtin.Char.toNat : Char + 371. builtin.Char.toNat : Char -> Nat - 371. builtin.Float.toRepresentation : Float + 372. builtin.Float.toRepresentation : Float -> Nat - 372. builtin.Int.toRepresentation : Int + 373. builtin.Int.toRepresentation : Int -> Nat - 373. builtin.Char.toText : Char + 374. builtin.Char.toText : Char -> Text - 374. builtin.Float.toText : Float + 375. builtin.Float.toText : Float -> Text - 375. builtin.Handle.toText : Handle + 376. builtin.Handle.toText : Handle -> Text - 376. builtin.Int.toText : Int + 377. builtin.Int.toText : Int -> Text - 377. builtin.Nat.toText : Nat + 378. builtin.Nat.toText : Nat -> Text - 378. builtin.Socket.toText : Socket + 379. builtin.Socket.toText : Socket -> Text - 379. builtin.Link.Term.toText : Term + 380. builtin.Link.Term.toText : Term -> Text - 380. builtin.ThreadId.toText : ThreadId + 381. builtin.ThreadId.toText : ThreadId -> Text - 381. builtin.Text.toUtf8 : Text + 382. builtin.Text.toUtf8 : Text -> Bytes - 382. builtin.todo : a -> b - 383. builtin.Debug.trace : Text + 383. builtin.todo : a -> b + 384. builtin.Debug.trace : Text -> a -> () - 384. builtin.Int.trailingZeros : Int + 385. builtin.Int.trailingZeros : Int -> Nat - 385. builtin.Nat.trailingZeros : Nat + 386. builtin.Nat.trailingZeros : Nat -> Nat - 386. builtin.Float.truncate : Float + 387. builtin.Float.truncate : Float -> Int - 387. builtin.Int.truncate0 : Int + 388. builtin.Int.truncate0 : Int -> Nat - 388. builtin.io2.MVar.tryTake : MVar a + 389. builtin.io2.MVar.tryTake : MVar a ->{IO} Optional a - 389. builtin.Text.uncons : Text + 390. builtin.Text.uncons : Text -> Optional ( Char, Text) - 390. builtin.Any.unsafeExtract : Any + 391. builtin.Any.unsafeExtract : Any -> a - 391. builtin.Text.unsnoc : Text + 392. builtin.Text.unsnoc : Text -> Optional ( Text, Char) - 392. builtin.Code.validate : [( Term, + 393. builtin.Code.validate : [( Term, Code)] ->{IO} Optional Failure - 393. builtin.io2.validateSandboxed : [Term] + 394. builtin.io2.validateSandboxed : [Term] -> a -> Boolean - 394. builtin.Value.value : a + 395. builtin.Value.value : a -> Value - 395. builtin.Debug.watch : Text + 396. builtin.Debug.watch : Text -> a -> a - 396. builtin.Ref.write : Ref g a + 397. builtin.Ref.write : Ref g a -> a ->{g} () - 397. builtin.io2.TVar.write : TVar a + 398. builtin.io2.TVar.write : TVar a -> a ->{STM} () - 398. builtin.Int.xor : Int + 399. builtin.Int.xor : Int -> Int -> Int - 399. builtin.Nat.xor : Nat + 400. builtin.Nat.xor : Nat -> Nat -> Nat diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index 2c10714665..32cce87fb0 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #j7ar890fgd .old` to make an old namespace + `fork #6rnlsqcthn .old` to make an old namespace accessible again, - `reset-root #j7ar890fgd` to reset the root namespace and + `reset-root #6rnlsqcthn` to reset the root namespace and its history to that of the specified namespace. - 1. #396ap2v898 : add - 2. #j7ar890fgd : add - 3. #7eacs027uv : builtins.merge + 1. #8kr5i8gver : add + 2. #6rnlsqcthn : add + 3. #odl13ktegj : builtins.merge 4. #sg60bvjo91 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index aeaa5fb227..359838bbba 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - โ–ก 1. #4vt616ak19 (start of history) + โ–ก 1. #ia768a41ec (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #6k85v9fd02 + โŠ™ 1. #7su28m7gvs > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #0rpodsf1gq + โŠ™ 2. #00duj13j0k > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #4vt616ak19 (start of history) + โ–ก 3. #ia768a41ec (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #6k85v9fd02 + โŠ™ 1. #7su28m7gvs > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #0rpodsf1gq + โŠ™ 2. #00duj13j0k > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #4vt616ak19 (start of history) + โ–ก 3. #ia768a41ec (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - โ–ก 1. #4vt616ak19 (start of history) + โ–ก 1. #ia768a41ec (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #h1ecefevst + โŠ™ 1. #3g9mjnkcpa - Deletes: Nat.* Nat.+ - โ–ก 2. #4vt616ak19 (start of history) + โ–ก 2. #ia768a41ec (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From 19f1b365b63c1d18a25806ae48a60584069612cb Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 16 Jun 2022 14:12:04 -0600 Subject: [PATCH 360/529] Update unison-cli/src/Unison/CommandLine/OutputMessages.hs Co-authored-by: Arya Irani <538571+aryairani@users.noreply.github.com> --- unison-cli/src/Unison/CommandLine/OutputMessages.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 663814f7e1..d491a4fa65 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1640,6 +1640,7 @@ notifyUser dir o = case o of UnreachableCodeserver codeServerURL -> P.lines $ [ P.wrap $ "Unable to reach the code server hosted at:" <> P.string (Servant.showBaseUrl codeServerURL), + , "" P.wrap "Please check your network, ensure you've provided the correct location, or try again later." ] InvalidResponse resp -> P.fatalCallout $ P.hang "Invalid response received from codeserver:" (P.shown resp) From cdf15c732e43b0e83ed8ae93f81ba5c5727873e3 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 16 Jun 2022 14:13:19 -0600 Subject: [PATCH 361/529] Fix bad syntax on PR suggestion --- unison-cli/src/Unison/CommandLine/OutputMessages.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index d491a4fa65..b5cd60a141 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1640,7 +1640,7 @@ notifyUser dir o = case o of UnreachableCodeserver codeServerURL -> P.lines $ [ P.wrap $ "Unable to reach the code server hosted at:" <> P.string (Servant.showBaseUrl codeServerURL), - , "" + "", P.wrap "Please check your network, ensure you've provided the correct location, or try again later." ] InvalidResponse resp -> P.fatalCallout $ P.hang "Invalid response received from codeserver:" (P.shown resp) From 2acaa5e713bda20e9b88e874b9386e1396d40374 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Thu, 16 Jun 2022 17:13:27 -0400 Subject: [PATCH 362/529] remove all effect vars on all funcs in HashHandle --- .../src/U/Codebase/Sqlite/V2/HashHandle.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/HashHandle.hs b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/HashHandle.hs index 359dd078dc..b2a74ddc84 100644 --- a/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/HashHandle.hs +++ b/codebase2/codebase-sqlite-hashing-v2/src/U/Codebase/Sqlite/V2/HashHandle.hs @@ -12,8 +12,8 @@ import qualified Unison.Hashing.V2.Type as H2 v2HashHandle :: HashHandle v2HashHandle = HashHandle - { toReference = h2ToV2Reference . H2.toReference . v2ToH2Type, + { toReference = h2ToV2Reference . H2.toReference . v2ToH2Type . removeAllEffectVars, toReferenceMentions = Set.map h2ToV2Reference . H2.toReferenceMentions . v2ToH2Type . removeAllEffectVars, - toReferenceDecl = \h -> h2ToV2Reference . H2.toReference . v2ToH2TypeD h, + toReferenceDecl = \h -> h2ToV2Reference . H2.toReference . v2ToH2TypeD h . removeAllEffectVars, toReferenceDeclMentions = \h -> Set.map h2ToV2Reference . H2.toReferenceMentions . v2ToH2TypeD h . removeAllEffectVars } From 838ced957e5b3fc0c255b89a5fd055d756dfe2c7 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 16 Jun 2022 20:41:15 -0400 Subject: [PATCH 363/529] Add more array substrate - Rework sized byte array writes. They're now explicitly big endian, and always use byte offsets instead of multiples of the number of bytes to be read - Add universal equality/comparison support for arrays --- parser-typechecker/src/Unison/Builtin.hs | 18 +- .../src/Unison/Runtime/Builtin.hs | 265 +++++++++++++----- .../src/Unison/Runtime/Machine.hs | 27 ++ 3 files changed, 227 insertions(+), 83 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 5995c7ad95..ee2c62cfe2 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -538,21 +538,21 @@ builtinsSrc = marrayt g a --> nat --> Type.effect () [g, DD.exceptionType ()] a, B "MutableByteArray.read8" . forall1 "g" $ \g -> mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, - B "MutableByteArray.read16" . forall1 "g" $ \g -> + B "MutableByteArray.read16be" . forall1 "g" $ \g -> mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, - B "MutableByteArray.read32" . forall1 "g" $ \g -> + B "MutableByteArray.read32be" . forall1 "g" $ \g -> mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, - B "MutableByteArray.read64" . forall1 "g" $ \g -> + B "MutableByteArray.read64be" . forall1 "g" $ \g -> mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, B "MutableArray.write" . forall2 "g" "a" $ \g a -> marrayt g a --> nat --> a --> Type.effect () [g, DD.exceptionType ()] unit, B "MutableByteArray.write8" . forall1 "g" $ \g -> mbytearrayt g --> nat --> nat --> Type.effect () [g, DD.exceptionType ()] unit, - B "MutableByteArray.write16" . forall1 "g" $ \g -> + B "MutableByteArray.write16be" . forall1 "g" $ \g -> mbytearrayt g --> nat --> nat --> Type.effect () [g, DD.exceptionType ()] unit, - B "MutableByteArray.write32" . forall1 "g" $ \g -> + B "MutableByteArray.write32be" . forall1 "g" $ \g -> mbytearrayt g --> nat --> nat --> Type.effect () [g, DD.exceptionType ()] unit, - B "MutableByteArray.write64" . forall1 "g" $ \g -> + B "MutableByteArray.write64be" . forall1 "g" $ \g -> mbytearrayt g --> nat --> nat --> Type.effect () [g, DD.exceptionType ()] unit, B "ImmutableArray.copyTo!" . forall2 "g" "a" $ \g a -> marrayt g a --> nat --> iarrayt a --> nat --> nat @@ -564,11 +564,11 @@ builtinsSrc = iarrayt a --> nat --> Type.effect1 () (DD.exceptionType ()) a, B "ImmutableByteArray.read8" $ ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, - B "ImmutableByteArray.read16" $ + B "ImmutableByteArray.read16be" $ ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, - B "ImmutableByteArray.read32" $ + B "ImmutableByteArray.read32be" $ ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, - B "ImmutableByteArray.read64" $ + B "ImmutableByteArray.read64be" $ ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, B "MutableArray.freeze!" . forall2 "g" "a" $ \g a -> marrayt g a --> Type.effect1 () g (iarrayt a), diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 961b01e250..c1e1e94539 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -34,6 +34,7 @@ import qualified Control.Monad.Primitive as PA import Control.Monad.State.Strict (State, execState, modify) import qualified Crypto.Hash as Hash import qualified Crypto.MAC.HMAC as HMAC +import Data.Bits (shiftL, shiftR, (.|.)) import qualified Data.ByteArray as BA import Data.ByteString (hGet, hGetSome, hPut) import qualified Data.ByteString.Lazy as L @@ -2414,8 +2415,8 @@ declareForeigns = do in if l == 0 then pure (Right ()) else - checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l - 1) (0 :: Word8) $ - checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l - 1) (0 :: Word8) $ + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ + checkBoundsPrim name (PA.sizeofMutableByteArray src) (soff + l) 0 $ Right <$> PA.copyMutableByteArray @IO dst @@ -2448,8 +2449,8 @@ declareForeigns = do in if l == 0 then pure (Right ()) else - checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l - 1) (0 :: Word8) $ - checkBoundsPrim name (PA.sizeofByteArray src) (soff + l - 1) (0 :: Word8) $ + checkBoundsPrim name (PA.sizeofMutableByteArray dst) (doff + l) 0 $ + checkBoundsPrim name (PA.sizeofByteArray src) (soff + l) 0 $ Right <$> PA.copyByteArray @IO dst @@ -2463,48 +2464,48 @@ declareForeigns = do $ checkedRead "MutableArray.read" declareForeign Tracked "MutableByteArray.read8" boxNatToExnNat . mkForeign - $ checkedReadPrim @Word8 "MutableByteArray.read8" - declareForeign Tracked "MutableByteArray.read16" boxNatToExnNat + $ checkedRead8 "MutableByteArray.read8" + declareForeign Tracked "MutableByteArray.read16be" boxNatToExnNat . mkForeign - $ checkedReadPrim @Word16 "MutableByteArray.read16" - declareForeign Tracked "MutableByteArray.read32" boxNatToExnNat + $ checkedRead16 "MutableByteArray.read16be" + declareForeign Tracked "MutableByteArray.read32be" boxNatToExnNat . mkForeign - $ checkedReadPrim @Word32 "MutableByteArray.read32" - declareForeign Tracked "MutableByteArray.read64" boxNatToExnNat + $ checkedRead32 "MutableByteArray.read32be" + declareForeign Tracked "MutableByteArray.read64be" boxNatToExnNat . mkForeign - $ checkedReadPrim @Word64 "MutableByteArray.read64" + $ checkedRead64 "MutableByteArray.read64be" declareForeign Tracked "MutableArray.write" boxNatBoxToExnUnit . mkForeign $ checkedWrite "MutableArray.write" declareForeign Tracked "MutableByteArray.write8" boxNatNatToExnUnit . mkForeign - $ checkedWritePrim @Word8 "MutableByteArray.write8" - declareForeign Tracked "MutableByteArray.write16" boxNatNatToExnUnit + $ checkedWrite8 "MutableByteArray.write8" + declareForeign Tracked "MutableByteArray.write16be" boxNatNatToExnUnit . mkForeign - $ checkedWritePrim @Word16 "MutableByteArray.write16" - declareForeign Tracked "MutableByteArray.write32" boxNatNatToExnUnit + $ checkedWrite16 "MutableByteArray.write16be" + declareForeign Tracked "MutableByteArray.write32be" boxNatNatToExnUnit . mkForeign - $ checkedWritePrim @Word32 "MutableByteArray.write32" - declareForeign Tracked "MutableByteArray.write64" boxNatNatToExnUnit + $ checkedWrite32 "MutableByteArray.write32be" + declareForeign Tracked "MutableByteArray.write64be" boxNatNatToExnUnit . mkForeign - $ checkedWritePrim @Word64 "MutableByteArray.write64" + $ checkedWrite64 "MutableByteArray.write64be" declareForeign Untracked "ImmutableArray.read" boxNatToExnBox . mkForeign $ checkedIndex "ImmutableArray.read" declareForeign Untracked "ImmutableByteArray.read8" boxNatToExnNat . mkForeign - $ checkedIndexPrim @Word8 "ImmutableByteArray.read8" - declareForeign Untracked "ImmutableByteArray.read16" boxNatToExnNat + $ checkedIndex8 "ImmutableByteArray.read8" + declareForeign Untracked "ImmutableByteArray.read16be" boxNatToExnNat . mkForeign - $ checkedIndexPrim @Word16 "ImmutableByteArray.read16" - declareForeign Untracked "ImmutableByteArray.read32" boxNatToExnNat + $ checkedIndex16 "ImmutableByteArray.read16be" + declareForeign Untracked "ImmutableByteArray.read32be" boxNatToExnNat . mkForeign - $ checkedIndexPrim @Word32 "ImmutableByteArray.read32" - declareForeign Untracked "ImmutableByteArray.read64" boxNatToExnNat + $ checkedIndex32 "ImmutableByteArray.read32be" + declareForeign Untracked "ImmutableByteArray.read64be" boxNatToExnNat . mkForeign - $ checkedIndexPrim @Word64 "ImmutableByteArray.read64" + $ checkedIndex64 "ImmutableByteArray.read64be" declareForeign Tracked "MutableByteArray.freeze!" boxDirect . mkForeign $ PA.unsafeFreezeByteArray @@ -2519,8 +2520,8 @@ declareForeigns = do checkBoundsPrim "MutableByteArray.freeze" (PA.sizeofMutableByteArray src) - (off + len - 1) - (0 :: Word8) + (off + len) + 0 $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) declareForeign Tracked "MutableArray.freeze" boxNatNatToExnBox . mkForeign $ @@ -2593,43 +2594,153 @@ checkedIndex name (arr, w) = w (Right <$> PA.indexArrayM arr (fromIntegral w)) -checkedReadPrim :: - forall a. - PA.Prim a => - Text -> - (PA.MutableByteArray RW, Word64) -> - IO (Either Failure a) -checkedReadPrim name (arr, i) = - checkBoundsPrim - name - (PA.sizeofMutableByteArray arr) - i - (undefined :: a) - (Right <$> PA.readByteArray arr (fromIntegral i)) - -checkedWritePrim :: - forall a. - PA.Prim a => - Text -> - (PA.MutableByteArray RW, Word64, a) -> - IO (Either Failure ()) -checkedWritePrim name (arr, i, v) = - checkBoundsPrim - name - (PA.sizeofMutableByteArray arr) - i - v - (Right <$> PA.writeByteArray arr (fromIntegral i) v) - -checkedIndexPrim :: - forall a. PA.Prim a => Text -> (PA.ByteArray, Word64) -> IO (Either Failure a) -checkedIndexPrim name (arr, i) = - checkBoundsPrim - name - (PA.sizeofByteArray arr) - i - (undefined :: a) - (pure . Right $ PA.indexByteArray arr (fromIntegral i)) +checkedRead8 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead8 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ + (Right . fromIntegral) <$> PA.readByteArray @Word8 arr j + where + j = fromIntegral i + +checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead16 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ + (mk16) + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + where + j = fromIntegral i + +checkedRead32 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead32 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ + mk32 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + where + j = fromIntegral i + +checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead64 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ + mk64 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + <*> PA.readByteArray @Word8 arr (j + 4) + <*> PA.readByteArray @Word8 arr (j + 5) + <*> PA.readByteArray @Word8 arr (j + 6) + <*> PA.readByteArray @Word8 arr (j + 7) + where + j = fromIntegral i + +mk16 :: Word8 -> Word8 -> Either Failure Word64 +mk16 b0 b1 = Right $ (fromIntegral $ b0 `shiftL` 8) .|. (fromIntegral b1) + +mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk32 b0 b1 b2 b3 = + Right $ + (fromIntegral $ b0 `shiftL` 24) + .|. (fromIntegral $ b1 `shiftL` 16) + .|. (fromIntegral $ b2 `shiftL` 8) + .|. (fromIntegral b3) + +mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk64 b0 b1 b2 b3 b4 b5 b6 b7 = + Right $ + (fromIntegral $ b0 `shiftL` 56) + .|. (fromIntegral $ b1 `shiftL` 48) + .|. (fromIntegral $ b2 `shiftL` 40) + .|. (fromIntegral $ b3 `shiftL` 32) + .|. (fromIntegral $ b4 `shiftL` 24) + .|. (fromIntegral $ b5 `shiftL` 16) + .|. (fromIntegral $ b6 `shiftL` 8) + .|. (fromIntegral b7) + +checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite8 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 1 $ do + PA.writeByteArray arr j (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite16 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite16 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite32 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite32 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 4 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 24 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 16 :: Word8) + PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 3) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +checkedWrite64 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) +checkedWrite64 name (arr, i, v) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ do + PA.writeByteArray arr j (fromIntegral $ v `shiftR` 56 :: Word8) + PA.writeByteArray arr (j + 1) (fromIntegral $ v `shiftR` 48 :: Word8) + PA.writeByteArray arr (j + 2) (fromIntegral $ v `shiftR` 40 :: Word8) + PA.writeByteArray arr (j + 3) (fromIntegral $ v `shiftR` 32 :: Word8) + PA.writeByteArray arr (j + 4) (fromIntegral $ v `shiftR` 24 :: Word8) + PA.writeByteArray arr (j + 5) (fromIntegral $ v `shiftR` 16 :: Word8) + PA.writeByteArray arr (j + 6) (fromIntegral $ v `shiftR` 8 :: Word8) + PA.writeByteArray arr (j + 7) (fromIntegral v :: Word8) + pure (Right ()) + where + j = fromIntegral i + +-- index single byte +checkedIndex8 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex8 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 1 . pure $ + let j = fromIntegral i + in Right . fromIntegral $ PA.indexByteArray @Word8 arr j + +-- index 16 big-endian +checkedIndex16 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex16 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 2 . pure $ + let j = fromIntegral i + in mk16 (PA.indexByteArray arr j) (PA.indexByteArray arr (j + 1)) + +-- index 32 big-endian +checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex32 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 4 . pure $ + let j = fromIntegral i + in mk32 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + +-- index 64 big-endian +checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex64 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 8 . pure $ + let j = fromIntegral i + in mk64 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + (PA.indexByteArray arr (j + 4)) + (PA.indexByteArray arr (j + 5)) + (PA.indexByteArray arr (j + 6)) + (PA.indexByteArray arr (j + 7)) checkBounds :: Text -> Int -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) checkBounds name l w act @@ -2641,24 +2752,30 @@ checkBounds name l w act -- Performs a bounds check on a byte array. Strategy is as follows: -- +-- isz = signed array size-in-bytes +-- off = unsigned byte offset into the array +-- esz = unsigned number of bytes to be read +-- -- 1. Turn the signed size-in-bytes of the array unsigned --- 2. Get the size of an element to be read --- 3. Divide 1 by 2 to get the size-in-elements --- 4. Check if the unsigned index is too large +-- 2. Add the offset to the to-be-read number to get the maximum size needed +-- 3. Check that the actual array size is at least as big as the needed size +-- 4. Check that the offset is less than the size -- --- This should avoid having to worry about overflows. +-- Step 4 ensures that step 3 has not overflowed. Since an actual array size can +-- only be 63 bits (since it is signed), the only way for 3 to overflow is if +-- the offset is larger than a possible array size, since it would need to be +-- 2^64-k, where k is the small (<=8) number of bytes to be read. checkBoundsPrim :: - PA.Prim a => Text -> Int -> Word64 -> a -> IO (Either Failure b) -> IO (Either Failure b) -checkBoundsPrim name isz w a act - | w >= asz = pure $ Left err + Text -> Int -> Word64 -> Word64 -> IO (Either Failure b) -> IO (Either Failure b) +checkBoundsPrim name isz off esz act + | w > bsz || off > bsz = pure $ Left err | otherwise = act where msg = name <> ": array index out of bounds" - err = Failure Ty.arrayFailureRef msg (natValue w) + err = Failure Ty.arrayFailureRef msg (natValue off) bsz = fromIntegral isz - sz = fromIntegral $ PA.sizeOf a - asz = bsz `div` sz + w = off + esz hostPreference :: Maybe Util.Text.Text -> SYS.HostPreference hostPreference Nothing = SYS.HostAny diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index 9f8d1271b4..b37e675a74 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -13,6 +13,7 @@ import Control.Exception import Data.Bits import qualified Data.Map.Strict as M import Data.Ord (comparing) +import qualified Data.Primitive.Array as PA import qualified Data.Primitive.PrimArray as PA import qualified Data.Sequence as Sq import qualified Data.Set as S @@ -1918,9 +1919,21 @@ universalEq frn = eqc | Just sl <- maybeUnwrapForeign Rf.listRef fl, Just sr <- maybeUnwrapForeign Rf.listRef fr = length sl == length sr && and (Sq.zipWith eqc sl sr) + | Just al <- maybeUnwrapForeign Rf.iarrayRef fl, + Just ar <- maybeUnwrapForeign Rf.iarrayRef fr = + arrayEq eqc al ar | otherwise = frn fl fr eqc c d = closureNum c == closureNum d +arrayEq :: (Closure -> Closure -> Bool) -> PA.Array Closure -> PA.Array Closure -> Bool +arrayEq eqc l r + | PA.sizeofArray l /= PA.sizeofArray r = False + | otherwise = go (PA.sizeofArray l) + where + go i + | i < 0 = True + | otherwise = eqc (PA.indexArray l i) (PA.indexArray r i) && go (i - 1) + -- IEEE floating point layout is such that comparison as integers -- somewhat works. Positive floating values map to positive integers -- and negatives map to negatives. The corner cases are: @@ -2018,5 +2031,19 @@ universalCompare frn = cmpc False | Just sl <- maybeUnwrapForeign Rf.listRef fl, Just sr <- maybeUnwrapForeign Rf.listRef fr = comparing Sq.length sl sr <> fold (Sq.zipWith (cmpc tyEq) sl sr) + | Just al <- maybeUnwrapForeign Rf.iarrayRef fl, + Just ar <- maybeUnwrapForeign Rf.iarrayRef fr = + arrayCmp (cmpc tyEq) al ar | otherwise = frn fl fr cmpc _ c d = comparing closureNum c d + +arrayCmp :: + (Closure -> Closure -> Ordering) -> + PA.Array Closure -> + PA.Array Closure -> + Ordering +arrayCmp cmpc l r = comparing PA.sizeofArray l r <> go (PA.sizeofArray l) + where + go i + | i < 0 = EQ + | otherwise = cmpc (PA.indexArray l i) (PA.indexArray r i) <> go (i - 1) From 561be9c85961dbaaf0fc6f04a1361fcdad34f341 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 17 Jun 2022 09:17:38 -0400 Subject: [PATCH 364/529] Add some missing array equality support --- parser-typechecker/src/Unison/Runtime/Foreign.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Runtime/Foreign.hs b/parser-typechecker/src/Unison/Runtime/Foreign.hs index c952b26059..474edb1049 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign.hs @@ -21,6 +21,7 @@ where import Control.Concurrent (MVar, ThreadId) import qualified Crypto.Hash as Hash import Data.IORef (IORef) +import Data.Primitive (ByteArray, MutableArray, MutableByteArray) import Data.Tagged (Tagged (..)) import qualified Data.X509 as X509 import Network.Socket (Socket) @@ -70,6 +71,9 @@ ref2eq r -- Ditto | r == Ty.refRef = Just $ promote ((==) @(IORef ())) | r == Ty.threadIdRef = Just $ promote ((==) @ThreadId) + | r == Ty.marrayRef = Just $ promote ((==) @(MutableArray () ())) + | r == Ty.mbytearrayRef = Just $ promote ((==) @(MutableByteArray ())) + | r == Ty.ibytearrayRef = Just $ promote ((==) @ByteArray) | otherwise = Nothing ref2cmp :: Reference -> Maybe (a -> b -> Ordering) @@ -79,6 +83,7 @@ ref2cmp r | r == Ty.typeLinkRef = Just $ promote tylCmp | r == Ty.bytesRef = Just $ promote (compare @Bytes) | r == Ty.threadIdRef = Just $ promote (compare @ThreadId) + | r == Ty.ibytearrayRef = Just $ promote (compare @ByteArray) | otherwise = Nothing instance Eq Foreign where @@ -143,7 +148,6 @@ instance BuiltinForeign Value where foreignRef = Tagged Ty.valueRef instance BuiltinForeign TimeSpec where foreignRef = Tagged Ty.timeSpecRef - data HashAlgorithm where -- Reference is a reference to the hash algorithm HashAlgorithm :: Hash.HashAlgorithm a => Reference -> a -> HashAlgorithm From 901d83834e513ab6518adec32bae1b6c86a25e2e Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 15 Jun 2022 16:29:11 -0600 Subject: [PATCH 365/529] Add temp entity tables for old schema versions. This is a bit of a hack to handle the fact that saveObject now tries to flush temp entity tables, and they might not exist on old schema versions --- .../codebase-sqlite/sql/001-temp-entity-tables.sql | 14 ++++++++------ .../Unison/Codebase/SqliteCodebase/Migrations.hs | 10 ++++++++++ 2 files changed, 18 insertions(+), 6 deletions(-) diff --git a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql index a5bc1baf53..043f8436c5 100644 --- a/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql +++ b/codebase2/codebase-sqlite/sql/001-temp-entity-tables.sql @@ -1,4 +1,4 @@ -create table temp_entity_type_description ( +create table if not exists temp_entity_type_description ( id integer primary key not null, description text unique not null ); @@ -7,7 +7,9 @@ insert into temp_entity_type_description values (1, 'Decl Component'), (2, 'Namespace'), (3, 'Patch'), - (4, 'Causal'); + (4, 'Causal') + ON CONFLICT DO NOTHING +; -- A "temp entity" is a term/decl/namespace/patch/causal that we cannot store in the database proper due to missing -- dependencies. @@ -19,7 +21,7 @@ insert into temp_entity_type_description values -- Similarly, each `temp_entity` row implies we do not have the entity in the database proper. When and if we *do* store -- an entity proper (after storing all of its dependencies), we should always atomically delete the corresponding -- `temp_entity` row, if any. -create table temp_entity ( +create table if not exists temp_entity ( hash text primary key not null, blob bytes not null, type_id integer not null references temp_entity_type_description(id) @@ -51,11 +53,11 @@ create table temp_entity ( -- |========================================| -- | #foo | #bar | aT.Eb.cx | -- +----------------------------------------+ -create table temp_entity_missing_dependency ( +create table if not exists temp_entity_missing_dependency ( dependent text not null references temp_entity(hash), dependency text not null, dependencyJwt text not null, unique (dependent, dependency) ); -create index temp_entity_missing_dependency_ix_dependent on temp_entity_missing_dependency (dependent); -create index temp_entity_missing_dependency_ix_dependency on temp_entity_missing_dependency (dependency) +create index if not exists temp_entity_missing_dependency_ix_dependent on temp_entity_missing_dependency (dependent); +create index if not exists temp_entity_missing_dependency_ix_dependency on temp_entity_missing_dependency (dependency) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs index 8a3372dd87..f9a3b9d70d 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations.hs @@ -72,6 +72,16 @@ ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer co let migrationsToRun = Map.filterWithKey (\v _ -> v > schemaVersion) migs when (localOrRemote == Local && (not . null) migrationsToRun) $ backupCodebase root + -- This is a bit of a hack, hopefully we can remove this when we have a more + -- reliable way to freeze old migration code in time. + -- The problem is that 'saveObject' has been changed to flush temp entity tables, + -- but old schema versions still use 'saveObject', but don't have the tables! + -- We can create the tables no matter what, there won't be anything to flush, so + -- everything still works as expected. + -- + -- Hopefully we can remove this once we've got better methods of freezing migration + -- code in time. + when (schemaVersion < 5) $ run Q.addTempEntityTables for_ (Map.toAscList migrationsToRun) $ \(SchemaVersion v, migration) -> do putStrLn $ "๐Ÿ”จ Migrating codebase to version " <> show v <> "..." run migration From c093ebd82a78e7b6a4413ac5a10d4e569ec3fa4f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 17 Jun 2022 08:52:04 -0600 Subject: [PATCH 366/529] Update Name lookup index in half the time (#3124) * Implement name lookup on shallow branches --- .../src/Unison/Codebase/SqliteCodebase.hs | 2 +- .../Codebase/SqliteCodebase/Operations.hs | 99 ++++++++++++++----- 2 files changed, 75 insertions(+), 26 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index aee7379340..0c8899eb19 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -488,7 +488,7 @@ sqliteCodebase debugName root localOrRemote action = do beforeImpl = (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r), namesAtPath = \path -> Sqlite.runReadOnlyTransaction conn \runTx -> runTx (CodebaseOps.namesAtPath path), - updateNameLookup = Sqlite.runTransaction conn $ CodebaseOps.updateNameLookupIndex getDeclType, + updateNameLookup = Sqlite.runTransaction conn (CodebaseOps.updateNameLookupIndexFromV2Root getDeclType), connection = conn } let finalizer :: MonadIO m => m () diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 8e4e20f3b1..becd23f39b 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -7,14 +7,18 @@ -- are unified with non-sqlite operations in the Codebase interface, like 'appendReflog'. module Unison.Codebase.SqliteCodebase.Operations where +import Control.Lens (ifoldMap) import Data.Bifunctor (Bifunctor (bimap), second) import Data.Bitraversable (bitraverse) import Data.Either.Extra () import qualified Data.List as List +import qualified Data.List.NonEmpty as NEList import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text +import qualified U.Codebase.Branch as V2Branch +import qualified U.Codebase.Causal as V2Causal import U.Codebase.HashTags (CausalHash (unCausalHash)) import qualified U.Codebase.Reference as C.Reference import qualified U.Codebase.Referent as C.Referent @@ -28,7 +32,7 @@ import qualified U.Util.Hash as H2 import qualified Unison.Builtin as Builtins import Unison.Codebase.Branch (Branch (..)) import qualified Unison.Codebase.Branch as Branch -import qualified Unison.Codebase.Branch.Names as Branch +import qualified Unison.Codebase.Branch.Names as V1Branch import qualified Unison.Codebase.Causal.Type as Causal import Unison.Codebase.Patch (Patch) import Unison.Codebase.Path (Path) @@ -593,24 +597,76 @@ namesAtPath path = do Nothing -> (mempty, [(n, ref)]) Just stripped -> ([(Name.makeRelative stripped, ref)], mempty) -saveRootNamesIndex :: Names -> Transaction () -saveRootNamesIndex Names {Names.terms, Names.types} = do - let termNames :: [(S.NamedRef (C.Referent.Referent, Maybe C.Referent.ConstructorType))] - termNames = Rel.toList terms <&> \(name, ref) -> S.NamedRef {reversedSegments = nameSegments name, ref = splitReferent ref} - let typeNames :: [(S.NamedRef C.Reference.Reference)] - typeNames = - Rel.toList types - <&> ( \(name, ref) -> - S.NamedRef {reversedSegments = nameSegments name, ref = Cv.reference1to2 ref} - ) - Ops.rebuildNameIndex termNames typeNames +-- | Update the root namespace names index which is used by the share server for serving api +-- requests. +-- +-- This version should be used if you've already got the root Branch pre-loaded, otherwise +-- it's faster to use 'updateNameLookupIndexFromV2Branch' +updateNameLookupIndexFromV1Branch :: Branch Transaction -> Sqlite.Transaction () +updateNameLookupIndexFromV1Branch root = do + saveRootNamesIndexV1 (V1Branch.toNames . Branch.head $ root) where - nameSegments :: Name -> NonEmpty Text - nameSegments = coerce @(NonEmpty NameSegment) @(NonEmpty Text) . Name.reverseSegments - splitReferent :: Referent.Referent -> (C.Referent.Referent, Maybe C.Referent.ConstructorType) - splitReferent referent = case referent of - Referent.Ref {} -> (Cv.referent1to2 referent, Nothing) - Referent.Con _ref ct -> (Cv.referent1to2 referent, Just (Cv.constructorType1to2 ct)) + saveRootNamesIndexV1 :: Names -> Transaction () + saveRootNamesIndexV1 Names {Names.terms, Names.types} = do + let termNames :: [(S.NamedRef (C.Referent.Referent, Maybe C.Referent.ConstructorType))] + termNames = Rel.toList terms <&> \(name, ref) -> S.NamedRef {reversedSegments = nameSegments name, ref = splitReferent ref} + let typeNames :: [(S.NamedRef C.Reference.Reference)] + typeNames = + Rel.toList types + <&> ( \(name, ref) -> + S.NamedRef {reversedSegments = nameSegments name, ref = Cv.reference1to2 ref} + ) + Ops.rebuildNameIndex termNames typeNames + where + nameSegments :: Name -> NonEmpty Text + nameSegments = coerce @(NonEmpty NameSegment) @(NonEmpty Text) . Name.reverseSegments + splitReferent :: Referent.Referent -> (C.Referent.Referent, Maybe C.Referent.ConstructorType) + splitReferent referent = case referent of + Referent.Ref {} -> (Cv.referent1to2 referent, Nothing) + Referent.Con _ref ct -> (Cv.referent1to2 referent, Just (Cv.constructorType1to2 ct)) + +-- | Update the root namespace names index which is used by the share server for serving api +-- requests. +-- +-- This version should be used if you don't already have the root Branch pre-loaded, +-- If you do, use 'updateNameLookupIndexFromV2Branch' instead. +updateNameLookupIndexFromV2Root :: (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> Sqlite.Transaction () +updateNameLookupIndexFromV2Root getDeclType = do + rootHash <- Ops.expectRootCausalHash + causalBranch <- Ops.expectCausalBranchByCausalHash rootHash + (termNameMap, typeNameMap) <- nameMapsFromV2Branch causalBranch + let expandedTermNames = Map.toList termNameMap >>= (\(name, refs) -> (name,) <$> Set.toList refs) + termNameList <- do + for expandedTermNames \(name, ref) -> do + refWithCT <- addReferentCT ref + pure S.NamedRef {S.reversedSegments = coerce name, S.ref = refWithCT} + let typeNameList = do + (name, refs) <- Map.toList typeNameMap + ref <- Set.toList refs + pure $ S.NamedRef {S.reversedSegments = coerce name, S.ref = ref} + Ops.rebuildNameIndex termNameList typeNameList + where + addReferentCT :: C.Referent.Referent -> Transaction (C.Referent.Referent, Maybe C.Referent.ConstructorType) + addReferentCT referent = case referent of + C.Referent.Ref {} -> pure (referent, Nothing) + C.Referent.Con ref _conId -> do + ct <- getDeclType ref + pure (referent, Just $ Cv.constructorType1to2 ct) + + -- Traverse a v2 branch + -- Collects two maps, one with all term names and one with all type names. + -- Note that unlike the `Name` type in `unison-core1`, this list of name segments is in + -- forward order, e.g. `["base", "List", "map"]` + nameMapsFromV2Branch :: Monad m => V2Branch.CausalBranch m -> m (Map (NonEmpty V2Branch.NameSegment) (Set C.Referent.Referent), Map (NonEmpty V2Branch.NameSegment) (Set C.Reference.Reference)) + nameMapsFromV2Branch cb = do + b <- V2Causal.value cb + let (shallowTermNames, shallowTypeNames) = (Map.keysSet <$> V2Branch.terms b, Map.keysSet <$> V2Branch.types b) + allChildNames <- for (V2Branch.children b) nameMapsFromV2Branch + let (prefixedChildTerms, prefixedChildTypes) = + flip ifoldMap allChildNames \nameSegment (childTermNames, childTypeNames) -> + let addSegment = Map.mapKeys (nameSegment NEList.<|) + in (addSegment childTermNames, addSegment childTypeNames) + pure (Map.mapKeys (NEList.:| []) shallowTermNames <> prefixedChildTerms, Map.mapKeys (NEList.:| []) shallowTypeNames <> prefixedChildTypes) mkGetDeclType :: MonadIO m => m (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) mkGetDeclType = do @@ -618,10 +674,3 @@ mkGetDeclType = do pure $ \ref -> do conn <- Sqlite.unsafeGetConnection Sqlite.unsafeIO $ Cache.apply declTypeCache (\ref -> Sqlite.unsafeUnTransaction (getDeclType ref) conn) ref - --- | Update the root namespace names index which is used by the share server for serving api --- requests. -updateNameLookupIndex :: (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> Sqlite.Transaction () -updateNameLookupIndex getDeclType = do - root <- uncachedLoadRootBranch getDeclType - saveRootNamesIndex (Branch.toNames . Branch.head $ root) From 8098f285ba33118908ae8b68db79521ef7f8e7a0 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 17 Jun 2022 08:52:35 -0600 Subject: [PATCH 367/529] Redirect back to share URI after successful login (#3128) --- unison-cli/src/Unison/Auth/OAuth.hs | 24 +++++++++++++++--------- 1 file changed, 15 insertions(+), 9 deletions(-) diff --git a/unison-cli/src/Unison/Auth/OAuth.hs b/unison-cli/src/Unison/Auth/OAuth.hs index b31c40c76f..ba9d25426b 100644 --- a/unison-cli/src/Unison/Auth/OAuth.hs +++ b/unison-cli/src/Unison/Auth/OAuth.hs @@ -37,16 +37,19 @@ ucmOAuthClientID = "ucm" -- | A server in the format expected for a Wai Application -- This is a temporary server which is spun up only until we get a code back from the -- auth server. -authTransferServer :: (Code -> IO Response) -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived +authTransferServer :: (Code -> Maybe URI -> IO Response) -> Request -> (Response -> IO ResponseReceived) -> IO ResponseReceived authTransferServer callback req respond = - case (requestMethod req, pathInfo req, getCodeQuery req) of - ("GET", ["redirect"], Just code) -> do - callback code >>= respond + case (requestMethod req, pathInfo req, getQueryParams req) of + ("GET", ["redirect"], (Just code, maybeNextURI)) -> do + callback code maybeNextURI >>= respond _ -> respond (responseLBS status404 [] "Not Found") where - getCodeQuery req = do - code <- join $ Prelude.lookup "code" (queryString req) - pure $ Text.decodeUtf8 code + getQueryParams req = do + let code = join $ Prelude.lookup "code" (queryString req) + nextURI = do + nextBS <- join $ Prelude.lookup "next" (queryString req) + parseURI (BSC.unpack nextBS) + in (Text.decodeUtf8 <$> code, nextURI) -- | Direct the user through an authentication flow with the given server and store the -- credentials in the provided credential manager. @@ -63,7 +66,7 @@ authenticateCodeserver credsManager codeserverURI = UnliftIO.try @_ @CredentialF -- and it all works out fine. redirectURIVar <- UnliftIO.newEmptyMVar (verifier, challenge, state) <- generateParams - let codeHandler code = do + let codeHandler code mayNextURI = do redirectURI <- UnliftIO.readMVar redirectURIVar result <- exchangeCode httpClient tokenEndpoint code verifier redirectURI UnliftIO.putMVar authResultVar result @@ -72,7 +75,10 @@ authenticateCodeserver credsManager codeserverURI = UnliftIO.try @_ @CredentialF debugM Auth "Auth Error" err pure $ Wai.responseLBS internalServerError500 [] "Something went wrong, please try again." Right _ -> - pure $ Wai.responseLBS ok200 [] "Authorization successful. You may close this page and return to UCM." + case mayNextURI of + Nothing -> pure $ Wai.responseLBS found302 [] "Authorization successful. You may close this page and return to UCM." + Just nextURI -> + pure $ Wai.responseLBS found302 [("LOCATION", BSC.pack $ show @URI nextURI)] "Authorization successful. You may close this page and return to UCM." toIO <- UnliftIO.askRunInIO liftIO . Warp.withApplication (pure $ authTransferServer codeHandler) $ \port -> toIO $ do let redirectURI = "http://localhost:" <> show port <> "/redirect" From ec073f988a4484239ef1548ede96b55d4c4af8ec Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 17 Jun 2022 10:10:30 -0600 Subject: [PATCH 368/529] Ensure reversed names are actually reversed. --- .../Codebase/SqliteCodebase/Operations.hs | 21 ++++++++----------- 1 file changed, 9 insertions(+), 12 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index becd23f39b..21948ff5f4 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -7,7 +7,7 @@ -- are unified with non-sqlite operations in the Codebase interface, like 'appendReflog'. module Unison.Codebase.SqliteCodebase.Operations where -import Control.Lens (ifoldMap) +import Control.Lens (ifor) import Data.Bifunctor (Bifunctor (bimap), second) import Data.Bitraversable (bitraverse) import Data.Either.Extra () @@ -634,7 +634,7 @@ updateNameLookupIndexFromV2Root :: (C.Reference.Reference -> Sqlite.Transaction updateNameLookupIndexFromV2Root getDeclType = do rootHash <- Ops.expectRootCausalHash causalBranch <- Ops.expectCausalBranchByCausalHash rootHash - (termNameMap, typeNameMap) <- nameMapsFromV2Branch causalBranch + (termNameMap, typeNameMap) <- nameMapsFromV2Branch [] causalBranch let expandedTermNames = Map.toList termNameMap >>= (\(name, refs) -> (name,) <$> Set.toList refs) termNameList <- do for expandedTermNames \(name, ref) -> do @@ -655,18 +655,15 @@ updateNameLookupIndexFromV2Root getDeclType = do -- Traverse a v2 branch -- Collects two maps, one with all term names and one with all type names. - -- Note that unlike the `Name` type in `unison-core1`, this list of name segments is in - -- forward order, e.g. `["base", "List", "map"]` - nameMapsFromV2Branch :: Monad m => V2Branch.CausalBranch m -> m (Map (NonEmpty V2Branch.NameSegment) (Set C.Referent.Referent), Map (NonEmpty V2Branch.NameSegment) (Set C.Reference.Reference)) - nameMapsFromV2Branch cb = do + -- Note that unlike the `Name` type in `unison-core1`, this list of name segments is + -- in reverse order, e.g. `["map", "List", "base"]` + nameMapsFromV2Branch :: Monad m => [V2Branch.NameSegment] -> V2Branch.CausalBranch m -> m (Map (NonEmpty V2Branch.NameSegment) (Set C.Referent.Referent), Map (NonEmpty V2Branch.NameSegment) (Set C.Reference.Reference)) + nameMapsFromV2Branch reversedNamePrefix cb = do b <- V2Causal.value cb let (shallowTermNames, shallowTypeNames) = (Map.keysSet <$> V2Branch.terms b, Map.keysSet <$> V2Branch.types b) - allChildNames <- for (V2Branch.children b) nameMapsFromV2Branch - let (prefixedChildTerms, prefixedChildTypes) = - flip ifoldMap allChildNames \nameSegment (childTermNames, childTypeNames) -> - let addSegment = Map.mapKeys (nameSegment NEList.<|) - in (addSegment childTermNames, addSegment childTypeNames) - pure (Map.mapKeys (NEList.:| []) shallowTermNames <> prefixedChildTerms, Map.mapKeys (NEList.:| []) shallowTypeNames <> prefixedChildTypes) + (prefixedChildTerms, prefixedChildTypes) <- + fold <$> (ifor (V2Branch.children b) $ \nameSegment cb -> (nameMapsFromV2Branch (nameSegment : reversedNamePrefix) cb)) + pure (Map.mapKeys (NEList.:| reversedNamePrefix) shallowTermNames <> prefixedChildTerms, Map.mapKeys (NEList.:| reversedNamePrefix) shallowTypeNames <> prefixedChildTypes) mkGetDeclType :: MonadIO m => m (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) mkGetDeclType = do From 1df5751a2b4e65543446ca65e23c685ec95a1d15 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 17 Jun 2022 10:25:28 -0600 Subject: [PATCH 369/529] Fix mis-typed sqlite columns in name lookup index --- .../U/Codebase/Sqlite/Queries.hs | 23 ++++++++++--------- 1 file changed, 12 insertions(+), 11 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 860ba6ede5..d0c9de0d66 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -758,6 +758,7 @@ expectTempEntity hash = do |] {- ORMOLU_ENABLE -} + -- | look up all of the input entity's dependencies in the main table, to convert it to a sync entity tempToSyncEntity :: TempEntity -> Transaction SyncEntity tempToSyncEntity = \case @@ -1364,27 +1365,27 @@ resetNameLookupTables = do [here| CREATE TABLE term_name_lookup ( reversed_name TEXT NOT NULL, -- e.g. map.List.base - referent_builtin INTEGER NULL, - referent_object_id INTEGER NULL, + referent_builtin TEXT NULL, + referent_component_hash TEXT NULL, referent_component_index INTEGER NULL, referent_constructor_index INTEGER NULL, referent_constructor_type INTEGER NULL, - PRIMARY KEY (reversed_name, referent_builtin, referent_object_id, referent_component_index, referent_constructor_index) + PRIMARY KEY (reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index) ) |] -- Don't need this index at the moment, but will likely be useful later. -- execute_ -- [here| - -- CREATE INDEX IF NOT EXISTS term_name_by_referent_lookup ON term_name_lookup(referent_builtin, referent_object_id, referent_component_index, referent_constructor_index) + -- CREATE INDEX IF NOT EXISTS term_name_by_referent_lookup ON term_name_lookup(referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index) -- |] execute_ [here| CREATE TABLE type_name_lookup ( reversed_name TEXT NOT NULL, -- e.g. map.List.base - reference_builtin INTEGER NULL, - reference_object_id INTEGER NULL, + reference_builtin TEXT NULL, + reference_component_hash INTEGER NULL, reference_component_index INTEGER NULL, - PRIMARY KEY (reversed_name, reference_builtin, reference_object_id, reference_component_index) + PRIMARY KEY (reversed_name, reference_builtin, reference_component_hash, reference_component_index) ); |] @@ -1402,7 +1403,7 @@ insertTermNames names = do asRow (a, b) = a :. Only b sql = [here| - INSERT INTO term_name_lookup (reversed_name, referent_builtin, referent_object_id, referent_component_index, referent_constructor_index, referent_constructor_type) + INSERT INTO term_name_lookup (reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type) VALUES (?, ?, ?, ?, ?, ?) ON CONFLICT DO NOTHING |] @@ -1414,7 +1415,7 @@ insertTypeNames names = where sql = [here| - INSERT INTO type_name_lookup (reversed_name, reference_builtin, reference_object_id, reference_component_index) + INSERT INTO type_name_lookup (reversed_name, reference_builtin, reference_component_hash, reference_component_index) VALUES (?, ?, ?, ?) ON CONFLICT DO NOTHING |] @@ -1427,7 +1428,7 @@ rootTermNames = do unRow (a :. Only b) = (a, b) sql = [here| - SELECT reversed_name, referent_builtin, referent_object_id, referent_component_index, referent_constructor_index, referent_constructor_type FROM term_name_lookup + SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type FROM term_name_lookup ORDER BY reversed_name ASC |] @@ -1438,7 +1439,7 @@ rootTypeNames = do where sql = [here| - SELECT reversed_name, reference_builtin, reference_object_id, reference_component_index FROM type_name_lookup + SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index FROM type_name_lookup ORDER BY reversed_name ASC |] From f00c5153a22daffcf846e1b527392a06c36f38fb Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 17 Jun 2022 10:46:43 -0600 Subject: [PATCH 370/529] Add ensureAuthenticated combinator (#3127) --- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 8 +++++--- .../Unison/Codebase/Editor/HandleInput/AuthLogin.hs | 12 +++++++++++- 2 files changed, 16 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 33745c5d11..768438ab38 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -50,7 +50,7 @@ import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..)) import Unison.Codebase.Editor.Command as Command import Unison.Codebase.Editor.DisplayObject import qualified Unison.Codebase.Editor.Git as Git -import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin) +import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin, ensureAuthenticatedWithCodeserver) import Unison.Codebase.Editor.HandleInput.LoopState (Action, Action', MonadCommand (..), eval, liftF, respond, respondNumbered) import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState import qualified Unison.Codebase.Editor.HandleInput.NamespaceDependencies as NamespaceDependencies @@ -1858,11 +1858,12 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch) PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) -handlePushToUnisonShare :: MonadIO m => WriteShareRemotePath -> Path.Absolute -> PushBehavior -> Action' m v () +handlePushToUnisonShare :: (MonadUnliftIO m) => WriteShareRemotePath -> Path.Absolute -> PushBehavior -> Action' m v () handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} localPath behavior = do let codeserver = Codeserver.resolveCodeserver server let baseURL = codeserverBaseURL codeserver let sharePath = Share.Path (repo Nel.:| pathToSegments remotePath) + ensureAuthenticatedWithCodeserver codeserver LoopState.Env {authHTTPClient, codebase = Codebase {connection}} <- ask @@ -2313,10 +2314,11 @@ viewRemoteGitBranch :: viewRemoteGitBranch ns gitBranchBehavior action = do eval $ ViewRemoteGitBranch ns gitBranchBehavior action -importRemoteShareBranch :: MonadIO m => ReadShareRemoteNamespace -> Action' m v (Either (Output v) (Branch m)) +importRemoteShareBranch :: MonadUnliftIO m => ReadShareRemoteNamespace -> Action' m v (Either (Output v) (Branch m)) importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do let codeserver = Codeserver.resolveCodeserver server let baseURL = codeserverBaseURL codeserver + ensureAuthenticatedWithCodeserver codeserver mapLeft Output.ShareError <$> do let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs index 0b100261a2..71c9b25bd2 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/AuthLogin.hs @@ -1,12 +1,22 @@ -module Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin) where +module Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin, ensureAuthenticatedWithCodeserver) where import Control.Monad.Reader +import Unison.Auth.CredentialManager (getCredentials) import Unison.Auth.OAuth (authenticateCodeserver) import Unison.Codebase.Editor.HandleInput.LoopState import Unison.Codebase.Editor.Output (Output (CredentialFailureMsg, Success)) import Unison.Share.Types import qualified UnliftIO +-- | Checks if the user has valid auth for the given codeserver, +-- and runs through an authentication flow if not. +ensureAuthenticatedWithCodeserver :: UnliftIO.MonadUnliftIO m => CodeserverURI -> Action m i v () +ensureAuthenticatedWithCodeserver codeserverURI = do + credsMan <- asks credentialManager + getCredentials credsMan (codeserverIdFromCodeserverURI codeserverURI) >>= \case + Right _ -> pure () + Left _ -> authLogin codeserverURI + authLogin :: UnliftIO.MonadUnliftIO m => CodeserverURI -> Action m i v () authLogin host = do credsMan <- asks credentialManager From 7e830d41e8c80960764eb27bf3b5ebffb01a869c Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Fri, 17 Jun 2022 13:12:08 -0400 Subject: [PATCH 371/529] Update codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs Co-authored-by: Mitchell Rosen --- codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs index b7fb067575..f219c12940 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/HashHandle.hs @@ -15,7 +15,7 @@ data HashHandle = HashHandle toReference :: C.Term.Type Symbol -> C.Reference, -- | Hash type's mentions toReferenceMentions :: C.Term.Type Symbol -> Set C.Reference, - -- | Hash decl + -- | Hash the type of a single constructor in a decl component. The provided hash argument is the hash of the decl component. toReferenceDecl :: Hash -> C.Type.TypeD Symbol -> C.Reference, -- | Hash decl's mentions toReferenceDeclMentions :: Hash -> C.Type.TypeD Symbol -> Set C.Reference From 6628afc361df04be0694c78ba862c0b34be1e84c Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Fri, 17 Jun 2022 13:12:22 -0400 Subject: [PATCH 372/529] Update codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs Co-authored-by: Mitchell Rosen --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 2e41cff70f..5cad78f7c3 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -719,7 +719,6 @@ flushCausalDependents hh chId = do -- 3. For each like #bar and #baz with no more rows in temp_entity_missing_dependency, -- insert_entity them. tryMoveTempEntityDependents :: - -- | Move TempEntity to main HashHandle -> Hash32 -> Transaction () From ae075a2c4a6b940c89139d7ff88b83768968b1cb Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Fri, 17 Jun 2022 13:19:47 -0400 Subject: [PATCH 373/529] no RecordWildCards --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 6 ++---- 1 file changed, 2 insertions(+), 4 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 5cad78f7c3..32b4ef9c49 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} - -- | Some naming conventions used in this module: -- -- * @32@: the base32 representation of a hash @@ -1731,7 +1729,7 @@ saveTermComponent :: -- | term component [(C.Term Symbol, C.Term.Type Symbol)] -> Transaction ObjectId -saveTermComponent hh@HashHandle {..} maybeEncodedTerms h terms = do +saveTermComponent hh@HashHandle {toReference, toReferenceMentions} maybeEncodedTerms h terms = do when debug . traceM $ "Operations.saveTermComponent " ++ show h sTermElements <- traverse (uncurry c2sTerm) terms hashId <- saveHashHash h @@ -1790,7 +1788,7 @@ saveDeclComponent :: Hash -> [C.Decl Symbol] -> Transaction ObjectId -saveDeclComponent hh@HashHandle {..} maybeEncodedDecls h decls = do +saveDeclComponent hh@HashHandle {toReferenceDecl, toReferenceDeclMentions} maybeEncodedDecls h decls = do when debug . traceM $ "Operations.saveDeclComponent " ++ show h sDeclElements <- traverse (c2sDecl saveText expectObjectIdForPrimaryHash) decls hashId <- saveHashHash h From ad01752128f4a95fec1ca41afbc1c1e6523d8779 Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Fri, 17 Jun 2022 13:46:14 -0400 Subject: [PATCH 374/529] Update codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs --- codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 699898e449..dac3a01da4 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -888,6 +888,7 @@ tempToSyncEntity = \case {- ORMOLU_DISABLE -} +-- | looking up all of the text and hashes is the first step of converting a SyncEntity to a Share.Entity syncToTempEntity :: SyncEntity -> Transaction TempEntity syncToTempEntity = \case Entity.TC term -> Entity.TC <$> syncToTempTermComponent term From 8ba6e8445f28bf02e9500dbf2c028810b9145393 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 17 Jun 2022 15:46:30 -0400 Subject: [PATCH 375/529] Avoid a problem that was causing transcripts to fail. Seems like a bug that should be looked further into in the future --- parser-typechecker/src/Unison/Runtime/Machine.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index b37e675a74..82341efce2 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -1916,19 +1916,22 @@ universalEq frn = eqc && eql (==) us1 us2 && eql eqc bs1 bs2 eqc (Foreign fl) (Foreign fr) - | Just sl <- maybeUnwrapForeign Rf.listRef fl, - Just sr <- maybeUnwrapForeign Rf.listRef fr = - length sl == length sr && and (Sq.zipWith eqc sl sr) + -- TODO: if these guards are swappepd, transcripts fail. This doesn't make + -- sense, and seems likely to be unsafeCoerce related, but I'm not sure + -- exactly what's going on at the moment. | Just al <- maybeUnwrapForeign Rf.iarrayRef fl, Just ar <- maybeUnwrapForeign Rf.iarrayRef fr = arrayEq eqc al ar + | Just sl <- maybeUnwrapForeign Rf.listRef fl, + Just sr <- maybeUnwrapForeign Rf.listRef fr = + length sl == length sr && and (Sq.zipWith eqc sl sr) | otherwise = frn fl fr eqc c d = closureNum c == closureNum d arrayEq :: (Closure -> Closure -> Bool) -> PA.Array Closure -> PA.Array Closure -> Bool arrayEq eqc l r | PA.sizeofArray l /= PA.sizeofArray r = False - | otherwise = go (PA.sizeofArray l) + | otherwise = go (PA.sizeofArray l - 1) where go i | i < 0 = True From bbb2e52e6ae82b1ed597419faa0208631cae3de3 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 17 Jun 2022 15:47:19 -0400 Subject: [PATCH 376/529] Transcript fixes --- unison-src/transcripts/alias-many.output.md | 60 +++++++++---------- unison-src/transcripts/merges.output.md | 12 ++-- .../transcripts/name-selection.output.md | 18 +++--- unison-src/transcripts/reflog.output.md | 10 ++-- unison-src/transcripts/squash.output.md | 20 +++---- 5 files changed, 60 insertions(+), 60 deletions(-) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 097c377585..7e0db5619c 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -157,15 +157,15 @@ Let's try it! -> Nat -> Nat ->{g, Exception} () - 125. ImmutableByteArray.read16 : ImmutableByteArray - -> Nat - ->{Exception} Nat - 126. ImmutableByteArray.read32 : ImmutableByteArray - -> Nat - ->{Exception} Nat - 127. ImmutableByteArray.read64 : ImmutableByteArray - -> Nat - ->{Exception} Nat + 125. ImmutableByteArray.read16be : ImmutableByteArray + -> Nat + ->{Exception} Nat + 126. ImmutableByteArray.read32be : ImmutableByteArray + -> Nat + ->{Exception} Nat + 127. ImmutableByteArray.read64be : ImmutableByteArray + -> Nat + ->{Exception} Nat 128. ImmutableByteArray.read8 : ImmutableByteArray -> Nat ->{Exception} Nat @@ -470,30 +470,30 @@ Let's try it! ->{g} ImmutableByteArray 331. MutableByteArray.freeze! : MutableByteArray g ->{g} ImmutableByteArray - 332. MutableByteArray.read16 : MutableByteArray g - -> Nat - ->{g, Exception} Nat - 333. MutableByteArray.read32 : MutableByteArray g - -> Nat - ->{g, Exception} Nat - 334. MutableByteArray.read64 : MutableByteArray g - -> Nat - ->{g, Exception} Nat + 332. MutableByteArray.read16be : MutableByteArray g + -> Nat + ->{g, Exception} Nat + 333. MutableByteArray.read32be : MutableByteArray g + -> Nat + ->{g, Exception} Nat + 334. MutableByteArray.read64be : MutableByteArray g + -> Nat + ->{g, Exception} Nat 335. MutableByteArray.read8 : MutableByteArray g -> Nat ->{g, Exception} Nat - 336. MutableByteArray.write16 : MutableByteArray g - -> Nat - -> Nat - ->{g, Exception} () - 337. MutableByteArray.write32 : MutableByteArray g - -> Nat - -> Nat - ->{g, Exception} () - 338. MutableByteArray.write64 : MutableByteArray g - -> Nat - -> Nat - ->{g, Exception} () + 336. MutableByteArray.write16be : MutableByteArray g + -> Nat + -> Nat + ->{g, Exception} () + 337. MutableByteArray.write32be : MutableByteArray g + -> Nat + -> Nat + ->{g, Exception} () + 338. MutableByteArray.write64be : MutableByteArray g + -> Nat + -> Nat + ->{g, Exception} () 339. MutableByteArray.write8 : MutableByteArray g -> Nat -> Nat diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index b797063ede..0fd9667b3f 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -121,13 +121,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #abf3t3skdj + โŠ™ 1. #mcqqte53bn - Deletes: feature1.y - โŠ™ 2. #7u7981fggg + โŠ™ 2. #ujgae8vdq6 + Adds / updates: @@ -138,26 +138,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - โŠ™ 3. #n3thhc4ija + โŠ™ 3. #p4h54aa4ib + Adds / updates: feature1.y - โŠ™ 4. #emlkep058v + โŠ™ 4. #5duofffdoh > Moves: Original name New name x master.x - โŠ™ 5. #eh2rm2mt08 + โŠ™ 5. #s3idlrliqf + Adds / updates: x - โ–ก 6. #84g32tb0ov (start of history) + โ–ก 6. #9dqsngn7um (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md index 022eb242fc..eb37d42182 100644 --- a/unison-src/transcripts/name-selection.output.md +++ b/unison-src/transcripts/name-selection.output.md @@ -990,26 +990,26 @@ d = c + 10 ->{g} a 345. builtin.io2.TVar.read : TVar a ->{STM} a - 346. builtin.ImmutableByteArray.read16 : ImmutableByteArray + 346. builtin.ImmutableByteArray.read16be : ImmutableByteArray -> Nat ->{Exception} Nat - 347. builtin.MutableByteArray.read16 : MutableByteArray + 347. builtin.MutableByteArray.read16be : MutableByteArray g -> Nat ->{g, Exception} Nat - 348. builtin.ImmutableByteArray.read32 : ImmutableByteArray + 348. builtin.ImmutableByteArray.read32be : ImmutableByteArray -> Nat ->{Exception} Nat - 349. builtin.MutableByteArray.read32 : MutableByteArray + 349. builtin.MutableByteArray.read32be : MutableByteArray g -> Nat ->{g, Exception} Nat - 350. builtin.ImmutableByteArray.read64 : ImmutableByteArray + 350. builtin.ImmutableByteArray.read64be : ImmutableByteArray -> Nat ->{Exception} Nat - 351. builtin.MutableByteArray.read64 : MutableByteArray + 351. builtin.MutableByteArray.read64be : MutableByteArray g -> Nat ->{g, @@ -1212,19 +1212,19 @@ d = c + 10 429. builtin.io2.TVar.write : TVar a -> a ->{STM} () - 430. builtin.MutableByteArray.write16 : MutableByteArray + 430. builtin.MutableByteArray.write16be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 431. builtin.MutableByteArray.write32 : MutableByteArray + 431. builtin.MutableByteArray.write32be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 432. builtin.MutableByteArray.write64 : MutableByteArray + 432. builtin.MutableByteArray.write64be : MutableByteArray g -> Nat -> Nat diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index b3d1c15b90..0887ecd94c 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #rca6hfi0r8 .old` to make an old namespace + `fork #kf3i16i9lh .old` to make an old namespace accessible again, - `reset-root #rca6hfi0r8` to reset the root namespace and + `reset-root #kf3i16i9lh` to reset the root namespace and its history to that of the specified namespace. - 1. #lr7nj9g3hf : add - 2. #rca6hfi0r8 : add - 3. #eioje18gql : builtins.merge + 1. #u4dg7hpdsv : add + 2. #kf3i16i9lh : add + 3. #3omft8cib5 : builtins.merge 4. #sg60bvjo91 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index 3a838002d9..ad54c7a1d2 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - โ–ก 1. #6df7la2hva (start of history) + โ–ก 1. #pkghak0jll (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #0krh277ege + โŠ™ 1. #4kv78foqvp > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #togjet5r88 + โŠ™ 2. #idn2q6rkrk > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #6df7la2hva (start of history) + โ–ก 3. #pkghak0jll (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #0krh277ege + โŠ™ 1. #4kv78foqvp > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #togjet5r88 + โŠ™ 2. #idn2q6rkrk > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #6df7la2hva (start of history) + โ–ก 3. #pkghak0jll (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - โ–ก 1. #6df7la2hva (start of history) + โ–ก 1. #pkghak0jll (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #h7cl4aka6v + โŠ™ 1. #2sduecu6ns - Deletes: Nat.* Nat.+ - โ–ก 2. #6df7la2hva (start of history) + โ–ก 2. #pkghak0jll (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From e006ba28cf439df7e9062ceff6c04d37037edbf6 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 17 Jun 2022 15:39:04 -0600 Subject: [PATCH 377/529] Don't add duplicate auth headers --- unison-cli/src/Unison/Auth/HTTPClient.hs | 27 ++++++++++++++++-------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/unison-cli/src/Unison/Auth/HTTPClient.hs b/unison-cli/src/Unison/Auth/HTTPClient.hs index 4b7b0c25ff..5bfb18a4bb 100644 --- a/unison-cli/src/Unison/Auth/HTTPClient.hs +++ b/unison-cli/src/Unison/Auth/HTTPClient.hs @@ -32,12 +32,21 @@ newAuthenticatedHTTPClient responder tokenProvider ucmVersion = liftIO $ do -- If a host isn't associated with any credentials auth is omitted. authMiddleware :: (Output v -> IO ()) -> TokenProvider -> (Request -> IO Request) authMiddleware responder tokenProvider req = do - case codeserverIdFromURI $ (HTTP.getUri req) of - -- If we can't identify an appropriate codeserver we pass it through without any auth. - Left _ -> pure req - Right codeserverHost -> do - tokenProvider codeserverHost >>= \case - Right token -> pure $ HTTP.applyBearerAuth (Text.encodeUtf8 token) req - Left err -> do - responder (Output.CredentialFailureMsg err) - pure req + -- The http manager "may run this function multiple times" when preparing a request. + -- We may wish to look into a better way to attach auth to our requests in middleware, but + -- this is a simple fix that works for now. + -- https://github.com/snoyberg/http-client/issues/350 + case Prelude.lookup ("Authorization") (HTTP.requestHeaders req) of + Just _ -> pure req + Nothing -> do + case codeserverIdFromURI $ (HTTP.getUri req) of + -- If we can't identify an appropriate codeserver we pass it through without any auth. + Left _ -> pure req + Right codeserverHost -> do + tokenProvider codeserverHost >>= \case + Right token -> do + let newReq = HTTP.applyBearerAuth (Text.encodeUtf8 token) req + pure newReq + Left err -> do + responder (Output.CredentialFailureMsg err) + pure req From 05c27048265342695e807d562d2f5a6df9295f2d Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Sat, 18 Jun 2022 22:41:36 -0400 Subject: [PATCH 378/529] `do` parses as `'let` now, and this is used by pretty-printer Also updated round trip tests to exercise --- parser-typechecker/src/Unison/Lexer.hs | 2 + parser-typechecker/src/Unison/TermParser.hs | 6 + parser-typechecker/src/Unison/TermPrinter.hs | 26 +-- unison-src/transcripts-round-trip/main.md | 40 ++-- .../transcripts-round-trip/main.output.md | 174 +++++++++--------- 5 files changed, 130 insertions(+), 118 deletions(-) diff --git a/parser-typechecker/src/Unison/Lexer.hs b/parser-typechecker/src/Unison/Lexer.hs index 12c9e66ebc..5c9a4d3f18 100644 --- a/parser-typechecker/src/Unison/Lexer.hs +++ b/parser-typechecker/src/Unison/Lexer.hs @@ -929,6 +929,7 @@ lexemes' eof = <|> openKw "cases" <|> openKw "where" <|> openKw "let" + <|> openKw "do" where ifElse = openKw "if" <|> closeKw' (Just "then") ["if"] (lit "then") @@ -1270,6 +1271,7 @@ keywords = [ "if", "then", "else", + "do", "forall", "โˆ€", "handle", diff --git a/parser-typechecker/src/Unison/TermParser.hs b/parser-typechecker/src/Unison/TermParser.hs index 84c2802a85..57b0cde812 100644 --- a/parser-typechecker/src/Unison/TermParser.hs +++ b/parser-typechecker/src/Unison/TermParser.hs @@ -400,6 +400,7 @@ termLeaf = keywordBlock, list term, delayQuote, + delayBlock, bang, docBlock, doc2Block @@ -901,6 +902,11 @@ delayQuote = P.label "quote" $ do e <- termLeaf pure $ DD.delayTerm (ann start <> ann e) e +delayBlock :: Var v => TermP v +delayBlock = P.label "do" $ do + b <- block "do" + pure $ DD.delayTerm (ann b) b + bang :: Var v => TermP v bang = P.label "bang" $ do start <- reserved "!" diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index 852dd116dc..fd4550746d 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -254,17 +254,21 @@ pretty0 paren (p >= 11 || isBlock x && p >= 3) $ fmt S.DelayForceChar (l "!") <> pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x - Delay' x -> - paren (p >= 11 || isBlock x && p >= 3) $ - fmt S.DelayForceChar (l "'") - <> ( case x of - Lets' _ _ -> id - -- Add indentation below if we're opening parens with '( - -- This is in case the contents are a long function application - -- in which case the arguments should be indented. - _ -> PP.indentAfterNewline " " - ) - (pretty0 n (ac (if isBlock x then 0 else 10) Normal im doc) x) + Delay' x + | Lets' _ _ <- x -> + paren (p >= 3) $ + fmt S.ControlKeyword "do" `PP.hang` pretty0 n (ac 0 Block im doc) x + | otherwise -> + paren (p >= 11 || isBlock x && p >= 3) $ + fmt S.DelayForceChar (l "'") + <> ( case x of + Lets' _ _ -> id + -- Add indentation below if we're opening parens with '( + -- This is in case the contents are a long function application + -- in which case the arguments should be indented. + _ -> PP.indentAfterNewline " " + ) + (pretty0 n (ac 10 Normal im doc) x) List' xs -> PP.group $ (fmt S.DelimiterChar $ l "[") <> optSpace diff --git a/unison-src/transcripts-round-trip/main.md b/unison-src/transcripts-round-trip/main.md index d23dcdb25a..e0975b1241 100644 --- a/unison-src/transcripts-round-trip/main.md +++ b/unison-src/transcripts-round-trip/main.md @@ -266,7 +266,7 @@ broken = use Nat + y = 12 13 + y - !addNumbers + !addNumbers ``` ``` ucm @@ -282,7 +282,7 @@ broken = ```unison:hide tvarmodify tvar fun = () -broken tvar = +broken tvar = '(tvarmodify tvar (cases Some _ -> "oh boy isn't this a very very very very very very very long string?" None -> "")) @@ -299,7 +299,7 @@ broken tvar = ``` ```unison:hide -broken = cases +broken = cases Some loooooooooooooooooooooooooooooooooooooooooooooooooooooooong | loooooooooooooooooooooooooooooooooooooooooooooooooooooooong == 1 -> () ``` @@ -319,7 +319,7 @@ broken = cases structural type SomethingUnusuallyLong = SomethingUnusuallyLong Text Text Text foo = let - go x = + go x = 'match (a -> a) x with SomethingUnusuallyLong lijaefliejalfijelfj aefilaeifhlei liaehjffeafijij | lijaefliejalfijelfj == aefilaeifhlei -> 0 @@ -330,7 +330,7 @@ foo = let ```ucm .> add -.> edit SomethingUnusuallyLong foo +.> edit SomethingUnusuallyLong foo .> undo ``` @@ -357,11 +357,11 @@ foo = let ## Multiline expressions in multiliine lists ```unison:hide -foo a b c d e f g h i j = 42 +foo a b c d e f g h i j = 42 use Nat + x = [ 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 - , foo 12939233 2102020 329292 429292 522020 62929292 72020202 820202 920202 1020202 ] + , foo 12939233 2102020 329292 429292 522020 62929292 72020202 820202 920202 1020202 ] ``` ```ucm @@ -377,20 +377,20 @@ x = [ 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 ## Delayed computations passed to a function as the last argument When a delayed computation block is passed to a function as the last argument -in a context where the ambient precedence is low enough, we can elide parentheses -around it and use a "soft hang" to put the `'let` on the same line as the function call. +in a context where the ambient precedence is low enough, we can elide parentheses +around it and use a "soft hang" to put the `'let` on the same line as the function call. This looks nice. - forkAt usEast 'let + forkAt usEast do x = thing1 y = thing2 ... vs the not as pretty but still correct: - forkAt - usEast - ('let + forkAt + usEast + (do x = thing1 y = thing2 ...) @@ -400,33 +400,33 @@ Okay, here's the test, showing that we use the prettier version when possible: ```unison:hide (+) a b = ##Nat.+ a b -foo a b = 42 +foo a b = 42 -bar0 x = 'let +bar0 x = do a = 1 b = 2 foo a 'let c = 3 a + b -bar1 x = 'let +bar1 x = do a = 1 b = 2 foo (100 + 200 + 300 + 400 + 500 + 600 + 700 + 800 + 900 + 1000 + 1100 + 1200 + 1300 + 1400 + 1500) 'let c = 3 a + b -bar2 x = 'let +bar2 x = do a = 1 b = 2 - 1 + foo a 'let + 1 + foo a do c = 3 a + b -bar3 x = 'let +bar3 x = do a = 1 b = 2 - c = foo 'let + c = foo do c = 3 a + b c diff --git a/unison-src/transcripts-round-trip/main.output.md b/unison-src/transcripts-round-trip/main.output.md index 46b68ae073..47902b308c 100644 --- a/unison-src/transcripts-round-trip/main.output.md +++ b/unison-src/transcripts-round-trip/main.output.md @@ -34,15 +34,15 @@ x = 1 + 1 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #7q3vkcpt75 .old` to make an old namespace + `fork #3uk2laeo44 .old` to make an old namespace accessible again, - `reset-root #7q3vkcpt75` to reset the root namespace and + `reset-root #3uk2laeo44` to reset the root namespace and its history to that of the specified namespace. - 1. #9u7u21tka1 : add - 2. #7q3vkcpt75 : builtins.mergeio + 1. #5d37lofc79 : add + 2. #3uk2laeo44 : builtins.mergeio 3. #sg60bvjo91 : (initial reflogged namespace) .> reset-root 2 @@ -116,17 +116,17 @@ Without the above stanza, the `edit` will send the definition to the most recent most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #7q3vkcpt75 .old` to make an old namespace + `fork #3uk2laeo44 .old` to make an old namespace accessible again, - `reset-root #7q3vkcpt75` to reset the root namespace and + `reset-root #3uk2laeo44` to reset the root namespace and its history to that of the specified namespace. - 1. #braja24u2c : add - 2. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 3. #9u7u21tka1 : add - 4. #7q3vkcpt75 : builtins.mergeio + 1. #m90i9pca73 : add + 2. #3uk2laeo44 : reset-root #3uk2laeo44 + 3. #5d37lofc79 : add + 4. #3uk2laeo44 : builtins.mergeio 5. #sg60bvjo91 : (initial reflogged namespace) .> reset-root 2 @@ -191,19 +191,19 @@ f x = let most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #7q3vkcpt75 .old` to make an old namespace + `fork #3uk2laeo44 .old` to make an old namespace accessible again, - `reset-root #7q3vkcpt75` to reset the root namespace and + `reset-root #3uk2laeo44` to reset the root namespace and its history to that of the specified namespace. - 1. #r4cr8bjrq6 : add - 2. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 3. #braja24u2c : add - 4. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 5. #9u7u21tka1 : add - 6. #7q3vkcpt75 : builtins.mergeio + 1. #ru0oo7dcnh : add + 2. #3uk2laeo44 : reset-root #3uk2laeo44 + 3. #m90i9pca73 : add + 4. #3uk2laeo44 : reset-root #3uk2laeo44 + 5. #5d37lofc79 : add + 6. #3uk2laeo44 : builtins.mergeio 7. #sg60bvjo91 : (initial reflogged namespace) .> reset-root 2 @@ -273,21 +273,21 @@ h xs = match xs with most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #7q3vkcpt75 .old` to make an old namespace + `fork #3uk2laeo44 .old` to make an old namespace accessible again, - `reset-root #7q3vkcpt75` to reset the root namespace and + `reset-root #3uk2laeo44` to reset the root namespace and its history to that of the specified namespace. - 1. #uhh1lpve1d : add - 2. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 3. #r4cr8bjrq6 : add - 4. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 5. #braja24u2c : add - 6. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 7. #9u7u21tka1 : add - 8. #7q3vkcpt75 : builtins.mergeio + 1. #c5qfjje3vn : add + 2. #3uk2laeo44 : reset-root #3uk2laeo44 + 3. #ru0oo7dcnh : add + 4. #3uk2laeo44 : reset-root #3uk2laeo44 + 5. #m90i9pca73 : add + 6. #3uk2laeo44 : reset-root #3uk2laeo44 + 7. #5d37lofc79 : add + 8. #3uk2laeo44 : builtins.mergeio 9. #sg60bvjo91 : (initial reflogged namespace) .> reset-root 2 @@ -353,23 +353,23 @@ foo n _ = n most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #7q3vkcpt75 .old` to make an old namespace + `fork #3uk2laeo44 .old` to make an old namespace accessible again, - `reset-root #7q3vkcpt75` to reset the root namespace and + `reset-root #3uk2laeo44` to reset the root namespace and its history to that of the specified namespace. - 1. #v4mbt4a1fa : add - 2. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 3. #uhh1lpve1d : add - 4. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 5. #r4cr8bjrq6 : add - 6. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 7. #braja24u2c : add - 8. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 9. #9u7u21tka1 : add - 10. #7q3vkcpt75 : builtins.mergeio + 1. #90vn9fdk1t : add + 2. #3uk2laeo44 : reset-root #3uk2laeo44 + 3. #c5qfjje3vn : add + 4. #3uk2laeo44 : reset-root #3uk2laeo44 + 5. #ru0oo7dcnh : add + 6. #3uk2laeo44 : reset-root #3uk2laeo44 + 7. #m90i9pca73 : add + 8. #3uk2laeo44 : reset-root #3uk2laeo44 + 9. #5d37lofc79 : add + 10. #3uk2laeo44 : builtins.mergeio 11. #sg60bvjo91 : (initial reflogged namespace) .> reset-root 2 @@ -432,25 +432,25 @@ foo = most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #7q3vkcpt75 .old` to make an old namespace + `fork #3uk2laeo44 .old` to make an old namespace accessible again, - `reset-root #7q3vkcpt75` to reset the root namespace and + `reset-root #3uk2laeo44` to reset the root namespace and its history to that of the specified namespace. - 1. #qam2buklki : add - 2. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 3. #v4mbt4a1fa : add - 4. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 5. #uhh1lpve1d : add - 6. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 7. #r4cr8bjrq6 : add - 8. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 9. #braja24u2c : add - 10. #7q3vkcpt75 : reset-root #7q3vkcpt75 - 11. #9u7u21tka1 : add - 12. #7q3vkcpt75 : builtins.mergeio + 1. #fqe7rpjits : add + 2. #3uk2laeo44 : reset-root #3uk2laeo44 + 3. #90vn9fdk1t : add + 4. #3uk2laeo44 : reset-root #3uk2laeo44 + 5. #c5qfjje3vn : add + 6. #3uk2laeo44 : reset-root #3uk2laeo44 + 7. #ru0oo7dcnh : add + 8. #3uk2laeo44 : reset-root #3uk2laeo44 + 9. #m90i9pca73 : add + 10. #3uk2laeo44 : reset-root #3uk2laeo44 + 11. #5d37lofc79 : add + 12. #3uk2laeo44 : builtins.mergeio 13. #sg60bvjo91 : (initial reflogged namespace) .> reset-root 2 @@ -595,7 +595,7 @@ x = '(let x : 'Optional Nat x = - ('let + (do abort 0) |> toOptional @@ -665,7 +665,7 @@ r = 'let /Users/pchiusano/unison/scratch.u r : 'Nat - r = 'let + r = do y = 0 y @@ -770,7 +770,7 @@ broken = use Nat + y = 12 13 + y - !addNumbers + !addNumbers ``` ```ucm @@ -790,7 +790,7 @@ broken = broken : Nat broken = addNumbers : 'Nat - addNumbers = 'let + addNumbers = do use Nat + y = 12 13 + y @@ -823,7 +823,7 @@ broken = ```unison tvarmodify tvar fun = () -broken tvar = +broken tvar = '(tvarmodify tvar (cases Some _ -> "oh boy isn't this a very very very very very very very long string?" None -> "")) @@ -883,7 +883,7 @@ broken tvar = ``` ```unison -broken = cases +broken = cases Some loooooooooooooooooooooooooooooooooooooooooooooooooooooooong | loooooooooooooooooooooooooooooooooooooooooooooooooooooooong == 1 -> () ``` @@ -938,7 +938,7 @@ broken = cases structural type SomethingUnusuallyLong = SomethingUnusuallyLong Text Text Text foo = let - go x = + go x = 'match (a -> a) x with SomethingUnusuallyLong lijaefliejalfijelfj aefilaeifhlei liaehjffeafijij | lijaefliejalfijelfj == aefilaeifhlei -> 0 @@ -955,7 +955,7 @@ foo = let structural type SomethingUnusuallyLong foo : 'Nat -.> edit SomethingUnusuallyLong foo +.> edit SomethingUnusuallyLong foo โ˜๏ธ @@ -968,11 +968,11 @@ foo = let foo : 'Nat foo = go x = - 'match (a -> a) x with + '(match (a -> a) x with SomethingUnusuallyLong lijaefliejalfijelfj aefilaeifhlei liaehjffeafijij | lijaefliejalfijelfj == aefilaeifhlei -> 0 - | lijaefliejalfijelfj == liaehjffeafijij -> 1 + | lijaefliejalfijelfj == liaehjffeafijij -> 1) go (SomethingUnusuallyLong "one" "two" "three") You can edit them there, then do `update` to replace the @@ -1068,11 +1068,11 @@ foo = let ## Multiline expressions in multiliine lists ```unison -foo a b c d e f g h i j = 42 +foo a b c d e f g h i j = 42 use Nat + x = [ 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 - , foo 12939233 2102020 329292 429292 522020 62929292 72020202 820202 920202 1020202 ] + , foo 12939233 2102020 329292 429292 522020 62929292 72020202 820202 920202 1020202 ] ``` ```ucm @@ -1176,20 +1176,20 @@ x = [ 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 ## Delayed computations passed to a function as the last argument When a delayed computation block is passed to a function as the last argument -in a context where the ambient precedence is low enough, we can elide parentheses -around it and use a "soft hang" to put the `'let` on the same line as the function call. +in a context where the ambient precedence is low enough, we can elide parentheses +around it and use a "soft hang" to put the `'let` on the same line as the function call. This looks nice. - forkAt usEast 'let + forkAt usEast do x = thing1 y = thing2 ... vs the not as pretty but still correct: - forkAt - usEast - ('let + forkAt + usEast + (do x = thing1 y = thing2 ...) @@ -1199,33 +1199,33 @@ Okay, here's the test, showing that we use the prettier version when possible: ```unison (+) a b = ##Nat.+ a b -foo a b = 42 +foo a b = 42 -bar0 x = 'let +bar0 x = do a = 1 b = 2 foo a 'let c = 3 a + b -bar1 x = 'let +bar1 x = do a = 1 b = 2 foo (100 + 200 + 300 + 400 + 500 + 600 + 700 + 800 + 900 + 1000 + 1100 + 1200 + 1300 + 1400 + 1500) 'let c = 3 a + b -bar2 x = 'let +bar2 x = do a = 1 b = 2 - 1 + foo a 'let + 1 + foo a do c = 3 a + b -bar3 x = 'let +bar3 x = do a = 1 b = 2 - c = foo 'let + c = foo do c = 3 a + b c @@ -1251,16 +1251,16 @@ bar3 x = 'let /Users/pchiusano/unison/scratch.u bar0 : x -> () -> Nat - bar0 x = 'let + bar0 x = do a = 1 b = 2 - foo a 'let + foo a do c = 3 a + b bar1 : x -> () -> Nat bar1 x = - 'let + do a = 1 b = 2 foo @@ -1279,24 +1279,24 @@ bar3 x = 'let + 1300 + 1400 + 1500) - 'let + do c = 3 a + b bar2 : x -> () -> Nat - bar2 x = 'let + bar2 x = do a = 1 b = 2 - 1 + (foo a 'let + 1 + (foo a do c = 3 a + b) bar3 : x -> () -> b -> Nat - bar3 x = 'let + bar3 x = do a = 1 b = 2 c = - foo 'let + foo do c = 3 a + b c From 582332d0c1ad593e2e3d856bc332217bce3fbe8d Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Sat, 18 Jun 2022 23:01:27 -0400 Subject: [PATCH 379/529] update unit test to show use of `do` syntax --- parser-typechecker/tests/Unison/Test/TermPrinter.hs | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/tests/Unison/Test/TermPrinter.hs b/parser-typechecker/tests/Unison/Test/TermPrinter.hs index cb697a2d48..a52e90c416 100644 --- a/parser-typechecker/tests/Unison/Test/TermPrinter.hs +++ b/parser-typechecker/tests/Unison/Test/TermPrinter.hs @@ -477,11 +477,15 @@ test = tcBreaks 50 "if true then match x with 12 -> x else x", tcBreaks 50 "if true then x else match x with 12 -> x", pending $ tcBreaks 80 "x -> (if c then t else f)", -- TODO 'unexpected )', surplus parens - tcBreaks - 80 + tcDiffRtt + True "'let\n\ \ foo = bar\n\ - \ baz foo", + \ baz foo" + "do\n\ + \ foo = bar\n\ + \ baz foo" + 80, tcBreaks 80 "!let\n\ From 3e1bf1d82f764664c112067ac36b567e9fb21e11 Mon Sep 17 00:00:00 2001 From: Dan Freeman Date: Sun, 19 Jun 2022 16:20:40 -0600 Subject: [PATCH 380/529] Add dfreeman to the contributor list --- CONTRIBUTORS.markdown | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.markdown b/CONTRIBUTORS.markdown index cff5437fb0..1d059cc2d0 100644 --- a/CONTRIBUTORS.markdown +++ b/CONTRIBUTORS.markdown @@ -68,3 +68,4 @@ The format for this list: name, GitHub handle * Harald Gliebe (@hagl) * Phil de Joux (@philderbeast) * Travis Staton (@tstat) +* Dan Freeman (@dfreeman) From 1c5f9a2d3c1f7615e5eacdda83adfcb393405ac0 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Mon, 20 Jun 2022 15:52:14 -0400 Subject: [PATCH 381/529] Avoid inilning a function with `unsafeCoerce` When it's inlined, it seems to cause strange behavior in the places it's called, likely due to unsound optimizations. --- parser-typechecker/src/Unison/Runtime/Foreign.hs | 1 + parser-typechecker/src/Unison/Runtime/Machine.hs | 3 --- 2 files changed, 1 insertion(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/Foreign.hs b/parser-typechecker/src/Unison/Runtime/Foreign.hs index 474edb1049..ba60cdfa74 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign.hs @@ -115,6 +115,7 @@ maybeUnwrapForeign :: Reference -> Foreign -> Maybe a maybeUnwrapForeign rt (Wrap r e) | rt == r = Just (unsafeCoerce e) | otherwise = Nothing +{-# NOINLINE maybeUnwrapForeign #-} class BuiltinForeign f where foreignRef :: Tagged f Reference diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index 82341efce2..80a2df9956 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -1916,9 +1916,6 @@ universalEq frn = eqc && eql (==) us1 us2 && eql eqc bs1 bs2 eqc (Foreign fl) (Foreign fr) - -- TODO: if these guards are swappepd, transcripts fail. This doesn't make - -- sense, and seems likely to be unsafeCoerce related, but I'm not sure - -- exactly what's going on at the moment. | Just al <- maybeUnwrapForeign Rf.iarrayRef fl, Just ar <- maybeUnwrapForeign Rf.iarrayRef fr = arrayEq eqc al ar From 6f5e2c74db0709831e2ee8f0c549dcc9420ea0f9 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 20 Jun 2022 16:04:45 -0400 Subject: [PATCH 382/529] make pull report number of outstanding entities to download (like push) --- .../src/Unison/Codebase/Editor/HandleInput.hs | 22 ++++- unison-cli/src/Unison/Share/Sync.hs | 97 +++++++++---------- 2 files changed, 65 insertions(+), 54 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 768438ab38..9fbb862ba0 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -146,6 +146,7 @@ import qualified Unison.Server.SearchResult as SR import qualified Unison.Server.SearchResult' as SR' import qualified Unison.Share.Codeserver as Codeserver import qualified Unison.Share.Sync as Share +import qualified Unison.Share.Sync.Types as Sync import Unison.Share.Types (codeserverBaseURL) import qualified Unison.ShortHash as SH import qualified Unison.Sqlite as Sqlite @@ -174,7 +175,6 @@ import Unison.Util.TransitiveClosure (transitiveClosure) import Unison.Var (Var) import qualified Unison.Var as Var import qualified Unison.WatchKind as WK -import qualified Unison.Share.Sync.Types as Sync defaultPatchNameSegment :: NameSegment defaultPatchNameSegment = "patch" @@ -2339,16 +2339,28 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" Just branch -> pure (Right branch) where - -- Provide the given action a callback that prints out the number of entities downloaded. - withEntitiesDownloadedProgressCallback :: ((Int -> IO ()) -> IO a) -> IO a + -- Provide the given action a callback that prints out the number of entities downloaded, and the number of entities + -- enqueued to be downloaded. + withEntitiesDownloadedProgressCallback :: ((Int -> Int -> IO ()) -> IO a) -> IO a withEntitiesDownloadedProgressCallback action = do entitiesDownloadedVar <- newTVarIO 0 + entitiesToDownloadVar <- newTVarIO 0 Console.Regions.displayConsoleRegions do Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do Console.Regions.setConsoleRegion region do entitiesDownloaded <- readTVar entitiesDownloadedVar - pure ("\n Downloaded " <> tShow entitiesDownloaded <> " entities...\n\n") - result <- action \entitiesDownloaded -> atomically (writeTVar entitiesDownloadedVar entitiesDownloaded) + entitiesToDownload <- readTVar entitiesToDownloadVar + pure $ + "\n Downloaded " + <> tShow entitiesDownloaded + <> "/" + <> tShow (entitiesDownloaded + entitiesToDownload) + <> " entities...\n\n" + result <- + action \entitiesDownloaded entitiesToDownload -> + atomically do + writeTVar entitiesDownloadedVar entitiesDownloaded + writeTVar entitiesToDownloadVar entitiesToDownload entitiesDownloaded <- readTVarIO entitiesDownloadedVar Console.Regions.finishConsoleRegion region $ "\n Downloaded " <> tShow entitiesDownloaded <> " entities.\n" diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index e242b70a42..a9dd5875fb 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -24,7 +24,6 @@ import Control.Monad.Except import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader import qualified Data.Foldable as Foldable (find) -import Data.IORef (atomicModifyIORef', newIORef) import Data.List.NonEmpty (pattern (:|)) import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as List.NonEmpty @@ -336,63 +335,54 @@ pull :: Sqlite.Connection -> -- | The repo+path to pull from. Share.Path -> - -- | Callback that is given the total number of entities downloaded. - (Int -> IO ()) -> + -- | Callback that is given the total number of entities downloaded, and the number of outstanding entities to + -- download. + (Int -> Int -> IO ()) -> IO (Either (SyncError PullError) CausalHash) -pull httpClient unisonShareUrl conn repoPath@(Share.pathRepoName -> repoName) downloadCountCallback = catchSyncErrors do +pull httpClient unisonShareUrl conn repoPath downloadProgressCallback = catchSyncErrors do getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case Left err -> pure (Left (PullErrorGetCausalHashByPath err)) -- There's nothing at the remote path, so there's no causal to pull. Right Nothing -> pure (Left (PullErrorNoHistoryAtPath repoPath)) Right (Just hashJwt) -> do let hash = Share.hashJWTHash hashJwt - doDownload <- makeDoDownload httpClient unisonShareUrl repoName downloadCountCallback - tempEntities <- + (maybeTempEntities, downloadedSoFar) <- Sqlite.runTransaction conn (Q.entityLocation hash) >>= \case - Just Q.EntityInMainStorage -> pure Nothing - Just Q.EntityInTempStorage -> pure (Just (NESet.singleton hash)) - Nothing -> downloadEntities doDownload conn (NESet.singleton hashJwt) - whenJust tempEntities (completeTempEntities doDownload conn) + Just Q.EntityInMainStorage -> pure (Nothing, 0) + Just Q.EntityInTempStorage -> pure (Just (NESet.singleton hash), 0) + Nothing -> do + tempEntities <- doDownload (NESet.singleton hashJwt) + pure (tempEntities, 1) + downloadedTotal <- + case maybeTempEntities of + Nothing -> pure downloadedSoFar + Just tempEntities -> do + completeTempEntities + doDownload + conn + (\downloaded enqueued -> downloadProgressCallback (downloaded + downloadedSoFar) enqueued) + tempEntities + downloadProgressCallback downloadedTotal 0 pure (Right (hash32ToCausalHash hash)) + where + repoName = Share.pathRepoName repoPath + doDownload = downloadEntities httpClient unisonShareUrl conn repoName --- Make a "do download" function - it's in IO in order to close over an IORef that contains the total count of --- entities we've downloaded. -makeDoDownload :: - -- | The HTTP client to use for Unison Share requests. - AuthenticatedHttpClient -> - -- | The Unison Share URL. - BaseUrl -> - -- | The repo to pull from. - Share.RepoName -> - -- | Callback that is given the total number of entities downloaded. - (Int -> IO ()) -> - IO (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -makeDoDownload httpClient unisonShareUrl repoName downloadCountCallback = do - downloadCountRef <- newIORef 0 - pure \hashes -> do - -- we feel okay ignoring the "no read permission" case because it should have been triggered by getCausalHashByPath - Share.DownloadEntitiesSuccess entities <- - httpDownloadEntities - httpClient - unisonShareUrl - Share.DownloadEntitiesRequest {repoName, hashes} - newDownloadCount <- - atomicModifyIORef' downloadCountRef \count -> let count' = count + NEMap.size entities in (count', count') - downloadCountCallback newDownloadCount - pure entities - --- | Finish downloading entities from Unison Share +-- | Finish downloading entities from Unison Share. Returns the total number of entities downloaded. -- -- Precondition: the entities were *already* downloaded at some point in the past, and are now sitting in the -- `temp_entity` table, waiting for their dependencies to arrive so they can be flushed to main storage. completeTempEntities :: - (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -> + (NESet Share.HashJWT -> IO (Maybe (NESet Hash32))) -> Sqlite.Connection -> + (Int -> Int -> IO ()) -> NESet Hash32 -> - IO () -completeTempEntities doDownload conn = - let loop :: NESet Share.HashJWT -> IO () - loop allHashes = do + IO Int +completeTempEntities doDownload conn downloadProgressCallback = + let loop :: Int -> NESet Share.HashJWT -> IO Int + loop !downloadCount allHashes = do + downloadProgressCallback downloadCount (NESet.size allHashes) + -- Each request only contains a certain maximum number of entities; split the set of hashes we need to download -- into those we will download right now, and those we will begin downloading on the next iteration of the loop. let (hashes, nextHashes0) = @@ -400,14 +390,17 @@ completeTempEntities doDownload conn = This hs1 -> (hs1, Set.empty) That hs2 -> (hs2, Set.empty) -- impossible, this only happens if we split at 0 These hs1 hs2 -> (hs1, NESet.toSet hs2) - nextHashes <- - downloadEntities doDownload conn hashes >>= \case + maybeNextHashes <- + doDownload hashes >>= \case Nothing -> pure (NESet.nonEmptySet nextHashes0) Just newTempEntities -> do newElaboratedHashes <- elaborate newTempEntities pure (Just (union10 newElaboratedHashes nextHashes0)) - whenJust nextHashes loop - in \hashes0 -> elaborate hashes0 >>= loop + let !newDownloadCount = downloadCount + NESet.size hashes + case maybeNextHashes of + Nothing -> pure newDownloadCount + Just nextHashes -> loop newDownloadCount nextHashes + in \hashes0 -> elaborate hashes0 >>= loop 0 where elaborate :: NESet Hash32 -> IO (NESet Share.HashJWT) elaborate hashes = @@ -416,12 +409,18 @@ completeTempEntities doDownload conn = -- | Download a set of entities from Unison Share. Returns the subset of those entities that we stored in temp storage -- (`temp_entitiy`) instead of main storage (`object` / `causal`) due to missing dependencies. downloadEntities :: - (NESet Share.HashJWT -> IO (NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT))) -> + AuthenticatedHttpClient -> + BaseUrl -> Sqlite.Connection -> + Share.RepoName -> NESet Share.HashJWT -> IO (Maybe (NESet Hash32)) -downloadEntities doDownload conn hashes = do - entities <- doDownload hashes +downloadEntities httpClient unisonShareUrl conn repoName hashes = do + Share.DownloadEntitiesSuccess entities <- + httpDownloadEntities + httpClient + unisonShareUrl + Share.DownloadEntitiesRequest {repoName, hashes} fmap NESet.nonEmptySet do Sqlite.runTransaction conn do NEMap.toList entities & foldMapM \(hash, entity) -> From 021b9965f690229bde1366be5adb342f6de30d36 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 21 Jun 2022 10:17:58 -0600 Subject: [PATCH 383/529] Use production share server (#3138) * Use production share server * Don't use port in default share server It won't recognize the codeserver in auth checks if the port is implied later, since https://host:443 /= https://host --- parser-typechecker/src/Unison/Share/Types.hs | 8 ++++---- unison-cli/src/Unison/Share/Codeserver.hs | 7 +++---- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/parser-typechecker/src/Unison/Share/Types.hs b/parser-typechecker/src/Unison/Share/Types.hs index 4b27b437e9..5c8cd73211 100644 --- a/parser-typechecker/src/Unison/Share/Types.hs +++ b/parser-typechecker/src/Unison/Share/Types.hs @@ -116,9 +116,9 @@ newtype CodeserverId = CodeserverId {codeserverId :: Text} -- -- >>> import Data.Maybe (fromJust) -- >>> import Network.URI (parseURI) --- >>> codeserverIdFromURI (CodeserverURI . fromJust $ parseURI "http://localhost:5424/api") --- >>> codeserverIdFromURI (CodeserverURI . fromJust $ parseURI "https://share.unison-lang.org/api") --- Right "localhost" +-- >>> codeserverIdFromURI (fromJust $ parseURI "http://localhost:5424/api") +-- >>> codeserverIdFromURI (fromJust $ parseURI "https://share.unison-lang.org/api") +-- Right "localhost:5424" -- Right "share.unison-lang.org" codeserverIdFromURI :: URI -> Either Text CodeserverId codeserverIdFromURI uri = @@ -129,7 +129,7 @@ codeserverIdFromURI uri = -- | Builds a CodeserverId from a URIAuth codeserverIdFromURIAuth :: URIAuth -> CodeserverId codeserverIdFromURIAuth ua = - (CodeserverId (Text.pack $ uriUserInfo ua <> uriRegName ua <> uriPort ua)) + (CodeserverId (Text.pack $ uriRegName ua <> uriPort ua)) -- | Gets the CodeserverId for a given CodeserverURI codeserverIdFromCodeserverURI :: CodeserverURI -> CodeserverId diff --git a/unison-cli/src/Unison/Share/Codeserver.hs b/unison-cli/src/Unison/Share/Codeserver.hs index 9e2b710e5d..f12bc36426 100644 --- a/unison-cli/src/Unison/Share/Codeserver.hs +++ b/unison-cli/src/Unison/Share/Codeserver.hs @@ -12,14 +12,13 @@ import UnliftIO.Environment (lookupEnv) defaultCodeserver :: CodeserverURI defaultCodeserver = unsafePerformIO $ do lookupEnv "UNISON_SHARE_HOST" <&> \case - -- TODO: swap to production share before release. Nothing -> CodeserverURI { codeserverScheme = Share.Https, codeserverUserInfo = "", - codeserverRegName = "share-next.us-west-2.unison-lang.org", - codeserverPort = Just 443, - codeserverPath = ["api"] + codeserverRegName = "api.unison-lang.org", + codeserverPort = Nothing, + codeserverPath = [] } Just shareHost -> fromMaybe (error $ "Share Host is not a valid URI: " <> shareHost) $ do From f898cd6ecbc13333c2ebd94579db954253e0c2e7 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 21 Jun 2022 10:42:41 -0600 Subject: [PATCH 384/529] Make user id optional on hash-jwts to accomodate unauthenticated public downloads. (#3141) --- unison-share-api/src/Unison/Sync/Types.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 6e8e12c638..8fa5ae1e9b 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -152,7 +152,7 @@ hashJWTHash = data HashJWTClaims = HashJWTClaims { hash :: Hash32, - userId :: Text + userId :: Maybe Text } deriving stock (Show, Eq, Ord) From ea143517e5f587107704429a7d363c2ac3aba885 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 21 Jun 2022 11:09:16 -0600 Subject: [PATCH 385/529] Don't auto-login on pulling public routes; pull base from share (#3139) * Don't auto-login on pulling public routes. * Update base version parser * Fix version parser tests * Don't print error on unauthenticated requests, need to wait to see if the server 401's first. * Update unison-cli/src/Unison/Codebase/Editor/HandleInput.hs Co-authored-by: Mitchell Rosen * out of date comment Co-authored-by: Mitchell Rosen --- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 6 ++++ unison-cli/src/Unison/Auth/HTTPClient.hs | 15 ++++----- .../src/Unison/Codebase/Editor/HandleInput.hs | 5 +-- .../Unison/Codebase/Editor/VersionParser.hs | 32 +++++++++---------- .../src/Unison/Codebase/TranscriptParser.hs | 2 +- unison-cli/src/Unison/CommandLine/Main.hs | 2 +- unison-cli/src/Unison/CommandLine/Welcome.hs | 14 ++++---- unison-cli/tests/Unison/Test/VersionParser.hs | 10 +++--- unison-cli/unison/Main.hs | 4 +-- 9 files changed, 46 insertions(+), 44 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 973a6f298a..bc50360f82 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -119,6 +119,12 @@ data ReadShareRemoteNamespace = ReadShareRemoteNamespace } deriving stock (Eq, Show) +isPublic :: ReadShareRemoteNamespace -> Bool +isPublic ReadShareRemoteNamespace {path} = + case path of + ("public" Path.:< _) -> True + _ -> False + data WriteRemotePath = WriteRemotePathGit WriteGitRemotePath | WriteRemotePathShare WriteShareRemotePath diff --git a/unison-cli/src/Unison/Auth/HTTPClient.hs b/unison-cli/src/Unison/Auth/HTTPClient.hs index 5bfb18a4bb..441f0a93fd 100644 --- a/unison-cli/src/Unison/Auth/HTTPClient.hs +++ b/unison-cli/src/Unison/Auth/HTTPClient.hs @@ -5,8 +5,6 @@ import Network.HTTP.Client (Request) import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Client.TLS as HTTP import Unison.Auth.Tokens (TokenProvider) -import Unison.Codebase.Editor.Output (Output) -import qualified Unison.Codebase.Editor.Output as Output import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Prelude import Unison.Share.Types (codeserverIdFromURI) @@ -17,11 +15,11 @@ newtype AuthenticatedHttpClient = AuthenticatedHttpClient HTTP.Manager -- | Returns a new http manager which applies the appropriate Authorization header to -- any hosts our UCM is authenticated with. -newAuthenticatedHTTPClient :: MonadIO m => (Output v -> IO ()) -> TokenProvider -> UCMVersion -> m AuthenticatedHttpClient -newAuthenticatedHTTPClient responder tokenProvider ucmVersion = liftIO $ do +newAuthenticatedHTTPClient :: MonadIO m => TokenProvider -> UCMVersion -> m AuthenticatedHttpClient +newAuthenticatedHTTPClient tokenProvider ucmVersion = liftIO $ do let managerSettings = HTTP.tlsManagerSettings - & HTTP.addRequestMiddleware (authMiddleware responder tokenProvider) + & HTTP.addRequestMiddleware (authMiddleware tokenProvider) & HTTP.setUserAgent (HTTP.ucmUserAgent ucmVersion) AuthenticatedHttpClient <$> HTTP.newTlsManagerWith managerSettings @@ -30,8 +28,8 @@ newAuthenticatedHTTPClient responder tokenProvider ucmVersion = liftIO $ do -- and the request is likely to trigger a 401 response which the caller can detect and initiate a re-auth. -- -- If a host isn't associated with any credentials auth is omitted. -authMiddleware :: (Output v -> IO ()) -> TokenProvider -> (Request -> IO Request) -authMiddleware responder tokenProvider req = do +authMiddleware :: TokenProvider -> (Request -> IO Request) +authMiddleware tokenProvider req = do -- The http manager "may run this function multiple times" when preparing a request. -- We may wish to look into a better way to attach auth to our requests in middleware, but -- this is a simple fix that works for now. @@ -47,6 +45,5 @@ authMiddleware responder tokenProvider req = do Right token -> do let newReq = HTTP.applyBearerAuth (Text.encodeUtf8 token) req pure newReq - Left err -> do - responder (Output.CredentialFailureMsg err) + Left _err -> do pure req diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 768438ab38..ad32cb89bf 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -2315,10 +2315,11 @@ viewRemoteGitBranch ns gitBranchBehavior action = do eval $ ViewRemoteGitBranch ns gitBranchBehavior action importRemoteShareBranch :: MonadUnliftIO m => ReadShareRemoteNamespace -> Action' m v (Either (Output v) (Branch m)) -importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do +importRemoteShareBranch rrn@(ReadShareRemoteNamespace {server, repo, path}) = do let codeserver = Codeserver.resolveCodeserver server let baseURL = codeserverBaseURL codeserver - ensureAuthenticatedWithCodeserver codeserver + -- Auto-login to share if pulling from a non-public path + when (not $ RemoteRepo.isPublic rrn) $ ensureAuthenticatedWithCodeserver codeserver mapLeft Output.ShareError <$> do let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index d93095638a..d5d1c930bc 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -12,10 +12,16 @@ import Unison.Codebase.Editor.RemoteRepo import qualified Unison.Codebase.Path as Path -- | Parse git version strings into valid unison namespaces. --- "release/M1j" -> "releases._M1j" --- "release/M1j.2" -> "releases._M1j_2" --- "latest-*" -> "trunk" -defaultBaseLib :: Parsec Void Text ReadGitRemoteNamespace +-- +-- >>> parseMaybe defaultBaseLib "release/M1j" +-- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.dev.base.releases._M1j}) +-- +-- >>> parseMaybe defaultBaseLib "release/M1j.2" +-- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.dev.base.releases._M1j_2}) +-- +-- >>> parseMaybe defaultBaseLib "latest-1234" +-- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.dev.base.trunk}) +defaultBaseLib :: Parsec Void Text ReadShareRemoteNamespace defaultBaseLib = fmap makeNS $ latest <|> release where latest, release, version :: Parsec Void Text Text @@ -23,18 +29,10 @@ defaultBaseLib = fmap makeNS $ latest <|> release release = fmap ("releases._" <>) $ "release/" *> version <* eof version = do Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) - makeNS :: Text -> ReadGitRemoteNamespace + makeNS :: Text -> ReadShareRemoteNamespace makeNS t = - ReadGitRemoteNamespace - { repo = - ReadGitRepo - { url = "https://github.com/unisonweb/base", - -- Use the 'v4' branch of base for now. - -- We can revert back to the main branch once enough people have upgraded ucm and - -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm - -- release). - ref = Just "v4" - }, - sbh = Nothing, - path = Path.fromText t + ReadShareRemoteNamespace + { server = DefaultCodeserver, + repo = "unison", + path = "public" Path.:< "dev" Path.:< "base" Path.:< Path.fromText t } diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index d243700ad6..cc59064c41 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -442,7 +442,7 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do "The transcript was expecting an error in the stanza above, but did not encounter one." ] - authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient print tokenProvider ucmVersion + authenticatedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion let loop state = do writeIORef pathRef (view LoopState.currentPath state) let env = diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 00ba12b622..8689fb73e8 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -196,7 +196,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba writeIORef pathRef (view LoopState.currentPath state) credMan <- newCredentialManager let tokenProvider = AuthN.newTokenProvider credMan - authorizedHTTPClient <- AuthN.newAuthenticatedHTTPClient notify tokenProvider ucmVersion + authorizedHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion let env = LoopState.Env { LoopState.authHTTPClient = authorizedHTTPClient, diff --git a/unison-cli/src/Unison/CommandLine/Welcome.hs b/unison-cli/src/Unison/CommandLine/Welcome.hs index 59b9b10b9e..1b3eccf216 100644 --- a/unison-cli/src/Unison/CommandLine/Welcome.hs +++ b/unison-cli/src/Unison/CommandLine/Welcome.hs @@ -7,7 +7,7 @@ import System.Random (randomRIO) import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Unison.Codebase.Editor.Input -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadRemoteNamespace (..)) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), ReadShareRemoteNamespace (..)) import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SyncMode as SyncMode @@ -25,7 +25,7 @@ data Welcome = Welcome } data DownloadBase - = DownloadBase ReadGitRemoteNamespace + = DownloadBase ReadShareRemoteNamespace | DontDownloadBase -- Previously Created is different from Previously Onboarded because a user can @@ -38,7 +38,7 @@ data CodebaseInitStatus data Onboarding = Init CodebaseInitStatus -- Can transition to [DownloadingBase, Author, Finished, PreviouslyOnboarded] - | DownloadingBase ReadGitRemoteNamespace -- Can transition to [Author, Finished] + | DownloadingBase ReadShareRemoteNamespace -- Can transition to [Author, Finished] | Author -- Can transition to [Finished] -- End States | Finished @@ -48,14 +48,14 @@ welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> Text -> Welcome welcome initStatus downloadBase filePath unisonVersion = Welcome (Init initStatus) downloadBase filePath unisonVersion -pullBase :: ReadGitRemoteNamespace -> Either Event Input +pullBase :: ReadShareRemoteNamespace -> Either Event Input pullBase ns = let seg = NameSegment "base" rootPath = Path.Path {Path.toSeq = singleton seg} abs = Path.Absolute {Path.unabsolute = rootPath} pullRemote = PullRemoteBranchI - (Just (ReadRemoteNamespaceGit ns)) + (Just (ReadRemoteNamespaceShare ns)) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete PullWithHistory @@ -77,7 +77,7 @@ run codebase Welcome {onboarding = onboarding, downloadBase = downloadBase, watc go PreviouslyOnboarded (headerMsg : acc) where headerMsg = toInput (header version) - DownloadingBase ns@ReadGitRemoteNamespace {path} -> + DownloadingBase ns@(ReadShareRemoteNamespace {path}) -> go Author ([pullBaseInput, downloadMsg] ++ acc) where downloadMsg = Right $ CreateMessage (downloading path) @@ -104,7 +104,7 @@ determineFirstStep downloadBase codebase = do case downloadBase of DownloadBase ns | isEmptyCodebase -> - pure $ DownloadingBase ns + pure $ DownloadingBase ns _ -> pure PreviouslyOnboarded diff --git a/unison-cli/tests/Unison/Test/VersionParser.hs b/unison-cli/tests/Unison/Test/VersionParser.hs index 51f83333db..3417e84b48 100644 --- a/unison-cli/tests/Unison/Test/VersionParser.hs +++ b/unison-cli/tests/Unison/Test/VersionParser.hs @@ -26,10 +26,10 @@ makeTest (version, path) = expectEqual (rightMay $ runParser defaultBaseLib "versionparser" version) ( Just - -- We've hard-coded the v4 branch for base for now. See 'defaultBaseLib' - ( ReadGitRemoteNamespace - (ReadGitRepo "https://github.com/unisonweb/base" (Just "v4")) - Nothing - (Path.fromText path) + ( ReadShareRemoteNamespace + { server = DefaultCodeserver, + repo = "unison", + path = Path.fromList ["public", "dev", "base"] <> Path.fromText path + } ) ) diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index 6df256e56a..c2eb057f2b 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -50,7 +50,7 @@ import Text.Pretty.Simple (pHPrint) import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Editor.Input as Input -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadShareRemoteNamespace) import qualified Unison.Codebase.Editor.VersionParser as VP import Unison.Codebase.Execute (execute) import Unison.Codebase.Init (CodebaseInitOptions (..), InitError (..), InitResult (..), SpecifiedCodebase (..)) @@ -418,7 +418,7 @@ isFlag f arg = arg == f || arg == "-" ++ f || arg == "--" ++ f getConfigFilePath :: Maybe FilePath -> IO FilePath getConfigFilePath mcodepath = (FP. ".unisonConfig") <$> Codebase.getCodebaseDir mcodepath -defaultBaseLib :: Maybe ReadGitRemoteNamespace +defaultBaseLib :: Maybe ReadShareRemoteNamespace defaultBaseLib = rightMay $ runParser VP.defaultBaseLib "version" gitRef From 364799386e5b546a93a8916c41a93fb64759e5e0 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Tue, 21 Jun 2022 16:38:04 -0400 Subject: [PATCH 386/529] Report correct number of downloaded entities --- unison-cli/src/Unison/Share/Sync.hs | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index a9dd5875fb..4bd9f97616 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -346,23 +346,23 @@ pull httpClient unisonShareUrl conn repoPath downloadProgressCallback = catchSyn Right Nothing -> pure (Left (PullErrorNoHistoryAtPath repoPath)) Right (Just hashJwt) -> do let hash = Share.hashJWTHash hashJwt - (maybeTempEntities, downloadedSoFar) <- + (maybeTempEntities, downloaded1) <- Sqlite.runTransaction conn (Q.entityLocation hash) >>= \case Just Q.EntityInMainStorage -> pure (Nothing, 0) Just Q.EntityInTempStorage -> pure (Just (NESet.singleton hash), 0) Nothing -> do tempEntities <- doDownload (NESet.singleton hashJwt) pure (tempEntities, 1) - downloadedTotal <- + downloaded2 <- case maybeTempEntities of - Nothing -> pure downloadedSoFar + Nothing -> pure 0 Just tempEntities -> do completeTempEntities doDownload conn - (\downloaded enqueued -> downloadProgressCallback (downloaded + downloadedSoFar) enqueued) + (\downloaded enqueued -> downloadProgressCallback (downloaded + downloaded1) enqueued) tempEntities - downloadProgressCallback downloadedTotal 0 + downloadProgressCallback (downloaded1 + downloaded2) 0 pure (Right (hash32ToCausalHash hash)) where repoName = Share.pathRepoName repoPath From f0b63e782e449fb896f45023053739dac5afe509 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Wed, 22 Jun 2022 11:37:34 -0400 Subject: [PATCH 387/529] Some array additions/fixes - Add 24 and 40 bit primitive reads. These are directly supported by Chez, and are convenient for base32hex coding. - Add size operations on builtin arrays. - Fix order of operations in implementations multi-byte array reads. They were shifting before promoting to a larger word size, which would just zero the values out. --- parser-typechecker/src/Unison/Builtin.hs | 12 + .../src/Unison/Runtime/Builtin.hs | 105 ++- unison-src/transcripts/alias-many.output.md | 626 +++++++++--------- .../transcripts/builtins-merge.output.md | 8 +- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- .../transcripts/name-selection.output.md | 203 +++--- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 9 files changed, 568 insertions(+), 432 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 4542249ffd..4d6847dc86 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -528,6 +528,10 @@ builtinsSrc = reft g a --> Type.effect1 () g a, B "Ref.write" . forall2 "a" "g" $ \a g -> reft g a --> a --> Type.effect1 () g unit, + B "MutableArray.size" . forall2 "g" "a" $ \g a -> marrayt g a --> nat, + B "MutableByteArray.size" . forall1 "g" $ \g -> mbytearrayt g --> nat, + B "ImmutableArray.size" . forall1 "a" $ \a -> iarrayt a --> nat, + B "ImmutableByteArray.size" $ ibytearrayt --> nat, B "MutableArray.copyTo!" . forall2 "g" "a" $ \g a -> marrayt g a --> nat --> marrayt g a --> nat --> nat --> Type.effect () [g, DD.exceptionType ()] unit, @@ -540,8 +544,12 @@ builtinsSrc = mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, B "MutableByteArray.read16be" . forall1 "g" $ \g -> mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, + B "MutableByteArray.read24be" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, B "MutableByteArray.read32be" . forall1 "g" $ \g -> mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, + B "MutableByteArray.read40be" . forall1 "g" $ \g -> + mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, B "MutableByteArray.read64be" . forall1 "g" $ \g -> mbytearrayt g --> nat --> Type.effect () [g, DD.exceptionType ()] nat, B "MutableArray.write" . forall2 "g" "a" $ \g a -> @@ -566,8 +574,12 @@ builtinsSrc = ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, B "ImmutableByteArray.read16be" $ ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, + B "ImmutableByteArray.read24be" $ + ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, B "ImmutableByteArray.read32be" $ ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, + B "ImmutableByteArray.read40be" $ + ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, B "ImmutableByteArray.read64be" $ ibytearrayt --> nat --> Type.effect1 () (DD.exceptionType ()) nat, B "MutableArray.freeze!" . forall2 "g" "a" $ \g a -> diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 30d3248e94..593adb15d5 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -2443,6 +2443,15 @@ declareForeigns = do (fromIntegral soff) (fromIntegral l) + declareForeign Untracked "ImmutableArray.size" boxToNat . mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofArray @Closure + declareForeign Untracked "MutableArray.size" boxToNat . mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableArray @PA.RealWorld @Closure + declareForeign Untracked "ImmutableByteArray.size" boxToNat . mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofByteArray + declareForeign Untracked "MutableByteArray.size" boxToNat . mkForeign $ + pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld + declareForeign Tracked "ImmutableByteArray.copyTo!" boxNatBoxNatNatToExnUnit . mkForeign $ \(dst, doff, src, soff, l) -> @@ -2469,9 +2478,15 @@ declareForeigns = do declareForeign Tracked "MutableByteArray.read16be" boxNatToExnNat . mkForeign $ checkedRead16 "MutableByteArray.read16be" + declareForeign Tracked "MutableByteArray.read24be" boxNatToExnNat + . mkForeign + $ checkedRead24 "MutableByteArray.read24be" declareForeign Tracked "MutableByteArray.read32be" boxNatToExnNat . mkForeign $ checkedRead32 "MutableByteArray.read32be" + declareForeign Tracked "MutableByteArray.read40be" boxNatToExnNat + . mkForeign + $ checkedRead40 "MutableByteArray.read40be" declareForeign Tracked "MutableByteArray.read64be" boxNatToExnNat . mkForeign $ checkedRead64 "MutableByteArray.read64be" @@ -2501,9 +2516,15 @@ declareForeigns = do declareForeign Untracked "ImmutableByteArray.read16be" boxNatToExnNat . mkForeign $ checkedIndex16 "ImmutableByteArray.read16be" + declareForeign Untracked "ImmutableByteArray.read24be" boxNatToExnNat + . mkForeign + $ checkedIndex24 "ImmutableByteArray.read24be" declareForeign Untracked "ImmutableByteArray.read32be" boxNatToExnNat . mkForeign $ checkedIndex32 "ImmutableByteArray.read32be" + declareForeign Untracked "ImmutableByteArray.read40be" boxNatToExnNat + . mkForeign + $ checkedIndex40 "ImmutableByteArray.read40be" declareForeign Untracked "ImmutableByteArray.read64be" boxNatToExnNat . mkForeign $ checkedIndex64 "ImmutableByteArray.read64be" @@ -2605,9 +2626,19 @@ checkedRead8 name (arr, i) = checkedRead16 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) checkedRead16 name (arr, i) = checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 2 $ - (mk16) + mk16 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + where + j = fromIntegral i + +checkedRead24 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead24 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 3 $ + mk24 <$> PA.readByteArray @Word8 arr j <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) where j = fromIntegral i @@ -2622,6 +2653,18 @@ checkedRead32 name (arr, i) = where j = fromIntegral i +checkedRead40 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) +checkedRead40 name (arr, i) = + checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 6 $ + mk40 + <$> PA.readByteArray @Word8 arr j + <*> PA.readByteArray @Word8 arr (j + 1) + <*> PA.readByteArray @Word8 arr (j + 2) + <*> PA.readByteArray @Word8 arr (j + 3) + <*> PA.readByteArray @Word8 arr (j + 4) + where + j = fromIntegral i + checkedRead64 :: Text -> (PA.MutableByteArray RW, Word64) -> IO (Either Failure Word64) checkedRead64 name (arr, i) = checkBoundsPrim name (PA.sizeofMutableByteArray arr) i 8 $ @@ -2638,26 +2681,42 @@ checkedRead64 name (arr, i) = j = fromIntegral i mk16 :: Word8 -> Word8 -> Either Failure Word64 -mk16 b0 b1 = Right $ (fromIntegral $ b0 `shiftL` 8) .|. (fromIntegral b1) +mk16 b0 b1 = Right $ (fromIntegral b0 `shiftL` 8) .|. (fromIntegral b1) + +mk24 :: Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk24 b0 b1 b2 = + Right $ + (fromIntegral b0 `shiftL` 16) + .|. (fromIntegral b1 `shiftL` 8) + .|. (fromIntegral b2) mk32 :: Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 mk32 b0 b1 b2 b3 = Right $ - (fromIntegral $ b0 `shiftL` 24) - .|. (fromIntegral $ b1 `shiftL` 16) - .|. (fromIntegral $ b2 `shiftL` 8) + (fromIntegral b0 `shiftL` 24) + .|. (fromIntegral b1 `shiftL` 16) + .|. (fromIntegral b2 `shiftL` 8) .|. (fromIntegral b3) +mk40 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 +mk40 b0 b1 b2 b3 b4 = + Right $ + (fromIntegral b0 `shiftL` 32) + .|. (fromIntegral b1 `shiftL` 24) + .|. (fromIntegral b2 `shiftL` 16) + .|. (fromIntegral b3 `shiftL` 8) + .|. (fromIntegral b4) + mk64 :: Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Word8 -> Either Failure Word64 mk64 b0 b1 b2 b3 b4 b5 b6 b7 = Right $ - (fromIntegral $ b0 `shiftL` 56) - .|. (fromIntegral $ b1 `shiftL` 48) - .|. (fromIntegral $ b2 `shiftL` 40) - .|. (fromIntegral $ b3 `shiftL` 32) - .|. (fromIntegral $ b4 `shiftL` 24) - .|. (fromIntegral $ b5 `shiftL` 16) - .|. (fromIntegral $ b6 `shiftL` 8) + (fromIntegral b0 `shiftL` 56) + .|. (fromIntegral b1 `shiftL` 48) + .|. (fromIntegral b2 `shiftL` 40) + .|. (fromIntegral b3 `shiftL` 32) + .|. (fromIntegral b4 `shiftL` 24) + .|. (fromIntegral b5 `shiftL` 16) + .|. (fromIntegral b6 `shiftL` 8) .|. (fromIntegral b7) checkedWrite8 :: Text -> (PA.MutableByteArray RW, Word64, Word64) -> IO (Either Failure ()) @@ -2717,6 +2776,16 @@ checkedIndex16 name (arr, i) = let j = fromIntegral i in mk16 (PA.indexByteArray arr j) (PA.indexByteArray arr (j + 1)) +-- index 32 big-endian +checkedIndex24 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex24 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 3 . pure $ + let j = fromIntegral i + in mk24 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + -- index 32 big-endian checkedIndex32 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) checkedIndex32 name (arr, i) = @@ -2728,6 +2797,18 @@ checkedIndex32 name (arr, i) = (PA.indexByteArray arr (j + 2)) (PA.indexByteArray arr (j + 3)) +-- index 40 big-endian +checkedIndex40 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) +checkedIndex40 name (arr, i) = + checkBoundsPrim name (PA.sizeofByteArray arr) i 5 . pure $ + let j = fromIntegral i + in mk40 + (PA.indexByteArray arr j) + (PA.indexByteArray arr (j + 1)) + (PA.indexByteArray arr (j + 2)) + (PA.indexByteArray arr (j + 3)) + (PA.indexByteArray arr (j + 4)) + -- index 64 big-endian checkedIndex64 :: Text -> (PA.ByteArray, Word64) -> IO (Either Failure Word64) checkedIndex64 name (arr, i) = diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index 783f577d65..c15487ae45 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -151,448 +151,464 @@ Let's try it! 123. ImmutableArray.read : ImmutableArray a -> Nat ->{Exception} a - 124. builtin type ImmutableByteArray - 125. ImmutableByteArray.copyTo! : MutableByteArray g + 124. ImmutableArray.size : ImmutableArray a -> Nat + 125. builtin type ImmutableByteArray + 126. ImmutableByteArray.copyTo! : MutableByteArray g -> Nat -> ImmutableByteArray -> Nat -> Nat ->{g, Exception} () - 126. ImmutableByteArray.read16be : ImmutableByteArray + 127. ImmutableByteArray.read16be : ImmutableByteArray -> Nat ->{Exception} Nat - 127. ImmutableByteArray.read32be : ImmutableByteArray + 128. ImmutableByteArray.read24be : ImmutableByteArray -> Nat ->{Exception} Nat - 128. ImmutableByteArray.read64be : ImmutableByteArray + 129. ImmutableByteArray.read32be : ImmutableByteArray -> Nat ->{Exception} Nat - 129. ImmutableByteArray.read8 : ImmutableByteArray + 130. ImmutableByteArray.read40be : ImmutableByteArray + -> Nat + ->{Exception} Nat + 131. ImmutableByteArray.read64be : ImmutableByteArray + -> Nat + ->{Exception} Nat + 132. ImmutableByteArray.read8 : ImmutableByteArray -> Nat ->{Exception} Nat - 130. builtin type Int - 131. Int.* : Int -> Int -> Int - 132. Int.+ : Int -> Int -> Int - 133. Int.- : Int -> Int -> Int - 134. Int./ : Int -> Int -> Int - 135. Int.and : Int -> Int -> Int - 136. Int.complement : Int -> Int - 137. Int.eq : Int -> Int -> Boolean - 138. Int.fromRepresentation : Nat -> Int - 139. Int.fromText : Text -> Optional Int - 140. Int.gt : Int -> Int -> Boolean - 141. Int.gteq : Int -> Int -> Boolean - 142. Int.increment : Int -> Int - 143. Int.isEven : Int -> Boolean - 144. Int.isOdd : Int -> Boolean - 145. Int.leadingZeros : Int -> Nat - 146. Int.lt : Int -> Int -> Boolean - 147. Int.lteq : Int -> Int -> Boolean - 148. Int.mod : Int -> Int -> Int - 149. Int.negate : Int -> Int - 150. Int.or : Int -> Int -> Int - 151. Int.popCount : Int -> Nat - 152. Int.pow : Int -> Nat -> Int - 153. Int.shiftLeft : Int -> Nat -> Int - 154. Int.shiftRight : Int -> Nat -> Int - 155. Int.signum : Int -> Int - 156. Int.toFloat : Int -> Float - 157. Int.toRepresentation : Int -> Nat - 158. Int.toText : Int -> Text - 159. Int.trailingZeros : Int -> Nat - 160. Int.truncate0 : Int -> Nat - 161. Int.xor : Int -> Int -> Int - 162. unique type io2.ArrayFailure - 163. unique type io2.BufferMode - 164. io2.BufferMode.BlockBuffering : BufferMode - 165. io2.BufferMode.LineBuffering : BufferMode - 166. io2.BufferMode.NoBuffering : BufferMode - 167. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 168. io2.Clock.internals.monotonic : '{IO} Either + 133. ImmutableByteArray.size : ImmutableByteArray -> Nat + 134. builtin type Int + 135. Int.* : Int -> Int -> Int + 136. Int.+ : Int -> Int -> Int + 137. Int.- : Int -> Int -> Int + 138. Int./ : Int -> Int -> Int + 139. Int.and : Int -> Int -> Int + 140. Int.complement : Int -> Int + 141. Int.eq : Int -> Int -> Boolean + 142. Int.fromRepresentation : Nat -> Int + 143. Int.fromText : Text -> Optional Int + 144. Int.gt : Int -> Int -> Boolean + 145. Int.gteq : Int -> Int -> Boolean + 146. Int.increment : Int -> Int + 147. Int.isEven : Int -> Boolean + 148. Int.isOdd : Int -> Boolean + 149. Int.leadingZeros : Int -> Nat + 150. Int.lt : Int -> Int -> Boolean + 151. Int.lteq : Int -> Int -> Boolean + 152. Int.mod : Int -> Int -> Int + 153. Int.negate : Int -> Int + 154. Int.or : Int -> Int -> Int + 155. Int.popCount : Int -> Nat + 156. Int.pow : Int -> Nat -> Int + 157. Int.shiftLeft : Int -> Nat -> Int + 158. Int.shiftRight : Int -> Nat -> Int + 159. Int.signum : Int -> Int + 160. Int.toFloat : Int -> Float + 161. Int.toRepresentation : Int -> Nat + 162. Int.toText : Int -> Text + 163. Int.trailingZeros : Int -> Nat + 164. Int.truncate0 : Int -> Nat + 165. Int.xor : Int -> Int -> Int + 166. unique type io2.ArrayFailure + 167. unique type io2.BufferMode + 168. io2.BufferMode.BlockBuffering : BufferMode + 169. io2.BufferMode.LineBuffering : BufferMode + 170. io2.BufferMode.NoBuffering : BufferMode + 171. io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode + 172. io2.Clock.internals.monotonic : '{IO} Either Failure TimeSpec - 169. io2.Clock.internals.nsec : TimeSpec -> Nat - 170. io2.Clock.internals.processCPUTime : '{IO} Either + 173. io2.Clock.internals.nsec : TimeSpec -> Nat + 174. io2.Clock.internals.processCPUTime : '{IO} Either Failure TimeSpec - 171. io2.Clock.internals.realtime : '{IO} Either + 175. io2.Clock.internals.realtime : '{IO} Either Failure TimeSpec - 172. io2.Clock.internals.sec : TimeSpec -> Int - 173. io2.Clock.internals.threadCPUTime : '{IO} Either + 176. io2.Clock.internals.sec : TimeSpec -> Int + 177. io2.Clock.internals.threadCPUTime : '{IO} Either Failure TimeSpec - 174. builtin type io2.Clock.internals.TimeSpec - 175. unique type io2.Failure - 176. io2.Failure.Failure : Type -> Text -> Any -> Failure - 177. unique type io2.FileMode - 178. io2.FileMode.Append : FileMode - 179. io2.FileMode.Read : FileMode - 180. io2.FileMode.ReadWrite : FileMode - 181. io2.FileMode.Write : FileMode - 182. builtin type io2.Handle - 183. builtin type io2.IO - 184. io2.IO.array : Nat ->{IO} MutableArray {IO} a - 185. io2.IO.arrayOf : a -> Nat ->{IO} MutableArray {IO} a - 186. io2.IO.bytearray : Nat ->{IO} MutableByteArray {IO} - 187. io2.IO.bytearrayOf : Nat + 178. builtin type io2.Clock.internals.TimeSpec + 179. unique type io2.Failure + 180. io2.Failure.Failure : Type -> Text -> Any -> Failure + 181. unique type io2.FileMode + 182. io2.FileMode.Append : FileMode + 183. io2.FileMode.Read : FileMode + 184. io2.FileMode.ReadWrite : FileMode + 185. io2.FileMode.Write : FileMode + 186. builtin type io2.Handle + 187. builtin type io2.IO + 188. io2.IO.array : Nat ->{IO} MutableArray {IO} a + 189. io2.IO.arrayOf : a -> Nat ->{IO} MutableArray {IO} a + 190. io2.IO.bytearray : Nat ->{IO} MutableByteArray {IO} + 191. io2.IO.bytearrayOf : Nat -> Nat ->{IO} MutableByteArray {IO} - 188. io2.IO.clientSocket.impl : Text + 192. io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 189. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 190. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 191. io2.IO.createDirectory.impl : Text + 193. io2.IO.closeFile.impl : Handle ->{IO} Either Failure () + 194. io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () + 195. io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 192. io2.IO.createTempDirectory.impl : Text + 196. io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 193. io2.IO.delay.impl : Nat ->{IO} Either Failure () - 194. io2.IO.directoryContents.impl : Text + 197. io2.IO.delay.impl : Nat ->{IO} Either Failure () + 198. io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 195. io2.IO.fileExists.impl : Text + 199. io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 196. io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 197. io2.IO.getArgs.impl : '{IO} Either Failure [Text] - 198. io2.IO.getBuffering.impl : Handle + 200. io2.IO.forkComp : '{IO} a ->{IO} ThreadId + 201. io2.IO.getArgs.impl : '{IO} Either Failure [Text] + 202. io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 199. io2.IO.getBytes.impl : Handle + 203. io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 200. io2.IO.getCurrentDirectory.impl : '{IO} Either + 204. io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 201. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 202. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 203. io2.IO.getFileTimestamp.impl : Text + 205. io2.IO.getEnv.impl : Text ->{IO} Either Failure Text + 206. io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat + 207. io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 204. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 205. io2.IO.getSomeBytes.impl : Handle + 208. io2.IO.getLine.impl : Handle ->{IO} Either Failure Text + 209. io2.IO.getSomeBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 206. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 207. io2.IO.handlePosition.impl : Handle + 210. io2.IO.getTempDirectory.impl : '{IO} Either Failure Text + 211. io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 208. io2.IO.isDirectory.impl : Text + 212. io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 209. io2.IO.isFileEOF.impl : Handle + 213. io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 210. io2.IO.isFileOpen.impl : Handle + 214. io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 211. io2.IO.isSeekable.impl : Handle + 215. io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 212. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 213. io2.IO.listen.impl : Socket ->{IO} Either Failure () - 214. io2.IO.openFile.impl : Text + 216. io2.IO.kill.impl : ThreadId ->{IO} Either Failure () + 217. io2.IO.listen.impl : Socket ->{IO} Either Failure () + 218. io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 215. io2.IO.putBytes.impl : Handle + 219. io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 216. io2.IO.ref : a ->{IO} Ref {IO} a - 217. io2.IO.removeDirectory.impl : Text + 220. io2.IO.ref : a ->{IO} Ref {IO} a + 221. io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 218. io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 219. io2.IO.renameDirectory.impl : Text + 222. io2.IO.removeFile.impl : Text ->{IO} Either Failure () + 223. io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 220. io2.IO.renameFile.impl : Text + 224. io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 221. io2.IO.seekHandle.impl : Handle + 225. io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 222. io2.IO.serverSocket.impl : Optional Text + 226. io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 223. io2.IO.setBuffering.impl : Handle + 227. io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 224. io2.IO.setCurrentDirectory.impl : Text + 228. io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 225. io2.IO.socketAccept.impl : Socket + 229. io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 226. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 227. io2.IO.socketReceive.impl : Socket + 230. io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat + 231. io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 228. io2.IO.socketSend.impl : Socket + 232. io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 229. io2.IO.stdHandle : StdHandle -> Handle - 230. io2.IO.systemTime.impl : '{IO} Either Failure Nat - 231. io2.IO.systemTimeMicroseconds : '{IO} Int - 232. unique type io2.IOError - 233. io2.IOError.AlreadyExists : IOError - 234. io2.IOError.EOF : IOError - 235. io2.IOError.IllegalOperation : IOError - 236. io2.IOError.NoSuchThing : IOError - 237. io2.IOError.PermissionDenied : IOError - 238. io2.IOError.ResourceBusy : IOError - 239. io2.IOError.ResourceExhausted : IOError - 240. io2.IOError.UserError : IOError - 241. unique type io2.IOFailure - 242. builtin type io2.MVar - 243. io2.MVar.isEmpty : MVar a ->{IO} Boolean - 244. io2.MVar.new : a ->{IO} MVar a - 245. io2.MVar.newEmpty : '{IO} MVar a - 246. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 247. io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 248. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 249. io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 250. io2.MVar.tryPut.impl : MVar a + 233. io2.IO.stdHandle : StdHandle -> Handle + 234. io2.IO.systemTime.impl : '{IO} Either Failure Nat + 235. io2.IO.systemTimeMicroseconds : '{IO} Int + 236. unique type io2.IOError + 237. io2.IOError.AlreadyExists : IOError + 238. io2.IOError.EOF : IOError + 239. io2.IOError.IllegalOperation : IOError + 240. io2.IOError.NoSuchThing : IOError + 241. io2.IOError.PermissionDenied : IOError + 242. io2.IOError.ResourceBusy : IOError + 243. io2.IOError.ResourceExhausted : IOError + 244. io2.IOError.UserError : IOError + 245. unique type io2.IOFailure + 246. builtin type io2.MVar + 247. io2.MVar.isEmpty : MVar a ->{IO} Boolean + 248. io2.MVar.new : a ->{IO} MVar a + 249. io2.MVar.newEmpty : '{IO} MVar a + 250. io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () + 251. io2.MVar.read.impl : MVar a ->{IO} Either Failure a + 252. io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a + 253. io2.MVar.take.impl : MVar a ->{IO} Either Failure a + 254. io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 251. io2.MVar.tryRead.impl : MVar a + 255. io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 252. io2.MVar.tryTake : MVar a ->{IO} Optional a - 253. unique type io2.SeekMode - 254. io2.SeekMode.AbsoluteSeek : SeekMode - 255. io2.SeekMode.RelativeSeek : SeekMode - 256. io2.SeekMode.SeekFromEnd : SeekMode - 257. builtin type io2.Socket - 258. unique type io2.StdHandle - 259. io2.StdHandle.StdErr : StdHandle - 260. io2.StdHandle.StdIn : StdHandle - 261. io2.StdHandle.StdOut : StdHandle - 262. builtin type io2.STM - 263. io2.STM.atomically : '{STM} a ->{IO} a - 264. io2.STM.retry : '{STM} a - 265. builtin type io2.ThreadId - 266. builtin type io2.Tls - 267. builtin type io2.Tls.Cipher - 268. builtin type io2.Tls.ClientConfig - 269. io2.Tls.ClientConfig.certificates.set : [SignedCert] + 256. io2.MVar.tryTake : MVar a ->{IO} Optional a + 257. unique type io2.SeekMode + 258. io2.SeekMode.AbsoluteSeek : SeekMode + 259. io2.SeekMode.RelativeSeek : SeekMode + 260. io2.SeekMode.SeekFromEnd : SeekMode + 261. builtin type io2.Socket + 262. unique type io2.StdHandle + 263. io2.StdHandle.StdErr : StdHandle + 264. io2.StdHandle.StdIn : StdHandle + 265. io2.StdHandle.StdOut : StdHandle + 266. builtin type io2.STM + 267. io2.STM.atomically : '{STM} a ->{IO} a + 268. io2.STM.retry : '{STM} a + 269. builtin type io2.ThreadId + 270. builtin type io2.Tls + 271. builtin type io2.Tls.Cipher + 272. builtin type io2.Tls.ClientConfig + 273. io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 270. io2.TLS.ClientConfig.ciphers.set : [Cipher] + 274. io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 271. io2.Tls.ClientConfig.default : Text + 275. io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 272. io2.Tls.ClientConfig.versions.set : [Version] + 276. io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 273. io2.Tls.decodeCert.impl : Bytes + 277. io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 274. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 275. io2.Tls.encodeCert : SignedCert -> Bytes - 276. io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 277. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 278. io2.Tls.newClient.impl : ClientConfig + 278. io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] + 279. io2.Tls.encodeCert : SignedCert -> Bytes + 280. io2.Tls.encodePrivateKey : PrivateKey -> Bytes + 281. io2.Tls.handshake.impl : Tls ->{IO} Either Failure () + 282. io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 279. io2.Tls.newServer.impl : ServerConfig + 283. io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 280. builtin type io2.Tls.PrivateKey - 281. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 282. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 283. builtin type io2.Tls.ServerConfig - 284. io2.Tls.ServerConfig.certificates.set : [SignedCert] + 284. builtin type io2.Tls.PrivateKey + 285. io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes + 286. io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () + 287. builtin type io2.Tls.ServerConfig + 288. io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 285. io2.Tls.ServerConfig.ciphers.set : [Cipher] + 289. io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 286. io2.Tls.ServerConfig.default : [SignedCert] + 290. io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 287. io2.Tls.ServerConfig.versions.set : [Version] + 291. io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 288. builtin type io2.Tls.SignedCert - 289. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 290. builtin type io2.Tls.Version - 291. unique type io2.TlsFailure - 292. builtin type io2.TVar - 293. io2.TVar.new : a ->{STM} TVar a - 294. io2.TVar.newIO : a ->{IO} TVar a - 295. io2.TVar.read : TVar a ->{STM} a - 296. io2.TVar.readIO : TVar a ->{IO} a - 297. io2.TVar.swap : TVar a -> a ->{STM} a - 298. io2.TVar.write : TVar a -> a ->{STM} () - 299. io2.validateSandboxed : [Term] -> a -> Boolean - 300. unique type IsPropagated - 301. IsPropagated.IsPropagated : IsPropagated - 302. unique type IsTest - 303. IsTest.IsTest : IsTest - 304. unique type Link - 305. builtin type Link.Term - 306. Link.Term : Term -> Link - 307. Link.Term.toText : Term -> Text - 308. builtin type Link.Type - 309. Link.Type : Type -> Link - 310. builtin type List - 311. List.++ : [a] -> [a] -> [a] - 312. List.+: : a -> [a] -> [a] - 313. List.:+ : [a] -> a -> [a] - 314. List.at : Nat -> [a] -> Optional a - 315. List.cons : a -> [a] -> [a] - 316. List.drop : Nat -> [a] -> [a] - 317. List.empty : [a] - 318. List.size : [a] -> Nat - 319. List.snoc : [a] -> a -> [a] - 320. List.take : Nat -> [a] -> [a] - 321. metadata.isPropagated : IsPropagated - 322. metadata.isTest : IsTest - 323. builtin type MutableArray - 324. MutableArray.copyTo! : MutableArray g a + 292. builtin type io2.Tls.SignedCert + 293. io2.Tls.terminate.impl : Tls ->{IO} Either Failure () + 294. builtin type io2.Tls.Version + 295. unique type io2.TlsFailure + 296. builtin type io2.TVar + 297. io2.TVar.new : a ->{STM} TVar a + 298. io2.TVar.newIO : a ->{IO} TVar a + 299. io2.TVar.read : TVar a ->{STM} a + 300. io2.TVar.readIO : TVar a ->{IO} a + 301. io2.TVar.swap : TVar a -> a ->{STM} a + 302. io2.TVar.write : TVar a -> a ->{STM} () + 303. io2.validateSandboxed : [Term] -> a -> Boolean + 304. unique type IsPropagated + 305. IsPropagated.IsPropagated : IsPropagated + 306. unique type IsTest + 307. IsTest.IsTest : IsTest + 308. unique type Link + 309. builtin type Link.Term + 310. Link.Term : Term -> Link + 311. Link.Term.toText : Term -> Text + 312. builtin type Link.Type + 313. Link.Type : Type -> Link + 314. builtin type List + 315. List.++ : [a] -> [a] -> [a] + 316. List.+: : a -> [a] -> [a] + 317. List.:+ : [a] -> a -> [a] + 318. List.at : Nat -> [a] -> Optional a + 319. List.cons : a -> [a] -> [a] + 320. List.drop : Nat -> [a] -> [a] + 321. List.empty : [a] + 322. List.size : [a] -> Nat + 323. List.snoc : [a] -> a -> [a] + 324. List.take : Nat -> [a] -> [a] + 325. metadata.isPropagated : IsPropagated + 326. metadata.isTest : IsTest + 327. builtin type MutableArray + 328. MutableArray.copyTo! : MutableArray g a -> Nat -> MutableArray g a -> Nat -> Nat ->{g, Exception} () - 325. MutableArray.freeze : MutableArray g a + 329. MutableArray.freeze : MutableArray g a -> Nat -> Nat ->{g} ImmutableArray a - 326. MutableArray.freeze! : MutableArray g a + 330. MutableArray.freeze! : MutableArray g a ->{g} ImmutableArray a - 327. MutableArray.read : MutableArray g a + 331. MutableArray.read : MutableArray g a -> Nat ->{g, Exception} a - 328. MutableArray.write : MutableArray g a + 332. MutableArray.size : MutableArray g a -> Nat + 333. MutableArray.write : MutableArray g a -> Nat -> a ->{g, Exception} () - 329. builtin type MutableByteArray - 330. MutableByteArray.copyTo! : MutableByteArray g + 334. builtin type MutableByteArray + 335. MutableByteArray.copyTo! : MutableByteArray g -> Nat -> MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 331. MutableByteArray.freeze : MutableByteArray g + 336. MutableByteArray.freeze : MutableByteArray g -> Nat -> Nat ->{g} ImmutableByteArray - 332. MutableByteArray.freeze! : MutableByteArray g + 337. MutableByteArray.freeze! : MutableByteArray g ->{g} ImmutableByteArray - 333. MutableByteArray.read16be : MutableByteArray g + 338. MutableByteArray.read16be : MutableByteArray g + -> Nat + ->{g, Exception} Nat + 339. MutableByteArray.read24be : MutableByteArray g + -> Nat + ->{g, Exception} Nat + 340. MutableByteArray.read32be : MutableByteArray g -> Nat ->{g, Exception} Nat - 334. MutableByteArray.read32be : MutableByteArray g + 341. MutableByteArray.read40be : MutableByteArray g -> Nat ->{g, Exception} Nat - 335. MutableByteArray.read64be : MutableByteArray g + 342. MutableByteArray.read64be : MutableByteArray g -> Nat ->{g, Exception} Nat - 336. MutableByteArray.read8 : MutableByteArray g + 343. MutableByteArray.read8 : MutableByteArray g -> Nat ->{g, Exception} Nat - 337. MutableByteArray.write16be : MutableByteArray g + 344. MutableByteArray.size : MutableByteArray g -> Nat + 345. MutableByteArray.write16be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 338. MutableByteArray.write32be : MutableByteArray g + 346. MutableByteArray.write32be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 339. MutableByteArray.write64be : MutableByteArray g + 347. MutableByteArray.write64be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 340. MutableByteArray.write8 : MutableByteArray g + 348. MutableByteArray.write8 : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 341. builtin type Nat - 342. Nat.* : Nat -> Nat -> Nat - 343. Nat.+ : Nat -> Nat -> Nat - 344. Nat./ : Nat -> Nat -> Nat - 345. Nat.and : Nat -> Nat -> Nat - 346. Nat.complement : Nat -> Nat - 347. Nat.drop : Nat -> Nat -> Nat - 348. Nat.eq : Nat -> Nat -> Boolean - 349. Nat.fromText : Text -> Optional Nat - 350. Nat.gt : Nat -> Nat -> Boolean - 351. Nat.gteq : Nat -> Nat -> Boolean - 352. Nat.increment : Nat -> Nat - 353. Nat.isEven : Nat -> Boolean - 354. Nat.isOdd : Nat -> Boolean - 355. Nat.leadingZeros : Nat -> Nat - 356. Nat.lt : Nat -> Nat -> Boolean - 357. Nat.lteq : Nat -> Nat -> Boolean - 358. Nat.mod : Nat -> Nat -> Nat - 359. Nat.or : Nat -> Nat -> Nat - 360. Nat.popCount : Nat -> Nat - 361. Nat.pow : Nat -> Nat -> Nat - 362. Nat.shiftLeft : Nat -> Nat -> Nat - 363. Nat.shiftRight : Nat -> Nat -> Nat - 364. Nat.sub : Nat -> Nat -> Int - 365. Nat.toFloat : Nat -> Float - 366. Nat.toInt : Nat -> Int - 367. Nat.toText : Nat -> Text - 368. Nat.trailingZeros : Nat -> Nat - 369. Nat.xor : Nat -> Nat -> Nat - 370. structural type Optional a - 371. Optional.None : Optional a - 372. Optional.Some : a -> Optional a - 373. builtin type Ref - 374. Ref.read : Ref g a ->{g} a - 375. Ref.write : Ref g a -> a ->{g} () - 376. builtin type Request - 377. builtin type Scope - 378. Scope.array : Nat ->{Scope s} MutableArray (Scope s) a - 379. Scope.arrayOf : a + 349. builtin type Nat + 350. Nat.* : Nat -> Nat -> Nat + 351. Nat.+ : Nat -> Nat -> Nat + 352. Nat./ : Nat -> Nat -> Nat + 353. Nat.and : Nat -> Nat -> Nat + 354. Nat.complement : Nat -> Nat + 355. Nat.drop : Nat -> Nat -> Nat + 356. Nat.eq : Nat -> Nat -> Boolean + 357. Nat.fromText : Text -> Optional Nat + 358. Nat.gt : Nat -> Nat -> Boolean + 359. Nat.gteq : Nat -> Nat -> Boolean + 360. Nat.increment : Nat -> Nat + 361. Nat.isEven : Nat -> Boolean + 362. Nat.isOdd : Nat -> Boolean + 363. Nat.leadingZeros : Nat -> Nat + 364. Nat.lt : Nat -> Nat -> Boolean + 365. Nat.lteq : Nat -> Nat -> Boolean + 366. Nat.mod : Nat -> Nat -> Nat + 367. Nat.or : Nat -> Nat -> Nat + 368. Nat.popCount : Nat -> Nat + 369. Nat.pow : Nat -> Nat -> Nat + 370. Nat.shiftLeft : Nat -> Nat -> Nat + 371. Nat.shiftRight : Nat -> Nat -> Nat + 372. Nat.sub : Nat -> Nat -> Int + 373. Nat.toFloat : Nat -> Float + 374. Nat.toInt : Nat -> Int + 375. Nat.toText : Nat -> Text + 376. Nat.trailingZeros : Nat -> Nat + 377. Nat.xor : Nat -> Nat -> Nat + 378. structural type Optional a + 379. Optional.None : Optional a + 380. Optional.Some : a -> Optional a + 381. builtin type Ref + 382. Ref.read : Ref g a ->{g} a + 383. Ref.write : Ref g a -> a ->{g} () + 384. builtin type Request + 385. builtin type Scope + 386. Scope.array : Nat ->{Scope s} MutableArray (Scope s) a + 387. Scope.arrayOf : a -> Nat ->{Scope s} MutableArray (Scope s) a - 380. Scope.bytearray : Nat + 388. Scope.bytearray : Nat ->{Scope s} MutableByteArray (Scope s) - 381. Scope.bytearrayOf : Nat + 389. Scope.bytearrayOf : Nat -> Nat ->{Scope s} MutableByteArray (Scope s) - 382. Scope.ref : a ->{Scope s} Ref {Scope s} a - 383. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 384. structural type SeqView a b - 385. SeqView.VElem : a -> b -> SeqView a b - 386. SeqView.VEmpty : SeqView a b - 387. Socket.toText : Socket -> Text - 388. unique type Test.Result - 389. Test.Result.Fail : Text -> Result - 390. Test.Result.Ok : Text -> Result - 391. builtin type Text - 392. Text.!= : Text -> Text -> Boolean - 393. Text.++ : Text -> Text -> Text - 394. Text.drop : Nat -> Text -> Text - 395. Text.empty : Text - 396. Text.eq : Text -> Text -> Boolean - 397. Text.fromCharList : [Char] -> Text - 398. Text.fromUtf8.impl : Bytes -> Either Failure Text - 399. Text.gt : Text -> Text -> Boolean - 400. Text.gteq : Text -> Text -> Boolean - 401. Text.lt : Text -> Text -> Boolean - 402. Text.lteq : Text -> Text -> Boolean - 403. Text.repeat : Nat -> Text -> Text - 404. Text.size : Text -> Nat - 405. Text.take : Nat -> Text -> Text - 406. Text.toCharList : Text -> [Char] - 407. Text.toUtf8 : Text -> Bytes - 408. Text.uncons : Text -> Optional (Char, Text) - 409. Text.unsnoc : Text -> Optional (Text, Char) - 410. ThreadId.toText : ThreadId -> Text - 411. todo : a -> b - 412. structural type Tuple a b - 413. Tuple.Cons : a -> b -> Tuple a b - 414. structural type Unit - 415. Unit.Unit : () - 416. Universal.< : a -> a -> Boolean - 417. Universal.<= : a -> a -> Boolean - 418. Universal.== : a -> a -> Boolean - 419. Universal.> : a -> a -> Boolean - 420. Universal.>= : a -> a -> Boolean - 421. Universal.compare : a -> a -> Int - 422. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 423. builtin type Value - 424. Value.dependencies : Value -> [Term] - 425. Value.deserialize : Bytes -> Either Text Value - 426. Value.load : Value ->{IO} Either [Term] a - 427. Value.serialize : Value -> Bytes - 428. Value.value : a -> Value + 390. Scope.ref : a ->{Scope s} Ref {Scope s} a + 391. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r + 392. structural type SeqView a b + 393. SeqView.VElem : a -> b -> SeqView a b + 394. SeqView.VEmpty : SeqView a b + 395. Socket.toText : Socket -> Text + 396. unique type Test.Result + 397. Test.Result.Fail : Text -> Result + 398. Test.Result.Ok : Text -> Result + 399. builtin type Text + 400. Text.!= : Text -> Text -> Boolean + 401. Text.++ : Text -> Text -> Text + 402. Text.drop : Nat -> Text -> Text + 403. Text.empty : Text + 404. Text.eq : Text -> Text -> Boolean + 405. Text.fromCharList : [Char] -> Text + 406. Text.fromUtf8.impl : Bytes -> Either Failure Text + 407. Text.gt : Text -> Text -> Boolean + 408. Text.gteq : Text -> Text -> Boolean + 409. Text.lt : Text -> Text -> Boolean + 410. Text.lteq : Text -> Text -> Boolean + 411. Text.repeat : Nat -> Text -> Text + 412. Text.size : Text -> Nat + 413. Text.take : Nat -> Text -> Text + 414. Text.toCharList : Text -> [Char] + 415. Text.toUtf8 : Text -> Bytes + 416. Text.uncons : Text -> Optional (Char, Text) + 417. Text.unsnoc : Text -> Optional (Text, Char) + 418. ThreadId.toText : ThreadId -> Text + 419. todo : a -> b + 420. structural type Tuple a b + 421. Tuple.Cons : a -> b -> Tuple a b + 422. structural type Unit + 423. Unit.Unit : () + 424. Universal.< : a -> a -> Boolean + 425. Universal.<= : a -> a -> Boolean + 426. Universal.== : a -> a -> Boolean + 427. Universal.> : a -> a -> Boolean + 428. Universal.>= : a -> a -> Boolean + 429. Universal.compare : a -> a -> Int + 430. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 431. builtin type Value + 432. Value.dependencies : Value -> [Term] + 433. Value.deserialize : Bytes -> Either Text Value + 434. Value.load : Value ->{IO} Either [Term] a + 435. Value.serialize : Value -> Bytes + 436. Value.value : a -> Value .builtin> alias.many 94-104 .mylib diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index 89f1f0d2bf..d485a2514b 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -30,9 +30,9 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 19. Float/ (38 definitions) 20. Handle/ (1 definition) 21. ImmutableArray (builtin type) - 22. ImmutableArray/ (2 definitions) + 22. ImmutableArray/ (3 definitions) 23. ImmutableByteArray (builtin type) - 24. ImmutableByteArray/ (5 definitions) + 24. ImmutableByteArray/ (8 definitions) 25. Int (builtin type) 26. Int/ (31 definitions) 27. IsPropagated (type) @@ -44,9 +44,9 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 33. List (builtin type) 34. List/ (10 definitions) 35. MutableArray (builtin type) - 36. MutableArray/ (5 definitions) + 36. MutableArray/ (6 definitions) 37. MutableByteArray (builtin type) - 38. MutableByteArray/ (11 definitions) + 38. MutableByteArray/ (14 definitions) 39. Nat (builtin type) 40. Nat/ (28 definitions) 41. Optional (type) diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index 1f4ef37159..073bc51056 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (428 definitions) + 1. builtin/ (436 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (614 definitions) + 1. builtin/ (622 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index c7a8a38656..719ae8d8e4 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -121,13 +121,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #202434u8i8 + โŠ™ 1. #jr65avdlej - Deletes: feature1.y - โŠ™ 2. #320m7eprtp + โŠ™ 2. #pgehk3ct7o + Adds / updates: @@ -138,26 +138,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - โŠ™ 3. #aqe5ukkpho + โŠ™ 3. #0khri1tu5m + Adds / updates: feature1.y - โŠ™ 4. #jrmqnmjaof + โŠ™ 4. #q6f59u3o3k > Moves: Original name New name x master.x - โŠ™ 5. #c1if8chh6q + โŠ™ 5. #uqmo15fi7h + Adds / updates: x - โ–ก 6. #jbpdv7v5t3 (start of history) + โ–ก 6. #nff3e5eop8 (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md index 286f347609..42e4b481ec 100644 --- a/unison-src/transcripts/name-selection.output.md +++ b/unison-src/transcripts/name-selection.output.md @@ -999,248 +999,275 @@ d = c + 10 -> Nat ->{g, Exception} Nat - 349. builtin.ImmutableByteArray.read32be : ImmutableByteArray + 349. builtin.ImmutableByteArray.read24be : ImmutableByteArray -> Nat ->{Exception} Nat - 350. builtin.MutableByteArray.read32be : MutableByteArray + 350. builtin.MutableByteArray.read24be : MutableByteArray g -> Nat ->{g, Exception} Nat - 351. builtin.ImmutableByteArray.read64be : ImmutableByteArray + 351. builtin.ImmutableByteArray.read32be : ImmutableByteArray -> Nat ->{Exception} Nat - 352. builtin.MutableByteArray.read64be : MutableByteArray + 352. builtin.MutableByteArray.read32be : MutableByteArray g -> Nat ->{g, Exception} Nat - 353. builtin.ImmutableByteArray.read8 : ImmutableByteArray + 353. builtin.ImmutableByteArray.read40be : ImmutableByteArray -> Nat ->{Exception} Nat - 354. builtin.MutableByteArray.read8 : MutableByteArray + 354. builtin.MutableByteArray.read40be : MutableByteArray g -> Nat ->{g, Exception} Nat - 355. builtin.io2.TVar.readIO : TVar a + 355. builtin.ImmutableByteArray.read64be : ImmutableByteArray + -> Nat + ->{Exception} Nat + 356. builtin.MutableByteArray.read64be : MutableByteArray + g + -> Nat + ->{g, + Exception} Nat + 357. builtin.ImmutableByteArray.read8 : ImmutableByteArray + -> Nat + ->{Exception} Nat + 358. builtin.MutableByteArray.read8 : MutableByteArray + g + -> Nat + ->{g, + Exception} Nat + 359. builtin.io2.TVar.readIO : TVar a ->{IO} a - 356. builtin.io2.Clock.internals.realtime : '{IO} Either + 360. builtin.io2.Clock.internals.realtime : '{IO} Either Failure TimeSpec - 357. builtin.io2.IO.ref : a + 361. builtin.io2.IO.ref : a ->{IO} Ref {IO} a - 358. builtin.Scope.ref : a + 362. builtin.Scope.ref : a ->{Scope s} Ref {Scope s} a - 359. builtin.Text.repeat : Nat + 363. builtin.Text.repeat : Nat -> Text -> Text - 360. builtin.io2.STM.retry : '{STM} a - 361. builtin.Float.round : Float + 364. builtin.io2.STM.retry : '{STM} a + 365. builtin.Float.round : Float -> Int - 362. builtin.Scope.run : (โˆ€ s. + 366. builtin.Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 363. builtin.io2.Clock.internals.sec : TimeSpec + 367. builtin.io2.Clock.internals.sec : TimeSpec -> Int - 364. builtin.Code.serialize : Code + 368. builtin.Code.serialize : Code -> Bytes - 365. builtin.Value.serialize : Value + 369. builtin.Value.serialize : Value -> Bytes - 366. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] + 370. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 367. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] + 371. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 368. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] + 372. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 369. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] + 373. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 370. builtin.io2.Tls.ClientConfig.versions.set : [Version] + 374. builtin.io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 371. builtin.io2.Tls.ServerConfig.versions.set : [Version] + 375. builtin.io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 372. builtin.Int.shiftLeft : Int + 376. builtin.Int.shiftLeft : Int -> Nat -> Int - 373. builtin.Nat.shiftLeft : Nat + 377. builtin.Nat.shiftLeft : Nat -> Nat -> Nat - 374. builtin.Int.shiftRight : Int + 378. builtin.Int.shiftRight : Int -> Nat -> Int - 375. builtin.Nat.shiftRight : Nat + 379. builtin.Nat.shiftRight : Nat -> Nat -> Nat - 376. builtin.Int.signum : Int + 380. builtin.Int.signum : Int -> Int - 377. builtin.Float.sin : Float + 381. builtin.Float.sin : Float -> Float - 378. builtin.Float.sinh : Float + 382. builtin.Float.sinh : Float -> Float - 379. builtin.Bytes.size : Bytes + 383. builtin.Bytes.size : Bytes + -> Nat + 384. builtin.ImmutableArray.size : ImmutableArray + a + -> Nat + 385. builtin.ImmutableByteArray.size : ImmutableByteArray -> Nat - 380. builtin.List.size : [a] + 386. builtin.List.size : [a] + -> Nat + 387. builtin.MutableArray.size : MutableArray + g a + -> Nat + 388. builtin.MutableByteArray.size : MutableByteArray + g -> Nat - 381. builtin.Text.size : Text + 389. builtin.Text.size : Text -> Nat - 382. builtin.Float.sqrt : Float + 390. builtin.Float.sqrt : Float -> Float - 383. builtin.io2.IO.stdHandle : StdHandle + 391. builtin.io2.IO.stdHandle : StdHandle -> Handle - 384. builtin.Nat.sub : Nat + 392. builtin.Nat.sub : Nat -> Nat -> Int - 385. builtin.io2.TVar.swap : TVar a + 393. builtin.io2.TVar.swap : TVar a -> a ->{STM} a - 386. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int - 387. builtin.Bytes.take : Nat + 394. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int + 395. builtin.Bytes.take : Nat -> Bytes -> Bytes - 388. builtin.List.take : Nat + 396. builtin.List.take : Nat -> [a] -> [a] - 389. builtin.Text.take : Nat + 397. builtin.Text.take : Nat -> Text -> Text - 390. builtin.Float.tan : Float + 398. builtin.Float.tan : Float -> Float - 391. builtin.Float.tanh : Float + 399. builtin.Float.tanh : Float -> Float - 392. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either + 400. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either Failure TimeSpec - 393. builtin.Bytes.toBase16 : Bytes + 401. builtin.Bytes.toBase16 : Bytes -> Bytes - 394. builtin.Bytes.toBase32 : Bytes + 402. builtin.Bytes.toBase32 : Bytes -> Bytes - 395. builtin.Bytes.toBase64 : Bytes + 403. builtin.Bytes.toBase64 : Bytes -> Bytes - 396. builtin.Bytes.toBase64UrlUnpadded : Bytes + 404. builtin.Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 397. builtin.Text.toCharList : Text + 405. builtin.Text.toCharList : Text -> [Char] - 398. builtin.Int.toFloat : Int + 406. builtin.Int.toFloat : Int -> Float - 399. builtin.Nat.toFloat : Nat + 407. builtin.Nat.toFloat : Nat -> Float - 400. builtin.Nat.toInt : Nat + 408. builtin.Nat.toInt : Nat -> Int - 401. builtin.Bytes.toList : Bytes + 409. builtin.Bytes.toList : Bytes -> [Nat] - 402. builtin.Char.toNat : Char + 410. builtin.Char.toNat : Char -> Nat - 403. builtin.Float.toRepresentation : Float + 411. builtin.Float.toRepresentation : Float -> Nat - 404. builtin.Int.toRepresentation : Int + 412. builtin.Int.toRepresentation : Int -> Nat - 405. builtin.Char.toText : Char + 413. builtin.Char.toText : Char -> Text - 406. builtin.Float.toText : Float + 414. builtin.Float.toText : Float -> Text - 407. builtin.Handle.toText : Handle + 415. builtin.Handle.toText : Handle -> Text - 408. builtin.Int.toText : Int + 416. builtin.Int.toText : Int -> Text - 409. builtin.Nat.toText : Nat + 417. builtin.Nat.toText : Nat -> Text - 410. builtin.Socket.toText : Socket + 418. builtin.Socket.toText : Socket -> Text - 411. builtin.Link.Term.toText : Term + 419. builtin.Link.Term.toText : Term -> Text - 412. builtin.ThreadId.toText : ThreadId + 420. builtin.ThreadId.toText : ThreadId -> Text - 413. builtin.Text.toUtf8 : Text + 421. builtin.Text.toUtf8 : Text -> Bytes - 414. builtin.todo : a -> b - 415. builtin.Debug.trace : Text + 422. builtin.todo : a -> b + 423. builtin.Debug.trace : Text -> a -> () - 416. builtin.Int.trailingZeros : Int + 424. builtin.Int.trailingZeros : Int -> Nat - 417. builtin.Nat.trailingZeros : Nat + 425. builtin.Nat.trailingZeros : Nat -> Nat - 418. builtin.Float.truncate : Float + 426. builtin.Float.truncate : Float -> Int - 419. builtin.Int.truncate0 : Int + 427. builtin.Int.truncate0 : Int -> Nat - 420. builtin.io2.MVar.tryTake : MVar a + 428. builtin.io2.MVar.tryTake : MVar a ->{IO} Optional a - 421. builtin.Text.uncons : Text + 429. builtin.Text.uncons : Text -> Optional ( Char, Text) - 422. builtin.Any.unsafeExtract : Any + 430. builtin.Any.unsafeExtract : Any -> a - 423. builtin.Text.unsnoc : Text + 431. builtin.Text.unsnoc : Text -> Optional ( Text, Char) - 424. builtin.Code.validate : [( Term, + 432. builtin.Code.validate : [( Term, Code)] ->{IO} Optional Failure - 425. builtin.io2.validateSandboxed : [Term] + 433. builtin.io2.validateSandboxed : [Term] -> a -> Boolean - 426. builtin.Value.value : a + 434. builtin.Value.value : a -> Value - 427. builtin.Debug.watch : Text + 435. builtin.Debug.watch : Text -> a -> a - 428. builtin.MutableArray.write : MutableArray + 436. builtin.MutableArray.write : MutableArray g a -> Nat -> a ->{g, Exception} () - 429. builtin.Ref.write : Ref g a + 437. builtin.Ref.write : Ref g a -> a ->{g} () - 430. builtin.io2.TVar.write : TVar a + 438. builtin.io2.TVar.write : TVar a -> a ->{STM} () - 431. builtin.MutableByteArray.write16be : MutableByteArray + 439. builtin.MutableByteArray.write16be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 432. builtin.MutableByteArray.write32be : MutableByteArray + 440. builtin.MutableByteArray.write32be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 433. builtin.MutableByteArray.write64be : MutableByteArray + 441. builtin.MutableByteArray.write64be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 434. builtin.MutableByteArray.write8 : MutableByteArray + 442. builtin.MutableByteArray.write8 : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 435. builtin.Int.xor : Int + 443. builtin.Int.xor : Int -> Int -> Int - 436. builtin.Nat.xor : Nat + 444. builtin.Nat.xor : Nat -> Nat -> Nat diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index 2a1df00cdd..3e87a253c7 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #iqpoatoq9n .old` to make an old namespace + `fork #6avukg1d7b .old` to make an old namespace accessible again, - `reset-root #iqpoatoq9n` to reset the root namespace and + `reset-root #6avukg1d7b` to reset the root namespace and its history to that of the specified namespace. - 1. #n6l0a3mq9e : add - 2. #iqpoatoq9n : add - 3. #rhmjfkq4o8 : builtins.merge + 1. #k5sfmp4o7j : add + 2. #6avukg1d7b : add + 3. #r2v7tldu09 : builtins.merge 4. #sg60bvjo91 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index e72b698531..c2be548b8e 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - โ–ก 1. #m7huejvgd3 (start of history) + โ–ก 1. #86a70rllk7 (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #6f0a8lccsd + โŠ™ 1. #o7ieckac34 > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #rp32arn4ko + โŠ™ 2. #62nvn4fabv > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #m7huejvgd3 (start of history) + โ–ก 3. #86a70rllk7 (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #6f0a8lccsd + โŠ™ 1. #o7ieckac34 > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #rp32arn4ko + โŠ™ 2. #62nvn4fabv > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #m7huejvgd3 (start of history) + โ–ก 3. #86a70rllk7 (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - โ–ก 1. #m7huejvgd3 (start of history) + โ–ก 1. #86a70rllk7 (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #1rs3r831e3 + โŠ™ 1. #4aqembjjs5 - Deletes: Nat.* Nat.+ - โ–ก 2. #m7huejvgd3 (start of history) + โ–ก 2. #86a70rllk7 (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From 7baebea9281646364ae92dc97e79aae1d5bfce22 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 23 Jun 2022 10:25:01 -0400 Subject: [PATCH 388/529] begin implementing concurrent pull --- stack.yaml | 4 ++ stack.yaml.lock | 13 +++++++ unison-cli/package.yaml | 1 + unison-cli/src/Unison/Share/Sync.hs | 60 ++++++++++++++++++++++++++++- unison-cli/unison-cli.cabal | 7 +++- 5 files changed, 82 insertions(+), 3 deletions(-) diff --git a/stack.yaml b/stack.yaml index 2010e7d54f..3e061d0d20 100644 --- a/stack.yaml +++ b/stack.yaml @@ -40,6 +40,10 @@ extra-deps: commit: e47e9e9fe1f576f8c835183b9def52d73c01327a - github: unisonweb/shellmet commit: 2fd348592c8f51bb4c0ca6ba4bc8e38668913746 +- github: awkward-squad/ki + commit: 712e5031b586b5111577a73268a9a204073ed25d + subdirs: + - ki - guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 - prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 - sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 diff --git a/stack.yaml.lock b/stack.yaml.lock index 5b02d7d131..0a958a5ae6 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -26,6 +26,19 @@ packages: sha256: 05a169a7a6b68100630e885054dc1821d31cd06571b0317ec90c75ac2c41aeb7 original: url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz +- completed: + size: 16162 + subdir: ki + url: https://github.com/awkward-squad/ki/archive/712e5031b586b5111577a73268a9a204073ed25d.tar.gz + name: ki + version: 1.0.0 + sha256: e65c035a383dc43aeaeda7264d4570826402609bbc729b2e761ee41365691fa6 + pantry-tree: + size: 704 + sha256: ce05acf45f3594cd724cb9fd559e4657984335812a8620b6dc06d87f2134acdb + original: + subdir: ki + url: https://github.com/awkward-squad/ki/archive/712e5031b586b5111577a73268a9a204073ed25d.tar.gz - completed: hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 pantry-tree: diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 3cb48ed975..0490f9bd42 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -33,6 +33,7 @@ dependencies: - http-client-tls - http-types - jwt + - ki - lens - lock-file - megaparsec diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 4bd9f97616..6f151507d6 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -20,6 +20,7 @@ module Unison.Share.Sync ) where +import Control.Concurrent.STM import Control.Monad.Except import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader @@ -39,6 +40,8 @@ import qualified Data.Set.NonEmpty as NESet import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Encoding as Text.Lazy import Data.These (These (..)) +import Data.Void (Void) +import qualified Ki import qualified Network.HTTP.Client as Http.Client import qualified Network.HTTP.Types as HTTP import qualified Servant.API as Servant ((:<|>) (..), (:>)) @@ -378,7 +381,60 @@ completeTempEntities :: (Int -> Int -> IO ()) -> NESet Hash32 -> IO Int -completeTempEntities doDownload conn downloadProgressCallback = +completeTempEntities doDownload conn downloadProgressCallback initialHashes0 = do + initialHashes <- elaborate initialHashes0 + hashesVar <- newTVarIO (NESet.toSet initialHashes) + + entitiesQueue <- newTQueueIO + newTempEntitiesQueue <- newTQueueIO + outstandingWorkersCountVar <- newTVarIO (0 :: Int) + + Ki.scoped \scope -> do + Ki.fork_ scope do + forever do + entities <- atomically (readTQueue entitiesQueue) + newTempEntities0 <- + Sqlite.runTransaction conn do + NEMap.toList entities & foldMapM \(hash, entity) -> + upsertEntitySomewhere hash entity <&> \case + Q.EntityInMainStorage -> Set.empty + Q.EntityInTempStorage -> Set.singleton hash + whenJust (NESet.nonEmptySet newTempEntities0) \newTempEntities -> + atomically (writeTQueue newTempEntitiesQueue newTempEntities) + + Ki.fork_ scope do + forever do + newTempEntities <- atomically (readTQueue newTempEntitiesQueue) + newElaboratedHashes <- elaborate newTempEntities + atomically (modifyTVar' hashesVar (Set.union (NESet.toSet newElaboratedHashes))) + + let loop :: IO () + loop = do + hashes <- + atomically do + hashes <- readTVar hashesVar + if Set.null hashes + then retry + else do + let (hashes1, hashes2) = Set.splitAt 50 hashes + writeTVar hashesVar hashes2 + pure (NESet.unsafeFromSet hashes1) + + _ <- Ki.fork @() scope do + atomically (modifyTVar' outstandingWorkersCountVar (+ 1)) + Share.DownloadEntitiesSuccess entities <- + httpDownloadEntities + undefined -- httpClient + undefined -- unisonShareUrl + Share.DownloadEntitiesRequest {repoName = undefined, hashes} + atomically do + writeTQueue entitiesQueue entities + modifyTVar' outstandingWorkersCountVar \n -> n - 1 + + undefined + + loop + let loop :: Int -> NESet Share.HashJWT -> IO Int loop !downloadCount allHashes = do downloadProgressCallback downloadCount (NESet.size allHashes) @@ -400,7 +456,7 @@ completeTempEntities doDownload conn downloadProgressCallback = case maybeNextHashes of Nothing -> pure newDownloadCount Just nextHashes -> loop newDownloadCount nextHashes - in \hashes0 -> elaborate hashes0 >>= loop 0 + loop 0 initialHashes where elaborate :: NESet Hash32 -> IO (NESet Share.HashJWT) elaborate hashes = diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 8115855fb0..0de7f7d521 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack @@ -116,6 +116,7 @@ library , http-client-tls , http-types , jwt + , ki , lens , lock-file , megaparsec @@ -218,6 +219,7 @@ executable cli-integration-tests , http-client-tls , http-types , jwt + , ki , lens , lock-file , megaparsec @@ -315,6 +317,7 @@ executable transcripts , http-client-tls , http-types , jwt + , ki , lens , lock-file , megaparsec @@ -416,6 +419,7 @@ executable unison , http-client-tls , http-types , jwt + , ki , lens , lock-file , megaparsec @@ -525,6 +529,7 @@ test-suite cli-tests , http-client-tls , http-types , jwt + , ki , lens , lock-file , megaparsec From ad60aa4c76861268604ee15771f3609e2a314cb4 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 23 Jun 2022 15:06:14 -0400 Subject: [PATCH 389/529] implement concurrent pull --- .../U/Codebase/Sqlite/Queries.hs | 16 +- .../src/Unison/Codebase/SqliteCodebase.hs | 5 +- .../src/Unison/Codebase/Type.hs | 5 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 28 +- unison-cli/src/Unison/Share/Sync.hs | 251 +++++++++++------- 5 files changed, 172 insertions(+), 133 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index dac3a01da4..b150a2cbeb 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -1589,11 +1589,6 @@ deleteTempEntity hash = |] (Only hash) -data EmptyTempEntityMissingDependencies - = EmptyTempEntityMissingDependencies - deriving stock (Show) - deriving anyclass (SqliteExceptionReason) - -- | "Elaborate" a set of `temp_entity` hashes. -- -- Given a set of `temp_entity` hashes, returns the (known) set of transitive dependencies that haven't already been @@ -1610,7 +1605,7 @@ data EmptyTempEntityMissingDependencies -- -- ... then `elaborateHashes {A}` would return the singleton set {C} (because we take the set of transitive -- dependencies {A,B,C} and subtract the set we already have, {A,B}). -elaborateHashes :: Nel.NonEmpty Hash32 -> Transaction (Nel.NonEmpty Text) +elaborateHashes :: Nel.NonEmpty Hash32 -> Transaction [Text] elaborateHashes hashes = do execute_ [here| @@ -1618,13 +1613,12 @@ elaborateHashes hashes = do |] executeMany [here| - INSERT INTO new_temp_entity_dependents - (hash) + INSERT INTO new_temp_entity_dependents (hash) VALUES (?) |] (map Only (Nel.toList hashes)) result <- - queryListColCheck_ + queryListCol_ [here| WITH RECURSIVE elaborated_dependency (hash, hashJwt) AS ( SELECT temd.dependency, temd.dependencyJwt @@ -1644,10 +1638,6 @@ elaborateHashes hashes = do WHERE temp_entity.hash = elaborated_dependency.hash ) |] - ( \case - [] -> Left EmptyTempEntityMissingDependencies - x : xs -> Right (x Nel.:| xs) - ) execute_ [here|DROP TABLE new_temp_entity_dependents|] pure result diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index a7e17b845d..4aae8f20f9 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -196,7 +196,7 @@ sqliteCodebase :: m (Either Codebase1.OpenCodebaseError r) sqliteCodebase debugName root localOrRemote action = do Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root - withConnection debugName root $ \conn -> do + withConnection debugName root \conn -> do termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable typeOfTermCache <- Cache.semispaceCache 8192 declCache <- Cache.semispaceCache 1024 @@ -490,7 +490,8 @@ sqliteCodebase debugName root localOrRemote action = do namesAtPath = \path -> Sqlite.runReadOnlyTransaction conn \runTx -> runTx (CodebaseOps.namesAtPath path), updateNameLookup = Sqlite.runTransaction conn (CodebaseOps.updateNameLookupIndexFromV2Root getDeclType), - connection = conn + connection = conn, + withConnection = withConnection debugName root } let finalizer :: MonadIO m => m () finalizer = do diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 8087244a20..a3e4c4f518 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -181,7 +181,10 @@ data Codebase m v a = Codebase -- At one time the codebase was meant to abstract over the storage layer, but it has been cumbersome. Now we prefer -- to interact with SQLite directly, and so provide this temporary escape hatch, until we can eliminate this -- interface entirely. - connection :: Sqlite.Connection + connection :: Sqlite.Connection, + -- | Another escape hatch like the above connection, but this one makes a new connection to the same underlying + -- database file. This allows code (like pull-from-share) to use more than one connection concurrently. + withConnection :: forall x. (Sqlite.Connection -> IO x) -> IO x } -- | Whether a codebase is local or remote. diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f0460df262..f745f166a4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -8,7 +8,7 @@ where -- TODO: Don't import backend -import Control.Concurrent.STM (atomically, newTVarIO, readTVar, readTVarIO, writeTVar) +import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO, writeTVar) import qualified Control.Error.Util as ErrorUtil import Control.Lens import Control.Monad.Except (ExceptT (..), runExceptT, throwError, withExceptT) @@ -2322,16 +2322,16 @@ importRemoteShareBranch rrn@(ReadShareRemoteNamespace {server, repo, path}) = do when (not $ RemoteRepo.isPublic rrn) $ ensureAuthenticatedWithCodeserver codeserver mapLeft Output.ShareError <$> do let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) - LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask + LoopState.Env {authHTTPClient, codebase = codebase@Codebase {withConnection}} <- ask let pull :: IO (Either (Sync.SyncError Share.PullError) CausalHash) pull = - withEntitiesDownloadedProgressCallback \entitiesDownloadedProgressCallback -> + withEntitiesDownloadedProgressCallbacks \callbacks -> Share.pull authHTTPClient baseURL - connection + withConnection shareFlavoredPath - entitiesDownloadedProgressCallback + callbacks liftIO pull >>= \case Left (Sync.SyncError err) -> pure (Left (Output.ShareErrorPull err)) Left (Sync.TransportError err) -> pure (Left (Output.ShareErrorTransport err)) @@ -2340,10 +2340,9 @@ importRemoteShareBranch rrn@(ReadShareRemoteNamespace {server, repo, path}) = do Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" Just branch -> pure (Right branch) where - -- Provide the given action a callback that prints out the number of entities downloaded, and the number of entities - -- enqueued to be downloaded. - withEntitiesDownloadedProgressCallback :: ((Int -> Int -> IO ()) -> IO a) -> IO a - withEntitiesDownloadedProgressCallback action = do + -- Provide the given action callbacks that display to the terminal. + withEntitiesDownloadedProgressCallbacks :: (Share.DownloadProgressCallbacks -> IO a) -> IO a + withEntitiesDownloadedProgressCallbacks action = do entitiesDownloadedVar <- newTVarIO 0 entitiesToDownloadVar <- newTVarIO 0 Console.Regions.displayConsoleRegions do @@ -2355,13 +2354,12 @@ importRemoteShareBranch rrn@(ReadShareRemoteNamespace {server, repo, path}) = do "\n Downloaded " <> tShow entitiesDownloaded <> "/" - <> tShow (entitiesDownloaded + entitiesToDownload) + <> tShow entitiesToDownload <> " entities...\n\n" - result <- - action \entitiesDownloaded entitiesToDownload -> - atomically do - writeTVar entitiesDownloadedVar entitiesDownloaded - writeTVar entitiesToDownloadVar entitiesToDownload + result <- do + let downloaded n = atomically (modifyTVar' entitiesDownloadedVar (+ n)) + let toDownload n = atomically (modifyTVar' entitiesToDownloadVar (+ n)) + action Share.DownloadProgressCallbacks {downloaded, toDownload} entitiesDownloaded <- readTVarIO entitiesDownloadedVar Console.Regions.finishConsoleRegion region $ "\n Downloaded " <> tShow entitiesDownloaded <> " entities.\n" diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 6f151507d6..11b1f3d483 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -16,6 +16,7 @@ module Unison.Share.Sync -- ** Pull pull, + DownloadProgressCallbacks (..), PullError (..), ) where @@ -40,7 +41,6 @@ import qualified Data.Set.NonEmpty as NESet import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Encoding as Text.Lazy import Data.These (These (..)) -import Data.Void (Void) import qualified Ki import qualified Network.HTTP.Client as Http.Client import qualified Network.HTTP.Types as HTTP @@ -329,138 +329,186 @@ dagbfs goal children = ------------------------------------------------------------------------------------------------------------------------ -- Pull +-- | Download progress callbacks. +data DownloadProgressCallbacks = DownloadProgressCallbacks + { -- | Callback that's given a number of entities we just downloaded. + downloaded :: Int -> IO (), + -- | Callback that's given a number of entities we just realized we need to download later. + toDownload :: Int -> IO () + } + pull :: -- | The HTTP client to use for Unison Share requests. AuthenticatedHttpClient -> -- | The Unison Share URL. BaseUrl -> - -- | SQLite connection, for writing entities we pull. - Sqlite.Connection -> + -- | SQLite-connection-making function, for writing entities we pull. + (forall a. (Sqlite.Connection -> IO a) -> IO a) -> -- | The repo+path to pull from. Share.Path -> - -- | Callback that is given the total number of entities downloaded, and the number of outstanding entities to - -- download. - (Int -> Int -> IO ()) -> + DownloadProgressCallbacks -> IO (Either (SyncError PullError) CausalHash) -pull httpClient unisonShareUrl conn repoPath downloadProgressCallback = catchSyncErrors do +pull httpClient unisonShareUrl connect repoPath callbacks = catchSyncErrors do getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case Left err -> pure (Left (PullErrorGetCausalHashByPath err)) -- There's nothing at the remote path, so there's no causal to pull. Right Nothing -> pure (Left (PullErrorNoHistoryAtPath repoPath)) Right (Just hashJwt) -> do let hash = Share.hashJWTHash hashJwt - (maybeTempEntities, downloaded1) <- - Sqlite.runTransaction conn (Q.entityLocation hash) >>= \case - Just Q.EntityInMainStorage -> pure (Nothing, 0) - Just Q.EntityInTempStorage -> pure (Just (NESet.singleton hash), 0) - Nothing -> do - tempEntities <- doDownload (NESet.singleton hashJwt) - pure (tempEntities, 1) - downloaded2 <- - case maybeTempEntities of - Nothing -> pure 0 - Just tempEntities -> do - completeTempEntities - doDownload - conn - (\downloaded enqueued -> downloadProgressCallback (downloaded + downloaded1) enqueued) - tempEntities - downloadProgressCallback (downloaded1 + downloaded2) 0 + maybeTempEntities <- + connect \conn -> + Sqlite.runTransaction conn (Q.entityLocation hash) >>= \case + Just Q.EntityInMainStorage -> pure Nothing + Just Q.EntityInTempStorage -> pure (Just (NESet.singleton hash)) + Nothing -> do + toDownload callbacks 1 + tempEntities <- downloadEntities httpClient unisonShareUrl conn repoName (NESet.singleton hashJwt) + downloaded callbacks 1 + pure tempEntities + whenJust maybeTempEntities \tempEntities -> + completeTempEntities + httpClient + unisonShareUrl + connect + repoName + callbacks + tempEntities pure (Right (hash32ToCausalHash hash)) where repoName = Share.pathRepoName repoPath - doDownload = downloadEntities httpClient unisonShareUrl conn repoName -- | Finish downloading entities from Unison Share. Returns the total number of entities downloaded. -- -- Precondition: the entities were *already* downloaded at some point in the past, and are now sitting in the -- `temp_entity` table, waiting for their dependencies to arrive so they can be flushed to main storage. completeTempEntities :: - (NESet Share.HashJWT -> IO (Maybe (NESet Hash32))) -> - Sqlite.Connection -> - (Int -> Int -> IO ()) -> + AuthenticatedHttpClient -> + BaseUrl -> + (forall a. (Sqlite.Connection -> IO a) -> IO a) -> + Share.RepoName -> + DownloadProgressCallbacks -> NESet Hash32 -> - IO Int -completeTempEntities doDownload conn downloadProgressCallback initialHashes0 = do - initialHashes <- elaborate initialHashes0 - hashesVar <- newTVarIO (NESet.toSet initialHashes) + IO () +completeTempEntities httpClient unisonShareUrl connect repoName callbacks initialNewTempEntities = do + -- The set of hashes we still need to download from Unison Share + hashesVar <- newTVarIO Set.empty + -- The set of hashes that we haven't inserted yet, but will soon, because we've committed to downloading them. + uninsertedHashesVar <- newTVarIO Set.empty + + -- The entities payloads that we've downloaded from UnisonShare + -- FIXME pick up here commenting things entitiesQueue <- newTQueueIO + newTempEntitiesQueue <- newTQueueIO + outstandingWorkersCountVar <- newTVarIO (0 :: Int) + let recordWorking = modifyTVar' outstandingWorkersCountVar (+ 1) + let recordNotWorking = modifyTVar' outstandingWorkersCountVar \n -> n - 1 Ki.scoped \scope -> do + -- Inserter thread: dequeue from `entitiesQueue`, insert entities, enqueue to `newTempEntitiesQueue` Ki.fork_ scope do - forever do - entities <- atomically (readTQueue entitiesQueue) - newTempEntities0 <- - Sqlite.runTransaction conn do - NEMap.toList entities & foldMapM \(hash, entity) -> - upsertEntitySomewhere hash entity <&> \case - Q.EntityInMainStorage -> Set.empty - Q.EntityInTempStorage -> Set.singleton hash - whenJust (NESet.nonEmptySet newTempEntities0) \newTempEntities -> - atomically (writeTQueue newTempEntitiesQueue newTempEntities) - + connect \conn -> + forever do + (hashJwts, entities) <- + atomically do + entities <- readTQueue entitiesQueue + recordWorking + pure entities + newTempEntities0 <- + Sqlite.runTransaction conn do + NEMap.toList entities & foldMapM \(hash, entity) -> + upsertEntitySomewhere hash entity <&> \case + Q.EntityInMainStorage -> Set.empty + Q.EntityInTempStorage -> Set.singleton hash + atomically do + -- Avoid unnecessary retaining of these hashes to keep memory usage more stable. This algorithm would still be + -- correct if we never delete from `uninsertedHashes`. + modifyTVar' uninsertedHashesVar \uninsertedHashes -> + Set.difference uninsertedHashes (NESet.toSet hashJwts) + whenJust (NESet.nonEmptySet newTempEntities0) \newTempEntities -> + writeTQueue newTempEntitiesQueue newTempEntities + recordNotWorking + + -- Elaborator thread: dequeue from `newTempEntitiesQueue`, elaborate, "enqueue" to `hashesVar` Ki.fork_ scope do - forever do - newTempEntities <- atomically (readTQueue newTempEntitiesQueue) - newElaboratedHashes <- elaborate newTempEntities - atomically (modifyTVar' hashesVar (Set.union (NESet.toSet newElaboratedHashes))) - - let loop :: IO () - loop = do - hashes <- + connect \conn -> + forever do + newTempEntities <- atomically do - hashes <- readTVar hashesVar - if Set.null hashes - then retry - else do - let (hashes1, hashes2) = Set.splitAt 50 hashes - writeTVar hashesVar hashes2 - pure (NESet.unsafeFromSet hashes1) - - _ <- Ki.fork @() scope do - atomically (modifyTVar' outstandingWorkersCountVar (+ 1)) - Share.DownloadEntitiesSuccess entities <- - httpDownloadEntities - undefined -- httpClient - undefined -- unisonShareUrl - Share.DownloadEntitiesRequest {repoName = undefined, hashes} + newTempEntities <- readTQueue newTempEntitiesQueue + recordWorking + pure newTempEntities + newElaboratedHashes <- Sqlite.runTransaction conn (elaborateHashes newTempEntities) + n <- atomically do - writeTQueue entitiesQueue entities - modifyTVar' outstandingWorkersCountVar \n -> n - 1 - - undefined - - loop - - let loop :: Int -> NESet Share.HashJWT -> IO Int - loop !downloadCount allHashes = do - downloadProgressCallback downloadCount (NESet.size allHashes) - - -- Each request only contains a certain maximum number of entities; split the set of hashes we need to download - -- into those we will download right now, and those we will begin downloading on the next iteration of the loop. - let (hashes, nextHashes0) = - case NESet.splitAt 50 allHashes of - This hs1 -> (hs1, Set.empty) - That hs2 -> (hs2, Set.empty) -- impossible, this only happens if we split at 0 - These hs1 hs2 -> (hs1, NESet.toSet hs2) - maybeNextHashes <- - doDownload hashes >>= \case - Nothing -> pure (NESet.nonEmptySet nextHashes0) - Just newTempEntities -> do - newElaboratedHashes <- elaborate newTempEntities - pure (Just (union10 newElaboratedHashes nextHashes0)) - let !newDownloadCount = downloadCount + NESet.size hashes - case maybeNextHashes of - Nothing -> pure newDownloadCount - Just nextHashes -> loop newDownloadCount nextHashes - loop 0 initialHashes - where - elaborate :: NESet Hash32 -> IO (NESet Share.HashJWT) - elaborate hashes = - Sqlite.runTransaction conn (elaborateHashes hashes) + uninsertedHashes <- readTVar uninsertedHashesVar + hashes0 <- readTVar hashesVar + let !hashes1 = Set.union (Set.difference newElaboratedHashes uninsertedHashes) hashes0 + writeTVar hashesVar hashes1 + pure (Set.size hashes1 - Set.size hashes0) + toDownload callbacks n + atomically recordNotWorking + + -- Downloader thread: download entities, enqueue to `entitiesQueue` + let downloader :: NESet Share.HashJWT -> IO () + downloader hashes = do + Share.DownloadEntitiesSuccess entities <- + httpDownloadEntities + httpClient + unisonShareUrl + Share.DownloadEntitiesRequest {repoName, hashes} + downloaded callbacks (NESet.size hashes) + atomically do + writeTQueue entitiesQueue (hashes, entities) + recordNotWorking + + -- Dispatcher thread: "dequeue" from `hashesVar`, fork one-shot downloaders. + -- + -- We stop when all of the following are true: + -- + -- - There are no outstanding workers (downloaders, inserter, elaboraror) + -- - The inserter thread doesn't have any outstanding work enqueued (in `entitiesQueue`) + -- - The elaborator thread doesn't have any outstanding work enqueued (in `newTempEntitiesQueue`) + let dispatcher :: IO () + dispatcher = + (join . atomically . asum) + [ do + hashes <- readTVar hashesVar + when (Set.null hashes) retry + let (hashes1, hashes2) = Set.splitAt 50 hashes + modifyTVar' uninsertedHashesVar (Set.union hashes1) + writeTVar hashesVar hashes2 + pure do + -- Only allow 10 concurrent http workers + atomically do + workers <- readTVar outstandingWorkersCountVar + -- 12 workers = inserter + elaborator + 10 http workers + when (workers >= 12) retry + -- we do need to record the downloader as working outside of the worker thread, not inside. + -- otherwise, we might erroneously fall through the the teardown logic below and conclude there's + -- nothing more for the dispatcher to do, when in fact a downloader thread just hasn't made it as + -- far as recording its own existence + recordWorking + _ <- Ki.fork scope (downloader (NESet.unsafeFromSet hashes1)) + dispatcher, + do + workers <- readTVar outstandingWorkersCountVar + when (workers > 0) retry + isEmptyTQueue entitiesQueue >>= \case + False -> retry + True -> pure () + isEmptyTQueue newTempEntitiesQueue >>= \case + False -> retry + True -> pure () + -- No hashes left to download, no outstanding workers, no work in either queue - we're done! + pure (pure ()) + ] + + -- Kick off the cycle of inserter->elaborator->dispatcher->worker by giving the elaborator something to do + atomically (writeTQueue newTempEntitiesQueue initialNewTempEntities) + dispatcher -- | Download a set of entities from Unison Share. Returns the subset of those entities that we stored in temp storage -- (`temp_entitiy`) instead of main storage (`object` / `causal`) due to missing dependencies. @@ -580,10 +628,9 @@ union10 xs ys = -- 3. If it's in main storage, we should ignore it. -- -- In the end, we return a set of hashes that correspond to entities we actually need to download. -elaborateHashes :: NESet Hash32 -> Sqlite.Transaction (NESet Share.HashJWT) +elaborateHashes :: NESet Hash32 -> Sqlite.Transaction (Set Share.HashJWT) elaborateHashes hashes = - Q.elaborateHashes (NESet.toList hashes) - <&> NESet.fromList . coerce @(List.NonEmpty Text) @(List.NonEmpty Share.HashJWT) + Q.elaborateHashes (NESet.toList hashes) <&> Set.fromList . coerce @[Text] @[Share.HashJWT] -- | Upsert a downloaded entity "somewhere" - -- From 7bc7c3d1164d32f9d3ddf3570cd173c78b6572d4 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 23 Jun 2022 16:36:40 -0400 Subject: [PATCH 390/529] break up completeTempEntities a bit so it's easier to understand --- unison-cli/src/Unison/Share/Sync.hs | 198 ++++++++++++++++++---------- 1 file changed, 125 insertions(+), 73 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 11b1f3d483..d05387ceb4 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -41,6 +41,7 @@ import qualified Data.Set.NonEmpty as NESet import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Encoding as Text.Lazy import Data.These (These (..)) +import Data.Void (Void) import qualified Ki import qualified Network.HTTP.Client as Http.Client import qualified Network.HTTP.Types as HTTP @@ -377,6 +378,21 @@ pull httpClient unisonShareUrl connect repoPath callbacks = catchSyncErrors do where repoName = Share.pathRepoName repoPath +type WorkerCount = + TVar Int + +newWorkerCount :: IO WorkerCount +newWorkerCount = + newTVarIO 0 + +recordWorking :: WorkerCount -> STM () +recordWorking sem = + modifyTVar' sem (+ 1) + +recordNotWorking :: WorkerCount -> STM () +recordNotWorking sem = + modifyTVar' sem \n -> n - 1 + -- | Finish downloading entities from Unison Share. Returns the total number of entities downloaded. -- -- Precondition: the entities were *already* downloaded at some point in the past, and are now sitting in the @@ -390,31 +406,120 @@ completeTempEntities :: NESet Hash32 -> IO () completeTempEntities httpClient unisonShareUrl connect repoName callbacks initialNewTempEntities = do - -- The set of hashes we still need to download from Unison Share + -- The set of hashes we still need to download hashesVar <- newTVarIO Set.empty -- The set of hashes that we haven't inserted yet, but will soon, because we've committed to downloading them. uninsertedHashesVar <- newTVarIO Set.empty - -- The entities payloads that we've downloaded from UnisonShare - -- FIXME pick up here commenting things + -- The entities payloads (along with the jwts that we used to download them) that we've downloaded entitiesQueue <- newTQueueIO + -- The sets of new (at the time of inserting, anyway) temp entity rows, which we need to elaborate, then download. newTempEntitiesQueue <- newTQueueIO - outstandingWorkersCountVar <- newTVarIO (0 :: Int) - let recordWorking = modifyTVar' outstandingWorkersCountVar (+ 1) - let recordNotWorking = modifyTVar' outstandingWorkersCountVar \n -> n - 1 + workerCount <- newWorkerCount Ki.scoped \scope -> do + Ki.fork_ scope (inserter uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount) + Ki.fork_ scope (elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount) + -- Kick off the cycle of inserter->elaborator->dispatcher->worker by giving the elaborator something to do + atomically (writeTQueue newTempEntitiesQueue initialNewTempEntities) + dispatcher + (\hashes -> void (Ki.fork scope (downloader entitiesQueue workerCount hashes))) + hashesVar + uninsertedHashesVar + entitiesQueue + newTempEntitiesQueue + workerCount + where + -- Dispatcher thread: "dequeue" from `hashesVar`, fork one-shot downloaders. + -- + -- We stop when all of the following are true: + -- + -- - There are no outstanding workers (downloaders, inserter, elaboraror) + -- - The inserter thread doesn't have any outstanding work enqueued (in `entitiesQueue`) + -- - The elaborator thread doesn't have any outstanding work enqueued (in `newTempEntitiesQueue`) + dispatcher :: + (NESet Share.HashJWT -> IO ()) -> + TVar (Set Share.HashJWT) -> + TVar (Set Share.HashJWT) -> + TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) -> + TQueue (NESet Hash32) -> + WorkerCount -> + IO () + dispatcher forkDownloader hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount = + loop + where + loop :: IO () + loop = + join (atomically (dispatchWorkMode <|> checkIfDoneMode)) + + dispatchWorkMode :: STM (IO ()) + dispatchWorkMode = do + hashes <- readTVar hashesVar + when (Set.null hashes) retry + let (hashes1, hashes2) = Set.splitAt 50 hashes + modifyTVar' uninsertedHashesVar (Set.union hashes1) + writeTVar hashesVar hashes2 + pure do + -- Only allow 10 concurrent http workers + atomically do + workers <- readTVar workerCount + -- 12 workers = inserter + elaborator + 10 http workers + when (workers >= 12) retry + -- we do need to record the downloader as working outside of the worker thread, not inside. + -- otherwise, we might erroneously fall through the the teardown logic below and conclude there's + -- nothing more for the dispatcher to do, when in fact a downloader thread just hasn't made it as + -- far as recording its own existence + recordWorking workerCount + forkDownloader (NESet.unsafeFromSet hashes1) + loop + + -- Check to see if there are no hashes left to download, no outstanding workers, and no work in either queue + checkIfDoneMode :: STM (IO ()) + checkIfDoneMode = do + workers <- readTVar workerCount + when (workers > 0) retry + isEmptyTQueue entitiesQueue >>= \case + False -> retry + True -> pure () + isEmptyTQueue newTempEntitiesQueue >>= \case + False -> retry + True -> pure () + pure (pure ()) + + -- Downloader thread: download entities, enqueue to `entitiesQueue` + downloader :: + TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) -> + WorkerCount -> + NESet Share.HashJWT -> + IO () + downloader entitiesQueue workerCount hashes = do + Share.DownloadEntitiesSuccess entities <- + httpDownloadEntities + httpClient + unisonShareUrl + Share.DownloadEntitiesRequest {repoName, hashes} + downloaded callbacks (NESet.size hashes) + atomically do + writeTQueue entitiesQueue (hashes, entities) + recordNotWorking workerCount + -- Inserter thread: dequeue from `entitiesQueue`, insert entities, enqueue to `newTempEntitiesQueue` - Ki.fork_ scope do + inserter :: + TVar (Set Share.HashJWT) -> + TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) -> + TQueue (NESet Hash32) -> + WorkerCount -> + IO Void + inserter uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount = connect \conn -> forever do (hashJwts, entities) <- atomically do entities <- readTQueue entitiesQueue - recordWorking + recordWorking workerCount pure entities newTempEntities0 <- Sqlite.runTransaction conn do @@ -423,22 +528,28 @@ completeTempEntities httpClient unisonShareUrl connect repoName callbacks initia Q.EntityInMainStorage -> Set.empty Q.EntityInTempStorage -> Set.singleton hash atomically do - -- Avoid unnecessary retaining of these hashes to keep memory usage more stable. This algorithm would still be - -- correct if we never delete from `uninsertedHashes`. + -- Avoid unnecessary retaining of these hashes to keep memory usage more stable. This algorithm would still + -- be correct if we never delete from `uninsertedHashes`. modifyTVar' uninsertedHashesVar \uninsertedHashes -> Set.difference uninsertedHashes (NESet.toSet hashJwts) whenJust (NESet.nonEmptySet newTempEntities0) \newTempEntities -> writeTQueue newTempEntitiesQueue newTempEntities - recordNotWorking + recordNotWorking workerCount -- Elaborator thread: dequeue from `newTempEntitiesQueue`, elaborate, "enqueue" to `hashesVar` - Ki.fork_ scope do + elaborator :: + TVar (Set Share.HashJWT) -> + TVar (Set Share.HashJWT) -> + TQueue (NESet Hash32) -> + WorkerCount -> + IO Void + elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount = connect \conn -> forever do newTempEntities <- atomically do newTempEntities <- readTQueue newTempEntitiesQueue - recordWorking + recordWorking workerCount pure newTempEntities newElaboratedHashes <- Sqlite.runTransaction conn (elaborateHashes newTempEntities) n <- @@ -449,66 +560,7 @@ completeTempEntities httpClient unisonShareUrl connect repoName callbacks initia writeTVar hashesVar hashes1 pure (Set.size hashes1 - Set.size hashes0) toDownload callbacks n - atomically recordNotWorking - - -- Downloader thread: download entities, enqueue to `entitiesQueue` - let downloader :: NESet Share.HashJWT -> IO () - downloader hashes = do - Share.DownloadEntitiesSuccess entities <- - httpDownloadEntities - httpClient - unisonShareUrl - Share.DownloadEntitiesRequest {repoName, hashes} - downloaded callbacks (NESet.size hashes) - atomically do - writeTQueue entitiesQueue (hashes, entities) - recordNotWorking - - -- Dispatcher thread: "dequeue" from `hashesVar`, fork one-shot downloaders. - -- - -- We stop when all of the following are true: - -- - -- - There are no outstanding workers (downloaders, inserter, elaboraror) - -- - The inserter thread doesn't have any outstanding work enqueued (in `entitiesQueue`) - -- - The elaborator thread doesn't have any outstanding work enqueued (in `newTempEntitiesQueue`) - let dispatcher :: IO () - dispatcher = - (join . atomically . asum) - [ do - hashes <- readTVar hashesVar - when (Set.null hashes) retry - let (hashes1, hashes2) = Set.splitAt 50 hashes - modifyTVar' uninsertedHashesVar (Set.union hashes1) - writeTVar hashesVar hashes2 - pure do - -- Only allow 10 concurrent http workers - atomically do - workers <- readTVar outstandingWorkersCountVar - -- 12 workers = inserter + elaborator + 10 http workers - when (workers >= 12) retry - -- we do need to record the downloader as working outside of the worker thread, not inside. - -- otherwise, we might erroneously fall through the the teardown logic below and conclude there's - -- nothing more for the dispatcher to do, when in fact a downloader thread just hasn't made it as - -- far as recording its own existence - recordWorking - _ <- Ki.fork scope (downloader (NESet.unsafeFromSet hashes1)) - dispatcher, - do - workers <- readTVar outstandingWorkersCountVar - when (workers > 0) retry - isEmptyTQueue entitiesQueue >>= \case - False -> retry - True -> pure () - isEmptyTQueue newTempEntitiesQueue >>= \case - False -> retry - True -> pure () - -- No hashes left to download, no outstanding workers, no work in either queue - we're done! - pure (pure ()) - ] - - -- Kick off the cycle of inserter->elaborator->dispatcher->worker by giving the elaborator something to do - atomically (writeTQueue newTempEntitiesQueue initialNewTempEntities) - dispatcher + atomically (recordNotWorking workerCount) -- | Download a set of entities from Unison Share. Returns the subset of those entities that we stored in temp storage -- (`temp_entitiy`) instead of main storage (`object` / `causal`) due to missing dependencies. From 47bd01bcb6411e78fa37df63a0ad761ac9e4bb43 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 23 Jun 2022 16:41:06 -0400 Subject: [PATCH 391/529] more cleanup of concurrent pull code --- unison-cli/src/Unison/Share/Sync.hs | 39 ++++++++++++----------------- 1 file changed, 16 insertions(+), 23 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index d05387ceb4..27feff893e 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -363,9 +363,14 @@ pull httpClient unisonShareUrl connect repoPath callbacks = catchSyncErrors do Just Q.EntityInTempStorage -> pure (Just (NESet.singleton hash)) Nothing -> do toDownload callbacks 1 - tempEntities <- downloadEntities httpClient unisonShareUrl conn repoName (NESet.singleton hashJwt) + Share.DownloadEntitiesSuccess entities <- + httpDownloadEntities + httpClient + unisonShareUrl + Share.DownloadEntitiesRequest {repoName, hashes = NESet.singleton hashJwt} + tempEntities <- insertEntities conn entities downloaded callbacks 1 - pure tempEntities + pure (NESet.nonEmptySet tempEntities) whenJust maybeTempEntities \tempEntities -> completeTempEntities httpClient @@ -562,27 +567,15 @@ completeTempEntities httpClient unisonShareUrl connect repoName callbacks initia toDownload callbacks n atomically (recordNotWorking workerCount) --- | Download a set of entities from Unison Share. Returns the subset of those entities that we stored in temp storage --- (`temp_entitiy`) instead of main storage (`object` / `causal`) due to missing dependencies. -downloadEntities :: - AuthenticatedHttpClient -> - BaseUrl -> - Sqlite.Connection -> - Share.RepoName -> - NESet Share.HashJWT -> - IO (Maybe (NESet Hash32)) -downloadEntities httpClient unisonShareUrl conn repoName hashes = do - Share.DownloadEntitiesSuccess entities <- - httpDownloadEntities - httpClient - unisonShareUrl - Share.DownloadEntitiesRequest {repoName, hashes} - fmap NESet.nonEmptySet do - Sqlite.runTransaction conn do - NEMap.toList entities & foldMapM \(hash, entity) -> - upsertEntitySomewhere hash entity <&> \case - Q.EntityInMainStorage -> Set.empty - Q.EntityInTempStorage -> Set.singleton hash +-- | Insert entities into the database, and return the subset that went into temp storage (`temp_entitiy`) rather than +-- of main storage (`object` / `causal`) due to missing dependencies. +insertEntities :: Sqlite.Connection -> NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT) -> IO (Set Hash32) +insertEntities conn entities = + Sqlite.runTransaction conn do + NEMap.toList entities & foldMapM \(hash, entity) -> + upsertEntitySomewhere hash entity <&> \case + Q.EntityInMainStorage -> Set.empty + Q.EntityInTempStorage -> Set.singleton hash ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path From 3b16d19d8781c6606e923691d882339a6d7219bc Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 23 Jun 2022 19:46:08 -0400 Subject: [PATCH 392/529] Some adjustments to ability checking - Fixed an erroneous case when equating two sets of abilities. Normally we try to unify pieces of them with pieces of the opposite side to render them equal. However, in certain cases where that wasn't possible, we would just not do anything, and also not fail. This code tries some additional unification cases, and properly throws an error if nothing will work. - This caused some knock-on problems with certain test examples. For instance, if you annotate a handler as `Request {...} r -> ...`, then variables made up in the function body will fail to unify with the rigidly defined row. So ability checking for cases has been modified to avoid making up superfluous variables. --- .../src/Unison/Typechecker/Context.hs | 114 ++++++++++-------- 1 file changed, 67 insertions(+), 47 deletions(-) diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 1c552407f3..e44d2f285c 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -1215,18 +1215,34 @@ checkCases scrutType outType cases@(Term.MatchCase _ _ t : _) = scope (InMatch (ABT.annotation t)) $ do mes <- requestType (cases <&> \(Term.MatchCase p _ _) -> p) for_ mes $ \es -> - applyM scrutType >>= \sty -> do - v <- freshenVar Var.inferPatternPureV - g <- freshenVar Var.inferAbility - let lo = loc scrutType - vt = existentialp lo v - gt = existentialp lo g - es' = gt : es - appendContext [existential g, existential v] - subtype (Type.effectV lo (lo, Type.effects lo es') (lo, vt)) sty + applyM scrutType >>= \sty -> ensureReqEffects sty es scrutType' <- applyM =<< ungeneralize scrutType coalesceWanteds =<< traverse (checkCase scrutType' outType) cases +-- Checks a scrutinee type against a list of effects from e.g. a list of cases +-- from a handler. +-- +-- This opportunistically destructures the scrutinee type if it is of the form +-- `Request es r` in an effort to avoid introducing ability unification +-- variables that will be more difficult to infer. In such cases, we just run an +-- ability check directly against `es`. This works better, for instance, where a +-- signature has been given for the handler, and es = {A,B,g}, for a universal +-- g. In such a situation, we have no good way of solving via the general check +-- for {A,B,e} < {A,B,g} with a fresh `e` existential, but the `e` is actually +-- useless in this scenario. +ensureReqEffects :: Var v => Ord loc => Type v loc -> [Type v loc] -> M v loc () +ensureReqEffects (Type.Apps' (Type.Ref' req) [hes, _]) res + | req == Type.effectRef = expandAbilities [hes] >>= \hes -> abilityCheck' hes res +ensureReqEffects sty res = do + v <- freshenVar Var.inferPatternPureV + g <- freshenVar Var.inferAbility + let lo = loc sty + vt = existentialp lo v + gt = existentialp lo g + es' = gt : res + appendContext [existential g, existential v] + subtype (Type.effectV lo (lo, Type.effects lo es') (lo, vt)) sty + getEffect :: Var v => Ord loc => ConstructorReference -> M v loc (Type v loc) getEffect ref = do @@ -1389,28 +1405,29 @@ checkPattern scrutineeType p = ((v, v') :) <$> checkPattern scrutineeType p' -- ex: { a } -> a -- ex: { (x, 42) } -> a - Pattern.EffectPure loc p -> do - vt <- lift $ do - v <- freshenVar Var.inferPatternPureV - e <- freshenVar Var.inferPatternPureE - let vt = existentialp loc v - let et = existentialp loc e - appendContext [existential v, existential e] - subtype (Type.effectV loc (loc, et) (loc, vt)) scrutineeType - applyM vt - checkPattern vt p + Pattern.EffectPure loc p + -- Avoid creating extra effect variables when the scrutinee is already + -- known to be a Request. + -- + -- TODO: this should actually _always_ be the case, because we do a pass + -- across the entire case statement refining the scrutinee type. The + -- 'otherwise' still needs to be covered for exhaustivity, however. + | Type.Apps' (Type.Ref' req) [_, r] <- scrutineeType + , req == Type.effectRef -> checkPattern r p + | otherwise -> do + vt <- lift $ do + v <- freshenVar Var.inferPatternPureV + e <- freshenVar Var.inferPatternPureE + let vt = existentialp loc v + let et = existentialp loc e + appendContext [existential v, existential e] + subtype (Type.effectV loc (loc, et) (loc, vt)) scrutineeType + applyM vt + checkPattern vt p -- ex: { Stream.emit x -> k } -> ... Pattern.EffectBind loc ref args k -> do -- scrutineeType should be a supertype of `Effect e vt` -- for fresh existentials `e` and `vt` - e <- lift $ extendExistential Var.inferPatternBindE - v <- lift $ extendExistential Var.inferPatternBindV - let evt = - Type.effectV - loc - (loc, existentialp loc e) - (loc, existentialp loc v) - lift $ subtype evt scrutineeType ect <- lift $ getEffectConstructorType ref uect <- lift $ skolemize forcedEffect ect unless (Type.arity uect == length args) @@ -1423,27 +1440,23 @@ checkPattern scrutineeType p = step _ _ = lift . failWith $ PatternArityMismatch loc ect (length args) (ctorOutputType, vs) <- foldM step (uect, []) args + st <- lift $ applyM scrutineeType case ctorOutputType of -- an effect ctor should have exactly 1 effect! - Type.Effect'' [et] it -> do + Type.Effect'' [et] it -- expecting scrutineeType to be `Effect et vt` - - -- ensure that the variables in `et` unify with those from - -- the scrutinee. - lift $ do - res <- Type.flattenEffects <$> applyM (existentialp loc e) - abilityCheck' res [et] - - st <- lift $ applyM scrutineeType - case st of - Type.App' (Type.App' _ eff) vt -> - let kt = - Type.arrow - (Pattern.loc k) - it - (Type.effect (Pattern.loc k) [eff] vt) - in (vs ++) <$> checkPattern kt k - _ -> lift . compilerCrash $ PatternMatchFailure + | Type.Apps' _ [eff, vt] <- st -> do + + -- ensure that the variables in `et` unify with those from + -- the scrutinee. + lift $ abilityCheck' [eff] [et] + let kt = + Type.arrow + (Pattern.loc k) + it + (Type.effect (Pattern.loc k) [eff] vt) + (vs ++) <$> checkPattern kt k + | otherwise -> lift . compilerCrash $ PatternMatchFailure _ -> lift . compilerCrash $ EffectConstructorHadMultipleEffects @@ -2666,10 +2679,17 @@ equateAbilities ls rs = null vls, null vrs -> refine True [(loc t, bc, cv)] [cls ++ crs] + | [] <- com, null rs, null cls -> for_ vls defaultAbility + | [] <- com, null ls, null crs -> for_ vrs defaultAbility | otherwise -> do - for_ mlSlack $ \p -> refine False [p] [rs] - for_ mrSlack $ \p -> refine False [p] [ls] + mrefine mlSlack ls rs + mrefine mrSlack rs ls where + mrefine (Just p) _ es = refine False [p] [es] + mrefine Nothing _ [] = pure () + mrefine Nothing hs es = + getContext >>= failWith . AbilityCheckFailure hs es + refine common lbvs ess = do cv <- traverse freshenVar cn ctx <- getContext From d85e17e2563550aadb62d7fe085d520c39dd48f6 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 23 Jun 2022 19:57:32 -0400 Subject: [PATCH 393/529] Add test transcript --- unison-src/transcripts/fix3037.md | 18 ++++++++++++++++++ unison-src/transcripts/fix3037.output.md | 23 +++++++++++++++++++++++ 2 files changed, 41 insertions(+) create mode 100644 unison-src/transcripts/fix3037.md create mode 100644 unison-src/transcripts/fix3037.output.md diff --git a/unison-src/transcripts/fix3037.md b/unison-src/transcripts/fix3037.md new file mode 100644 index 0000000000..f9f0b584cc --- /dev/null +++ b/unison-src/transcripts/fix3037.md @@ -0,0 +1,18 @@ +```ucm:hide +.> builtins.merge +``` + +Tests for an unsound case of ability checking that was erroneously being +accepted before. In certain cases, abilities were able to be added to rows in +invariant positions. + +```unison:error +structural type Runner g = Runner (forall a. '{g} a -> {} a) + +pureRunner : Runner {} +pureRunner = Runner base.force + +-- this compiles, but shouldn't the effect type parameter on Runner be invariant? +runner : Runner {IO} +runner = pureRunner +``` diff --git a/unison-src/transcripts/fix3037.output.md b/unison-src/transcripts/fix3037.output.md new file mode 100644 index 0000000000..701bff0f44 --- /dev/null +++ b/unison-src/transcripts/fix3037.output.md @@ -0,0 +1,23 @@ +Tests for an unsound case of ability checking that was erroneously being +accepted before. In certain cases, abilities were able to be added to rows in +invariant positions. + +```unison +structural type Runner g = Runner (forall a. '{g} a -> {} a) + +pureRunner : Runner {} +pureRunner = Runner base.force + +-- this compiles, but shouldn't the effect type parameter on Runner be invariant? +runner : Runner {IO} +runner = pureRunner +``` + +```ucm + + The expression in red needs the {IO} ability, but this location does not have access to any abilities. + + 8 | runner = pureRunner + + +``` From efb365c60e2b75bed5abe968a44602914af2c954 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 24 Jun 2022 10:24:25 -0400 Subject: [PATCH 394/529] fix bug in elaborateHashes previously, it asserted that given a non-empty input, it would always produce a non-empty output, but that was a bad assumption. the output may be empty. --- .../U/Codebase/Sqlite/Queries.hs | 13 ++-------- unison-cli/src/Unison/Share/Sync.hs | 24 +++++++++++-------- 2 files changed, 16 insertions(+), 21 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index dac3a01da4..89c8c2e97b 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -1589,11 +1589,6 @@ deleteTempEntity hash = |] (Only hash) -data EmptyTempEntityMissingDependencies - = EmptyTempEntityMissingDependencies - deriving stock (Show) - deriving anyclass (SqliteExceptionReason) - -- | "Elaborate" a set of `temp_entity` hashes. -- -- Given a set of `temp_entity` hashes, returns the (known) set of transitive dependencies that haven't already been @@ -1610,7 +1605,7 @@ data EmptyTempEntityMissingDependencies -- -- ... then `elaborateHashes {A}` would return the singleton set {C} (because we take the set of transitive -- dependencies {A,B,C} and subtract the set we already have, {A,B}). -elaborateHashes :: Nel.NonEmpty Hash32 -> Transaction (Nel.NonEmpty Text) +elaborateHashes :: Nel.NonEmpty Hash32 -> Transaction [Text] elaborateHashes hashes = do execute_ [here| @@ -1624,7 +1619,7 @@ elaborateHashes hashes = do |] (map Only (Nel.toList hashes)) result <- - queryListColCheck_ + queryListCol_ [here| WITH RECURSIVE elaborated_dependency (hash, hashJwt) AS ( SELECT temd.dependency, temd.dependencyJwt @@ -1644,10 +1639,6 @@ elaborateHashes hashes = do WHERE temp_entity.hash = elaborated_dependency.hash ) |] - ( \case - [] -> Left EmptyTempEntityMissingDependencies - x : xs -> Right (x Nel.:| xs) - ) execute_ [here|DROP TABLE new_temp_entity_dependents|] pure result diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index a9dd5875fb..9944be242c 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -391,18 +391,23 @@ completeTempEntities doDownload conn downloadProgressCallback = That hs2 -> (hs2, Set.empty) -- impossible, this only happens if we split at 0 These hs1 hs2 -> (hs1, NESet.toSet hs2) maybeNextHashes <- - doDownload hashes >>= \case - Nothing -> pure (NESet.nonEmptySet nextHashes0) - Just newTempEntities -> do - newElaboratedHashes <- elaborate newTempEntities - pure (Just (union10 newElaboratedHashes nextHashes0)) + fmap NESet.nonEmptySet do + doDownload hashes >>= \case + Nothing -> pure nextHashes0 + Just newTempEntities -> do + newElaboratedHashes <- elaborate newTempEntities + pure (Set.union newElaboratedHashes nextHashes0) let !newDownloadCount = downloadCount + NESet.size hashes case maybeNextHashes of Nothing -> pure newDownloadCount Just nextHashes -> loop newDownloadCount nextHashes - in \hashes0 -> elaborate hashes0 >>= loop 0 + in \hashes0 -> do + hashes <- elaborate hashes0 + case NESet.nonEmptySet hashes of + Nothing -> pure 0 + Just hashes -> loop 0 hashes where - elaborate :: NESet Hash32 -> IO (NESet Share.HashJWT) + elaborate :: NESet Hash32 -> IO (Set Share.HashJWT) elaborate hashes = Sqlite.runTransaction conn (elaborateHashes hashes) @@ -524,10 +529,9 @@ union10 xs ys = -- 3. If it's in main storage, we should ignore it. -- -- In the end, we return a set of hashes that correspond to entities we actually need to download. -elaborateHashes :: NESet Hash32 -> Sqlite.Transaction (NESet Share.HashJWT) +elaborateHashes :: NESet Hash32 -> Sqlite.Transaction (Set Share.HashJWT) elaborateHashes hashes = - Q.elaborateHashes (NESet.toList hashes) - <&> NESet.fromList . coerce @(List.NonEmpty Text) @(List.NonEmpty Share.HashJWT) + Q.elaborateHashes (NESet.toList hashes) <&> Set.fromList . coerce @[Text] @[Share.HashJWT] -- | Upsert a downloaded entity "somewhere" - -- From 8b4bf8e9f10e6b67ae88eefec3f40892d6dae2c2 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 25 Jun 2022 00:12:39 -0400 Subject: [PATCH 395/529] Add Values literal to SQLite, use it to make elaborateHashes much smarter/faster --- .../U/Codebase/Sqlite/Queries.hs | 74 ++++++++++--------- lib/unison-sqlite/package.yaml | 2 + lib/unison-sqlite/src/Unison/Sqlite.hs | 14 ++-- lib/unison-sqlite/src/Unison/Sqlite/Sql.hs | 18 ++++- lib/unison-sqlite/src/Unison/Sqlite/Values.hs | 35 +++++++++ lib/unison-sqlite/unison-sqlite.cabal | 3 + 6 files changed, 104 insertions(+), 42 deletions(-) create mode 100644 lib/unison-sqlite/src/Unison/Sqlite/Values.hs diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index b150a2cbeb..f1708d3f9b 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -180,7 +180,7 @@ import Data.Bitraversable (bitraverse) import Data.Bytes.Put (runPutS) import qualified Data.Foldable as Foldable import qualified Data.List.Extra as List -import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as Nel import qualified Data.Map as Map import Data.Map.NonEmpty (NEMap) @@ -650,7 +650,7 @@ expectPrimaryHash32ByObjectId oId = queryOneCol sql (Only oId) WHERE object.id = ? |] -expectHashIdsForObject :: ObjectId -> Transaction (NonEmpty HashId) +expectHashIdsForObject :: ObjectId -> Transaction (List.NonEmpty HashId) expectHashIdsForObject oId = do primaryHashId <- queryOneCol sql1 (Only oId) hashIds <- queryListCol sql2 (Only oId) @@ -1606,40 +1606,42 @@ deleteTempEntity hash = -- ... then `elaborateHashes {A}` would return the singleton set {C} (because we take the set of transitive -- dependencies {A,B,C} and subtract the set we already have, {A,B}). elaborateHashes :: Nel.NonEmpty Hash32 -> Transaction [Text] -elaborateHashes hashes = do - execute_ - [here| - CREATE TABLE new_temp_entity_dependents (hash text) - |] - executeMany - [here| - INSERT INTO new_temp_entity_dependents (hash) - VALUES (?) - |] - (map Only (Nel.toList hashes)) - result <- - queryListCol_ - [here| - WITH RECURSIVE elaborated_dependency (hash, hashJwt) AS ( - SELECT temd.dependency, temd.dependencyJwt - FROM new_temp_entity_dependents AS new - JOIN temp_entity_missing_dependency AS temd - ON temd.dependent = new.hash - - UNION - SELECT temd.dependency, temd.dependencyJwt - FROM temp_entity_missing_dependency AS temd - JOIN elaborated_dependency AS ed - ON temd.dependent = ed.hash - ) - SELECT hashJwt FROM elaborated_dependency - WHERE NOT EXISTS ( - SELECT 1 FROM temp_entity - WHERE temp_entity.hash = elaborated_dependency.hash - ) - |] - execute_ [here|DROP TABLE new_temp_entity_dependents|] - pure result +elaborateHashes hashes = + queryListCol query hashesValues + where + query :: Sql + query = + fold + [ [sql| + WITH RECURSIVE + new_temp_entity_dependents (hash) AS ( + |], + valuesSql hashesValues, + [sql| + ), + elaborated_dependency (hash, hashJwt) AS ( + SELECT temd.dependency, temd.dependencyJwt + FROM new_temp_entity_dependents AS new + JOIN temp_entity_missing_dependency AS temd + ON temd.dependent = new.hash + + UNION + SELECT temd.dependency, temd.dependencyJwt + FROM temp_entity_missing_dependency AS temd + JOIN elaborated_dependency AS ed + ON temd.dependent = ed.hash + ) + SELECT hashJwt FROM elaborated_dependency + WHERE NOT EXISTS ( + SELECT 1 FROM temp_entity + WHERE temp_entity.hash = elaborated_dependency.hash + ) + |] + ] + + hashesValues :: Values (Only Hash32) + hashesValues = + Values (coerce @(List.NonEmpty Hash32) @(List.NonEmpty (Only Hash32)) hashes) moveTempEntityToMain :: HashHandle -> diff --git a/lib/unison-sqlite/package.yaml b/lib/unison-sqlite/package.yaml index 5ee014e0ac..e4fc8e58c7 100644 --- a/lib/unison-sqlite/package.yaml +++ b/lib/unison-sqlite/package.yaml @@ -19,10 +19,12 @@ dependencies: - direct-sqlite - exceptions - mtl + - neat-interpolation - pretty-simple - random - recover-rtti - sqlite-simple + - template-haskell - text - transformers - unison-prelude diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index 957b75417e..acbaf291e3 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -26,6 +26,9 @@ module Unison.Sqlite -- * Executing queries Sql (..), + sql, + Values (..), + valuesSql, -- ** Without results @@ -91,8 +94,8 @@ module Unison.Sqlite -- * Exceptions SomeSqliteException (..), isCantOpenException, - SqliteConnectException (..), - SqliteQueryException (..), + SqliteConnectException, + SqliteQueryException, SqliteExceptionReason, SomeSqliteExceptionReason (..), ExpectedAtMostOneRowException (..), @@ -128,14 +131,15 @@ import Unison.Sqlite.DataVersion (DataVersion (..), getDataVersion) import Unison.Sqlite.Exception ( SomeSqliteException (..), SomeSqliteExceptionReason (..), - SqliteConnectException (..), + SqliteConnectException, SqliteExceptionReason, - SqliteQueryException (..), + SqliteQueryException, isCantOpenException, ) import Unison.Sqlite.JournalMode (JournalMode (..), SetJournalModeException (..), trySetJournalMode) -import Unison.Sqlite.Sql (Sql (..)) +import Unison.Sqlite.Sql (Sql (..), sql) import Unison.Sqlite.Transaction +import Unison.Sqlite.Values (Values (..), valuesSql) -- $query-naming-convention -- diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Sql.hs b/lib/unison-sqlite/src/Unison/Sqlite/Sql.hs index 02ee234ef9..b747523146 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Sql.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Sql.hs @@ -1,11 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} + module Unison.Sqlite.Sql ( Sql (..), + sql, ) where +import Language.Haskell.TH.Quote (QuasiQuoter (quoteExp)) +import qualified Language.Haskell.TH.Syntax as TH +import qualified NeatInterpolation import Unison.Prelude -- | A SQL snippet. newtype Sql = Sql Text - deriving newtype (IsString, Show) + deriving newtype (IsString, Monoid, Semigroup, Show) + +-- | A quasi-quoter that produces expressions of type 'Sql'. +sql :: QuasiQuoter +sql = + NeatInterpolation.trimming + { quoteExp = + \string -> do + text <- quoteExp NeatInterpolation.trimming string + pure (TH.AppE (TH.ConE 'Sql) text) + } diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Values.hs b/lib/unison-sqlite/src/Unison/Sqlite/Values.hs new file mode 100644 index 0000000000..7e65103985 --- /dev/null +++ b/lib/unison-sqlite/src/Unison/Sqlite/Values.hs @@ -0,0 +1,35 @@ +module Unison.Sqlite.Values + ( Values (..), + valuesSql, + ) +where + +import qualified Data.List.NonEmpty as List (NonEmpty) +import qualified Data.List.NonEmpty as List.NonEmpty +import qualified Data.Text as Text +import qualified Database.SQLite.Simple as Sqlite.Simple +import Unison.Prelude +import Unison.Sqlite.Sql (Sql (..)) + +-- | A @VALUES@ literal. +newtype Values a + = Values (List.NonEmpty a) + deriving stock (Show) + +instance Sqlite.Simple.ToRow a => Sqlite.Simple.ToRow (Values a) where + toRow (Values values) = + foldMap Sqlite.Simple.toRow values + +-- | Example: given a 'Values' of length 3, where each element has a @toRow@ that produces 2 elements, produce the SQL +-- string: +-- +-- @ +-- VALUES (?, ?), (?, ?), (?, ?) +-- @ +valuesSql :: Sqlite.Simple.ToRow a => Values a -> Sql +valuesSql (Values values) = + Sql ("VALUES " <> Text.intercalate "," (map valueSql (List.NonEmpty.toList values))) + +valueSql :: Sqlite.Simple.ToRow a => a -> Text +valueSql value = + "(" <> Text.intercalate "," (map (\_ -> "?") (Sqlite.Simple.toRow value)) <> ")" diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 9c3ffa8a4e..e902d53369 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -21,6 +21,7 @@ library Unison.Sqlite.Connection Unison.Sqlite.Connection.Internal Unison.Sqlite.Transaction + Unison.Sqlite.Values other-modules: Unison.Sqlite.DataVersion Unison.Sqlite.Exception @@ -61,10 +62,12 @@ library , direct-sqlite , exceptions , mtl + , neat-interpolation , pretty-simple , random , recover-rtti , sqlite-simple + , template-haskell , text , transformers , unison-prelude From 71dd7448ed8f0e5fba411e2a51f6c6da9e4f3944 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 25 Jun 2022 00:15:13 -0400 Subject: [PATCH 396/529] add Values literal to unison-sqlite --- lib/unison-sqlite/package.yaml | 2 ++ lib/unison-sqlite/src/Unison/Sqlite.hs | 14 +++++--- lib/unison-sqlite/src/Unison/Sqlite/Sql.hs | 18 +++++++++- lib/unison-sqlite/src/Unison/Sqlite/Values.hs | 35 +++++++++++++++++++ lib/unison-sqlite/unison-sqlite.cabal | 3 ++ 5 files changed, 66 insertions(+), 6 deletions(-) create mode 100644 lib/unison-sqlite/src/Unison/Sqlite/Values.hs diff --git a/lib/unison-sqlite/package.yaml b/lib/unison-sqlite/package.yaml index 5ee014e0ac..e4fc8e58c7 100644 --- a/lib/unison-sqlite/package.yaml +++ b/lib/unison-sqlite/package.yaml @@ -19,10 +19,12 @@ dependencies: - direct-sqlite - exceptions - mtl + - neat-interpolation - pretty-simple - random - recover-rtti - sqlite-simple + - template-haskell - text - transformers - unison-prelude diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index 957b75417e..acbaf291e3 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -26,6 +26,9 @@ module Unison.Sqlite -- * Executing queries Sql (..), + sql, + Values (..), + valuesSql, -- ** Without results @@ -91,8 +94,8 @@ module Unison.Sqlite -- * Exceptions SomeSqliteException (..), isCantOpenException, - SqliteConnectException (..), - SqliteQueryException (..), + SqliteConnectException, + SqliteQueryException, SqliteExceptionReason, SomeSqliteExceptionReason (..), ExpectedAtMostOneRowException (..), @@ -128,14 +131,15 @@ import Unison.Sqlite.DataVersion (DataVersion (..), getDataVersion) import Unison.Sqlite.Exception ( SomeSqliteException (..), SomeSqliteExceptionReason (..), - SqliteConnectException (..), + SqliteConnectException, SqliteExceptionReason, - SqliteQueryException (..), + SqliteQueryException, isCantOpenException, ) import Unison.Sqlite.JournalMode (JournalMode (..), SetJournalModeException (..), trySetJournalMode) -import Unison.Sqlite.Sql (Sql (..)) +import Unison.Sqlite.Sql (Sql (..), sql) import Unison.Sqlite.Transaction +import Unison.Sqlite.Values (Values (..), valuesSql) -- $query-naming-convention -- diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Sql.hs b/lib/unison-sqlite/src/Unison/Sqlite/Sql.hs index 02ee234ef9..b747523146 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Sql.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Sql.hs @@ -1,11 +1,27 @@ +{-# LANGUAGE TemplateHaskell #-} + module Unison.Sqlite.Sql ( Sql (..), + sql, ) where +import Language.Haskell.TH.Quote (QuasiQuoter (quoteExp)) +import qualified Language.Haskell.TH.Syntax as TH +import qualified NeatInterpolation import Unison.Prelude -- | A SQL snippet. newtype Sql = Sql Text - deriving newtype (IsString, Show) + deriving newtype (IsString, Monoid, Semigroup, Show) + +-- | A quasi-quoter that produces expressions of type 'Sql'. +sql :: QuasiQuoter +sql = + NeatInterpolation.trimming + { quoteExp = + \string -> do + text <- quoteExp NeatInterpolation.trimming string + pure (TH.AppE (TH.ConE 'Sql) text) + } diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Values.hs b/lib/unison-sqlite/src/Unison/Sqlite/Values.hs new file mode 100644 index 0000000000..7e65103985 --- /dev/null +++ b/lib/unison-sqlite/src/Unison/Sqlite/Values.hs @@ -0,0 +1,35 @@ +module Unison.Sqlite.Values + ( Values (..), + valuesSql, + ) +where + +import qualified Data.List.NonEmpty as List (NonEmpty) +import qualified Data.List.NonEmpty as List.NonEmpty +import qualified Data.Text as Text +import qualified Database.SQLite.Simple as Sqlite.Simple +import Unison.Prelude +import Unison.Sqlite.Sql (Sql (..)) + +-- | A @VALUES@ literal. +newtype Values a + = Values (List.NonEmpty a) + deriving stock (Show) + +instance Sqlite.Simple.ToRow a => Sqlite.Simple.ToRow (Values a) where + toRow (Values values) = + foldMap Sqlite.Simple.toRow values + +-- | Example: given a 'Values' of length 3, where each element has a @toRow@ that produces 2 elements, produce the SQL +-- string: +-- +-- @ +-- VALUES (?, ?), (?, ?), (?, ?) +-- @ +valuesSql :: Sqlite.Simple.ToRow a => Values a -> Sql +valuesSql (Values values) = + Sql ("VALUES " <> Text.intercalate "," (map valueSql (List.NonEmpty.toList values))) + +valueSql :: Sqlite.Simple.ToRow a => a -> Text +valueSql value = + "(" <> Text.intercalate "," (map (\_ -> "?") (Sqlite.Simple.toRow value)) <> ")" diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 9c3ffa8a4e..e902d53369 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -21,6 +21,7 @@ library Unison.Sqlite.Connection Unison.Sqlite.Connection.Internal Unison.Sqlite.Transaction + Unison.Sqlite.Values other-modules: Unison.Sqlite.DataVersion Unison.Sqlite.Exception @@ -61,10 +62,12 @@ library , direct-sqlite , exceptions , mtl + , neat-interpolation , pretty-simple , random , recover-rtti , sqlite-simple + , template-haskell , text , transformers , unison-prelude From 4aea77cd4d06e6b5a5be4bb6fe621c15c63f8312 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 25 Jun 2022 00:22:37 -0400 Subject: [PATCH 397/529] use Values literal in elaborateHashes --- .../U/Codebase/Sqlite/Queries.hs | 75 ++++++++++--------- 1 file changed, 38 insertions(+), 37 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 89c8c2e97b..f1708d3f9b 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -180,7 +180,7 @@ import Data.Bitraversable (bitraverse) import Data.Bytes.Put (runPutS) import qualified Data.Foldable as Foldable import qualified Data.List.Extra as List -import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as Nel import qualified Data.Map as Map import Data.Map.NonEmpty (NEMap) @@ -650,7 +650,7 @@ expectPrimaryHash32ByObjectId oId = queryOneCol sql (Only oId) WHERE object.id = ? |] -expectHashIdsForObject :: ObjectId -> Transaction (NonEmpty HashId) +expectHashIdsForObject :: ObjectId -> Transaction (List.NonEmpty HashId) expectHashIdsForObject oId = do primaryHashId <- queryOneCol sql1 (Only oId) hashIds <- queryListCol sql2 (Only oId) @@ -1606,41 +1606,42 @@ deleteTempEntity hash = -- ... then `elaborateHashes {A}` would return the singleton set {C} (because we take the set of transitive -- dependencies {A,B,C} and subtract the set we already have, {A,B}). elaborateHashes :: Nel.NonEmpty Hash32 -> Transaction [Text] -elaborateHashes hashes = do - execute_ - [here| - CREATE TABLE new_temp_entity_dependents (hash text) - |] - executeMany - [here| - INSERT INTO new_temp_entity_dependents - (hash) - VALUES (?) - |] - (map Only (Nel.toList hashes)) - result <- - queryListCol_ - [here| - WITH RECURSIVE elaborated_dependency (hash, hashJwt) AS ( - SELECT temd.dependency, temd.dependencyJwt - FROM new_temp_entity_dependents AS new - JOIN temp_entity_missing_dependency AS temd - ON temd.dependent = new.hash - - UNION - SELECT temd.dependency, temd.dependencyJwt - FROM temp_entity_missing_dependency AS temd - JOIN elaborated_dependency AS ed - ON temd.dependent = ed.hash - ) - SELECT hashJwt FROM elaborated_dependency - WHERE NOT EXISTS ( - SELECT 1 FROM temp_entity - WHERE temp_entity.hash = elaborated_dependency.hash - ) - |] - execute_ [here|DROP TABLE new_temp_entity_dependents|] - pure result +elaborateHashes hashes = + queryListCol query hashesValues + where + query :: Sql + query = + fold + [ [sql| + WITH RECURSIVE + new_temp_entity_dependents (hash) AS ( + |], + valuesSql hashesValues, + [sql| + ), + elaborated_dependency (hash, hashJwt) AS ( + SELECT temd.dependency, temd.dependencyJwt + FROM new_temp_entity_dependents AS new + JOIN temp_entity_missing_dependency AS temd + ON temd.dependent = new.hash + + UNION + SELECT temd.dependency, temd.dependencyJwt + FROM temp_entity_missing_dependency AS temd + JOIN elaborated_dependency AS ed + ON temd.dependent = ed.hash + ) + SELECT hashJwt FROM elaborated_dependency + WHERE NOT EXISTS ( + SELECT 1 FROM temp_entity + WHERE temp_entity.hash = elaborated_dependency.hash + ) + |] + ] + + hashesValues :: Values (Only Hash32) + hashesValues = + Values (coerce @(List.NonEmpty Hash32) @(List.NonEmpty (Only Hash32)) hashes) moveTempEntityToMain :: HashHandle -> From da96da731c7dfc0c083d9a31a90731d0a8d94496 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 25 Jun 2022 09:24:02 -0400 Subject: [PATCH 398/529] make valuesSql more efficient --- lib/unison-sqlite/src/Unison/Sqlite/Values.hs | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Values.hs b/lib/unison-sqlite/src/Unison/Sqlite/Values.hs index 7e65103985..e38c4df052 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Values.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Values.hs @@ -28,8 +28,12 @@ instance Sqlite.Simple.ToRow a => Sqlite.Simple.ToRow (Values a) where -- @ valuesSql :: Sqlite.Simple.ToRow a => Values a -> Sql valuesSql (Values values) = - Sql ("VALUES " <> Text.intercalate "," (map valueSql (List.NonEmpty.toList values))) + Sql ("VALUES " <> Text.intercalate "," (replicate (length values) (valueSql columns))) + where + columns :: Int + columns = + length (Sqlite.Simple.toRow (List.NonEmpty.head values)) -valueSql :: Sqlite.Simple.ToRow a => a -> Text -valueSql value = - "(" <> Text.intercalate "," (map (\_ -> "?") (Sqlite.Simple.toRow value)) <> ")" +valueSql :: Int -> Text +valueSql columns = + "(" <> Text.intercalate "," (replicate columns "?") <> ")" From b61b7c39bdb68812c5d2b0be50134726f6a2c3af Mon Sep 17 00:00:00 2001 From: Emil Hotkowski Date: Mon, 27 Jun 2022 06:09:27 +0200 Subject: [PATCH 399/529] #3137 - Added exit flag on launch --- unison-cli/unison/ArgParse.hs | 18 ++++++++++--- unison-cli/unison/Main.hs | 48 +++++++++++++++++++---------------- 2 files changed, 41 insertions(+), 25 deletions(-) diff --git a/unison-cli/unison/ArgParse.hs b/unison-cli/unison/ArgParse.hs index 29ccfc2df0..2a00478436 100644 --- a/unison-cli/unison/ArgParse.hs +++ b/unison-cli/unison/ArgParse.hs @@ -87,6 +87,9 @@ data CodebasePathOption | DontCreateCodebaseWhenMissing FilePath deriving (Show, Eq) +data ShouldExit = Exit | DoNotExit + deriving (Show, Eq) + data IsHeadless = Headless | WithCLI deriving (Show, Eq) @@ -105,7 +108,8 @@ data Command -- | Options shared by sufficiently many subcommands. data GlobalOptions = GlobalOptions - { codebasePathOption :: Maybe CodebasePathOption + { codebasePathOption :: Maybe CodebasePathOption, + exitOption :: ShouldExit } deriving (Show, Eq) @@ -242,9 +246,12 @@ commandParser envOpts = globalOptionsParser :: Parser GlobalOptions globalOptionsParser = do -- ApplicativeDo - codebasePathOption <- codebasePathParser <|> codebaseCreateParser + codebasePathOption <- codebasePathParser <|> codebaseCreateParser + exitOption <- exitParser - pure GlobalOptions {codebasePathOption = codebasePathOption} + pure GlobalOptions {codebasePathOption = codebasePathOption, + exitOption = exitOption + } codebasePathParser :: Parser (Maybe CodebasePathOption) codebasePathParser = do @@ -266,6 +273,11 @@ codebaseCreateParser = do <> help "The path to a new or existing codebase (one will be created if there isn't one)" pure (fmap CreateCodebaseWhenMissing path) +exitParser :: Parser ShouldExit +exitParser = flag DoNotExit Exit (long "exit" <> help exitHelp) + where + exitHelp = "Exit repl after the command." + versionOptionParser :: String -> String -> Parser (a -> a) versionOptionParser progName version = infoOption (progName <> " version: " <> version) (short 'v' <> long "version" <> help "Show version") diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index c2eb057f2b..bfb92dd584 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -11,8 +11,9 @@ module Main where import ArgParse ( CodebasePathOption (..), Command (Init, Launch, PrintVersion, Run, Transcript), - GlobalOptions (GlobalOptions, codebasePathOption), + GlobalOptions (GlobalOptions, codebasePathOption, exitOption), IsHeadless (Headless, WithCLI), + ShouldExit(Exit, DoNotExit), RunSource (..), ShouldDownloadBase (..), ShouldForkCodebase (..), @@ -87,7 +88,7 @@ main = withCP65001 do progName <- getProgName -- hSetBuffering stdout NoBuffering -- cool (renderUsageInfo, globalOptions, command) <- parseCLIArgs progName (Text.unpack Version.gitDescribeWithDate) - let GlobalOptions {codebasePathOption = mCodePathOption} = globalOptions + let GlobalOptions {codebasePathOption = mCodePathOption, exitOption = exitOption} = globalOptions let mcodepath = fmap codebasePathOptionToPath mCodePathOption currentDir <- getCurrentDirectory @@ -211,27 +212,30 @@ main = withCP65001 do getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do runtime <- RTI.startRuntime RTI.Persistent Version.gitDescribeWithDate Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts runtime theCodebase $ \baseUrl -> do - case isHeadless of - Headless -> do - PT.putPrettyLn $ - P.lines - [ "I've started the Codebase API server at", - P.string $ Server.urlFor Server.Api baseUrl, - "and the Codebase UI at", - P.string $ Server.urlFor Server.UI baseUrl - ] + case exitOption of + DoNotExit -> do + case isHeadless of + Headless -> do + PT.putPrettyLn $ + P.lines + [ "I've started the Codebase API server at", + P.string $ Server.urlFor Server.Api baseUrl, + "and the Codebase UI at", + P.string $ Server.urlFor Server.UI baseUrl + ] - PT.putPrettyLn $ - P.string "Running the codebase manager headless with " - <> P.shown GHC.Conc.numCapabilities - <> " " - <> plural' GHC.Conc.numCapabilities "cpu" "cpus" - <> "." - mvar <- newEmptyMVar - takeMVar mvar - WithCLI -> do - PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..." - launch currentDir config runtime theCodebase [] (Just baseUrl) downloadBase initRes + PT.putPrettyLn $ + P.string "Running the codebase manager headless with " + <> P.shown GHC.Conc.numCapabilities + <> " " + <> plural' GHC.Conc.numCapabilities "cpu" "cpus" + <> "." + mvar <- newEmptyMVar + takeMVar mvar + WithCLI -> do + PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..." + launch currentDir config runtime theCodebase [] (Just baseUrl) downloadBase initRes + Exit -> do Exit.exitSuccess -- | Set user agent and configure TLS on global http client. -- Note that the authorized http client is distinct from the global http client. From 7400238ee851260e98d8cb149e265fa6106777e7 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Mon, 27 Jun 2022 13:48:24 -0400 Subject: [PATCH 400/529] Fix bug in uninsertedHashesVar --- unison-cli/src/Unison/Share/Sync.hs | 60 +++++++++++++++-------------- 1 file changed, 32 insertions(+), 28 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 27feff893e..c6dfb3dc2d 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -426,10 +426,10 @@ completeTempEntities httpClient unisonShareUrl connect repoName callbacks initia workerCount <- newWorkerCount Ki.scoped \scope -> do - Ki.fork_ scope (inserter uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount) + Ki.fork_ scope (inserter entitiesQueue newTempEntitiesQueue workerCount) Ki.fork_ scope (elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount) -- Kick off the cycle of inserter->elaborator->dispatcher->worker by giving the elaborator something to do - atomically (writeTQueue newTempEntitiesQueue initialNewTempEntities) + atomically (writeTQueue newTempEntitiesQueue (Set.empty, Just initialNewTempEntities)) dispatcher (\hashes -> void (Ki.fork scope (downloader entitiesQueue workerCount hashes))) hashesVar @@ -450,7 +450,7 @@ completeTempEntities httpClient unisonShareUrl connect repoName callbacks initia TVar (Set Share.HashJWT) -> TVar (Set Share.HashJWT) -> TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) -> - TQueue (NESet Hash32) -> + TQueue (Set Share.HashJWT, Maybe (NESet Hash32)) -> WorkerCount -> IO () dispatcher forkDownloader hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount = @@ -513,12 +513,11 @@ completeTempEntities httpClient unisonShareUrl connect repoName callbacks initia -- Inserter thread: dequeue from `entitiesQueue`, insert entities, enqueue to `newTempEntitiesQueue` inserter :: - TVar (Set Share.HashJWT) -> TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) -> - TQueue (NESet Hash32) -> + TQueue (Set Share.HashJWT, Maybe (NESet Hash32)) -> WorkerCount -> IO Void - inserter uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount = + inserter entitiesQueue newTempEntitiesQueue workerCount = connect \conn -> forever do (hashJwts, entities) <- @@ -533,39 +532,44 @@ completeTempEntities httpClient unisonShareUrl connect repoName callbacks initia Q.EntityInMainStorage -> Set.empty Q.EntityInTempStorage -> Set.singleton hash atomically do - -- Avoid unnecessary retaining of these hashes to keep memory usage more stable. This algorithm would still - -- be correct if we never delete from `uninsertedHashes`. - modifyTVar' uninsertedHashesVar \uninsertedHashes -> - Set.difference uninsertedHashes (NESet.toSet hashJwts) - whenJust (NESet.nonEmptySet newTempEntities0) \newTempEntities -> - writeTQueue newTempEntitiesQueue newTempEntities + writeTQueue newTempEntitiesQueue (NESet.toSet hashJwts, NESet.nonEmptySet newTempEntities0) recordNotWorking workerCount -- Elaborator thread: dequeue from `newTempEntitiesQueue`, elaborate, "enqueue" to `hashesVar` elaborator :: TVar (Set Share.HashJWT) -> TVar (Set Share.HashJWT) -> - TQueue (NESet Hash32) -> + TQueue (Set Share.HashJWT, Maybe (NESet Hash32)) -> WorkerCount -> IO Void elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount = connect \conn -> forever do - newTempEntities <- - atomically do - newTempEntities <- readTQueue newTempEntitiesQueue - recordWorking workerCount - pure newTempEntities - newElaboratedHashes <- Sqlite.runTransaction conn (elaborateHashes newTempEntities) - n <- - atomically do - uninsertedHashes <- readTVar uninsertedHashesVar - hashes0 <- readTVar hashesVar - let !hashes1 = Set.union (Set.difference newElaboratedHashes uninsertedHashes) hashes0 - writeTVar hashesVar hashes1 - pure (Set.size hashes1 - Set.size hashes0) - toDownload callbacks n - atomically (recordNotWorking workerCount) + (join . atomically) do + (hashJwts, mayNewTempEntities) <- readTQueue newTempEntitiesQueue + -- Avoid unnecessary retaining of these hashes to keep memory usage more stable. This algorithm would still + -- be correct if we never delete from `uninsertedHashes`. + -- + -- We remove the inserted hashes from uninsertedHashesVar at this point rather than right after insertion in order + -- to ensure that no running transaction of the elaborator is viewing a snapshot that precedes the snapshot + -- that inserted those hashes. + modifyTVar' uninsertedHashesVar \uninsertedHashes -> + Set.difference uninsertedHashes hashJwts + case mayNewTempEntities of + Nothing -> pure (pure ()) + Just newTempEntities -> do + recordWorking workerCount + pure do + newElaboratedHashes <- Sqlite.runTransaction conn (elaborateHashes newTempEntities) + n <- + atomically do + uninsertedHashes <- readTVar uninsertedHashesVar + hashes0 <- readTVar hashesVar + let !hashes1 = Set.union (Set.difference newElaboratedHashes uninsertedHashes) hashes0 + writeTVar hashesVar hashes1 + pure (Set.size hashes1 - Set.size hashes0) + toDownload callbacks n + atomically (recordNotWorking workerCount) -- | Insert entities into the database, and return the subset that went into temp storage (`temp_entitiy`) rather than -- of main storage (`object` / `causal`) due to missing dependencies. From 14f095a35975c0e1697576b6986657feba0f0c8f Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 28 Jun 2022 11:26:01 -0400 Subject: [PATCH 401/529] Adjust the effect variable 'tweaking' strategy This is a part of the type checker that mediates between some old inferred types and ones that work better in the new type checker. The idea was to turn, e.g. the type of foldRight: (a ->{g} b ->{g} b) -> b -> [a] ->{g} b into: (a ->{g1} b ->{g2} b) -> b ->[a] ->{g1,g2} b Which makes up distinct variables for each negative occurrence, which in turn means that solving those negative occurrences doesn't interfere in an order-dependent way. This is always sound, because you can instantiate `g` to the whole row, and use subtyping on the negative occurrences. However, having multi-variable rows in invariant positions doesn't work out very well, and this tweak prevents you from declaring such situations to only involve a single variable. So, this patch modifies the tweak to only occur if `g` only occurs in positions that are either covariant or contravariant. It may be "invariant" in that it occurs both covariantly _and_ contravariantly, but it may not occur in a single position that is considered invariant. --- .../src/Unison/Typechecker/Context.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index e44d2f285c..69f9b23725 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -1632,7 +1632,7 @@ tweakEffects :: Type v loc -> M v loc ([v], Type v loc) tweakEffects v0 t0 - | isEffectVar v0 t0 = + | isEffectVar v0 t0 && isVariant v0 t0 = rewrite (Just False) t0 >>= \case ([], ty) -> freshenTypeVar v0 >>= \out -> finish [out] ty @@ -1688,6 +1688,18 @@ isEffectVar u (Type.Arrow'' i es o) = p _ = False isEffectVar _ _ = False +isVariant :: Var v => TypeVar v loc -> Type v loc -> Bool +isVariant u = walk True + where + walk var (Type.ForallNamed' v t) + | u == v = True + | otherwise = walk var t + walk var (Type.Arrow'' i es o) = + walk var i && walk var o && all (walk var) es + walk var (Type.App' f x) = walk var f && walk False x + walk var (Type.Var' v) = u /= v || var + walk _ _ = True + skolemize :: Var v => Ord loc => From a789342a7a7cb0b581a8d9a01cb13118609b2251 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 28 Jun 2022 11:35:07 -0400 Subject: [PATCH 402/529] Comment `isVariant` check --- parser-typechecker/src/Unison/Typechecker/Context.hs | 3 +++ 1 file changed, 3 insertions(+) diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 69f9b23725..319d157727 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -1688,6 +1688,9 @@ isEffectVar u (Type.Arrow'' i es o) = p _ = False isEffectVar _ _ = False +-- Checks that a variable only occurs in variant positions. This may mean that +-- it occurs in both covariant and contravariant positions, so long as it +-- doesn't occur in a single position that is invariant, like the `x` in `F x`. isVariant :: Var v => TypeVar v loc -> Type v loc -> Bool isVariant u = walk True where From f739cdcf8e144eb71e6aef7397b9c9e9131163be Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 28 Jun 2022 11:35:28 -0400 Subject: [PATCH 403/529] Incidental indentation standardization --- .../src/Unison/Typechecker/Context.hs | 42 +++++++++---------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 319d157727..05beacecf1 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -1412,18 +1412,19 @@ checkPattern scrutineeType p = -- TODO: this should actually _always_ be the case, because we do a pass -- across the entire case statement refining the scrutinee type. The -- 'otherwise' still needs to be covered for exhaustivity, however. - | Type.Apps' (Type.Ref' req) [_, r] <- scrutineeType - , req == Type.effectRef -> checkPattern r p + | Type.Apps' (Type.Ref' req) [_, r] <- scrutineeType, + req == Type.effectRef -> + checkPattern r p | otherwise -> do - vt <- lift $ do - v <- freshenVar Var.inferPatternPureV - e <- freshenVar Var.inferPatternPureE - let vt = existentialp loc v - let et = existentialp loc e - appendContext [existential v, existential e] - subtype (Type.effectV loc (loc, et) (loc, vt)) scrutineeType - applyM vt - checkPattern vt p + vt <- lift $ do + v <- freshenVar Var.inferPatternPureV + e <- freshenVar Var.inferPatternPureE + let vt = existentialp loc v + let et = existentialp loc e + appendContext [existential v, existential e] + subtype (Type.effectV loc (loc, et) (loc, vt)) scrutineeType + applyM vt + checkPattern vt p -- ex: { Stream.emit x -> k } -> ... Pattern.EffectBind loc ref args k -> do -- scrutineeType should be a supertype of `Effect e vt` @@ -1446,16 +1447,15 @@ checkPattern scrutineeType p = Type.Effect'' [et] it -- expecting scrutineeType to be `Effect et vt` | Type.Apps' _ [eff, vt] <- st -> do - - -- ensure that the variables in `et` unify with those from - -- the scrutinee. - lift $ abilityCheck' [eff] [et] - let kt = - Type.arrow - (Pattern.loc k) - it - (Type.effect (Pattern.loc k) [eff] vt) - (vs ++) <$> checkPattern kt k + -- ensure that the variables in `et` unify with those from + -- the scrutinee. + lift $ abilityCheck' [eff] [et] + let kt = + Type.arrow + (Pattern.loc k) + it + (Type.effect (Pattern.loc k) [eff] vt) + (vs ++) <$> checkPattern kt k | otherwise -> lift . compilerCrash $ PatternMatchFailure _ -> lift . compilerCrash $ From 793cb2e42eed3ab54043a99c7fb32f26095d9e76 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 28 Jun 2022 10:09:01 -0600 Subject: [PATCH 404/529] Add a few more orphan instances for use in Enlil (#3147) * Add some more orphans, they're useful in Enlil * Add binary instance for Hash * Instance Updates * Moar instances * Remove unnecessary changes to sync types --- unison-share-api/package.yaml | 1 + unison-share-api/src/Unison/Server/Orphans.hs | 24 +++++++++++++++++++ unison-share-api/unison-share-api.cabal | 1 + 3 files changed, 26 insertions(+) diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 779210a011..9e17699d08 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -13,6 +13,7 @@ dependencies: - aeson - async - base + - binary - bytestring - containers - directory diff --git a/unison-share-api/src/Unison/Server/Orphans.hs b/unison-share-api/src/Unison/Server/Orphans.hs index 9f91864452..cfedee1c79 100644 --- a/unison-share-api/src/Unison/Server/Orphans.hs +++ b/unison-share-api/src/Unison/Server/Orphans.hs @@ -4,9 +4,15 @@ module Unison.Server.Orphans where import Data.Aeson +import qualified Data.Aeson as Aeson +import Data.Binary +import Data.ByteString.Short (ShortByteString) import Data.OpenApi import Data.Proxy import Servant +import U.Codebase.HashTags +import U.Util.Hash (Hash (..)) +import qualified U.Util.Hash as Hash import Unison.Codebase.Editor.DisplayObject import Unison.Codebase.ShortBranchHash ( ShortBranchHash (..), @@ -20,6 +26,16 @@ import Unison.Prelude import Unison.ShortHash (ShortHash) import Unison.Util.Pretty (Width (..)) +instance ToJSON Hash where + toJSON h = String $ Hash.toBase32HexText h + +instance FromJSON Hash where + parseJSON = Aeson.withText "Hash" $ pure . Hash.unsafeFromBase32HexText + +deriving via Hash instance ToJSON CausalHash + +deriving via Hash instance FromJSON CausalHash + instance ToJSON ShortHash where toEncoding = genericToEncoding defaultOptions @@ -30,6 +46,12 @@ deriving instance ToSchema ShortHash instance FromHttpApiData ShortBranchHash where parseUrlPiece = maybe (Left "Invalid ShortBranchHash") Right . SBH.fromText +deriving via ShortByteString instance Binary Hash + +deriving via Hash instance Binary CausalHash + +deriving via Text instance ToHttpApiData ShortBranchHash + instance (ToJSON b, ToJSON a) => ToJSON (DisplayObject b a) where toEncoding = genericToEncoding defaultOptions @@ -52,6 +74,8 @@ deriving anyclass instance ToParamSchema ShortBranchHash deriving via Int instance FromHttpApiData Width +deriving via Int instance ToHttpApiData Width + deriving anyclass instance ToParamSchema Width instance ToJSON n => ToJSON (HQ.HashQualified n) where diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index a9e3e75d7d..b93c096e90 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -70,6 +70,7 @@ library , aeson , async , base + , binary , bytestring , containers , directory From 261c6b3657905a3c706970c80ab01b2bc7cd3ff3 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 28 Jun 2022 14:21:03 -0400 Subject: [PATCH 405/529] update ki hash --- stack.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/stack.yaml b/stack.yaml index 3e061d0d20..9dc1813b4a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -41,7 +41,7 @@ extra-deps: - github: unisonweb/shellmet commit: 2fd348592c8f51bb4c0ca6ba4bc8e38668913746 - github: awkward-squad/ki - commit: 712e5031b586b5111577a73268a9a204073ed25d + commit: 563e96238dfe392dccf68d93953c8f30fd53bec8 subdirs: - ki - guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 From 98db2177c482ca15956d9b1193e4a58d32800321 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 28 Jun 2022 15:37:36 -0400 Subject: [PATCH 406/529] begin implementing parallel push --- stack.yaml.lock | 10 +- unison-cli/src/Unison/Share/Sync.hs | 166 ++++++++++++++++------------ 2 files changed, 102 insertions(+), 74 deletions(-) diff --git a/stack.yaml.lock b/stack.yaml.lock index 0a958a5ae6..85c999523c 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -27,18 +27,18 @@ packages: original: url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz - completed: - size: 16162 + size: 15840 subdir: ki - url: https://github.com/awkward-squad/ki/archive/712e5031b586b5111577a73268a9a204073ed25d.tar.gz + url: https://github.com/awkward-squad/ki/archive/563e96238dfe392dccf68d93953c8f30fd53bec8.tar.gz name: ki version: 1.0.0 - sha256: e65c035a383dc43aeaeda7264d4570826402609bbc729b2e761ee41365691fa6 + sha256: a45eb3dbe7333c108aef4afce7f763c7661919b09641ef9d241c7ca4a78bf735 pantry-tree: size: 704 - sha256: ce05acf45f3594cd724cb9fd559e4657984335812a8620b6dc06d87f2134acdb + sha256: c63220c438c076818e09061b117c56055e154f6abb66ea9bc44a3900fcabd654 original: subdir: ki - url: https://github.com/awkward-squad/ki/archive/712e5031b586b5111577a73268a9a204073ed25d.tar.gz + url: https://github.com/awkward-squad/ki/archive/563e96238dfe392dccf68d93953c8f30fd53bec8.tar.gz - completed: hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 pantry-tree: diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index c6dfb3dc2d..653e748e57 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -26,6 +26,8 @@ import Control.Monad.Except import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader import qualified Data.Foldable as Foldable (find) +import Data.IntSet (IntSet) +import qualified Data.IntSet as IntSet import Data.List.NonEmpty (pattern (:|)) import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as List.NonEmpty @@ -97,7 +99,7 @@ checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash uplo Share.UpdatePathHashMismatch mismatch -> pure (Left (CheckAndSetPushErrorHashMismatch mismatch)) Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do -- Upload the causal and all of its dependencies. - uploadEntities httpClient unisonShareUrl conn (Share.pathRepoName path) dependencies uploadProgressCallback >>= \case + uploadEntities httpClient unisonShareUrl undefined (Share.pathRepoName path) dependencies uploadProgressCallback >>= \case False -> pure (Left (CheckAndSetPushErrorNoWritePermission path)) True -> -- After uploading the causal and all of its dependencies, try setting the remote path again. @@ -191,7 +193,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash uploadProgress uploadEntities httpClient unisonShareUrl - conn + undefined (Share.pathRepoName path) (NESet.singleton (causalHashToHash32 headHash)) uploadProgressCallback @@ -545,31 +547,31 @@ completeTempEntities httpClient unisonShareUrl connect repoName callbacks initia elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount = connect \conn -> forever do - (join . atomically) do - (hashJwts, mayNewTempEntities) <- readTQueue newTempEntitiesQueue - -- Avoid unnecessary retaining of these hashes to keep memory usage more stable. This algorithm would still - -- be correct if we never delete from `uninsertedHashes`. - -- - -- We remove the inserted hashes from uninsertedHashesVar at this point rather than right after insertion in order - -- to ensure that no running transaction of the elaborator is viewing a snapshot that precedes the snapshot - -- that inserted those hashes. - modifyTVar' uninsertedHashesVar \uninsertedHashes -> - Set.difference uninsertedHashes hashJwts - case mayNewTempEntities of - Nothing -> pure (pure ()) - Just newTempEntities -> do - recordWorking workerCount - pure do - newElaboratedHashes <- Sqlite.runTransaction conn (elaborateHashes newTempEntities) - n <- - atomically do - uninsertedHashes <- readTVar uninsertedHashesVar - hashes0 <- readTVar hashesVar - let !hashes1 = Set.union (Set.difference newElaboratedHashes uninsertedHashes) hashes0 - writeTVar hashesVar hashes1 - pure (Set.size hashes1 - Set.size hashes0) - toDownload callbacks n - atomically (recordNotWorking workerCount) + (join . atomically) do + (hashJwts, mayNewTempEntities) <- readTQueue newTempEntitiesQueue + -- Avoid unnecessary retaining of these hashes to keep memory usage more stable. This algorithm would still + -- be correct if we never delete from `uninsertedHashes`. + -- + -- We remove the inserted hashes from uninsertedHashesVar at this point rather than right after insertion in order + -- to ensure that no running transaction of the elaborator is viewing a snapshot that precedes the snapshot + -- that inserted those hashes. + modifyTVar' uninsertedHashesVar \uninsertedHashes -> + Set.difference uninsertedHashes hashJwts + case mayNewTempEntities of + Nothing -> pure (pure ()) + Just newTempEntities -> do + recordWorking workerCount + pure do + newElaboratedHashes <- Sqlite.runTransaction conn (elaborateHashes newTempEntities) + n <- + atomically do + uninsertedHashes <- readTVar uninsertedHashesVar + hashes0 <- readTVar hashesVar + let !hashes1 = Set.union (Set.difference newElaboratedHashes uninsertedHashes) hashes0 + writeTVar hashesVar hashes1 + pure (Set.size hashes1 - Set.size hashes0) + toDownload callbacks n + atomically (recordNotWorking workerCount) -- | Insert entities into the database, and return the subset that went into temp storage (`temp_entitiy`) rather than -- of main storage (`object` / `causal`) due to missing dependencies. @@ -608,31 +610,77 @@ getCausalHashByPath httpClient unisonShareUrl repoPath = uploadEntities :: AuthenticatedHttpClient -> BaseUrl -> - Sqlite.Connection -> + (forall a. (Sqlite.Connection -> IO a) -> IO a) -> Share.RepoName -> NESet Hash32 -> (Int -> Int -> IO ()) -> IO Bool -uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadProgressCallback = - loop 0 hashes0 +uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgressCallback = + Ki.scoped \scope -> + dispatcher + (\workerId hashes -> void (Ki.fork scope (worker workerId hashes))) + undefined + undefined + undefined + undefined where - loop :: Int -> NESet Hash32 -> IO Bool - loop uploadCount allHashesSet = do - -- Each request only contains a certain maximum number of entities; split the set of hashes we need to upload into - -- those we will upload right now, and those we will begin uploading on the next iteration of the loop. - let (hashesSet, nextHashes) = - case NESet.splitAt 50 allHashesSet of - This hs1 -> (hs1, Set.empty) - That hs2 -> (hs2, Set.empty) -- impossible, this only happens if we split at 0 - These hs1 hs2 -> (hs1, NESet.toSet hs2) + dispatcher :: + (Int -> NESet Hash32 -> IO ()) -> + TVar (Set Hash32) -> + TVar (Set Hash32) -> + TVar Int -> + TVar IntSet -> + IO Bool + dispatcher forkWorker hashesVar dedupeVar nextWorkerIdVar workersVar = + loop + where + loop :: IO Bool + loop = + join (atomically (checkForFailureMode <|> dispatchWorkMode <|> checkIfDoneMode)) + + checkForFailureMode :: STM (IO Bool) + checkForFailureMode = + undefined + + dispatchWorkMode :: STM (IO Bool) + dispatchWorkMode = do + hashes <- readTVar hashesVar + when (Set.null hashes) retry + let (hashes1, hashes2) = Set.splitAt 50 hashes + modifyTVar' dedupeVar (Set.union hashes1) + writeTVar hashesVar hashes2 + pure do + workerId <- + atomically do + workerId <- readTVar nextWorkerIdVar + writeTVar nextWorkerIdVar $! workerId + 1 + modifyTVar' workersVar (IntSet.insert workerId) + pure workerId + forkWorker workerId (NESet.unsafeFromSet hashes1) + loop + + -- Check to see if there are no hashes left to upload and no outstanding workers. + checkIfDoneMode :: STM (IO Bool) + checkIfDoneMode = do + workers <- readTVar workersVar + when (not (IntSet.null workers)) retry + pure (pure True) + + worker :: Int -> NESet Hash32 -> IO () + worker workerId hashesSet = do + -- 2. upload those entities to server + -- 3. + -- 1. delete itself from running workers + -- 2. sample largest worker + -- 3. add to work queue + -- 4. block until that largest worker is done + -- 5. delete its assigned hashes from dedupeVar let hashesList = NESet.toAscList hashesSet - -- Get each entity that the server is missing out of the database. - entities <- Sqlite.runTransaction conn (traverse expectEntity hashesList) + entities <- connect \conn -> Sqlite.runTransaction conn (traverse expectEntity hashesList) - let uploadEntities :: IO Share.UploadEntitiesResponse - uploadEntities = do - -- Timing.time ("uploadEntities with " <> show (NESet.size hashesSet) <> " hashes.") do + let upload :: IO Share.UploadEntitiesResponse + upload = do httpUploadEntities httpClient unisonShareUrl @@ -641,31 +689,11 @@ uploadEntities httpClient unisonShareUrl conn repoName hashes0 uploadProgressCal repoName } - -- The new upload count *if* we make a successful upload. - let newUploadCount = uploadCount + NESet.size hashesSet - - uploadEntities >>= \case - Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> do - let newAllHashesSet = union10 moreHashes nextHashes - uploadProgressCallback newUploadCount (NESet.size newAllHashesSet) - loop newUploadCount newAllHashesSet - Share.UploadEntitiesNoWritePermission _ -> pure False - Share.UploadEntitiesHashMismatchForEntity {} -> pure False - Share.UploadEntitiesSuccess -> do - case NESet.nonEmptySet nextHashes of - Nothing -> do - uploadProgressCallback newUploadCount 0 - pure True - Just nextHashes1 -> do - uploadProgressCallback newUploadCount (NESet.size nextHashes1) - loop newUploadCount nextHashes1 - --- Union a non-empty set and a set. -union10 :: Ord a => NESet a -> Set a -> NESet a -union10 xs ys = - case NESet.nonEmptySet ys of - Nothing -> xs - Just zs -> NESet.union xs zs + upload >>= \case + Share.UploadEntitiesNeedDependencies (Share.NeedDependencies _moreHashes) -> undefined + Share.UploadEntitiesNoWritePermission _ -> undefined + Share.UploadEntitiesHashMismatchForEntity _ -> undefined + Share.UploadEntitiesSuccess -> undefined ------------------------------------------------------------------------------------------------------------------------ -- Database operations From 73419dd0cf7b53d1a61557c7e1e477ac63b5a662 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 28 Jun 2022 15:39:17 -0400 Subject: [PATCH 407/529] stack.yaml.lock changes --- stack.yaml.lock | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/stack.yaml.lock b/stack.yaml.lock index 0a958a5ae6..85c999523c 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -27,18 +27,18 @@ packages: original: url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz - completed: - size: 16162 + size: 15840 subdir: ki - url: https://github.com/awkward-squad/ki/archive/712e5031b586b5111577a73268a9a204073ed25d.tar.gz + url: https://github.com/awkward-squad/ki/archive/563e96238dfe392dccf68d93953c8f30fd53bec8.tar.gz name: ki version: 1.0.0 - sha256: e65c035a383dc43aeaeda7264d4570826402609bbc729b2e761ee41365691fa6 + sha256: a45eb3dbe7333c108aef4afce7f763c7661919b09641ef9d241c7ca4a78bf735 pantry-tree: size: 704 - sha256: ce05acf45f3594cd724cb9fd559e4657984335812a8620b6dc06d87f2134acdb + sha256: c63220c438c076818e09061b117c56055e154f6abb66ea9bc44a3900fcabd654 original: subdir: ki - url: https://github.com/awkward-squad/ki/archive/712e5031b586b5111577a73268a9a204073ed25d.tar.gz + url: https://github.com/awkward-squad/ki/archive/563e96238dfe392dccf68d93953c8f30fd53bec8.tar.gz - completed: hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 pantry-tree: From 42e8dc952c74c896a8897fc386aefaf52ee0e2bd Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Tue, 28 Jun 2022 18:47:40 -0400 Subject: [PATCH 408/529] implementation of fast text patterns (not hooked up to runtime yet) --- parser-typechecker/src/Unison/Builtin.hs | 18 ++- parser-typechecker/src/Unison/Util/Text.hs | 6 + .../src/Unison/Util/Text/Pattern.hs | 122 ++++++++++++++++++ .../unison-parser-typechecker.cabal | 1 + unison-core/src/Unison/Type.hs | 3 + 5 files changed, 149 insertions(+), 1 deletion(-) create mode 100644 parser-typechecker/src/Unison/Util/Text/Pattern.hs diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 4d6847dc86..8e81f52689 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -470,6 +470,21 @@ builtinsSrc = B "Text.fromCharList" $ list char --> text, B "Text.toUtf8" $ text --> bytes, B "Text.fromUtf8.impl.v3" $ bytes --> eithert failure text, + B "Text.patterns.eof" $ pat text, + B "Text.patterns.literal" $ text --> pat text, + B "Text.patterns.digit" $ pat text, + B "Text.patterns.letter" $ pat text, + B "Text.patterns.space" $ pat text, + B "Text.patterns.punctuation" $ pat text, + B "Text.patterns.charRange" $ char --> char --> pat text, + B "Text.patterns.notCharRange" $ char --> char --> pat text, + B "Text.patterns.charIn" $ list char --> pat text, + B "Text.patterns.notCharIn" $ list char --> pat text, + B "Pattern.many" $ forall1 "a" (\a -> pat a --> pat a), + B "Pattern.capture" $ forall1 "a" (\a -> pat a --> pat a), + B "Pattern.join" $ forall1 "a" (\a -> list (pat a) --> pat a), + B "Pattern.run" $ forall1 "a" (\a -> pat a --> a --> optionalt (tuple [list a, a])), + B "Pattern.isMatch" $ forall1 "a" (\a -> pat a --> a --> boolean), B "Char.toNat" $ char --> nat, B "Char.toText" $ char --> text, B "Char.fromNat" $ nat --> char, @@ -930,9 +945,10 @@ code = Type.code () value = Type.value () termLink = Type.termLink () -stm, tvar :: Type -> Type +stm, tvar, pat :: Type -> Type stm = Type.effect1 () (Type.ref () Type.stmRef) tvar a = Type.ref () Type.tvarRef `app` a +pat a = Type.ref () Type.patternRef `app` a timeSpec :: Type timeSpec = Type.ref () Type.timeSpecRef diff --git a/parser-typechecker/src/Unison/Util/Text.hs b/parser-typechecker/src/Unison/Util/Text.hs index 18dd0541de..6f1f4dd5fb 100644 --- a/parser-typechecker/src/Unison/Util/Text.hs +++ b/parser-typechecker/src/Unison/Util/Text.hs @@ -57,6 +57,12 @@ unsnoc :: Text -> Maybe (Text, Char) unsnoc t | size t == 0 = Nothing unsnoc t = (take (size t - 1) t,) <$> at (size t - 1) t +unconsChunk :: Text -> Maybe (Chunk, Text) +unconsChunk (Text r) = (\(a, b) -> (a, Text b)) <$> R.uncons r + +unsnocChunk :: Text -> Maybe (Text, Chunk) +unsnocChunk (Text r) = (\(a, b) -> (Text a, b)) <$> R.unsnoc r + at :: Int -> Text -> Maybe Char at n (Text t) = R.index n t diff --git a/parser-typechecker/src/Unison/Util/Text/Pattern.hs b/parser-typechecker/src/Unison/Util/Text/Pattern.hs new file mode 100644 index 0000000000..306ce8ce0e --- /dev/null +++ b/parser-typechecker/src/Unison/Util/Text/Pattern.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE BangPatterns #-} + +module Unison.Util.Text.Pattern where + +import Data.Char (isDigit, isLetter, isPunctuation, isSpace) +import qualified Data.Text as DT +import Unison.Util.Text (Text) +import qualified Unison.Util.Text as Text + +data Pattern + = Eof + | Literal Text -- matches and consumes that exact text + | Digit + | Letter + | Space + | Punctuation + | CharRange Char Char + | CharIn [Char] + | NotCharIn [Char] + | NotCharRange Char Char + | Join [Pattern] + | Capture Pattern + | Many Pattern + +uncons :: Pattern -> Text -> Maybe ([Text], Text) +uncons p = + let cp = compile p Nothing (\acc rem -> Just (reverse acc, rem)) + in \t -> cp [] t + +compile :: Pattern -> r -> ([Text] -> Text -> r) -> [Text] -> Text -> r +compile !Eof !err !success = go + where + go acc t + | Text.size t == 0 = success acc t + | otherwise = err +compile (Literal txt) !err !success = go + where + go acc t + | Text.take (Text.size txt) t == txt = success acc (Text.drop (Text.size txt) t) + | otherwise = err +compile (Capture c) !err !success = go + where + compiled = compile c (\e _ -> e) (\acc rem -> \_ f -> f acc rem) + go acc t = compiled acc t err success' + where + success' acc rem = success (Text.take (Text.size t - Text.size rem) t : acc) rem +compile (Join ps) !err !success = go ps + where + go [] = \acc t -> success acc t + go (p : ps) = + let pc = compile p err (\acc rem -> psc acc rem) + psc = compile (Join ps) err success + in pc +compile (NotCharIn cs) !err !success = go + where + ok = charNotInPred cs + go acc t = case Text.uncons t of + Just (ch, rem) | ok ch -> success acc rem + _ -> err +compile (CharIn cs) !err !success = go + where + ok = charInPred cs + go acc t = case Text.uncons t of + Just (ch, rem) | ok ch -> success acc rem + _ -> err +compile (CharRange c1 c2) !err !success = go + where + go acc t = case Text.uncons t of + Just (ch, rem) | ch >= c1 && ch <= c2 -> success acc rem + _ -> err +compile (NotCharRange c1 c2) !err !success = go + where + go acc t = case Text.uncons t of + Just (ch, rem) | not (ch >= c1 && ch <= c2) -> success acc rem + _ -> err +compile (Many p) !_ !success = case p of + CharIn cs -> walker (charInPred cs) + NotCharIn cs -> walker (charNotInPred cs) + Digit -> walker isDigit + Letter -> walker isLetter + Punctuation -> walker isPunctuation + Space -> walker isSpace + p -> go + where + compiled = compile p (\e _ -> e) (\acc rem -> \_ f -> f acc rem) + go acc t = compiled acc t (success acc t) go + where + walker ok = go + where + go acc t = case Text.unconsChunk t of + Nothing -> success acc t + Just (Text.chunkToText -> txt, t) -> case DT.dropWhile ok txt of + rem + | DT.null rem -> go acc t + | otherwise -> success acc (Text.fromText rem <> t) + {-# INLINE walker #-} +compile Digit !err !success = go + where + go acc t = case Text.uncons t of + Just (ch, rem) | isDigit ch -> success acc rem + _ -> err +compile Letter !err !success = go + where + go acc t = case Text.uncons t of + Just (ch, rem) | isLetter ch -> success acc rem + _ -> err +compile Punctuation !err !success = go + where + go acc t = case Text.uncons t of + Just (ch, rem) | isPunctuation ch -> success acc rem + _ -> err +compile Space !err !success = go + where + go acc t = case Text.uncons t of + Just (ch, rem) | isSpace ch -> success acc rem + _ -> err + +charInPred, charNotInPred :: [Char] -> Char -> Bool +charInPred [] = const False +charInPred (c : chs) = let ok = charInPred chs in \ci -> ci == c || ok ci +charNotInPred [] = const True +charNotInPred (c : chs) = let ok = charNotInPred chs in (\ci -> ci /= c && ok ci) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 3069c636e5..0104b7c478 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -149,6 +149,7 @@ library Unison.Util.Rope Unison.Util.Star3 Unison.Util.Text + Unison.Util.Text.Pattern Unison.Util.TQueue Unison.Util.TransitiveClosure hs-source-dirs: diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index caeaf49e53..b470af0d9e 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -271,6 +271,9 @@ tlsRef = Reference.Builtin "Tls" stmRef :: Reference stmRef = Reference.Builtin "STM" +patternRef :: Reference +patternRef = Reference.Builtin "Pattern" + tlsClientConfigRef :: Reference tlsClientConfigRef = Reference.Builtin "Tls.ClientConfig" From 71d380f9ce3ed49aed0022978f1846bad8d4aeb4 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 28 Jun 2022 20:39:32 -0400 Subject: [PATCH 409/529] more concurrent push work --- .../src/Unison/Codebase/Editor/HandleInput.hs | 6 +- unison-cli/src/Unison/Share/Sync.hs | 143 ++++++++++-------- 2 files changed, 84 insertions(+), 65 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f745f166a4..4995c0bb13 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1865,7 +1865,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l let sharePath = Share.Path (repo Nel.:| pathToSegments remotePath) ensureAuthenticatedWithCodeserver codeserver - LoopState.Env {authHTTPClient, codebase = Codebase {connection}} <- ask + LoopState.Env {authHTTPClient, codebase = Codebase {connection, withConnection}} <- ask -- doesn't handle the case where a non-existent path is supplied Sqlite.runTransaction connection (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath))) @@ -1880,7 +1880,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l Share.checkAndSetPush authHTTPClient baseURL - connection + withConnection sharePath Nothing localCausalHash @@ -1896,7 +1896,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l Share.fastForwardPush authHTTPClient baseURL - connection + withConnection sharePath localCausalHash entitiesUploadedProgressCallback diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 653e748e57..05d3311732 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -42,7 +42,6 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import qualified Data.Text.Lazy as Text.Lazy import qualified Data.Text.Lazy.Encoding as Text.Lazy -import Data.These (These (..)) import Data.Void (Void) import qualified Ki import qualified Network.HTTP.Client as Http.Client @@ -79,8 +78,8 @@ checkAndSetPush :: AuthenticatedHttpClient -> -- | The Unison Share URL. BaseUrl -> - -- | SQLite connection, for reading entities to push. - Sqlite.Connection -> + -- | SQLite-connection-making function, for writing entities we pull. + (forall a. (Sqlite.Connection -> IO a) -> IO a) -> -- | The repo+path to push to. Share.Path -> -- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error. @@ -91,7 +90,7 @@ checkAndSetPush :: -- | Callback that is given the total number of entities uploaded, and the number of outstanding entities to upload. (Int -> Int -> IO ()) -> IO (Either (SyncError CheckAndSetPushError) ()) -checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash uploadProgressCallback = catchSyncErrors do +checkAndSetPush httpClient unisonShareUrl connect path expectedHash causalHash uploadProgressCallback = catchSyncErrors do -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs -- this causal (UpdatePathMissingDependencies). updatePath >>= \case @@ -99,7 +98,7 @@ checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash uplo Share.UpdatePathHashMismatch mismatch -> pure (Left (CheckAndSetPushErrorHashMismatch mismatch)) Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do -- Upload the causal and all of its dependencies. - uploadEntities httpClient unisonShareUrl undefined (Share.pathRepoName path) dependencies uploadProgressCallback >>= \case + uploadEntities httpClient unisonShareUrl connect (Share.pathRepoName path) dependencies uploadProgressCallback >>= \case False -> pure (Left (CheckAndSetPushErrorNoWritePermission path)) True -> -- After uploading the causal and all of its dependencies, try setting the remote path again. @@ -137,8 +136,8 @@ fastForwardPush :: AuthenticatedHttpClient -> -- | The Unison Share URL. BaseUrl -> - -- | SQLite connection, for reading entities to push. - Sqlite.Connection -> + -- | SQLite-connection-making function, for writing entities we pull. + (forall a. (Sqlite.Connection -> IO a) -> IO a) -> -- | The repo+path to push to. Share.Path -> -- | The hash of our local causal to push. @@ -146,12 +145,13 @@ fastForwardPush :: -- | Callback that is given the total number of entities uploaded, and the number of outstanding entities to upload. (Int -> Int -> IO ()) -> IO (Either (SyncError FastForwardPushError) ()) -fastForwardPush httpClient unisonShareUrl conn path localHeadHash uploadProgressCallback = catchSyncErrors do +fastForwardPush httpClient unisonShareUrl connect path localHeadHash uploadProgressCallback = catchSyncErrors do getCausalHashByPath httpClient unisonShareUrl path >>= \case Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path)) Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path)) - Right (Just (Share.hashJWTHash -> remoteHeadHash)) -> - Sqlite.runTransaction conn (loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash)) >>= \case + Right (Just (Share.hashJWTHash -> remoteHeadHash)) -> do + let doLoadCausalSpineBewteen = loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash) + (connect \conn -> Sqlite.runTransaction conn doLoadCausalSpineBewteen) >>= \case -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a -- fast-forward push, so we don't bother trying - just report the error now. Nothing -> pure (Left (FastForwardPushErrorNotFastForward path)) @@ -193,7 +193,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash uploadProgress uploadEntities httpClient unisonShareUrl - undefined + connect (Share.pathRepoName path) (NESet.singleton (causalHashToHash32 headHash)) uploadProgressCallback @@ -615,37 +615,30 @@ uploadEntities :: NESet Hash32 -> (Int -> Int -> IO ()) -> IO Bool -uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgressCallback = +uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgressCallback = do + hashesVar <- newTVarIO (NESet.toSet hashes0) + -- FIXME document this + dedupeVar <- newTVarIO Set.empty + nextWorkerIdVar <- newTVarIO 0 + workersVar <- newTVarIO IntSet.empty + workerFailedVar <- newEmptyTMVarIO + Ki.scoped \scope -> - dispatcher - (\workerId hashes -> void (Ki.fork scope (worker workerId hashes))) - undefined - undefined - undefined - undefined - where - dispatcher :: - (Int -> NESet Hash32 -> IO ()) -> - TVar (Set Hash32) -> - TVar (Set Hash32) -> - TVar Int -> - TVar IntSet -> - IO Bool - dispatcher forkWorker hashesVar dedupeVar nextWorkerIdVar workersVar = - loop - where - loop :: IO Bool + let loop :: IO Bool loop = join (atomically (checkForFailureMode <|> dispatchWorkMode <|> checkIfDoneMode)) checkForFailureMode :: STM (IO Bool) - checkForFailureMode = - undefined + checkForFailureMode = do + () <- readTMVar workerFailedVar + pure (pure False) dispatchWorkMode :: STM (IO Bool) dispatchWorkMode = do hashes <- readTVar hashesVar when (Set.null hashes) retry + workers <- readTVar workersVar + when (IntSet.size workers >= 10) retry -- O(n), use Set Int instead? let (hashes1, hashes2) = Set.splitAt 50 hashes modifyTVar' dedupeVar (Set.union hashes1) writeTVar hashesVar hashes2 @@ -656,7 +649,9 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress writeTVar nextWorkerIdVar $! workerId + 1 modifyTVar' workersVar (IntSet.insert workerId) pure workerId - forkWorker workerId (NESet.unsafeFromSet hashes1) + _ <- + Ki.fork @() scope do + worker hashesVar dedupeVar workersVar workerFailedVar workerId (NESet.unsafeFromSet hashes1) loop -- Check to see if there are no hashes left to upload and no outstanding workers. @@ -665,35 +660,59 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress workers <- readTVar workersVar when (not (IntSet.null workers)) retry pure (pure True) - - worker :: Int -> NESet Hash32 -> IO () - worker workerId hashesSet = do - -- 2. upload those entities to server - -- 3. - -- 1. delete itself from running workers - -- 2. sample largest worker - -- 3. add to work queue - -- 4. block until that largest worker is done - -- 5. delete its assigned hashes from dedupeVar - - let hashesList = NESet.toAscList hashesSet - entities <- connect \conn -> Sqlite.runTransaction conn (traverse expectEntity hashesList) - - let upload :: IO Share.UploadEntitiesResponse - upload = do - httpUploadEntities - httpClient - unisonShareUrl - Share.UploadEntitiesRequest - { entities = NEMap.fromAscList (List.NonEmpty.zip hashesList entities), - repoName - } - - upload >>= \case - Share.UploadEntitiesNeedDependencies (Share.NeedDependencies _moreHashes) -> undefined - Share.UploadEntitiesNoWritePermission _ -> undefined - Share.UploadEntitiesHashMismatchForEntity _ -> undefined - Share.UploadEntitiesSuccess -> undefined + in loop + where + worker :: TVar (Set Hash32) -> TVar (Set Hash32) -> TVar IntSet -> TMVar () -> Int -> NESet Hash32 -> IO () + worker hashesVar dedupeVar workersVar workerFailedVar workerId hashes = do + entities <- + fmap NEMap.fromAscList do + connect \conn -> + Sqlite.runTransaction conn do + for (NESet.toAscList hashes) \hash -> do + entity <- expectEntity hash + pure (hash, entity) + + result <- + httpUploadEntities httpClient unisonShareUrl Share.UploadEntitiesRequest {entities, repoName} <&> \case + Share.UploadEntitiesNeedDependencies (Share.NeedDependencies moreHashes) -> Right (NESet.toSet moreHashes) + Share.UploadEntitiesNoWritePermission _ -> Left () + Share.UploadEntitiesHashMismatchForEntity _ -> error "hash mismatch; fixme" + Share.UploadEntitiesSuccess -> Right Set.empty + + case result of + Left () -> void (atomically (tryPutTMVar workerFailedVar ())) + Right moreHashes -> do + maybeYoungestWorkerAlive <- + atomically do + -- Record ourselves as "dead". The only work we have left to do is remove the hashes we just uploaded from + -- the `dedupe` set, but whether or not we are "alive" is relevant only to: + -- + -- - The main dispatcher thread, which terminates when there are no more hashes to upload, and no alive + -- workers. It is not important for us to delete from the `dedupe` set in this case. + -- + -- - Other worker threads, each of which independently decides when it is safe to delete the set of + -- hashes they just uploaded from the `dedupe` set (as we are doing now). + !workers <- IntSet.delete workerId <$> readTVar workersVar + writeTVar workersVar workers + -- Add more work (i.e. hashes to upload) to the work queue (really a work set), per the response we just + -- got from the server. Remember to only add hashes that aren't in the `dedupe` set (see the comment on + -- the dedupe set above for more info). + when (not (Set.null moreHashes)) do + dedupe <- readTVar dedupeVar + modifyTVar' hashesVar (Set.union (Set.difference moreHashes dedupe)) + pure (fst <$> IntSet.minView workers) + -- Block until we are sure that the server does not have any uncommitted transactions that see a version of + -- the database that does not include the entities we just uploaded. After that point, it's fine to remove the + -- hashes of the entities we just uploaded from the `dedupe` set, because they will never be relevant for any + -- subsequent deduping operations. If we didn't delete from the `dedupe` set, this algorithm would still be + -- correct, it would just use an unbounded amount of memory to remember all the hashes we've uploaded so far. + whenJust maybeYoungestWorkerAlive \youngestWorkerAlive -> do + atomically do + workers <- readTVar workersVar + case IntSet.minView workers of + Nothing -> pure () + Just (worker, _) -> when (worker <= youngestWorkerAlive) retry + atomically (modifyTVar' dedupeVar (`Set.difference` (NESet.toSet hashes))) ------------------------------------------------------------------------------------------------------------------------ -- Database operations From 3a5cd15d50fb5a0456aad9df7cf9dac3a4922a6a Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Tue, 28 Jun 2022 21:58:29 -0400 Subject: [PATCH 410/529] add `Pattern.or` combinator --- parser-typechecker/src/Unison/Builtin.hs | 5 ++ .../src/Unison/Util/Text/Pattern.hs | 81 +++++++++++-------- 2 files changed, 51 insertions(+), 35 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 8e81f52689..f4dbc57560 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -468,9 +468,13 @@ builtinsSrc = B "Text.unsnoc" $ text --> optionalt (tuple [text, char]), B "Text.toCharList" $ text --> list char, B "Text.fromCharList" $ list char --> text, + B "Text.reverse" $ text --> text, + B "Text.toUppercase" $ text --> text, + B "Text.toLowercase" $ text --> text, B "Text.toUtf8" $ text --> bytes, B "Text.fromUtf8.impl.v3" $ bytes --> eithert failure text, B "Text.patterns.eof" $ pat text, + B "Text.patterns.anyChar" $ pat text, B "Text.patterns.literal" $ text --> pat text, B "Text.patterns.digit" $ pat text, B "Text.patterns.letter" $ pat text, @@ -483,6 +487,7 @@ builtinsSrc = B "Pattern.many" $ forall1 "a" (\a -> pat a --> pat a), B "Pattern.capture" $ forall1 "a" (\a -> pat a --> pat a), B "Pattern.join" $ forall1 "a" (\a -> list (pat a) --> pat a), + B "Pattern.or" $ forall1 "a" (\a -> pat a --> pat a --> pat a), B "Pattern.run" $ forall1 "a" (\a -> pat a --> a --> optionalt (tuple [list a, a])), B "Pattern.isMatch" $ forall1 "a" (\a -> pat a --> a --> boolean), B "Char.toNat" $ char --> nat, diff --git a/parser-typechecker/src/Unison/Util/Text/Pattern.hs b/parser-typechecker/src/Unison/Util/Text/Pattern.hs index 306ce8ce0e..f2b18f063b 100644 --- a/parser-typechecker/src/Unison/Util/Text/Pattern.hs +++ b/parser-typechecker/src/Unison/Util/Text/Pattern.hs @@ -8,47 +8,60 @@ import Unison.Util.Text (Text) import qualified Unison.Util.Text as Text data Pattern - = Eof - | Literal Text -- matches and consumes that exact text - | Digit - | Letter - | Space - | Punctuation - | CharRange Char Char - | CharIn [Char] - | NotCharIn [Char] - | NotCharRange Char Char - | Join [Pattern] - | Capture Pattern - | Many Pattern + = Join [Pattern] -- sequencing of patterns + | Or Pattern Pattern -- left-biased choice: tries second pattern only if first fails + | Capture Pattern -- capture all the text consumed by the inner pattern, discarding its subcaptures + | Many Pattern -- zero or more repetitions (at least 1 can be written: Join [p, Many p]) + | AnyChar -- consume a single char + | Eof -- succeed if given the empty text, fail otherwise + | Literal Text -- succeed if input starts with the given text, advance by that text + | CharRange Char Char -- consume 1 char in the given range, or fail + | CharIn [Char] -- consume 1 char in the given set, or fail + | NotCharIn [Char] -- consume 1 char NOT in the given set, or fail + | NotCharRange Char Char -- consume 1 char NOT in the given range, or fail + | Digit -- consume 1 digit (according to Char.isDigit) + | Letter -- consume 1 letter (according to Char.isLetter) + | Space -- consume 1 space character (according to Char.isSpace) + | Punctuation -- consume 1 punctuation char (according to Char.isPunctuation) uncons :: Pattern -> Text -> Maybe ([Text], Text) uncons p = - let cp = compile p Nothing (\acc rem -> Just (reverse acc, rem)) + let cp = compile p (\_ _ -> Nothing) (\acc rem -> Just (reverse acc, rem)) in \t -> cp [] t -compile :: Pattern -> r -> ([Text] -> Text -> r) -> [Text] -> Text -> r +compile :: Pattern -> ([Text] -> Text -> r) -> ([Text] -> Text -> r) -> [Text] -> Text -> r compile !Eof !err !success = go where go acc t | Text.size t == 0 = success acc t - | otherwise = err + | otherwise = err acc t compile (Literal txt) !err !success = go where go acc t | Text.take (Text.size txt) t == txt = success acc (Text.drop (Text.size txt) t) - | otherwise = err + | otherwise = err acc t +compile AnyChar !err !success = go + where + go acc t = case Text.drop 1 t of + rem + | Text.size t > Text.size rem -> success acc rem + | otherwise -> err acc rem +compile (Capture (Many AnyChar)) !_ !success = \acc t -> success (t : acc) Text.empty compile (Capture c) !err !success = go where - compiled = compile c (\e _ -> e) (\acc rem -> \_ f -> f acc rem) - go acc t = compiled acc t err success' - where - success' acc rem = success (Text.take (Text.size t - Text.size rem) t : acc) rem + err' _ _ acc0 t0 = err acc0 t0 + success' _ rem acc0 t0 = success (Text.take (Text.size t0 - Text.size rem) t0 : acc0) rem + compiled = compile c err' success' + go acc t = compiled acc t acc t +compile (Or p1 p2) err success = cp1 + where + cp2 = compile p2 err success + cp1 = compile p1 cp2 success compile (Join ps) !err !success = go ps where - go [] = \acc t -> success acc t + go [] = success go (p : ps) = - let pc = compile p err (\acc rem -> psc acc rem) + let pc = compile p err psc psc = compile (Join ps) err success in pc compile (NotCharIn cs) !err !success = go @@ -56,34 +69,32 @@ compile (NotCharIn cs) !err !success = go ok = charNotInPred cs go acc t = case Text.uncons t of Just (ch, rem) | ok ch -> success acc rem - _ -> err + _ -> err acc t compile (CharIn cs) !err !success = go where ok = charInPred cs go acc t = case Text.uncons t of Just (ch, rem) | ok ch -> success acc rem - _ -> err + _ -> err acc t compile (CharRange c1 c2) !err !success = go where go acc t = case Text.uncons t of Just (ch, rem) | ch >= c1 && ch <= c2 -> success acc rem - _ -> err + _ -> err acc t compile (NotCharRange c1 c2) !err !success = go where go acc t = case Text.uncons t of Just (ch, rem) | not (ch >= c1 && ch <= c2) -> success acc rem - _ -> err + _ -> err acc t compile (Many p) !_ !success = case p of + AnyChar -> (\acc _ -> success acc Text.empty) CharIn cs -> walker (charInPred cs) NotCharIn cs -> walker (charNotInPred cs) Digit -> walker isDigit Letter -> walker isLetter Punctuation -> walker isPunctuation Space -> walker isSpace - p -> go - where - compiled = compile p (\e _ -> e) (\acc rem -> \_ f -> f acc rem) - go acc t = compiled acc t (success acc t) go + p -> let go = compile p success (\acc rem -> go acc rem) in go where walker ok = go where @@ -98,22 +109,22 @@ compile Digit !err !success = go where go acc t = case Text.uncons t of Just (ch, rem) | isDigit ch -> success acc rem - _ -> err + _ -> err acc t compile Letter !err !success = go where go acc t = case Text.uncons t of Just (ch, rem) | isLetter ch -> success acc rem - _ -> err + _ -> err acc t compile Punctuation !err !success = go where go acc t = case Text.uncons t of Just (ch, rem) | isPunctuation ch -> success acc rem - _ -> err + _ -> err acc t compile Space !err !success = go where go acc t = case Text.uncons t of Just (ch, rem) | isSpace ch -> success acc rem - _ -> err + _ -> err acc t charInPred, charNotInPred :: [Char] -> Char -> Bool charInPred [] = const False From 1b6d8f117a3a27d5c2071ea497260959419a7269 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 28 Jun 2022 23:06:09 -0400 Subject: [PATCH 411/529] give the dispatcher a name --- unison-cli/src/Unison/Share/Sync.hs | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 05d3311732..08980e776d 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -624,7 +624,13 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress workerFailedVar <- newEmptyTMVarIO Ki.scoped \scope -> - let loop :: IO Bool + dispatcher scope hashesVar dedupeVar nextWorkerIdVar workersVar workerFailedVar + where + dispatcher :: Ki.Scope -> TVar (Set Hash32) -> TVar (Set Hash32) -> TVar Int -> TVar IntSet -> TMVar () -> IO Bool + dispatcher scope hashesVar dedupeVar nextWorkerIdVar workersVar workerFailedVar = do + loop + where + loop :: IO Bool loop = join (atomically (checkForFailureMode <|> dispatchWorkMode <|> checkIfDoneMode)) @@ -660,8 +666,7 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress workers <- readTVar workersVar when (not (IntSet.null workers)) retry pure (pure True) - in loop - where + worker :: TVar (Set Hash32) -> TVar (Set Hash32) -> TVar IntSet -> TMVar () -> Int -> NESet Hash32 -> IO () worker hashesVar dedupeVar workersVar workerFailedVar workerId hashes = do entities <- From 53a788444346428c815299f8340e9ec36174ea3e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 28 Jun 2022 23:11:08 -0400 Subject: [PATCH 412/529] IntSet -> Set Int, because we want to call `size` --- unison-cli/src/Unison/Share/Sync.hs | 34 ++++++++++++++++------------- 1 file changed, 19 insertions(+), 15 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 08980e776d..da4162dd28 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -26,8 +26,6 @@ import Control.Monad.Except import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Control.Monad.Trans.Reader as Reader import qualified Data.Foldable as Foldable (find) -import Data.IntSet (IntSet) -import qualified Data.IntSet as IntSet import Data.List.NonEmpty (pattern (:|)) import qualified Data.List.NonEmpty as List (NonEmpty) import qualified Data.List.NonEmpty as List.NonEmpty @@ -620,13 +618,20 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress -- FIXME document this dedupeVar <- newTVarIO Set.empty nextWorkerIdVar <- newTVarIO 0 - workersVar <- newTVarIO IntSet.empty + workersVar <- newTVarIO Set.empty workerFailedVar <- newEmptyTMVarIO Ki.scoped \scope -> dispatcher scope hashesVar dedupeVar nextWorkerIdVar workersVar workerFailedVar where - dispatcher :: Ki.Scope -> TVar (Set Hash32) -> TVar (Set Hash32) -> TVar Int -> TVar IntSet -> TMVar () -> IO Bool + dispatcher :: + Ki.Scope -> + TVar (Set Hash32) -> + TVar (Set Hash32) -> + TVar Int -> + TVar (Set Int) -> + TMVar () -> + IO Bool dispatcher scope hashesVar dedupeVar nextWorkerIdVar workersVar workerFailedVar = do loop where @@ -644,7 +649,7 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress hashes <- readTVar hashesVar when (Set.null hashes) retry workers <- readTVar workersVar - when (IntSet.size workers >= 10) retry -- O(n), use Set Int instead? + when (Set.size workers >= 10) retry -- O(n), use Set Int instead? let (hashes1, hashes2) = Set.splitAt 50 hashes modifyTVar' dedupeVar (Set.union hashes1) writeTVar hashesVar hashes2 @@ -653,7 +658,7 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress atomically do workerId <- readTVar nextWorkerIdVar writeTVar nextWorkerIdVar $! workerId + 1 - modifyTVar' workersVar (IntSet.insert workerId) + modifyTVar' workersVar (Set.insert workerId) pure workerId _ <- Ki.fork @() scope do @@ -664,10 +669,10 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress checkIfDoneMode :: STM (IO Bool) checkIfDoneMode = do workers <- readTVar workersVar - when (not (IntSet.null workers)) retry + when (not (Set.null workers)) retry pure (pure True) - worker :: TVar (Set Hash32) -> TVar (Set Hash32) -> TVar IntSet -> TMVar () -> Int -> NESet Hash32 -> IO () + worker :: TVar (Set Hash32) -> TVar (Set Hash32) -> TVar (Set Int) -> TMVar () -> Int -> NESet Hash32 -> IO () worker hashesVar dedupeVar workersVar workerFailedVar workerId hashes = do entities <- fmap NEMap.fromAscList do @@ -687,7 +692,7 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress case result of Left () -> void (atomically (tryPutTMVar workerFailedVar ())) Right moreHashes -> do - maybeYoungestWorkerAlive <- + maybeYoungestWorkerThatWasAlive <- atomically do -- Record ourselves as "dead". The only work we have left to do is remove the hashes we just uploaded from -- the `dedupe` set, but whether or not we are "alive" is relevant only to: @@ -697,7 +702,7 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress -- -- - Other worker threads, each of which independently decides when it is safe to delete the set of -- hashes they just uploaded from the `dedupe` set (as we are doing now). - !workers <- IntSet.delete workerId <$> readTVar workersVar + !workers <- Set.delete workerId <$> readTVar workersVar writeTVar workersVar workers -- Add more work (i.e. hashes to upload) to the work queue (really a work set), per the response we just -- got from the server. Remember to only add hashes that aren't in the `dedupe` set (see the comment on @@ -705,18 +710,17 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress when (not (Set.null moreHashes)) do dedupe <- readTVar dedupeVar modifyTVar' hashesVar (Set.union (Set.difference moreHashes dedupe)) - pure (fst <$> IntSet.minView workers) + pure (Set.lookupMin workers) -- Block until we are sure that the server does not have any uncommitted transactions that see a version of -- the database that does not include the entities we just uploaded. After that point, it's fine to remove the -- hashes of the entities we just uploaded from the `dedupe` set, because they will never be relevant for any -- subsequent deduping operations. If we didn't delete from the `dedupe` set, this algorithm would still be -- correct, it would just use an unbounded amount of memory to remember all the hashes we've uploaded so far. - whenJust maybeYoungestWorkerAlive \youngestWorkerAlive -> do + whenJust maybeYoungestWorkerThatWasAlive \youngestWorkerThatWasAlive -> do atomically do workers <- readTVar workersVar - case IntSet.minView workers of - Nothing -> pure () - Just (worker, _) -> when (worker <= youngestWorkerAlive) retry + whenJust (Set.lookupMin workers) \youngestWorkerAlive -> + when (youngestWorkerAlive <= youngestWorkerThatWasAlive) retry atomically (modifyTVar' dedupeVar (`Set.difference` (NESet.toSet hashes))) ------------------------------------------------------------------------------------------------------------------------ From f280c26150bbb151ad227fec75cbd2a941973f75 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Tue, 28 Jun 2022 23:43:37 -0400 Subject: [PATCH 413/529] unit tests and fix infinite loop in many --- .../src/Unison/Util/Text/Pattern.hs | 11 +++++++--- .../tests/Unison/Test/Util/Text.hs | 21 +++++++++++++++++++ 2 files changed, 29 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/Util/Text/Pattern.hs b/parser-typechecker/src/Unison/Util/Text/Pattern.hs index f2b18f063b..08eac93904 100644 --- a/parser-typechecker/src/Unison/Util/Text/Pattern.hs +++ b/parser-typechecker/src/Unison/Util/Text/Pattern.hs @@ -24,8 +24,8 @@ data Pattern | Space -- consume 1 space character (according to Char.isSpace) | Punctuation -- consume 1 punctuation char (according to Char.isPunctuation) -uncons :: Pattern -> Text -> Maybe ([Text], Text) -uncons p = +run :: Pattern -> Text -> Maybe ([Text], Text) +run p = let cp = compile p (\_ _ -> Nothing) (\acc rem -> Just (reverse acc, rem)) in \t -> cp [] t @@ -94,7 +94,12 @@ compile (Many p) !_ !success = case p of Letter -> walker isLetter Punctuation -> walker isPunctuation Space -> walker isSpace - p -> let go = compile p success (\acc rem -> go acc rem) in go + p -> go + where + go = compile p success success' + success' acc rem + | Text.size rem == 0 = success acc rem + | otherwise = go acc rem where walker ok = go where diff --git a/parser-typechecker/tests/Unison/Test/Util/Text.hs b/parser-typechecker/tests/Unison/Test/Util/Text.hs index 757945d5e7..084c2ff772 100644 --- a/parser-typechecker/tests/Unison/Test/Util/Text.hs +++ b/parser-typechecker/tests/Unison/Test/Util/Text.hs @@ -8,6 +8,7 @@ import qualified Data.Text as T import EasyTest import qualified Unison.Util.Rope as R import qualified Unison.Util.Text as Text +import qualified Unison.Util.Text.Pattern as P test :: Test () test = @@ -98,6 +99,26 @@ test = depths = map depth ts note ("maximum depth for tree with " <> show (i * n) <> " chunks was " <> show maxDepth) expect' (maxDepth < log2 (i * n) * 2) + ok, + scope "patterns" $ do + expect' (P.run P.Eof "" == Just ([], "")) + expect' (P.run P.AnyChar "a" == Just ([], "")) + expect' (P.run (P.CharRange 'a' 'z') "a" == Just ([], "")) + expect' (P.run (P.NotCharRange 'a' 'z') "a" == Nothing) + expect' (P.run (P.Or (P.NotCharRange 'a' 'z') P.AnyChar) "abc" == Just ([], "bc")) + -- this shows that we ignore subcaptures + expect' (P.run (P.Join [P.Capture (P.Join [P.Capture P.AnyChar, P.Capture P.AnyChar]), P.AnyChar]) "abcdef" == Just (["ab"], "def")) + expect' (P.run (P.CharIn "0123") "3ab" == Just ([], "ab")) + expect' (P.run (P.NotCharIn "0123") "a3b" == Just ([], "3b")) + expect' (P.run (P.Capture (P.NotCharIn "0123")) "a3b" == Just (["a"], "3b")) + expect' (P.run (P.Many (P.CharIn "abcd")) "babbababac123" == Just ([], "123")) + expect' (P.run (P.Capture (P.Many (P.CharIn "abcd"))) "babbababac123" == Just (["babbababac"], "123")) + expect' (P.run (P.Capture (P.Many (P.Digit))) "012345abc" == Just (["012345"], "abc")) + expect' (P.run (P.Join [P.Capture (P.Many (P.Digit)), P.Literal ",", P.Capture (P.Many P.AnyChar)]) "012345,abc" == Just (["012345", "abc"], "")) + expect' + ( P.run (P.Many (P.Join [P.Capture (P.Many (P.Digit)), P.Many P.Space])) "01 10 20 1123 292 110 10" + == Just (["01", "10", "20", "1123", "292", "110", "10"], "") + ) ok ] where From 27b28fc2932b30e7c82521702b84634e06ac1298 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 29 Jun 2022 00:48:12 -0400 Subject: [PATCH 414/529] update dev.markdown --- development.markdown | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/development.markdown b/development.markdown index a4d1ff3189..3397e8c07f 100644 --- a/development.markdown +++ b/development.markdown @@ -22,7 +22,7 @@ On startup, Unison prints a url for the codebase UI. If you did step 3 above, th Most test suites support selecting a specific test to run by passing a prefix as a test argument: -* `stack test parser-typechecker --fast --test-arguments my-test-prefix` builds and runs most test suites, see below for exceptions to this (e.g. transcript tests). +* `stack test unison-parser-typechecker --fast --test-arguments my-test-prefix` builds and runs most test suites, see below for exceptions to this (e.g. transcript tests). Some tests are executables instead: From 2cc9a37d7b00c98c3de2b348c8a8139bd78bd5fa Mon Sep 17 00:00:00 2001 From: Emil Hotkowski Date: Wed, 29 Jun 2022 17:01:46 +0200 Subject: [PATCH 415/529] Added @emilhotkowski to contributors --- CONTRIBUTORS.markdown | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.markdown b/CONTRIBUTORS.markdown index 1d059cc2d0..a72a8a989a 100644 --- a/CONTRIBUTORS.markdown +++ b/CONTRIBUTORS.markdown @@ -69,3 +69,4 @@ The format for this list: name, GitHub handle * Phil de Joux (@philderbeast) * Travis Staton (@tstat) * Dan Freeman (@dfreeman) +* Emil Hotkowski (@emilhotkowski) From b2c03dbc6e2bd516197e7094dfee9a9e172c7e25 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 29 Jun 2022 11:45:12 -0400 Subject: [PATCH 416/529] added some todos for @dolio --- parser-typechecker/src/Unison/Builtin.hs | 9 +++++++++ parser-typechecker/src/Unison/Util/Text/Pattern.hs | 1 + 2 files changed, 10 insertions(+) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index f4dbc57560..ed80c38e59 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -468,13 +468,18 @@ builtinsSrc = B "Text.unsnoc" $ text --> optionalt (tuple [text, char]), B "Text.toCharList" $ text --> list char, B "Text.fromCharList" $ list char --> text, + -- Todo: implement me @dolio B "Text.reverse" $ text --> text, B "Text.toUppercase" $ text --> text, B "Text.toLowercase" $ text --> text, B "Text.toUtf8" $ text --> bytes, B "Text.fromUtf8.impl.v3" $ bytes --> eithert failure text, + -- TODO dolio these need implementation B "Text.patterns.eof" $ pat text, B "Text.patterns.anyChar" $ pat text, + -- Bytes.patterns.literal : Bytes -> Pattern Bytes + -- Bytes.patterns.word64be : Nat -> Pattern Bytes + -- Text.patterns.literal : Text -> Pattern Text B "Text.patterns.literal" $ text --> pat text, B "Text.patterns.digit" $ pat text, B "Text.patterns.letter" $ pat text, @@ -484,12 +489,16 @@ builtinsSrc = B "Text.patterns.notCharRange" $ char --> char --> pat text, B "Text.patterns.charIn" $ list char --> pat text, B "Text.patterns.notCharIn" $ list char --> pat text, + -- Pattern.many : Pattern a -> Pattern a B "Pattern.many" $ forall1 "a" (\a -> pat a --> pat a), B "Pattern.capture" $ forall1 "a" (\a -> pat a --> pat a), B "Pattern.join" $ forall1 "a" (\a -> list (pat a) --> pat a), B "Pattern.or" $ forall1 "a" (\a -> pat a --> pat a --> pat a), + -- Pattern.run : Pattern a -> a -> Optional ([a], a) B "Pattern.run" $ forall1 "a" (\a -> pat a --> a --> optionalt (tuple [list a, a])), B "Pattern.isMatch" $ forall1 "a" (\a -> pat a --> a --> boolean), + -- end todo + B "Char.toNat" $ char --> nat, B "Char.toText" $ char --> text, B "Char.fromNat" $ nat --> char, diff --git a/parser-typechecker/src/Unison/Util/Text/Pattern.hs b/parser-typechecker/src/Unison/Util/Text/Pattern.hs index 08eac93904..e859eb7035 100644 --- a/parser-typechecker/src/Unison/Util/Text/Pattern.hs +++ b/parser-typechecker/src/Unison/Util/Text/Pattern.hs @@ -29,6 +29,7 @@ run p = let cp = compile p (\_ _ -> Nothing) (\acc rem -> Just (reverse acc, rem)) in \t -> cp [] t +-- Pattern a -> ([a] -> a -> r) -> ... -- might need a takeable and droppable interface if go this route compile :: Pattern -> ([Text] -> Text -> r) -> ([Text] -> Text -> r) -> [Text] -> Text -> r compile !Eof !err !success = go where From 66cfab23d46736536c0e734d2ba4222b8774d076 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 29 Jun 2022 22:39:11 -0400 Subject: [PATCH 417/529] address PR feedback and do some minor cleanup also reduce number of downloaders from 10 to 5, because 5 has performed better in a few tests --- unison-cli/src/Unison/Share/Sync.hs | 118 ++++++++++++++-------------- 1 file changed, 58 insertions(+), 60 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index c6dfb3dc2d..ae492f2511 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -398,6 +398,11 @@ recordNotWorking :: WorkerCount -> STM () recordNotWorking sem = modifyTVar' sem \n -> n - 1 +-- What the dispatcher is to do +data DispatcherJob + = DispatcherForkWorker (NESet Share.HashJWT) + | DispatcherDone + -- | Finish downloading entities from Unison Share. Returns the total number of entities downloaded. -- -- Precondition: the entities were *already* downloaded at some point in the past, and are now sitting in the @@ -423,20 +428,16 @@ completeTempEntities httpClient unisonShareUrl connect repoName callbacks initia -- The sets of new (at the time of inserting, anyway) temp entity rows, which we need to elaborate, then download. newTempEntitiesQueue <- newTQueueIO + -- How many workers (downloader / inserter / elaborator) are currently doing stuff. workerCount <- newWorkerCount + -- Kick off the cycle of inserter->elaborator->dispatcher->downloader by giving the elaborator something to do + atomically (writeTQueue newTempEntitiesQueue (Set.empty, Just initialNewTempEntities)) + Ki.scoped \scope -> do Ki.fork_ scope (inserter entitiesQueue newTempEntitiesQueue workerCount) Ki.fork_ scope (elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount) - -- Kick off the cycle of inserter->elaborator->dispatcher->worker by giving the elaborator something to do - atomically (writeTQueue newTempEntitiesQueue (Set.empty, Just initialNewTempEntities)) - dispatcher - (\hashes -> void (Ki.fork scope (downloader entitiesQueue workerCount hashes))) - hashesVar - uninsertedHashesVar - entitiesQueue - newTempEntitiesQueue - workerCount + dispatcher hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount where -- Dispatcher thread: "dequeue" from `hashesVar`, fork one-shot downloaders. -- @@ -446,53 +447,49 @@ completeTempEntities httpClient unisonShareUrl connect repoName callbacks initia -- - The inserter thread doesn't have any outstanding work enqueued (in `entitiesQueue`) -- - The elaborator thread doesn't have any outstanding work enqueued (in `newTempEntitiesQueue`) dispatcher :: - (NESet Share.HashJWT -> IO ()) -> TVar (Set Share.HashJWT) -> TVar (Set Share.HashJWT) -> TQueue (NESet Share.HashJWT, NEMap Hash32 (Share.Entity Text Hash32 Share.HashJWT)) -> TQueue (Set Share.HashJWT, Maybe (NESet Hash32)) -> WorkerCount -> IO () - dispatcher forkDownloader hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount = - loop + dispatcher hashesVar uninsertedHashesVar entitiesQueue newTempEntitiesQueue workerCount = + Ki.scoped \scope -> + let loop :: IO () + loop = + atomically (dispatchWorkMode <|> checkIfDoneMode) >>= \case + DispatcherDone -> pure () + DispatcherForkWorker hashes -> do + atomically do + -- Only allow 5 concurrent downloaders (7 workers = inserter + elaborator + 5 downloaders) + workers <- readTVar workerCount + check (workers < 7) + -- we do need to record the downloader as working outside of the worker thread, not inside. + -- otherwise, we might erroneously fall through the the teardown logic below and conclude there's + -- nothing more for the dispatcher to do, when in fact a downloader thread just hasn't made it as + -- far as recording its own existence + recordWorking workerCount + _ <- Ki.fork @() scope (downloader entitiesQueue workerCount hashes) + loop + in loop where - loop :: IO () - loop = - join (atomically (dispatchWorkMode <|> checkIfDoneMode)) - - dispatchWorkMode :: STM (IO ()) + dispatchWorkMode :: STM DispatcherJob dispatchWorkMode = do hashes <- readTVar hashesVar - when (Set.null hashes) retry + check (not (Set.null hashes)) let (hashes1, hashes2) = Set.splitAt 50 hashes modifyTVar' uninsertedHashesVar (Set.union hashes1) writeTVar hashesVar hashes2 - pure do - -- Only allow 10 concurrent http workers - atomically do - workers <- readTVar workerCount - -- 12 workers = inserter + elaborator + 10 http workers - when (workers >= 12) retry - -- we do need to record the downloader as working outside of the worker thread, not inside. - -- otherwise, we might erroneously fall through the the teardown logic below and conclude there's - -- nothing more for the dispatcher to do, when in fact a downloader thread just hasn't made it as - -- far as recording its own existence - recordWorking workerCount - forkDownloader (NESet.unsafeFromSet hashes1) - loop + pure (DispatcherForkWorker (NESet.unsafeFromSet hashes1)) -- Check to see if there are no hashes left to download, no outstanding workers, and no work in either queue - checkIfDoneMode :: STM (IO ()) + checkIfDoneMode :: STM DispatcherJob checkIfDoneMode = do workers <- readTVar workerCount - when (workers > 0) retry - isEmptyTQueue entitiesQueue >>= \case - False -> retry - True -> pure () - isEmptyTQueue newTempEntitiesQueue >>= \case - False -> retry - True -> pure () - pure (pure ()) + check (workers == 0) + isEmptyTQueue entitiesQueue >>= check + isEmptyTQueue newTempEntitiesQueue >>= check + pure DispatcherDone -- Downloader thread: download entities, enqueue to `entitiesQueue` downloader :: @@ -545,31 +542,32 @@ completeTempEntities httpClient unisonShareUrl connect repoName callbacks initia elaborator hashesVar uninsertedHashesVar newTempEntitiesQueue workerCount = connect \conn -> forever do - (join . atomically) do + maybeNewTempEntities <- + atomically do (hashJwts, mayNewTempEntities) <- readTQueue newTempEntitiesQueue - -- Avoid unnecessary retaining of these hashes to keep memory usage more stable. This algorithm would still - -- be correct if we never delete from `uninsertedHashes`. + -- Avoid unnecessary retaining of these hashes to keep memory usage more stable. This algorithm would + -- still be correct if we never delete from `uninsertedHashes`. -- - -- We remove the inserted hashes from uninsertedHashesVar at this point rather than right after insertion in order - -- to ensure that no running transaction of the elaborator is viewing a snapshot that precedes the snapshot - -- that inserted those hashes. - modifyTVar' uninsertedHashesVar \uninsertedHashes -> - Set.difference uninsertedHashes hashJwts + -- We remove the inserted hashes from uninsertedHashesVar at this point rather than right after insertion + -- in order to ensure that no running transaction of the elaborator is viewing a snapshot that precedes + -- the snapshot that inserted those hashes. + modifyTVar' uninsertedHashesVar \uninsertedHashes -> Set.difference uninsertedHashes hashJwts case mayNewTempEntities of - Nothing -> pure (pure ()) + Nothing -> pure Nothing Just newTempEntities -> do recordWorking workerCount - pure do - newElaboratedHashes <- Sqlite.runTransaction conn (elaborateHashes newTempEntities) - n <- - atomically do - uninsertedHashes <- readTVar uninsertedHashesVar - hashes0 <- readTVar hashesVar - let !hashes1 = Set.union (Set.difference newElaboratedHashes uninsertedHashes) hashes0 - writeTVar hashesVar hashes1 - pure (Set.size hashes1 - Set.size hashes0) - toDownload callbacks n - atomically (recordNotWorking workerCount) + pure (Just newTempEntities) + whenJust maybeNewTempEntities \newTempEntities -> do + newElaboratedHashes <- Sqlite.runTransaction conn (elaborateHashes newTempEntities) + moreToDownload <- + atomically do + uninsertedHashes <- readTVar uninsertedHashesVar + hashes0 <- readTVar hashesVar + let !hashes1 = Set.union (Set.difference newElaboratedHashes uninsertedHashes) hashes0 + writeTVar hashesVar hashes1 + pure (Set.size hashes1 - Set.size hashes0) + toDownload callbacks moreToDownload + atomically (recordNotWorking workerCount) -- | Insert entities into the database, and return the subset that went into temp storage (`temp_entitiy`) rather than -- of main storage (`object` / `causal`) due to missing dependencies. From 2679bb59150616ea4fca661b8b9da9ddd902e2b3 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Thu, 30 Jun 2022 11:45:45 -0400 Subject: [PATCH 418/529] Use a fixed 100ms delay for transaction write lock retries --- .../src/Unison/Sqlite/Transaction.hs | 21 ++++++++++--------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 8fbcebb97e..5e966ba937 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -95,8 +95,8 @@ runTransaction conn (Transaction f) = liftIO do ignoringExceptions (Connection.rollback conn) case fromException exception of Just SqliteBusyException -> do - restore (threadDelay 100_000) - runWriteTransaction_ restore 200_000 conn (f conn) + restore (threadDelay transactionRetryDelay) + runWriteTransaction_ restore conn (f conn) _ -> throwIO exception Right result -> do Connection.commit conn @@ -139,26 +139,24 @@ runWriteTransaction conn f = uninterruptibleMask \restore -> runWriteTransaction_ restore - 100_000 conn (runInIO (f (\transaction -> liftIO (unsafeUnTransaction transaction conn)))) {-# SPECIALIZE runWriteTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-} -runWriteTransaction_ :: (forall x. IO x -> IO x) -> Int -> Connection -> IO a -> IO a -runWriteTransaction_ restore microseconds conn transaction = do - keepTryingToBeginImmediate restore conn microseconds +runWriteTransaction_ :: (forall x. IO x -> IO x) -> Connection -> IO a -> IO a +runWriteTransaction_ restore conn transaction = do + keepTryingToBeginImmediate restore conn result <- restore transaction `onException` ignoringExceptions (Connection.rollback conn) Connection.commit conn pure result -- @BEGIN IMMEDIATE@ until success. -keepTryingToBeginImmediate :: (forall x. IO x -> IO x) -> Connection -> Int -> IO () +keepTryingToBeginImmediate :: (forall x. IO x -> IO x) -> Connection -> IO () keepTryingToBeginImmediate restore conn = - let loop microseconds = + let loop = try @_ @SqliteQueryException (Connection.beginImmediate conn) >>= \case Left SqliteBusyException -> do - restore (threadDelay microseconds) - loop (microseconds * 2) + restore (threadDelay transactionRetryDelay) Left exception -> throwIO exception Right () -> pure () in loop @@ -374,3 +372,6 @@ queryOneColCheck_ s check = rowsModified :: Transaction Int rowsModified = Transaction Connection.rowsModified + +transactionRetryDelay :: Int +transactionRetryDelay = 100_000 From 2d6365603fa5f6300fc04406ff360860bb55143f Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 30 Jun 2022 12:07:03 -0400 Subject: [PATCH 419/529] parallel push work --- .../src/Unison/Codebase/Editor/HandleInput.hs | 11 +++-- unison-cli/src/Unison/Share/Sync.hs | 41 +++++++++++++------ 2 files changed, 33 insertions(+), 19 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 4995c0bb13..2959dabd39 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -8,7 +8,7 @@ where -- TODO: Don't import backend -import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO, writeTVar) +import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO) import qualified Control.Error.Util as ErrorUtil import Control.Lens import Control.Monad.Except (ExceptT (..), runExceptT, throwError, withExceptT) @@ -1909,8 +1909,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l pathToSegments = coerce Path.toList - -- Provide the given action a callback that prints out the number of entities uploaded, and the number of entities - -- enqueued to be uploaded. + -- Provide the given action callbacks that display to the terminal. withEntitiesUploadedProgressCallback :: ((Int -> Int -> IO ()) -> IO a) -> IO a withEntitiesUploadedProgressCallback action = do entitiesUploadedVar <- newTVarIO 0 @@ -1924,13 +1923,13 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l "\n Uploaded " <> tShow entitiesUploaded <> "/" - <> tShow (entitiesUploaded + entitiesToUpload) + <> tShow entitiesToUpload <> " entities...\n\n" result <- action \entitiesUploaded entitiesToUpload -> atomically do - writeTVar entitiesUploadedVar entitiesUploaded - writeTVar entitiesToUploadVar entitiesToUpload + modifyTVar' entitiesUploadedVar (+ entitiesUploaded) + modifyTVar' entitiesToUploadVar (+ entitiesToUpload) entitiesUploaded <- readTVarIO entitiesUploadedVar Console.Regions.finishConsoleRegion region $ "\n Uploaded " <> tShow entitiesUploaded <> " entities.\n" diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index da4162dd28..ae27c7ed1c 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -85,7 +85,8 @@ checkAndSetPush :: Maybe Hash32 -> -- | The hash of our local causal to push. CausalHash -> - -- | Callback that is given the total number of entities uploaded, and the number of outstanding entities to upload. + -- | Callback that is given the number of entities just uploaded, and the number of entities we just learned we need + -- to upload as well. (Int -> Int -> IO ()) -> IO (Either (SyncError CheckAndSetPushError) ()) checkAndSetPush httpClient unisonShareUrl connect path expectedHash causalHash uploadProgressCallback = catchSyncErrors do @@ -140,7 +141,8 @@ fastForwardPush :: Share.Path -> -- | The hash of our local causal to push. CausalHash -> - -- | Callback that is given the total number of entities uploaded, and the number of outstanding entities to upload. + -- | Callback that is given the number of entities just uploaded, and the number of entities we just learned we need + -- to upload as well. (Int -> Int -> IO ()) -> IO (Either (SyncError FastForwardPushError) ()) fastForwardPush httpClient unisonShareUrl connect path localHeadHash uploadProgressCallback = catchSyncErrors do @@ -621,6 +623,8 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress workersVar <- newTVarIO Set.empty workerFailedVar <- newEmptyTMVarIO + uploadProgressCallback 0 (NESet.size hashes0) + Ki.scoped \scope -> dispatcher scope hashesVar dedupeVar nextWorkerIdVar workersVar workerFailedVar where @@ -648,11 +652,15 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress dispatchWorkMode = do hashes <- readTVar hashesVar when (Set.null hashes) retry - workers <- readTVar workersVar - when (Set.size workers >= 10) retry -- O(n), use Set Int instead? let (hashes1, hashes2) = Set.splitAt 50 hashes modifyTVar' dedupeVar (Set.union hashes1) writeTVar hashesVar hashes2 + pure (join (atomically (forkWorkerMode (NESet.unsafeFromSet hashes1) <|> checkForFailureMode))) + + forkWorkerMode :: NESet Hash32 -> STM (IO Bool) + forkWorkerMode hashes = do + workers <- readTVar workersVar + when (Set.size workers >= 5) retry pure do workerId <- atomically do @@ -662,10 +670,9 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress pure workerId _ <- Ki.fork @() scope do - worker hashesVar dedupeVar workersVar workerFailedVar workerId (NESet.unsafeFromSet hashes1) + worker hashesVar dedupeVar workersVar workerFailedVar workerId hashes loop - -- Check to see if there are no hashes left to upload and no outstanding workers. checkIfDoneMode :: STM (IO Bool) checkIfDoneMode = do workers <- readTVar workersVar @@ -692,7 +699,8 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress case result of Left () -> void (atomically (tryPutTMVar workerFailedVar ())) Right moreHashes -> do - maybeYoungestWorkerThatWasAlive <- + uploadProgressCallback (NESet.size hashes) 0 + (maybeYoungestWorkerThatWasAlive, numNewHashes) <- atomically do -- Record ourselves as "dead". The only work we have left to do is remove the hashes we just uploaded from -- the `dedupe` set, but whether or not we are "alive" is relevant only to: @@ -707,10 +715,17 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress -- Add more work (i.e. hashes to upload) to the work queue (really a work set), per the response we just -- got from the server. Remember to only add hashes that aren't in the `dedupe` set (see the comment on -- the dedupe set above for more info). - when (not (Set.null moreHashes)) do - dedupe <- readTVar dedupeVar - modifyTVar' hashesVar (Set.union (Set.difference moreHashes dedupe)) - pure (Set.lookupMin workers) + numNewHashes <- + if not (Set.null moreHashes) + then do + dedupe <- readTVar dedupeVar + hashes0 <- readTVar hashesVar + let !hashes1 = Set.union (Set.difference moreHashes dedupe) hashes0 + writeTVar hashesVar hashes1 + pure (Set.size hashes1 - Set.size hashes0) + else pure 0 + pure (Set.lookupMax workers, numNewHashes) + uploadProgressCallback 0 numNewHashes -- Block until we are sure that the server does not have any uncommitted transactions that see a version of -- the database that does not include the entities we just uploaded. After that point, it's fine to remove the -- hashes of the entities we just uploaded from the `dedupe` set, because they will never be relevant for any @@ -719,8 +734,8 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress whenJust maybeYoungestWorkerThatWasAlive \youngestWorkerThatWasAlive -> do atomically do workers <- readTVar workersVar - whenJust (Set.lookupMin workers) \youngestWorkerAlive -> - when (youngestWorkerAlive <= youngestWorkerThatWasAlive) retry + whenJust (Set.lookupMin workers) \oldestWorkerAlive -> + when (oldestWorkerAlive <= youngestWorkerThatWasAlive) retry atomically (modifyTVar' dedupeVar (`Set.difference` (NESet.toSet hashes))) ------------------------------------------------------------------------------------------------------------------------ From ed0d6545c025164287fdfb3633f2db02e2a9b834 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 30 Jun 2022 12:42:25 -0400 Subject: [PATCH 420/529] refactoring for readability --- unison-cli/src/Unison/Share/Sync.hs | 58 ++++++++++++++++++----------- 1 file changed, 36 insertions(+), 22 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 1ea31cdb7c..b125f6a40e 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -600,6 +600,12 @@ getCausalHashByPath httpClient unisonShareUrl repoPath = ------------------------------------------------------------------------------------------------------------------------ -- Upload entities +data UploadDispatcherJob + = UploadDispatcherReturnFailure + | UploadDispatcherForkWorkerWhenAvailable (NESet Hash32) + | UploadDispatcherForkWorker (NESet Hash32) + | UploadDispatcherDone + -- | Upload a set of entities to Unison Share. If the server responds that it cannot yet store any hash(es) due to -- missing dependencies, send those dependencies too, and on and on, until the server stops responding that it's missing -- anything. @@ -639,43 +645,51 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress where loop :: IO Bool loop = - join (atomically (checkForFailureMode <|> dispatchWorkMode <|> checkIfDoneMode)) - - checkForFailureMode :: STM (IO Bool) + doJob [checkForFailureMode, dispatchWorkMode, checkIfDoneMode] + + doJob :: [STM UploadDispatcherJob] -> IO Bool + doJob jobs = + atomically (asum jobs) >>= \case + UploadDispatcherReturnFailure -> pure False + UploadDispatcherForkWorkerWhenAvailable hashes -> doJob [forkWorkerMode hashes, checkForFailureMode] + UploadDispatcherForkWorker hashes -> do + workerId <- + atomically do + workerId <- readTVar nextWorkerIdVar + writeTVar nextWorkerIdVar $! workerId + 1 + modifyTVar' workersVar (Set.insert workerId) + pure workerId + _ <- + Ki.fork @() scope do + worker hashesVar dedupeVar workersVar workerFailedVar workerId hashes + loop + UploadDispatcherDone -> pure True + + checkForFailureMode :: STM UploadDispatcherJob checkForFailureMode = do () <- readTMVar workerFailedVar - pure (pure False) + pure UploadDispatcherReturnFailure - dispatchWorkMode :: STM (IO Bool) + dispatchWorkMode :: STM UploadDispatcherJob dispatchWorkMode = do hashes <- readTVar hashesVar when (Set.null hashes) retry let (hashes1, hashes2) = Set.splitAt 50 hashes modifyTVar' dedupeVar (Set.union hashes1) writeTVar hashesVar hashes2 - pure (join (atomically (forkWorkerMode (NESet.unsafeFromSet hashes1) <|> checkForFailureMode))) + pure (UploadDispatcherForkWorkerWhenAvailable (NESet.unsafeFromSet hashes1)) - forkWorkerMode :: NESet Hash32 -> STM (IO Bool) + forkWorkerMode :: NESet Hash32 -> STM UploadDispatcherJob forkWorkerMode hashes = do workers <- readTVar workersVar - when (Set.size workers >= 5) retry - pure do - workerId <- - atomically do - workerId <- readTVar nextWorkerIdVar - writeTVar nextWorkerIdVar $! workerId + 1 - modifyTVar' workersVar (Set.insert workerId) - pure workerId - _ <- - Ki.fork @() scope do - worker hashesVar dedupeVar workersVar workerFailedVar workerId hashes - loop - - checkIfDoneMode :: STM (IO Bool) + when (Set.size workers >= 10) retry + pure (UploadDispatcherForkWorker hashes) + + checkIfDoneMode :: STM UploadDispatcherJob checkIfDoneMode = do workers <- readTVar workersVar when (not (Set.null workers)) retry - pure (pure True) + pure UploadDispatcherDone worker :: TVar (Set Hash32) -> TVar (Set Hash32) -> TVar (Set Int) -> TMVar () -> Int -> NESet Hash32 -> IO () worker hashesVar dedupeVar workersVar workerFailedVar workerId hashes = do From 9bc1e24b9b0de94a1780b3f7a7522b65e11ac46b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 30 Jun 2022 12:54:05 -0400 Subject: [PATCH 421/529] separate the upload progress callbacks into two --- .../src/Unison/Codebase/Editor/HandleInput.hs | 23 ++++++------ unison-cli/src/Unison/Share/Sync.hs | 35 +++++++++++-------- 2 files changed, 32 insertions(+), 26 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 2959dabd39..e236f7d8d0 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1876,7 +1876,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l PushBehavior.RequireEmpty -> do let push :: IO (Either (Sync.SyncError Share.CheckAndSetPushError) ()) push = - withEntitiesUploadedProgressCallback \entitiesUploadedProgressCallback -> + withEntitiesUploadedProgressCallbacks \callbacks -> Share.checkAndSetPush authHTTPClient baseURL @@ -1884,7 +1884,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l sharePath Nothing localCausalHash - entitiesUploadedProgressCallback + callbacks liftIO push >>= \case Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorCheckAndSetPush err)) Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err)) @@ -1892,14 +1892,14 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l PushBehavior.RequireNonEmpty -> do let push :: IO (Either (Sync.SyncError Share.FastForwardPushError) ()) push = do - withEntitiesUploadedProgressCallback \entitiesUploadedProgressCallback -> + withEntitiesUploadedProgressCallbacks \callbacks -> Share.fastForwardPush authHTTPClient baseURL withConnection sharePath localCausalHash - entitiesUploadedProgressCallback + callbacks liftIO push >>= \case Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorFastForwardPush err)) Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err)) @@ -1910,8 +1910,8 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l coerce Path.toList -- Provide the given action callbacks that display to the terminal. - withEntitiesUploadedProgressCallback :: ((Int -> Int -> IO ()) -> IO a) -> IO a - withEntitiesUploadedProgressCallback action = do + withEntitiesUploadedProgressCallbacks :: (Share.UploadProgressCallbacks -> IO a) -> IO a + withEntitiesUploadedProgressCallbacks action = do entitiesUploadedVar <- newTVarIO 0 entitiesToUploadVar <- newTVarIO 0 Console.Regions.displayConsoleRegions do @@ -1925,11 +1925,12 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l <> "/" <> tShow entitiesToUpload <> " entities...\n\n" - result <- - action \entitiesUploaded entitiesToUpload -> - atomically do - modifyTVar' entitiesUploadedVar (+ entitiesUploaded) - modifyTVar' entitiesToUploadVar (+ entitiesToUpload) + result <- do + action + Share.UploadProgressCallbacks + { uploaded = \n -> atomically (modifyTVar' entitiesUploadedVar (+ n)), + toUpload = \n -> atomically (modifyTVar' entitiesToUploadVar (+ n)) + } entitiesUploaded <- readTVarIO entitiesUploadedVar Console.Regions.finishConsoleRegion region $ "\n Uploaded " <> tShow entitiesUploaded <> " entities.\n" diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index b125f6a40e..626f73e1e9 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -13,6 +13,7 @@ module Unison.Share.Sync CheckAndSetPushError (..), fastForwardPush, FastForwardPushError (..), + UploadProgressCallbacks (..), -- ** Pull pull, @@ -85,11 +86,9 @@ checkAndSetPush :: Maybe Hash32 -> -- | The hash of our local causal to push. CausalHash -> - -- | Callback that is given the number of entities just uploaded, and the number of entities we just learned we need - -- to upload as well. - (Int -> Int -> IO ()) -> + UploadProgressCallbacks -> IO (Either (SyncError CheckAndSetPushError) ()) -checkAndSetPush httpClient unisonShareUrl connect path expectedHash causalHash uploadProgressCallback = catchSyncErrors do +checkAndSetPush httpClient unisonShareUrl connect path expectedHash causalHash callbacks = catchSyncErrors do -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs -- this causal (UpdatePathMissingDependencies). updatePath >>= \case @@ -97,7 +96,7 @@ checkAndSetPush httpClient unisonShareUrl connect path expectedHash causalHash u Share.UpdatePathHashMismatch mismatch -> pure (Left (CheckAndSetPushErrorHashMismatch mismatch)) Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do -- Upload the causal and all of its dependencies. - uploadEntities httpClient unisonShareUrl connect (Share.pathRepoName path) dependencies uploadProgressCallback >>= \case + uploadEntities httpClient unisonShareUrl connect (Share.pathRepoName path) dependencies callbacks >>= \case False -> pure (Left (CheckAndSetPushErrorNoWritePermission path)) True -> -- After uploading the causal and all of its dependencies, try setting the remote path again. @@ -141,11 +140,9 @@ fastForwardPush :: Share.Path -> -- | The hash of our local causal to push. CausalHash -> - -- | Callback that is given the number of entities just uploaded, and the number of entities we just learned we need - -- to upload as well. - (Int -> Int -> IO ()) -> + UploadProgressCallbacks -> IO (Either (SyncError FastForwardPushError) ()) -fastForwardPush httpClient unisonShareUrl connect path localHeadHash uploadProgressCallback = catchSyncErrors do +fastForwardPush httpClient unisonShareUrl connect path localHeadHash callbacks = catchSyncErrors do getCausalHashByPath httpClient unisonShareUrl path >>= \case Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path)) Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path)) @@ -196,7 +193,7 @@ fastForwardPush httpClient unisonShareUrl connect path localHeadHash uploadProgr connect (Share.pathRepoName path) (NESet.singleton (causalHashToHash32 headHash)) - uploadProgressCallback + callbacks -- Return a list (in oldest-to-newest order) of hashes along the causal spine that connects the given arguments, -- excluding the newest hash (second argument). @@ -600,6 +597,14 @@ getCausalHashByPath httpClient unisonShareUrl repoPath = ------------------------------------------------------------------------------------------------------------------------ -- Upload entities +-- | Upload progress callbacks. +data UploadProgressCallbacks = UploadProgressCallbacks + { -- | Callback that's given a number of entities we just uploaded. + uploaded :: Int -> IO (), + -- | Callback that's given a number of entities we just realized we need to upload later. + toUpload :: Int -> IO () + } + data UploadDispatcherJob = UploadDispatcherReturnFailure | UploadDispatcherForkWorkerWhenAvailable (NESet Hash32) @@ -617,9 +622,9 @@ uploadEntities :: (forall a. (Sqlite.Connection -> IO a) -> IO a) -> Share.RepoName -> NESet Hash32 -> - (Int -> Int -> IO ()) -> + UploadProgressCallbacks -> IO Bool -uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgressCallback = do +uploadEntities httpClient unisonShareUrl connect repoName hashes0 callbacks = do hashesVar <- newTVarIO (NESet.toSet hashes0) -- FIXME document this dedupeVar <- newTVarIO Set.empty @@ -627,7 +632,7 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress workersVar <- newTVarIO Set.empty workerFailedVar <- newEmptyTMVarIO - uploadProgressCallback 0 (NESet.size hashes0) + toUpload callbacks (NESet.size hashes0) Ki.scoped \scope -> dispatcher scope hashesVar dedupeVar nextWorkerIdVar workersVar workerFailedVar @@ -711,7 +716,7 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress case result of Left () -> void (atomically (tryPutTMVar workerFailedVar ())) Right moreHashes -> do - uploadProgressCallback (NESet.size hashes) 0 + uploaded callbacks (NESet.size hashes) (maybeYoungestWorkerThatWasAlive, numNewHashes) <- atomically do -- Record ourselves as "dead". The only work we have left to do is remove the hashes we just uploaded from @@ -737,7 +742,7 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 uploadProgress pure (Set.size hashes1 - Set.size hashes0) else pure 0 pure (Set.lookupMax workers, numNewHashes) - uploadProgressCallback 0 numNewHashes + toUpload callbacks numNewHashes -- Block until we are sure that the server does not have any uncommitted transactions that see a version of -- the database that does not include the entities we just uploaded. After that point, it's fine to remove the -- hashes of the entities we just uploaded from the `dedupe` set, because they will never be relevant for any From 2fd55eb2721e48b05e247a961741e6470b580314 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 30 Jun 2022 11:14:51 -0600 Subject: [PATCH 422/529] Try fixing windows cache --- .github/workflows/ci.yaml | 25 ++++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 74c3c6045a..4aff040280 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -39,8 +39,9 @@ jobs: # purge one manually. # Cache ~/.stack, keyed by the contents of 'stack.yaml'. - - uses: actions/cache@v2 - name: cache ~/.stack + - uses: actions/cache@v3 + name: cache ~/.stack (unix) + if: runner.os != 'Windows' with: path: ~/.stack # Main cache key: commit hash. This should always result in a cache miss... @@ -55,8 +56,26 @@ jobs: stack-0_${{matrix.os}}-${{hashFiles('stack.yaml')}} stack-0_${{matrix.os}} + # Cache ~/.stack, keyed by the contents of 'stack.yaml'. + - uses: actions/cache@v3 + name: cache ~/.stack (Windows) + if: runner.os == 'Windows' + with: + path: "%LOCALAPPDATA%\\Programs\\stack" + # Main cache key: commit hash. This should always result in a cache miss... + # So when loading a cache we'll always fall back to the restore-keys, + # which should load the most recent cache via a prefix search on the most + # recent branch cache. + # Then it will save a new cache at this commit sha, which should be used by + # the next build on this branch. + key: stack-0_${{matrix.os}}-${{hashFiles('stack.yaml')}}-${{github.sha}} + # Fall-back to use the most recent cache for the stack.yaml, or failing that the OS + restore-keys: | + stack-0_${{matrix.os}}-${{hashFiles('stack.yaml')}} + stack-0_${{matrix.os}} + # Cache each local package's ~/.stack-work for fast incremental builds in CI. - - uses: actions/cache@v2 + - uses: actions/cache@v3 name: cache .stack-work with: path: | From e55223f851046f7cf5994a469959ade0c823fc31 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 30 Jun 2022 11:21:47 -0600 Subject: [PATCH 423/529] Don't need to test old versions of MacOS any more. It's old, and not providing much value over the other mac build --- .github/workflows/ci.yaml | 1 - 1 file changed, 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 4aff040280..56d428a7aa 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -27,7 +27,6 @@ jobs: # temporarily disable non-windows builds to speed up iteration time - ubuntu-20.04 - macOS-11.0 - - macOS-10.15 - windows-2019 steps: - uses: actions/checkout@v2 From c0af7c2cef94bd7f76ce27fa620d783b403c6f07 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Thu, 30 Jun 2022 13:22:26 -0400 Subject: [PATCH 424/529] actually retry --- lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 5e966ba937..9421c4e824 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -157,6 +157,7 @@ keepTryingToBeginImmediate restore conn = try @_ @SqliteQueryException (Connection.beginImmediate conn) >>= \case Left SqliteBusyException -> do restore (threadDelay transactionRetryDelay) + loop Left exception -> throwIO exception Right () -> pure () in loop From 46924472681bf5a7cb580a1014947b4e71ffa051 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 30 Jun 2022 11:28:32 -0600 Subject: [PATCH 425/529] Add "namespace" to name lookup index (#3165) * Add namespace to name lookup index * Fix name index queries * More instances for paths * Sqlite changes * Redundant import * Update api transcripts * Use GLOB for proper query optimization on namespace search * Slight optimization * Rename namespace size to match old name --- .../U/Codebase/Sqlite/NamedRef.hs | 7 ++- .../U/Codebase/Sqlite/Queries.hs | 59 +++++++++++++++++-- lib/unison-sqlite/src/Unison/Sqlite.hs | 1 + .../src/Unison/Sqlite/Connection.hs | 26 ++++++++ .../src/Unison/Sqlite/Transaction.hs | 6 ++ .../src/Unison/Codebase/Path.hs | 10 ++++ .../Server/Endpoints/NamespaceListing.hs | 9 ++- unison-share-api/src/Unison/Server/Orphans.hs | 28 +++++++++ .../transcripts/api-namespace-list.output.md | 8 ++- 9 files changed, 141 insertions(+), 13 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs index ff0a959e85..47c94534a4 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs @@ -1,6 +1,7 @@ module U.Codebase.Sqlite.NamedRef where import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NEL import qualified Data.List.NonEmpty as NonEmpty import qualified Data.Text as Text import Unison.Prelude @@ -29,10 +30,14 @@ data NamedRef ref = NamedRef {reversedSegments :: ReversedSegments, ref :: ref} instance ToRow ref => ToRow (NamedRef ref) where toRow (NamedRef {reversedSegments = segments, ref}) = - [toField (Text.intercalate "." . toList $ segments)] <> toRow ref + [toField reversedName, toField namespace] <> toRow ref + where + reversedName = Text.intercalate "." . toList $ segments + namespace = Text.intercalate "." . reverse . NEL.tail $ segments instance FromRow ref => FromRow (NamedRef ref) where fromRow = do reversedSegments <- NonEmpty.fromList . Text.splitOn "." <$> field + _namespace <- void $ field @Text ref <- fromRow pure (NamedRef {reversedSegments, ref}) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index f1708d3f9b..c0d799fd68 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -129,6 +129,7 @@ module U.Codebase.Sqlite.Queries insertTypeNames, rootTermNames, rootTypeNames, + getNamespaceDefinitionCount, -- * garbage collection garbageCollectObjectsWithoutHashes, @@ -188,6 +189,7 @@ import qualified Data.Map.NonEmpty as NEMap import qualified Data.Sequence as Seq import qualified Data.Set as Set import Data.String.Here.Uninterpolated (here, hereFile) +import qualified Data.Text as Text import qualified Data.Vector as Vector import qualified U.Codebase.Decl as C import qualified U.Codebase.Decl as C.Decl @@ -1389,7 +1391,10 @@ resetNameLookupTables = do execute_ [here| CREATE TABLE term_name_lookup ( - reversed_name TEXT NOT NULL, -- e.g. map.List.base + -- The name of the term: E.g. map.List.base + reversed_name TEXT NOT NULL, + -- The namespace containing this term, not reversed: E.g. base.List + namespace TEXT NOT NULL, referent_builtin TEXT NULL, referent_component_hash TEXT NULL, referent_component_index INTEGER NULL, @@ -1398,6 +1403,10 @@ resetNameLookupTables = do PRIMARY KEY (reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index) ) |] + execute_ + [here| + CREATE INDEX term_names_by_namespace ON term_name_lookup(namespace) + |] -- Don't need this index at the moment, but will likely be useful later. -- execute_ -- [here| @@ -1406,13 +1415,20 @@ resetNameLookupTables = do execute_ [here| CREATE TABLE type_name_lookup ( - reversed_name TEXT NOT NULL, -- e.g. map.List.base + -- The name of the term: E.g. List.base + reversed_name TEXT NOT NULL, + -- The namespace containing this term, not reversed: E.g. base.List + namespace TEXT NOT NULL, reference_builtin TEXT NULL, reference_component_hash INTEGER NULL, reference_component_index INTEGER NULL, PRIMARY KEY (reversed_name, reference_builtin, reference_component_hash, reference_component_index) ); |] + execute_ + [here| + CREATE INDEX type_names_by_namespace ON type_name_lookup(namespace) + |] -- Don't need this index at the moment, but will likely be useful later. -- execute_ @@ -1428,11 +1444,42 @@ insertTermNames names = do asRow (a, b) = a :. Only b sql = [here| - INSERT INTO term_name_lookup (reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type) - VALUES (?, ?, ?, ?, ?, ?) + INSERT INTO term_name_lookup (reversed_name, namespace, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type) + VALUES (?, ?, ?, ?, ?, ?, ?) ON CONFLICT DO NOTHING |] +-- | We need to escape any special characters for globbing. +-- +-- >>> globEscape "Nat.*.doc" +-- "Nat.[*].doc" +globEscape :: Text -> Text +globEscape = + -- We can't use Text.replace, since we'd end up replacing either "[" or "]" multiple + -- times. + Text.concatMap \case + '*' -> "*" + '?' -> "[?]" + '[' -> "[[]" + ']' -> "[]]" + c -> Text.singleton c + +-- | Gets the count of all definitions within the given namespace. +-- NOTE: This requires a working name lookup index. +getNamespaceDefinitionCount :: Text -> Transaction Int +getNamespaceDefinitionCount namespace = do + let subnamespace = globEscape namespace <> ".*" + queryOneCol sql (subnamespace, namespace, subnamespace, namespace) + where + sql = + [here| + SELECT COUNT(*) FROM ( + SELECT 1 FROM term_name_lookup WHERE namespace GLOB ? OR namespace = ? + UNION ALL + SELECT 1 FROM type_name_lookup WHERE namespace GLOB ? OR namespace = ? + ) + |] + -- | Insert the given set of type names into the name lookup table insertTypeNames :: [S.NamedRef (Reference.TextReference)] -> Transaction () insertTypeNames names = @@ -1440,8 +1487,8 @@ insertTypeNames names = where sql = [here| - INSERT INTO type_name_lookup (reversed_name, reference_builtin, reference_component_hash, reference_component_index) - VALUES (?, ?, ?, ?) + INSERT INTO type_name_lookup (reversed_name, namespace, reference_builtin, reference_component_hash, reference_component_index) + VALUES (?, ?, ?, ?, ?) ON CONFLICT DO NOTHING |] diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index acbaf291e3..075ae41c81 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -51,6 +51,7 @@ module Unison.Sqlite queryMaybeCol, queryOneRow, queryOneCol, + queryManyListRow, -- **** With checks queryListRowCheck, diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index 499e83d1a3..b4fbcaac29 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -25,6 +25,7 @@ module Unison.Sqlite.Connection queryMaybeCol, queryOneRow, queryOneCol, + queryManyListRow, -- **** With checks queryListRowCheck, @@ -189,6 +190,31 @@ executeMany conn@(Connection _ _ conn0) s = \case sql = s } +-- | Run a query many times using a prepared statement. +queryManyListRow :: forall q r. (Sqlite.ToRow q, Sqlite.FromRow r) => Connection -> Sql -> [q] -> IO [[r]] +queryManyListRow conn@(Connection _ _ conn0) s params = case params of + [] -> pure [] + _ -> handle handler do + logQuery s (Just params) Nothing + Sqlite.withStatement conn0 (coerce s) \stmt -> do + for params \p -> + Sqlite.withBind stmt p $ exhaustQuery stmt + where + handler :: Sqlite.SQLError -> IO a + handler exception = + throwSqliteQueryException + SqliteQueryExceptionInfo + { connection = conn, + exception = SomeSqliteExceptionReason exception, + params = Just params, + sql = s + } + exhaustQuery :: Sqlite.Statement -> IO [r] + exhaustQuery stmt = do + Sqlite.nextRow stmt >>= \case + Just a -> (a :) <$> exhaustQuery stmt + Nothing -> pure [] + -- Without results, without parameters execute_ :: Connection -> Sql -> IO () diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index 8fbcebb97e..f2ff395a19 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -31,6 +31,7 @@ module Unison.Sqlite.Transaction queryMaybeCol, queryOneRow, queryOneCol, + queryManyListRow, -- **** With checks queryListRowCheck, @@ -211,6 +212,11 @@ execute_ :: Sql -> Transaction () execute_ s = Transaction \conn -> Connection.execute_ conn s +-- | Run a query many times using a prepared statement. +queryManyListRow :: (Sqlite.FromRow r, Sqlite.ToRow q) => Sql -> [q] -> Transaction [[r]] +queryManyListRow s params = + Transaction \conn -> Connection.queryManyListRow conn s params + -- With results, with parameters, without checks queryStreamRow :: diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index 7463dcedb0..5158e6f598 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -11,7 +11,9 @@ module Unison.Codebase.Path ( Path (..), Path' (..), Absolute (..), + pattern AbsolutePath', Relative (..), + pattern RelativePath', Resolve (..), pattern Empty, pattern (Lens.:<), @@ -263,6 +265,14 @@ toName' = Name.unsafeFromText . toText' pattern Empty = Path Seq.Empty +pattern AbsolutePath' :: Absolute -> Path' +pattern AbsolutePath' p = Path' (Left p) + +pattern RelativePath' :: Relative -> Path' +pattern RelativePath' p = Path' (Right p) + +{-# COMPLETE AbsolutePath', RelativePath' #-} + empty :: Path empty = Path mempty diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs index c64469e5c8..1fd172a531 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs @@ -73,7 +73,7 @@ instance ToSample NamespaceListing where NamespaceListing "." "#gjlk0dna8dongct6lsd19d1o9hi5n642t8jttga5e81e91fviqjdffem0tlddj7ahodjo5" - [Subnamespace $ NamedNamespace "base" "#19d1o9hi5n642t8jttg"] + [Subnamespace $ NamedNamespace "base" "#19d1o9hi5n642t8jttg" (Just 237)] ) ] @@ -103,7 +103,9 @@ deriving instance ToSchema NamespaceObject data NamedNamespace = NamedNamespace { namespaceName :: UnisonName, - namespaceHash :: UnisonHash + namespaceHash :: UnisonHash, + -- May not be provided on all server implementations. + namespaceSize :: Maybe Int } deriving (Generic, Show) @@ -140,7 +142,8 @@ backendListEntryToNamespaceObject ppe typeWidth = \case Subnamespace $ NamedNamespace { namespaceName = NameSegment.toText name, - namespaceHash = "#" <> Hash.toBase32HexText (Causal.unCausalHash hash) + namespaceHash = "#" <> Hash.toBase32HexText (Causal.unCausalHash hash), + namespaceSize = Nothing } Backend.ShallowPatchEntry name -> PatchObject . NamedPatch $ NameSegment.toText name diff --git a/unison-share-api/src/Unison/Server/Orphans.hs b/unison-share-api/src/Unison/Server/Orphans.hs index cfedee1c79..73e76853ae 100644 --- a/unison-share-api/src/Unison/Server/Orphans.hs +++ b/unison-share-api/src/Unison/Server/Orphans.hs @@ -9,11 +9,14 @@ import Data.Binary import Data.ByteString.Short (ShortByteString) import Data.OpenApi import Data.Proxy +import qualified Data.Text as Text import Servant import U.Codebase.HashTags import U.Util.Hash (Hash (..)) import qualified U.Util.Hash as Hash import Unison.Codebase.Editor.DisplayObject +import qualified Unison.Codebase.Path as Path +import qualified Unison.Codebase.Path.Parse as Path import Unison.Codebase.ShortBranchHash ( ShortBranchHash (..), ) @@ -87,3 +90,28 @@ instance ToJSON ConstructorType where toEncoding = genericToEncoding defaultOptions deriving instance ToSchema ConstructorType + +instance FromHttpApiData Path.Relative where + parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of + Left s -> Left (Text.pack s) + Right (Path.RelativePath' p) -> Right p + Right (Path.AbsolutePath' _) -> Left $ "Expected relative path, but " <> txt <> " was absolute." + +instance ToHttpApiData Path.Relative where + toUrlPiece = tShow + +instance FromHttpApiData Path.Absolute where + parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of + Left s -> Left (Text.pack s) + Right (Path.RelativePath' _) -> Left $ "Expected absolute path, but " <> txt <> " was relative." + Right (Path.AbsolutePath' p) -> Right p + +instance ToHttpApiData Path.Absolute where + toUrlPiece = tShow + +instance FromHttpApiData Path.Path' where + parseUrlPiece txt = mapLeft Text.pack $ Path.parsePath' (Text.unpack txt) + +instance ToHttpApiData Path.Path' where + toUrlPiece = tShow + diff --git a/unison-src/transcripts/api-namespace-list.output.md b/unison-src/transcripts/api-namespace-list.output.md index b610eedeaf..97d6194d64 100644 --- a/unison-src/transcripts/api-namespace-list.output.md +++ b/unison-src/transcripts/api-namespace-list.output.md @@ -71,7 +71,8 @@ GET /api/list?namespace=nested.names { "contents": { "namespaceHash": "#n1egracfeljprftoktbjcase2hs4f4p8idbhs5ujipl42agld1810hrq9t7p7ped16aagni2cm1fjcjhho770jh80ipthhmg0cnsur0", - "namespaceName": "x" + "namespaceName": "x", + "namespaceSize": null }, "tag": "Subnamespace" } @@ -119,7 +120,8 @@ GET /api/list?namespace=names&relativeTo=nested { "contents": { "namespaceHash": "#n1egracfeljprftoktbjcase2hs4f4p8idbhs5ujipl42agld1810hrq9t7p7ped16aagni2cm1fjcjhho770jh80ipthhmg0cnsur0", - "namespaceName": "x" + "namespaceName": "x", + "namespaceSize": null }, "tag": "Subnamespace" } @@ -127,4 +129,4 @@ GET /api/list?namespace=names&relativeTo=nested "namespaceListingFQN": "nested.names", "namespaceListingHash": "#oms19b4f9s3c8tb5skeb8jii95ij35n3hdg038pu6rv5b0fikqe4gd7lnu6a1i6aq5tdh2opdo4s0sfrupvk6vfkr9lf0n752gbl8o0" } -``` \ No newline at end of file +``` From ebc75b53f74afc1f2b0d92aebd9156225bde46c6 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 30 Jun 2022 13:36:21 -0400 Subject: [PATCH 426/529] 10 -> 5 --- unison-cli/src/Unison/Share/Sync.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 626f73e1e9..c993fa8ed0 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -687,7 +687,7 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 callbacks = do forkWorkerMode :: NESet Hash32 -> STM UploadDispatcherJob forkWorkerMode hashes = do workers <- readTVar workersVar - when (Set.size workers >= 10) retry + when (Set.size workers >= 5) retry pure (UploadDispatcherForkWorker hashes) checkIfDoneMode :: STM UploadDispatcherJob From c86c96d462e22f4b64d0a6644d414f81d7ff993b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 30 Jun 2022 12:39:24 -0600 Subject: [PATCH 427/529] Try a different env-var syntax :( --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 56d428a7aa..4b7d6cb2be 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -60,7 +60,7 @@ jobs: name: cache ~/.stack (Windows) if: runner.os == 'Windows' with: - path: "%LOCALAPPDATA%\\Programs\\stack" + path: "${{LOCALAPPDATA}}\\Programs\\stack" # Main cache key: commit hash. This should always result in a cache miss... # So when loading a cache we'll always fall back to the restore-keys, # which should load the most recent cache via a prefix search on the most From f14d26e9585b2057ec11404edad5fb202a90a175 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 30 Jun 2022 14:46:06 -0400 Subject: [PATCH 428/529] More text pattern work - Add a replicate pattern, for matching m-n copies of a pattern - Add runtime implementations for patterns --- parser-typechecker/src/Unison/Builtin.hs | 1 + .../src/Unison/Runtime/Builtin.hs | 123 ++++++++++++++++-- .../src/Unison/Runtime/Foreign.hs | 4 + parser-typechecker/src/Unison/Util/Text.hs | 31 +++++ .../src/Unison/Util/Text/Pattern.hs | 35 +++++ 5 files changed, 182 insertions(+), 12 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index ed80c38e59..01528f0317 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -491,6 +491,7 @@ builtinsSrc = B "Text.patterns.notCharIn" $ list char --> pat text, -- Pattern.many : Pattern a -> Pattern a B "Pattern.many" $ forall1 "a" (\a -> pat a --> pat a), + B "Pattern.replicate" $ forall1 "a" (\a -> nat --> nat --> pat a --> pat a), B "Pattern.capture" $ forall1 "a" (\a -> pat a --> pat a), B "Pattern.join" $ forall1 "a" (\a -> list (pat a) --> pat a), B "Pattern.or" $ forall1 "a" (\a -> pat a --> pat a --> pat a), diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 593adb15d5..5b9d9d26d5 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -28,6 +28,7 @@ import Control.Concurrent as SYS import Control.Concurrent.MVar as SYS import qualified Control.Concurrent.STM as STM import Control.DeepSeq (NFData) +import Control.Exception (evaluate) import qualified Control.Exception.Safe as Exception import Control.Monad.Catch (MonadCatch) import qualified Control.Monad.Primitive as PA @@ -123,6 +124,7 @@ import Unison.Reference import Unison.Referent (pattern Ref) import Unison.Runtime.ANF as ANF import Unison.Runtime.ANF.Serialize as ANF +import Unison.Runtime.Exception (die) import Unison.Runtime.Foreign ( Foreign (Wrap), HashAlgorithm (..), @@ -138,6 +140,7 @@ import qualified Unison.Util.Bytes as Bytes import Unison.Util.EnumContainers as EC import Unison.Util.Text (Text) import qualified Unison.Util.Text as Util.Text +import qualified Unison.Util.Text.Pattern as TPat import Unison.Var type Failure = F.Failure Closure @@ -171,6 +174,11 @@ fresh4 = (v1, v2, v3, v4) where [v1, v2, v3, v4] = freshes 4 +fresh5 :: Var v => (v, v, v, v, v) +fresh5 = (v1, v2, v3, v4, v5) + where + [v1, v2, v3, v4, v5] = freshes 5 + fresh6 :: Var v => (v, v, v, v, v, v) fresh6 = (v1, v2, v3, v4, v5, v6) where @@ -1148,8 +1156,8 @@ outMaybe maybe result = (1, ([BX], TAbs maybe $ some maybe)) ] -outMaybeTup :: forall v. Var v => v -> v -> v -> v -> v -> v -> v -> ANormal v -outMaybeTup a b n u bp p result = +outMaybeNTup :: forall v. Var v => v -> v -> v -> v -> v -> v -> v -> ANormal v +outMaybeNTup a b n u bp p result = TMatch result . MatchSum $ mapFromList [ (0, ([], none)), @@ -1165,6 +1173,22 @@ outMaybeTup a b n u bp p result = ) ] +outMaybeTup :: Var v => v -> v -> v -> v -> v -> v -> ANormal v +outMaybeTup a b u bp ap result = + TMatch result . MatchSum $ + mapFromList + [ (0, ([], none)), + ( 1, + ( [BX, BX], + TAbss [a, b] + . TLetD u BX (TCon Ty.unitRef 0 []) + . TLetD bp BX (TCon Ty.pairRef 0 [b, u]) + . TLetD ap BX (TCon Ty.pairRef 0 [a, bp]) + $ some ap + ) + ) + ] + outIoFail :: forall v. Var v => v -> v -> v -> v -> ANormal v outIoFail stack1 stack2 fail result = TMatch result . MatchSum $ @@ -1393,6 +1417,8 @@ boxBoxTo0 instr = where (arg1, arg2) = fresh2 +-- a -> b -> Option c + -- a -> Bool boxToBool :: ForeignOp boxToBool = @@ -1401,6 +1427,13 @@ boxToBool = where (arg, result) = fresh2 +-- a -> b -> Bool +boxBoxToBool :: ForeignOp +boxBoxToBool = + inBxBx arg1 arg2 result $ boolift result + where + (arg1, arg2, result) = fresh3 + -- Nat -> c -- Works for an type that's packed into a word, just -- pass `wordDirect Ty.natRef`, `wordDirect Ty.floatRef` @@ -1498,13 +1531,20 @@ boxToMaybeBox = where (arg, maybe, result) = fresh3 --- a -> Maybe b -boxToMaybeTup :: ForeignOp -boxToMaybeTup = - inBx arg result $ outMaybeTup a b c u bp p result +-- a -> Maybe (Nat, b) +boxToMaybeNTup :: ForeignOp +boxToMaybeNTup = + inBx arg result $ outMaybeNTup a b c u bp p result where (arg, a, b, c, u, bp, p, result) = fresh8 +-- a -> b -> Maybe (c, d) +boxBoxToMaybeTup :: ForeignOp +boxBoxToMaybeTup = + inBxBx arg1 arg2 result $ outMaybeTup a b u bp ap result + where + (arg1, arg2, a, b, u, bp, ap, result) = fresh8 + -- a -> Either Failure Bool boxToEFBool :: ForeignOp boxToEFBool = @@ -1571,6 +1611,17 @@ natToBox = wordDirect Ty.natRef natNatToBox :: ForeignOp natNatToBox = wordWordDirect Ty.natRef Ty.natRef +-- Nat -> Nat -> a -> b +natNatBoxToBox :: ForeignOp +natNatBoxToBox instr = + ([BX, BX, BX],) + . TAbss [a1, a2, a3] + . unbox a1 Ty.natRef ua1 + . unbox a2 Ty.natRef ua2 + $ TFOp instr [ua1, ua2, a3] + where + (a1, a2, a3, ua1, ua2) = fresh5 + -- a -> Nat -> c -- Nat only boxNatToBox :: ForeignOp @@ -2378,12 +2429,12 @@ declareForeigns = do declareForeign Untracked "Bytes.fromBase64UrlUnpadded" boxDirect . mkForeign $ pure . mapLeft Util.Text.fromText . Bytes.fromBase64UrlUnpadded - declareForeign Untracked "Bytes.decodeNat64be" boxToMaybeTup . mkForeign $ pure . Bytes.decodeNat64be - declareForeign Untracked "Bytes.decodeNat64le" boxToMaybeTup . mkForeign $ pure . Bytes.decodeNat64le - declareForeign Untracked "Bytes.decodeNat32be" boxToMaybeTup . mkForeign $ pure . Bytes.decodeNat32be - declareForeign Untracked "Bytes.decodeNat32le" boxToMaybeTup . mkForeign $ pure . Bytes.decodeNat32le - declareForeign Untracked "Bytes.decodeNat16be" boxToMaybeTup . mkForeign $ pure . Bytes.decodeNat16be - declareForeign Untracked "Bytes.decodeNat16le" boxToMaybeTup . mkForeign $ pure . Bytes.decodeNat16le + declareForeign Untracked "Bytes.decodeNat64be" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64be + declareForeign Untracked "Bytes.decodeNat64le" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat64le + declareForeign Untracked "Bytes.decodeNat32be" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32be + declareForeign Untracked "Bytes.decodeNat32le" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat32le + declareForeign Untracked "Bytes.decodeNat16be" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16be + declareForeign Untracked "Bytes.decodeNat16le" boxToMaybeNTup . mkForeign $ pure . Bytes.decodeNat16le declareForeign Untracked "Bytes.encodeNat64be" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat64be declareForeign Untracked "Bytes.encodeNat64le" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat64le @@ -2587,6 +2638,54 @@ declareForeigns = do PA.fillByteArray arr 0 sz init pure arr + declareForeign Untracked "Text.patterns.literal" boxDirect . mkForeign $ + \txt -> evaluate . TPat.cpattern $ TPat.Literal txt + declareForeign Untracked "Text.patterns.digit" direct . mkForeign $ + let v = TPat.cpattern TPat.Digit in \() -> pure v + declareForeign Untracked "Text.patterns.letter" direct . mkForeign $ + let v = TPat.cpattern TPat.Letter in \() -> pure v + declareForeign Untracked "Text.patterns.space" direct . mkForeign $ + let v = TPat.cpattern TPat.Space in \() -> pure v + declareForeign Untracked "Text.patterns.punctuation" direct . mkForeign $ + let v = TPat.cpattern TPat.Punctuation in \() -> pure v + declareForeign Untracked "Text.patterns.anyChar" direct . mkForeign $ + let v = TPat.cpattern TPat.AnyChar in \() -> pure v + declareForeign Untracked "Text.patterns.eof" direct . mkForeign $ + let v = TPat.cpattern TPat.Eof in \() -> pure v + let ccd = wordWordDirect Ty.charRef Ty.charRef + declareForeign Untracked "Text.patterns.charRange" ccd . mkForeign $ + \(beg, end) -> evaluate . TPat.cpattern $ TPat.CharRange beg end + declareForeign Untracked "Text.patterns.notCharRange" ccd . mkForeign $ + \(beg, end) -> evaluate . TPat.cpattern $ TPat.NotCharRange beg end + declareForeign Untracked "Text.patterns.charIn" boxDirect . mkForeign $ \ccs -> do + cs <- for ccs $ \case + Closure.DataU1 _ _ i -> pure (toEnum i) + _ -> die "Text.patterns.charIn: non-character closure" + evaluate . TPat.cpattern $ TPat.CharIn cs + declareForeign Untracked "Text.patterns.notCharIn" boxDirect . mkForeign $ \ccs -> do + cs <- for ccs $ \case + Closure.DataU1 _ _ i -> pure (toEnum i) + _ -> die "Text.patterns.notCharIn: non-character closure" + evaluate . TPat.cpattern $ TPat.NotCharIn cs + declareForeign Untracked "Pattern.many" boxDirect . mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Many p + declareForeign Untracked "Pattern.capture" boxDirect . mkForeign $ + \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p + declareForeign Untracked "Pattern.join" boxDirect . mkForeign $ \ps -> + evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps + declareForeign Untracked "Pattern.or" boxDirect . mkForeign $ + \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r + declareForeign Untracked "Pattern.replicate" natNatBoxToBox . mkForeign $ + \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> + let m = fromIntegral m0; n = fromIntegral n0 + in evaluate . TPat.cpattern $ TPat.Replicate m n p + + declareForeign Untracked "Pattern.run" boxBoxToMaybeTup . mkForeign $ + \(TPat.CP _ matcher, input :: Text) -> pure $ matcher input + + declareForeign Untracked "Pattern.isMatch" boxBoxToBool . mkForeign $ + \(TPat.CP _ matcher, input :: Text) -> pure . isJust $ matcher input + type RW = PA.PrimState IO checkedRead :: diff --git a/parser-typechecker/src/Unison/Runtime/Foreign.hs b/parser-typechecker/src/Unison/Runtime/Foreign.hs index ba60cdfa74..9d42f33b7e 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign.hs @@ -35,6 +35,7 @@ import Unison.Symbol (Symbol) import qualified Unison.Type as Ty import Unison.Util.Bytes (Bytes) import Unison.Util.Text (Text) +import Unison.Util.Text.Pattern (CPattern) import Unsafe.Coerce data Foreign where @@ -159,6 +160,9 @@ data Failure a = Failure Reference Text a instance BuiltinForeign HashAlgorithm where foreignRef = Tagged Ty.hashAlgorithmRef +instance BuiltinForeign CPattern where + foreignRef = Tagged Ty.patternRef + wrapBuiltin :: forall f. BuiltinForeign f => f -> Foreign wrapBuiltin x = Wrap r x where diff --git a/parser-typechecker/src/Unison/Util/Text.hs b/parser-typechecker/src/Unison/Util/Text.hs index 6f1f4dd5fb..0b07421f0f 100644 --- a/parser-typechecker/src/Unison/Util/Text.hs +++ b/parser-typechecker/src/Unison/Util/Text.hs @@ -9,6 +9,8 @@ import Data.List (foldl', unfoldr) import Data.String (IsString (..)) import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Text.Internal as T +import qualified Data.Text.Unsafe as T (Iter (..), iter) import qualified Unison.Util.Bytes as B import qualified Unison.Util.Rope as R import Prelude hiding (drop, replicate, take) @@ -101,6 +103,35 @@ toText :: Text -> T.Text toText (Text t) = T.concat (chunkToText <$> unfoldr R.uncons t) {-# INLINE toText #-} +-- Drop with both a maximum size and a predicate. Yields actual number of +-- dropped characters. +-- +-- Unavailable from text package. +dropTextWhileMax :: (Char -> Bool) -> Int -> T.Text -> (Int, T.Text) +dropTextWhileMax p n t@(T.Text arr off len) = loop 0 0 + where + loop !i !j + | j >= len = (i, T.empty) + | i < n, p c = loop (i + 1) (j + d) + | otherwise = (i, T.Text arr (off + j) (len - j)) + where + T.Iter c d = T.iter t j +{-# INLINE [1] dropTextWhileMax #-} + +dropWhileMax :: (Char -> Bool) -> Int -> Text -> (Int, Text) +dropWhileMax p = go 0 + where + go !total !d t + | d <= 0 = (total, t) + | Just (chunk, t) <- unconsChunk t = + case dropTextWhileMax p d (chunkToText chunk) of + (i, rest) + | T.null rest, i < d -> go (total + i) (d - i) t + | T.null rest -> (total + i, t) + | otherwise -> (total + i, fromText rest <> t) + | otherwise = (total, empty) +{-# INLINE dropWhileMax #-} + instance Eq Chunk where (Chunk n a) == (Chunk n2 a2) = n == n2 && a == a2 instance Ord Chunk where (Chunk _ a) `compare` (Chunk _ a2) = compare a a2 diff --git a/parser-typechecker/src/Unison/Util/Text/Pattern.hs b/parser-typechecker/src/Unison/Util/Text/Pattern.hs index e859eb7035..5c23a74fbc 100644 --- a/parser-typechecker/src/Unison/Util/Text/Pattern.hs +++ b/parser-typechecker/src/Unison/Util/Text/Pattern.hs @@ -12,6 +12,7 @@ data Pattern | Or Pattern Pattern -- left-biased choice: tries second pattern only if first fails | Capture Pattern -- capture all the text consumed by the inner pattern, discarding its subcaptures | Many Pattern -- zero or more repetitions (at least 1 can be written: Join [p, Many p]) + | Replicate Int Int Pattern -- m to n occurrences of a pattern, optional = 0-1 | AnyChar -- consume a single char | Eof -- succeed if given the empty text, fail otherwise | Literal Text -- succeed if input starts with the given text, advance by that text @@ -24,6 +25,19 @@ data Pattern | Space -- consume 1 space character (according to Char.isSpace) | Punctuation -- consume 1 punctuation char (according to Char.isPunctuation) +-- Wrapper type. Holds a pattern together with its compilation. This is used as +-- the semantic value of a unison `Pattern a`. Laziness avoids building the +-- matcher until it actually needs to be used, and also avoids recalculating the +-- match function if a `CPattern` is 'run' multiple times, while allowing the +-- builtin runner to just take two arguments, and not try to build a partial +-- application by hand. +-- +-- In the future, this can existentially quantify over the type being matched. +data CPattern = CP Pattern (Text -> Maybe ([Text], Text)) + +cpattern :: Pattern -> CPattern +cpattern p = CP p (run p) + run :: Pattern -> Text -> Maybe ([Text], Text) run p = let cp = compile p (\_ _ -> Nothing) (\acc rem -> Just (reverse acc, rem)) @@ -111,6 +125,27 @@ compile (Many p) !_ !success = case p of | DT.null rem -> go acc t | otherwise -> success acc (Text.fromText rem <> t) {-# INLINE walker #-} +compile (Replicate m n p) !err !success = case p of + AnyChar -> \acc t -> + if Text.size t < m + then err acc t + else success acc (Text.drop n t) + CharIn cs -> dropper (charInPred cs) + NotCharIn cs -> dropper (charNotInPred cs) + Digit -> dropper isDigit + Letter -> dropper isLetter + Punctuation -> dropper isPunctuation + Space -> dropper isSpace + _ -> go1 m + where + go1 0 = go2 (n - m) + go1 n = compile p err (go1 (n - 1)) + go2 0 = success + go2 n = compile p success (go2 (n - 1)) + + dropper ok acc t + | (i, rest) <- Text.dropWhileMax ok n t, i >= m = success acc rest + | otherwise = err acc t compile Digit !err !success = go where go acc t = case Text.uncons t of From fcead4f60817c62749ce0b970abba6196a4d6760 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 30 Jun 2022 14:48:59 -0400 Subject: [PATCH 429/529] document a couple magic numbers --- unison-cli/src/Unison/Share/Sync.hs | 17 ++++++++++++++--- 1 file changed, 14 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index c993fa8ed0..1d1a322f8c 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -64,6 +64,17 @@ import qualified Unison.Sync.Types as Share import Unison.Util.Monoid (foldMapM) import qualified UnliftIO +------------------------------------------------------------------------------------------------------------------------ +-- Pile of constants + +-- | The maximum number of downloader threads, during a pull. +maxSimultaneousPullDownloaders :: Int +maxSimultaneousPullDownloaders = 5 + +-- | The maximum number of push workers at a time. Each push worker reads from the database and uploads entities. +maxSimultaneousPushWorkers :: Int +maxSimultaneousPushWorkers = 5 + ------------------------------------------------------------------------------------------------------------------------ -- Push @@ -460,9 +471,9 @@ completeTempEntities httpClient unisonShareUrl connect repoName callbacks initia DispatcherDone -> pure () DispatcherForkWorker hashes -> do atomically do - -- Only allow 5 concurrent downloaders (7 workers = inserter + elaborator + 5 downloaders) + -- Limit number of simultaneous downloaders (plus 2, for inserter and elaborator) workers <- readTVar workerCount - check (workers < 7) + check (workers < maxSimultaneousPullDownloaders + 2) -- we do need to record the downloader as working outside of the worker thread, not inside. -- otherwise, we might erroneously fall through the the teardown logic below and conclude there's -- nothing more for the dispatcher to do, when in fact a downloader thread just hasn't made it as @@ -687,7 +698,7 @@ uploadEntities httpClient unisonShareUrl connect repoName hashes0 callbacks = do forkWorkerMode :: NESet Hash32 -> STM UploadDispatcherJob forkWorkerMode hashes = do workers <- readTVar workersVar - when (Set.size workers >= 5) retry + when (Set.size workers >= maxSimultaneousPushWorkers) retry pure (UploadDispatcherForkWorker hashes) checkIfDoneMode :: STM UploadDispatcherJob From 005dae495676d8cf694ee5601e41b26ed2c81185 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 30 Jun 2022 14:49:43 -0400 Subject: [PATCH 430/529] fix typo --- unison-cli/src/Unison/Share/Sync.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 1d1a322f8c..547729fde6 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -158,8 +158,8 @@ fastForwardPush httpClient unisonShareUrl connect path localHeadHash callbacks = Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path)) Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path)) Right (Just (Share.hashJWTHash -> remoteHeadHash)) -> do - let doLoadCausalSpineBewteen = loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash) - (connect \conn -> Sqlite.runTransaction conn doLoadCausalSpineBewteen) >>= \case + let doLoadCausalSpineBetween = loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash) + (connect \conn -> Sqlite.runTransaction conn doLoadCausalSpineBetween) >>= \case -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a -- fast-forward push, so we don't bother trying - just report the error now. Nothing -> pure (Left (FastForwardPushErrorNotFastForward path)) From 98d8d0ec42e89dfe14b0833b4a0372387705bb13 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 30 Jun 2022 14:54:28 -0400 Subject: [PATCH 431/529] add a doc to `dedupeVar` --- unison-cli/src/Unison/Share/Sync.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 547729fde6..184560f406 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -637,7 +637,10 @@ uploadEntities :: IO Bool uploadEntities httpClient unisonShareUrl connect repoName hashes0 callbacks = do hashesVar <- newTVarIO (NESet.toSet hashes0) - -- FIXME document this + -- Semantically, this is the set of hashes we've uploaded so far, but we do delete from it when it's safe to, so it + -- doesn't grow unbounded. It's used to filter out hashes that would be duplicate uploads: the server, when responding + -- to any particular upload request, may declare that it still needs some hashes that we're in the process of + -- uploading from another thread. dedupeVar <- newTVarIO Set.empty nextWorkerIdVar <- newTVarIO 0 workersVar <- newTVarIO Set.empty From 6c5a69dc7b7b1595ba1cc278dc3f01f8cb7573f5 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 30 Jun 2022 13:05:58 -0600 Subject: [PATCH 432/529] Fix bad reads --- .../U/Codebase/Sqlite/NamedRef.hs | 9 +++++--- .../U/Codebase/Sqlite/Queries.hs | 22 ++++++++++--------- 2 files changed, 18 insertions(+), 13 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs index 47c94534a4..ea69c9c642 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs @@ -30,14 +30,17 @@ data NamedRef ref = NamedRef {reversedSegments :: ReversedSegments, ref :: ref} instance ToRow ref => ToRow (NamedRef ref) where toRow (NamedRef {reversedSegments = segments, ref}) = - [toField reversedName, toField namespace] <> toRow ref + [toField reversedName] <> toRow ref where reversedName = Text.intercalate "." . toList $ segments - namespace = Text.intercalate "." . reverse . NEL.tail $ segments instance FromRow ref => FromRow (NamedRef ref) where fromRow = do reversedSegments <- NonEmpty.fromList . Text.splitOn "." <$> field - _namespace <- void $ field @Text ref <- fromRow pure (NamedRef {reversedSegments, ref}) + +toRowWithNamespace :: ToRow ref => NamedRef ref -> [SQLData] +toRowWithNamespace nr = toRow nr <> [SQLText namespace] + where + namespace = Text.intercalate "." . reverse . NEL.tail . reversedSegments $ nr diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index c0d799fd68..42d7b5e045 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -225,7 +225,8 @@ import U.Codebase.Sqlite.LocalIds LocalTextId (..), ) import qualified U.Codebase.Sqlite.LocalIds as LocalIds -import qualified U.Codebase.Sqlite.NamedRef as S +import U.Codebase.Sqlite.NamedRef (NamedRef) +import qualified U.Codebase.Sqlite.NamedRef as NamedRef import U.Codebase.Sqlite.ObjectType (ObjectType (DeclComponent, Namespace, Patch, TermComponent)) import qualified U.Codebase.Sqlite.ObjectType as ObjectType import U.Codebase.Sqlite.Orphans () @@ -1437,14 +1438,15 @@ resetNameLookupTables = do -- |] -- | Insert the given set of term names into the name lookup table -insertTermNames :: [S.NamedRef (Referent.TextReferent, Maybe S.ConstructorType)] -> Transaction () +insertTermNames :: [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)] -> Transaction () insertTermNames names = do - executeMany sql (fmap asRow <$> names) + executeMany sql (NamedRef.toRowWithNamespace . fmap refToRow <$> names) where - asRow (a, b) = a :. Only b + refToRow :: (Referent.TextReferent, Maybe NamedRef.ConstructorType) -> (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType)) + refToRow (ref, ct) = ref :. Only ct sql = [here| - INSERT INTO term_name_lookup (reversed_name, namespace, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type) + INSERT INTO term_name_lookup (reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type, namespace) VALUES (?, ?, ?, ?, ?, ?, ?) ON CONFLICT DO NOTHING |] @@ -1481,19 +1483,19 @@ getNamespaceDefinitionCount namespace = do |] -- | Insert the given set of type names into the name lookup table -insertTypeNames :: [S.NamedRef (Reference.TextReference)] -> Transaction () +insertTypeNames :: [NamedRef (Reference.TextReference)] -> Transaction () insertTypeNames names = - executeMany sql names + executeMany sql (NamedRef.toRowWithNamespace <$> names) where sql = [here| - INSERT INTO type_name_lookup (reversed_name, namespace, reference_builtin, reference_component_hash, reference_component_index) + INSERT INTO type_name_lookup (reversed_name, reference_builtin, reference_component_hash, reference_component_index, namespace) VALUES (?, ?, ?, ?, ?) ON CONFLICT DO NOTHING |] -- | Get the list of a term names in the root namespace according to the name lookup index -rootTermNames :: Transaction [S.NamedRef (Referent.TextReferent, Maybe S.ConstructorType)] +rootTermNames :: Transaction [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)] rootTermNames = do (fmap . fmap) unRow <$> queryListRow_ sql where @@ -1505,7 +1507,7 @@ rootTermNames = do |] -- | Get the list of a type names in the root namespace according to the name lookup index -rootTypeNames :: Transaction [S.NamedRef Reference.TextReference] +rootTypeNames :: Transaction [NamedRef Reference.TextReference] rootTypeNames = do queryListRow_ sql where From f2be954bd77d42d4f6cc0939a522ca824add621c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 30 Jun 2022 14:10:15 -0600 Subject: [PATCH 433/529] 12737925's time's the charm. --- .github/workflows/ci.yaml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index 4b7d6cb2be..67b7079c57 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -60,7 +60,7 @@ jobs: name: cache ~/.stack (Windows) if: runner.os == 'Windows' with: - path: "${{LOCALAPPDATA}}\\Programs\\stack" + path: "C:\\Users\\runneradmin\\AppData\\Local\\Programs\\stack" # Main cache key: commit hash. This should always result in a cache miss... # So when loading a cache we'll always fall back to the restore-keys, # which should load the most recent cache via a prefix search on the most From 6f5345ceba4405af0d927cb5e015057de0822978 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Thu, 30 Jun 2022 16:14:40 -0400 Subject: [PATCH 434/529] Equality/ordering for Patterns --- parser-typechecker/src/Unison/Runtime/Foreign.hs | 2 ++ parser-typechecker/src/Unison/Util/Text/Pattern.hs | 7 +++++++ 2 files changed, 9 insertions(+) diff --git a/parser-typechecker/src/Unison/Runtime/Foreign.hs b/parser-typechecker/src/Unison/Runtime/Foreign.hs index 9d42f33b7e..6d10eba6cd 100644 --- a/parser-typechecker/src/Unison/Runtime/Foreign.hs +++ b/parser-typechecker/src/Unison/Runtime/Foreign.hs @@ -75,6 +75,7 @@ ref2eq r | r == Ty.marrayRef = Just $ promote ((==) @(MutableArray () ())) | r == Ty.mbytearrayRef = Just $ promote ((==) @(MutableByteArray ())) | r == Ty.ibytearrayRef = Just $ promote ((==) @ByteArray) + | r == Ty.patternRef = Just $ promote ((==) @CPattern) | otherwise = Nothing ref2cmp :: Reference -> Maybe (a -> b -> Ordering) @@ -85,6 +86,7 @@ ref2cmp r | r == Ty.bytesRef = Just $ promote (compare @Bytes) | r == Ty.threadIdRef = Just $ promote (compare @ThreadId) | r == Ty.ibytearrayRef = Just $ promote (compare @ByteArray) + | r == Ty.patternRef = Just $ promote (compare @CPattern) | otherwise = Nothing instance Eq Foreign where diff --git a/parser-typechecker/src/Unison/Util/Text/Pattern.hs b/parser-typechecker/src/Unison/Util/Text/Pattern.hs index 5c23a74fbc..3c1d6972b7 100644 --- a/parser-typechecker/src/Unison/Util/Text/Pattern.hs +++ b/parser-typechecker/src/Unison/Util/Text/Pattern.hs @@ -24,6 +24,7 @@ data Pattern | Letter -- consume 1 letter (according to Char.isLetter) | Space -- consume 1 space character (according to Char.isSpace) | Punctuation -- consume 1 punctuation char (according to Char.isPunctuation) + deriving (Eq, Ord) -- Wrapper type. Holds a pattern together with its compilation. This is used as -- the semantic value of a unison `Pattern a`. Laziness avoids building the @@ -35,6 +36,12 @@ data Pattern -- In the future, this can existentially quantify over the type being matched. data CPattern = CP Pattern (Text -> Maybe ([Text], Text)) +instance Eq CPattern where + CP p _ == CP q _ = p == q + +instance Ord CPattern where + CP p _ `compare` CP q _ = compare p q + cpattern :: Pattern -> CPattern cpattern p = CP p (run p) From ac97f2a1f5a0a97c98fa863b6ca7c77bfa710bf5 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Thu, 30 Jun 2022 23:35:26 -0400 Subject: [PATCH 435/529] prefer local names to names outside the current namespace when pretty-printing --- .../src/Unison/Codebase/Editor/HandleInput.hs | 6 +++--- unison-share-api/src/Unison/Server/Backend.hs | 14 +++++++++----- 2 files changed, 12 insertions(+), 8 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index e236f7d8d0..c5f10399c0 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -187,7 +187,8 @@ currentPrettyPrintEnvDecl :: (Path -> Backend.NameScoping) -> Action' m v PPE.Pr currentPrettyPrintEnvDecl scoping = do root' <- use LoopState.root currentPath' <- Path.unabsolute <$> use LoopState.currentPath - prettyPrintEnvDecl (Backend.getCurrentPrettyNames (scoping currentPath') root') + hqLen <- eval CodebaseHashLength + pure $ Backend.getCurrentPrettyNames hqLen (scoping currentPath') root' loop :: forall m. MonadUnliftIO m => Action m (Either Event Input) Symbol () loop = do @@ -1962,8 +1963,7 @@ handleShowDefinition outputLoc inputQuery = do eval (GetDefinitionsBySuffixes (Just currentPath') root' includeCycles query) outputPath <- getOutputPath when (not (null types && null terms)) do - let printNames = Backend.getCurrentPrettyNames (Backend.AllNames currentPath') root' - let ppe = PPE.fromNamesDecl hqLength printNames + let ppe = Backend.getCurrentPrettyNames hqLength (Backend.Within currentPath') root' respond (DisplayDefinitions outputPath ppe types terms) when (not (null misses)) (respond (SearchTermsNotFound misses)) -- We set latestFile to be programmatically generated, if we diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index d2de690443..567f78bd2c 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -617,9 +617,13 @@ toAllNames :: NameScoping -> NameScoping toAllNames (AllNames p) = AllNames p toAllNames (Within p) = AllNames p -getCurrentPrettyNames :: NameScoping -> Branch m -> NamesWithHistory -getCurrentPrettyNames scope root = - NamesWithHistory (prettyNamesForBranch root scope) mempty +getCurrentPrettyNames :: Int -> NameScoping -> Branch m -> PPE.PrettyPrintEnvDecl +getCurrentPrettyNames hashLen scope root = + let primary = PPE.fromNamesDecl hashLen $ NamesWithHistory (parseNamesForBranch root scope) mempty + backup = PPE.fromNamesDecl hashLen $ NamesWithHistory (parseNamesForBranch root (AllNames mempty)) mempty + in PPE.PrettyPrintEnvDecl + (PPE.unsuffixifiedPPE primary <> PPE.unsuffixifiedPPE backup) + (PPE.suffixifiedPPE primary <> PPE.suffixifiedPPE backup) getCurrentParseNames :: NameScoping -> Branch m -> NamesWithHistory getCurrentParseNames scope root = @@ -1077,8 +1081,8 @@ scopedNamesForBranchHash codebase mbh path = do Nothing | shouldUseNamesIndex -> indexPrettyAndParseNames | otherwise -> do - rootBranch <- lift $ Codebase.getRootBranch codebase - pure $ prettyAndParseNamesForBranch rootBranch (AllNames path) + rootBranch <- lift $ Codebase.getRootBranch codebase + pure $ prettyAndParseNamesForBranch rootBranch (AllNames path) Just bh -> do rootHash <- lift $ Codebase.getRootBranchHash codebase if (Causal.unCausalHash bh == V2.Hash.unCausalHash rootHash) && shouldUseNamesIndex From b963789d042bb4d05237ab6ace587b6e3f052901 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Fri, 1 Jul 2022 00:08:09 -0400 Subject: [PATCH 436/529] transcript refresh --- .../namespace-dependencies.output.md | 10 +++++----- unison-src/transcripts/api-namespace-list.output.md | 2 +- unison-src/transcripts/create-author.output.md | 2 +- unison-src/transcripts/fix2254.output.md | 12 ++++++------ unison-src/transcripts/fix2567.output.md | 6 +++--- unison-src/transcripts/globbing.output.md | 8 ++++---- 6 files changed, 20 insertions(+), 20 deletions(-) diff --git a/unison-src/transcripts-using-base/namespace-dependencies.output.md b/unison-src/transcripts-using-base/namespace-dependencies.output.md index 3ed60630f7..89a6ca2fc0 100644 --- a/unison-src/transcripts-using-base/namespace-dependencies.output.md +++ b/unison-src/transcripts-using-base/namespace-dependencies.output.md @@ -33,16 +33,16 @@ hasMetadata = 3 .dependencies> namespace.dependencies External dependency Dependents in .dependencies - ##Int dependsOnInt + builtin.Int dependsOnInt - ##Nat dependsOnIntAndNat + builtin.Nat dependsOnIntAndNat dependsOnNat hasMetadata - ##Text hasMetadata + builtin.Text hasMetadata - ##Nat.drop dependsOnIntAndNat + builtin.Nat.drop dependsOnIntAndNat - #23g06bfjvi hasMetadata + metadata.myMetadata hasMetadata ``` diff --git a/unison-src/transcripts/api-namespace-list.output.md b/unison-src/transcripts/api-namespace-list.output.md index 97d6194d64..b62c949fa5 100644 --- a/unison-src/transcripts/api-namespace-list.output.md +++ b/unison-src/transcripts/api-namespace-list.output.md @@ -129,4 +129,4 @@ GET /api/list?namespace=names&relativeTo=nested "namespaceListingFQN": "nested.names", "namespaceListingHash": "#oms19b4f9s3c8tb5skeb8jii95ij35n3hdg038pu6rv5b0fikqe4gd7lnu6a1i6aq5tdh2opdo4s0sfrupvk6vfkr9lf0n752gbl8o0" } -``` +``` \ No newline at end of file diff --git a/unison-src/transcripts/create-author.output.md b/unison-src/transcripts/create-author.output.md index 41569526b7..d1bb3be4b8 100644 --- a/unison-src/transcripts/create-author.output.md +++ b/unison-src/transcripts/create-author.output.md @@ -29,7 +29,7 @@ def2 = 2 metadata.copyrightHolders.alicecoder : CopyrightHolder metadata.copyrightHolders.alicecoder = - CopyrightHolder alicecoder.guid "Alice McGee" + CopyrightHolder guid "Alice McGee" .foo> link metadata.authors.alicecoder def1 def2 diff --git a/unison-src/transcripts/fix2254.output.md b/unison-src/transcripts/fix2254.output.md index 996a309280..a80786ea69 100644 --- a/unison-src/transcripts/fix2254.output.md +++ b/unison-src/transcripts/fix2254.output.md @@ -87,8 +87,8 @@ Let's do the update now, and verify that the definitions all look good and there f : A Nat Nat Nat Nat -> Nat f = cases - A.A n -> n - _ -> 42 + A n -> n + _ -> 42 f2 : A Nat Nat Nat Nat -> Nat f2 a = @@ -98,15 +98,15 @@ Let's do the update now, and verify that the definitions all look good and there f3 : NeedsA Nat Nat -> Nat f3 = cases - NeedsA.NeedsA a -> + NeedsA a -> use Nat + f a + 20 - _ -> 0 + _ -> 0 g : A Nat Nat Nat Nat -> Nat g = cases - A.D n -> n - _ -> 43 + D n -> n + _ -> 43 .a2> todo diff --git a/unison-src/transcripts/fix2567.output.md b/unison-src/transcripts/fix2567.output.md index 727ec42695..4144325552 100644 --- a/unison-src/transcripts/fix2567.output.md +++ b/unison-src/transcripts/fix2567.output.md @@ -29,8 +29,8 @@ structural ability Foo where .somewhere> view Foo - structural ability .some.subnamespace.Foo where - blah : Nat ->{.some.subnamespace.Foo} Nat - woot : Nat -> (Nat, Nat) ->{.some.subnamespace.Foo} Nat + structural ability some.subnamespace.Foo where + blah : Nat ->{some.subnamespace.Foo} Nat + woot : Nat -> (Nat, Nat) ->{some.subnamespace.Foo} Nat ``` diff --git a/unison-src/transcripts/globbing.output.md b/unison-src/transcripts/globbing.output.md index 2021a94ab4..342d52460d 100644 --- a/unison-src/transcripts/globbing.output.md +++ b/unison-src/transcripts/globbing.output.md @@ -107,11 +107,11 @@ Globbing should work from within a namespace with both absolute and relative pat ```ucm .nested> view .othernest.to? - .othernest.toList : ##Nat - .othernest.toList = 6 + othernest.toList : ##Nat + othernest.toList = 6 - .othernest.toMap : ##Nat - .othernest.toMap = 7 + othernest.toMap : ##Nat + othernest.toMap = 7 .nested> view to? From 6353df3749d4d4a9dedf7d1a3cb5197ec960a70a Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 1 Jul 2022 10:01:00 -0400 Subject: [PATCH 437/529] Add test that uses Replicate pattern --- parser-typechecker/tests/Unison/Test/Util/Text.hs | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/parser-typechecker/tests/Unison/Test/Util/Text.hs b/parser-typechecker/tests/Unison/Test/Util/Text.hs index 084c2ff772..9285a57ee3 100644 --- a/parser-typechecker/tests/Unison/Test/Util/Text.hs +++ b/parser-typechecker/tests/Unison/Test/Util/Text.hs @@ -119,6 +119,11 @@ test = ( P.run (P.Many (P.Join [P.Capture (P.Many (P.Digit)), P.Many P.Space])) "01 10 20 1123 292 110 10" == Just (["01", "10", "20", "1123", "292", "110", "10"], "") ) + expect' $ + let part = P.Capture (P.Replicate 1 3 (P.Digit)) + dpart = P.Join [P.Literal ".", part] + ip = P.Join [part, P.Replicate 3 3 dpart, P.Eof] + in P.run ip "127.0.0.1" == Just (["127", "0", "0", "1"], "") ok ] where From 6ee5305e6db4c1c2356dfe818fc26a83c0cc09ac Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 1 Jul 2022 10:01:33 -0400 Subject: [PATCH 438/529] Transcript changes --- unison-src/transcripts/alias-many.output.md | 138 ++-- .../transcripts/builtins-merge.output.md | 51 +- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- .../transcripts/name-selection.output.md | 669 ++++++++++-------- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 7 files changed, 500 insertions(+), 404 deletions(-) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index c15487ae45..b557b843e2 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -547,68 +547,94 @@ Let's try it! 378. structural type Optional a 379. Optional.None : Optional a 380. Optional.Some : a -> Optional a - 381. builtin type Ref - 382. Ref.read : Ref g a ->{g} a - 383. Ref.write : Ref g a -> a ->{g} () - 384. builtin type Request - 385. builtin type Scope - 386. Scope.array : Nat ->{Scope s} MutableArray (Scope s) a - 387. Scope.arrayOf : a + 381. Pattern.capture : ##Pattern a -> ##Pattern a + 382. Pattern.isMatch : ##Pattern a -> a -> Boolean + 383. Pattern.join : [##Pattern a] -> ##Pattern a + 384. Pattern.many : ##Pattern a -> ##Pattern a + 385. Pattern.or : ##Pattern a -> ##Pattern a -> ##Pattern a + 386. Pattern.replicate : Nat + -> Nat + -> ##Pattern a + -> ##Pattern a + 387. Pattern.run : ##Pattern a -> a -> Optional ([a], a) + 388. builtin type Ref + 389. Ref.read : Ref g a ->{g} a + 390. Ref.write : Ref g a -> a ->{g} () + 391. builtin type Request + 392. builtin type Scope + 393. Scope.array : Nat ->{Scope s} MutableArray (Scope s) a + 394. Scope.arrayOf : a -> Nat ->{Scope s} MutableArray (Scope s) a - 388. Scope.bytearray : Nat + 395. Scope.bytearray : Nat ->{Scope s} MutableByteArray (Scope s) - 389. Scope.bytearrayOf : Nat + 396. Scope.bytearrayOf : Nat -> Nat ->{Scope s} MutableByteArray (Scope s) - 390. Scope.ref : a ->{Scope s} Ref {Scope s} a - 391. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 392. structural type SeqView a b - 393. SeqView.VElem : a -> b -> SeqView a b - 394. SeqView.VEmpty : SeqView a b - 395. Socket.toText : Socket -> Text - 396. unique type Test.Result - 397. Test.Result.Fail : Text -> Result - 398. Test.Result.Ok : Text -> Result - 399. builtin type Text - 400. Text.!= : Text -> Text -> Boolean - 401. Text.++ : Text -> Text -> Text - 402. Text.drop : Nat -> Text -> Text - 403. Text.empty : Text - 404. Text.eq : Text -> Text -> Boolean - 405. Text.fromCharList : [Char] -> Text - 406. Text.fromUtf8.impl : Bytes -> Either Failure Text - 407. Text.gt : Text -> Text -> Boolean - 408. Text.gteq : Text -> Text -> Boolean - 409. Text.lt : Text -> Text -> Boolean - 410. Text.lteq : Text -> Text -> Boolean - 411. Text.repeat : Nat -> Text -> Text - 412. Text.size : Text -> Nat - 413. Text.take : Nat -> Text -> Text - 414. Text.toCharList : Text -> [Char] - 415. Text.toUtf8 : Text -> Bytes - 416. Text.uncons : Text -> Optional (Char, Text) - 417. Text.unsnoc : Text -> Optional (Text, Char) - 418. ThreadId.toText : ThreadId -> Text - 419. todo : a -> b - 420. structural type Tuple a b - 421. Tuple.Cons : a -> b -> Tuple a b - 422. structural type Unit - 423. Unit.Unit : () - 424. Universal.< : a -> a -> Boolean - 425. Universal.<= : a -> a -> Boolean - 426. Universal.== : a -> a -> Boolean - 427. Universal.> : a -> a -> Boolean - 428. Universal.>= : a -> a -> Boolean - 429. Universal.compare : a -> a -> Int - 430. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 431. builtin type Value - 432. Value.dependencies : Value -> [Term] - 433. Value.deserialize : Bytes -> Either Text Value - 434. Value.load : Value ->{IO} Either [Term] a - 435. Value.serialize : Value -> Bytes - 436. Value.value : a -> Value + 397. Scope.ref : a ->{Scope s} Ref {Scope s} a + 398. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r + 399. structural type SeqView a b + 400. SeqView.VElem : a -> b -> SeqView a b + 401. SeqView.VEmpty : SeqView a b + 402. Socket.toText : Socket -> Text + 403. unique type Test.Result + 404. Test.Result.Fail : Text -> Result + 405. Test.Result.Ok : Text -> Result + 406. builtin type Text + 407. Text.!= : Text -> Text -> Boolean + 408. Text.++ : Text -> Text -> Text + 409. Text.drop : Nat -> Text -> Text + 410. Text.empty : Text + 411. Text.eq : Text -> Text -> Boolean + 412. Text.fromCharList : [Char] -> Text + 413. Text.fromUtf8.impl : Bytes -> Either Failure Text + 414. Text.gt : Text -> Text -> Boolean + 415. Text.gteq : Text -> Text -> Boolean + 416. Text.lt : Text -> Text -> Boolean + 417. Text.lteq : Text -> Text -> Boolean + 418. Text.patterns.anyChar : ##Pattern Text + 419. Text.patterns.charIn : [Char] -> ##Pattern Text + 420. Text.patterns.charRange : Char -> Char -> ##Pattern Text + 421. Text.patterns.digit : ##Pattern Text + 422. Text.patterns.eof : ##Pattern Text + 423. Text.patterns.letter : ##Pattern Text + 424. Text.patterns.literal : Text -> ##Pattern Text + 425. Text.patterns.notCharIn : [Char] -> ##Pattern Text + 426. Text.patterns.notCharRange : Char + -> Char + -> ##Pattern Text + 427. Text.patterns.punctuation : ##Pattern Text + 428. Text.patterns.space : ##Pattern Text + 429. Text.repeat : Nat -> Text -> Text + 430. Text.reverse : Text -> Text + 431. Text.size : Text -> Nat + 432. Text.take : Nat -> Text -> Text + 433. Text.toCharList : Text -> [Char] + 434. Text.toLowercase : Text -> Text + 435. Text.toUppercase : Text -> Text + 436. Text.toUtf8 : Text -> Bytes + 437. Text.uncons : Text -> Optional (Char, Text) + 438. Text.unsnoc : Text -> Optional (Text, Char) + 439. ThreadId.toText : ThreadId -> Text + 440. todo : a -> b + 441. structural type Tuple a b + 442. Tuple.Cons : a -> b -> Tuple a b + 443. structural type Unit + 444. Unit.Unit : () + 445. Universal.< : a -> a -> Boolean + 446. Universal.<= : a -> a -> Boolean + 447. Universal.== : a -> a -> Boolean + 448. Universal.> : a -> a -> Boolean + 449. Universal.>= : a -> a -> Boolean + 450. Universal.compare : a -> a -> Int + 451. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 452. builtin type Value + 453. Value.dependencies : Value -> [Term] + 454. Value.deserialize : Bytes -> Either Text Value + 455. Value.load : Value ->{IO} Either [Term] a + 456. Value.serialize : Value -> Bytes + 457. Value.value : a -> Value .builtin> alias.many 94-104 .mylib diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index d485a2514b..99120176a0 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -51,30 +51,31 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 40. Nat/ (28 definitions) 41. Optional (type) 42. Optional/ (2 definitions) - 43. Ref (builtin type) - 44. Ref/ (2 definitions) - 45. Request (builtin type) - 46. Scope (builtin type) - 47. Scope/ (6 definitions) - 48. SeqView (type) - 49. SeqView/ (2 definitions) - 50. Socket/ (1 definition) - 51. Test/ (3 definitions) - 52. Text (builtin type) - 53. Text/ (18 definitions) - 54. ThreadId/ (1 definition) - 55. Tuple (type) - 56. Tuple/ (1 definition) - 57. Unit (type) - 58. Unit/ (1 definition) - 59. Universal/ (6 definitions) - 60. Value (builtin type) - 61. Value/ (5 definitions) - 62. bug (a -> b) - 63. crypto/ (13 definitions) - 64. io2/ (138 definitions) - 65. metadata/ (2 definitions) - 66. todo (a -> b) - 67. unsafe/ (1 definition) + 43. Pattern/ (7 definitions) + 44. Ref (builtin type) + 45. Ref/ (2 definitions) + 46. Request (builtin type) + 47. Scope (builtin type) + 48. Scope/ (6 definitions) + 49. SeqView (type) + 50. SeqView/ (2 definitions) + 51. Socket/ (1 definition) + 52. Test/ (3 definitions) + 53. Text (builtin type) + 54. Text/ (32 definitions) + 55. ThreadId/ (1 definition) + 56. Tuple (type) + 57. Tuple/ (1 definition) + 58. Unit (type) + 59. Unit/ (1 definition) + 60. Universal/ (6 definitions) + 61. Value (builtin type) + 62. Value/ (5 definitions) + 63. bug (a -> b) + 64. crypto/ (13 definitions) + 65. io2/ (138 definitions) + 66. metadata/ (2 definitions) + 67. todo (a -> b) + 68. unsafe/ (1 definition) ``` diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index 073bc51056..257a55d8c7 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (436 definitions) + 1. builtin/ (457 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (622 definitions) + 1. builtin/ (643 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 719ae8d8e4..c2282e9e81 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -121,13 +121,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #jr65avdlej + โŠ™ 1. #r51pbp1b7j - Deletes: feature1.y - โŠ™ 2. #pgehk3ct7o + โŠ™ 2. #nd43pcs43p + Adds / updates: @@ -138,26 +138,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - โŠ™ 3. #0khri1tu5m + โŠ™ 3. #dauj1n1sem + Adds / updates: feature1.y - โŠ™ 4. #q6f59u3o3k + โŠ™ 4. #asktmhscn9 > Moves: Original name New name x master.x - โŠ™ 5. #uqmo15fi7h + โŠ™ 5. #1pf7k3nvca + Adds / updates: x - โ–ก 6. #nff3e5eop8 (start of history) + โ–ก 6. #gm6pdauqrf (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md index 42e4b481ec..ae7c67ba5e 100644 --- a/unison-src/transcripts/name-selection.output.md +++ b/unison-src/transcripts/name-selection.output.md @@ -315,89 +315,102 @@ d = c + 10 144. builtin.Nat.and : Nat -> Nat -> Nat - 145. builtin.io2.IO.array : Nat + 145. builtin.Text.patterns.anyChar : ##Pattern + Text + 146. builtin.io2.IO.array : Nat ->{IO} MutableArray {IO} a - 146. builtin.Scope.array : Nat + 147. builtin.Scope.array : Nat ->{Scope s} MutableArray (Scope s) a - 147. builtin.io2.IO.arrayOf : a + 148. builtin.io2.IO.arrayOf : a -> Nat ->{IO} MutableArray {IO} a - 148. builtin.Scope.arrayOf : a + 149. builtin.Scope.arrayOf : a -> Nat ->{Scope s} MutableArray (Scope s) a - 149. builtin.Float.asin : Float + 150. builtin.Float.asin : Float -> Float - 150. builtin.Float.asinh : Float + 151. builtin.Float.asinh : Float -> Float - 151. builtin.Bytes.at : Nat + 152. builtin.Bytes.at : Nat -> Bytes -> Optional Nat - 152. builtin.List.at : Nat + 153. builtin.List.at : Nat -> [a] -> Optional a - 153. builtin.Float.atan : Float + 154. builtin.Float.atan : Float -> Float - 154. builtin.Float.atan2 : Float + 155. builtin.Float.atan2 : Float -> Float -> Float - 155. builtin.Float.atanh : Float + 156. builtin.Float.atanh : Float -> Float - 156. builtin.io2.STM.atomically : '{STM} a + 157. builtin.io2.STM.atomically : '{STM} a ->{IO} a - 157. builtin.bug : a -> b - 158. builtin.io2.IO.bytearray : Nat + 158. builtin.bug : a -> b + 159. builtin.io2.IO.bytearray : Nat ->{IO} MutableByteArray {IO} - 159. builtin.Scope.bytearray : Nat + 160. builtin.Scope.bytearray : Nat ->{Scope s} MutableByteArray (Scope s) - 160. builtin.io2.IO.bytearrayOf : Nat + 161. builtin.io2.IO.bytearrayOf : Nat -> Nat ->{IO} MutableByteArray {IO} - 161. builtin.Scope.bytearrayOf : Nat + 162. builtin.Scope.bytearrayOf : Nat -> Nat ->{Scope s} MutableByteArray (Scope s) - 162. โ”Œ c#gjmq673r1v : Nat - 163. โ”” aaaa.tooManySegments : Nat - 164. builtin.Code.cache_ : [( Term, + 163. โ”Œ c#gjmq673r1v : Nat + 164. โ”” aaaa.tooManySegments : Nat + 165. builtin.Code.cache_ : [( Term, Code)] ->{IO} [Term] - 165. builtin.Float.ceiling : Float + 166. builtin.Pattern.capture : ##Pattern + a + -> ##Pattern + a + 167. builtin.Float.ceiling : Float -> Int - 166. builtin.unsafe.coerceAbilities : (a + 168. builtin.Text.patterns.charIn : [Char] + -> ##Pattern + Text + 169. builtin.Text.patterns.charRange : Char + -> Char + -> ##Pattern + Text + 170. builtin.unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 167. builtin.Universal.compare : a + 171. builtin.Universal.compare : a -> a -> Int - 168. builtin.Int.complement : Int + 172. builtin.Int.complement : Int -> Int - 169. builtin.Nat.complement : Nat + 173. builtin.Nat.complement : Nat -> Nat - 170. builtin.Bytes.gzip.compress : Bytes + 174. builtin.Bytes.gzip.compress : Bytes -> Bytes - 171. builtin.Bytes.zlib.compress : Bytes + 175. builtin.Bytes.zlib.compress : Bytes -> Bytes - 172. builtin.ImmutableArray.copyTo! : MutableArray + 176. builtin.ImmutableArray.copyTo! : MutableArray g a -> Nat -> ImmutableArray @@ -406,7 +419,7 @@ d = c + 10 -> Nat ->{g, Exception} () - 173. builtin.ImmutableByteArray.copyTo! : MutableByteArray + 177. builtin.ImmutableByteArray.copyTo! : MutableByteArray g -> Nat -> ImmutableByteArray @@ -414,7 +427,7 @@ d = c + 10 -> Nat ->{g, Exception} () - 174. builtin.MutableArray.copyTo! : MutableArray + 178. builtin.MutableArray.copyTo! : MutableArray g a -> Nat -> MutableArray @@ -423,7 +436,7 @@ d = c + 10 -> Nat ->{g, Exception} () - 175. builtin.MutableByteArray.copyTo! : MutableByteArray + 179. builtin.MutableByteArray.copyTo! : MutableByteArray g -> Nat -> MutableByteArray @@ -432,842 +445,898 @@ d = c + 10 -> Nat ->{g, Exception} () - 176. builtin.Float.cos : Float + 180. builtin.Float.cos : Float -> Float - 177. builtin.Float.cosh : Float + 181. builtin.Float.cosh : Float -> Float - 178. builtin.Bytes.decodeNat16be : Bytes + 182. builtin.Bytes.decodeNat16be : Bytes -> Optional ( Nat, Bytes) - 179. builtin.Bytes.decodeNat16le : Bytes + 183. builtin.Bytes.decodeNat16le : Bytes -> Optional ( Nat, Bytes) - 180. builtin.Bytes.decodeNat32be : Bytes + 184. builtin.Bytes.decodeNat32be : Bytes -> Optional ( Nat, Bytes) - 181. builtin.Bytes.decodeNat32le : Bytes + 185. builtin.Bytes.decodeNat32le : Bytes -> Optional ( Nat, Bytes) - 182. builtin.Bytes.decodeNat64be : Bytes + 186. builtin.Bytes.decodeNat64be : Bytes -> Optional ( Nat, Bytes) - 183. builtin.Bytes.decodeNat64le : Bytes + 187. builtin.Bytes.decodeNat64le : Bytes -> Optional ( Nat, Bytes) - 184. builtin.io2.Tls.decodePrivateKey : Bytes + 188. builtin.io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 185. builtin.Bytes.gzip.decompress : Bytes + 189. builtin.Bytes.gzip.decompress : Bytes -> Either Text Bytes - 186. builtin.Bytes.zlib.decompress : Bytes + 190. builtin.Bytes.zlib.decompress : Bytes -> Either Text Bytes - 187. builtin.io2.Tls.ClientConfig.default : Text + 191. builtin.io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 188. builtin.io2.Tls.ServerConfig.default : [SignedCert] + 192. builtin.io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 189. builtin.Code.dependencies : Code + 193. builtin.Code.dependencies : Code -> [Term] - 190. builtin.Value.dependencies : Value + 194. builtin.Value.dependencies : Value -> [Term] - 191. builtin.Code.deserialize : Bytes + 195. builtin.Code.deserialize : Bytes -> Either Text Code - 192. builtin.Value.deserialize : Bytes + 196. builtin.Value.deserialize : Bytes -> Either Text Value - 193. builtin.Code.display : Text + 197. builtin.Text.patterns.digit : ##Pattern + Text + 198. builtin.Code.display : Text -> Code -> Text - 194. builtin.Bytes.drop : Nat + 199. builtin.Bytes.drop : Nat -> Bytes -> Bytes - 195. builtin.List.drop : Nat + 200. builtin.List.drop : Nat -> [a] -> [a] - 196. builtin.Nat.drop : Nat + 201. builtin.Nat.drop : Nat -> Nat -> Nat - 197. builtin.Text.drop : Nat + 202. builtin.Text.drop : Nat -> Text -> Text - 198. builtin.Bytes.empty : Bytes - 199. builtin.List.empty : [a] - 200. builtin.Text.empty : Text - 201. builtin.io2.Tls.encodeCert : SignedCert + 203. builtin.Bytes.empty : Bytes + 204. builtin.List.empty : [a] + 205. builtin.Text.empty : Text + 206. builtin.io2.Tls.encodeCert : SignedCert -> Bytes - 202. builtin.Bytes.encodeNat16be : Nat + 207. builtin.Bytes.encodeNat16be : Nat -> Bytes - 203. builtin.Bytes.encodeNat16le : Nat + 208. builtin.Bytes.encodeNat16le : Nat -> Bytes - 204. builtin.Bytes.encodeNat32be : Nat + 209. builtin.Bytes.encodeNat32be : Nat -> Bytes - 205. builtin.Bytes.encodeNat32le : Nat + 210. builtin.Bytes.encodeNat32le : Nat -> Bytes - 206. builtin.Bytes.encodeNat64be : Nat + 211. builtin.Bytes.encodeNat64be : Nat -> Bytes - 207. builtin.Bytes.encodeNat64le : Nat + 212. builtin.Bytes.encodeNat64le : Nat -> Bytes - 208. builtin.io2.Tls.encodePrivateKey : PrivateKey + 213. builtin.io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 209. builtin.Float.eq : Float + 214. builtin.Text.patterns.eof : ##Pattern + Text + 215. builtin.Float.eq : Float -> Float -> Boolean - 210. builtin.Int.eq : Int + 216. builtin.Int.eq : Int -> Int -> Boolean - 211. builtin.Nat.eq : Nat + 217. builtin.Nat.eq : Nat -> Nat -> Boolean - 212. builtin.Text.eq : Text + 218. builtin.Text.eq : Text -> Text -> Boolean - 213. builtin.Float.exp : Float + 219. builtin.Float.exp : Float -> Float - 214. builtin.Bytes.flatten : Bytes + 220. builtin.Bytes.flatten : Bytes -> Bytes - 215. builtin.Float.floor : Float + 221. builtin.Float.floor : Float -> Int - 216. builtin.io2.IO.forkComp : '{IO} a + 222. builtin.io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 217. builtin.MutableArray.freeze : MutableArray + 223. builtin.MutableArray.freeze : MutableArray g a -> Nat -> Nat ->{g} ImmutableArray a - 218. builtin.MutableByteArray.freeze : MutableByteArray + 224. builtin.MutableByteArray.freeze : MutableByteArray g -> Nat -> Nat ->{g} ImmutableByteArray - 219. builtin.MutableArray.freeze! : MutableArray + 225. builtin.MutableArray.freeze! : MutableArray g a ->{g} ImmutableArray a - 220. builtin.MutableByteArray.freeze! : MutableByteArray + 226. builtin.MutableByteArray.freeze! : MutableByteArray g ->{g} ImmutableByteArray - 221. builtin.Bytes.fromBase16 : Bytes + 227. builtin.Bytes.fromBase16 : Bytes -> Either Text Bytes - 222. builtin.Bytes.fromBase32 : Bytes + 228. builtin.Bytes.fromBase32 : Bytes -> Either Text Bytes - 223. builtin.Bytes.fromBase64 : Bytes + 229. builtin.Bytes.fromBase64 : Bytes -> Either Text Bytes - 224. builtin.Bytes.fromBase64UrlUnpadded : Bytes + 230. builtin.Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes - 225. builtin.Text.fromCharList : [Char] + 231. builtin.Text.fromCharList : [Char] -> Text - 226. builtin.Bytes.fromList : [Nat] + 232. builtin.Bytes.fromList : [Nat] -> Bytes - 227. builtin.Char.fromNat : Nat + 233. builtin.Char.fromNat : Nat -> Char - 228. builtin.Float.fromRepresentation : Nat + 234. builtin.Float.fromRepresentation : Nat -> Float - 229. builtin.Int.fromRepresentation : Nat + 235. builtin.Int.fromRepresentation : Nat -> Int - 230. builtin.Float.fromText : Text + 236. builtin.Float.fromText : Text -> Optional Float - 231. builtin.Int.fromText : Text + 237. builtin.Int.fromText : Text -> Optional Int - 232. builtin.Nat.fromText : Text + 238. builtin.Nat.fromText : Text -> Optional Nat - 233. builtin.Float.gt : Float + 239. builtin.Float.gt : Float -> Float -> Boolean - 234. builtin.Int.gt : Int + 240. builtin.Int.gt : Int -> Int -> Boolean - 235. builtin.Nat.gt : Nat + 241. builtin.Nat.gt : Nat -> Nat -> Boolean - 236. builtin.Text.gt : Text + 242. builtin.Text.gt : Text -> Text -> Boolean - 237. builtin.Float.gteq : Float + 243. builtin.Float.gteq : Float -> Float -> Boolean - 238. builtin.Int.gteq : Int + 244. builtin.Int.gteq : Int -> Int -> Boolean - 239. builtin.Nat.gteq : Nat + 245. builtin.Nat.gteq : Nat -> Nat -> Boolean - 240. builtin.Text.gteq : Text + 246. builtin.Text.gteq : Text -> Text -> Boolean - 241. builtin.crypto.hash : HashAlgorithm + 247. builtin.crypto.hash : HashAlgorithm -> a -> Bytes - 242. builtin.crypto.hashBytes : HashAlgorithm + 248. builtin.crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 243. builtin.crypto.hmac : HashAlgorithm + 249. builtin.crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 244. builtin.crypto.hmacBytes : HashAlgorithm + 250. builtin.crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 245. builtin.io2.IO.clientSocket.impl : Text + 251. builtin.io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 246. builtin.io2.IO.closeFile.impl : Handle + 252. builtin.io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 247. builtin.io2.IO.closeSocket.impl : Socket + 253. builtin.io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 248. builtin.io2.IO.createDirectory.impl : Text + 254. builtin.io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 249. builtin.io2.IO.createTempDirectory.impl : Text + 255. builtin.io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 250. builtin.io2.Tls.decodeCert.impl : Bytes + 256. builtin.io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 251. builtin.io2.IO.delay.impl : Nat + 257. builtin.io2.IO.delay.impl : Nat ->{IO} Either Failure () - 252. builtin.io2.IO.directoryContents.impl : Text + 258. builtin.io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 253. builtin.io2.IO.fileExists.impl : Text + 259. builtin.io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 254. builtin.Text.fromUtf8.impl : Bytes + 260. builtin.Text.fromUtf8.impl : Bytes -> Either Failure Text - 255. builtin.io2.IO.getArgs.impl : '{IO} Either + 261. builtin.io2.IO.getArgs.impl : '{IO} Either Failure [Text] - 256. builtin.io2.IO.getBuffering.impl : Handle + 262. builtin.io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 257. builtin.io2.IO.getBytes.impl : Handle + 263. builtin.io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 258. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either + 264. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 259. builtin.io2.IO.getEnv.impl : Text + 265. builtin.io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 260. builtin.io2.IO.getFileSize.impl : Text + 266. builtin.io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 261. builtin.io2.IO.getFileTimestamp.impl : Text + 267. builtin.io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 262. builtin.io2.IO.getLine.impl : Handle + 268. builtin.io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 263. builtin.io2.IO.getSomeBytes.impl : Handle + 269. builtin.io2.IO.getSomeBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 264. builtin.io2.IO.getTempDirectory.impl : '{IO} Either + 270. builtin.io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 265. builtin.io2.IO.handlePosition.impl : Handle + 271. builtin.io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 266. builtin.io2.Tls.handshake.impl : Tls + 272. builtin.io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 267. builtin.io2.IO.isDirectory.impl : Text + 273. builtin.io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 268. builtin.io2.IO.isFileEOF.impl : Handle + 274. builtin.io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 269. builtin.io2.IO.isFileOpen.impl : Handle + 275. builtin.io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 270. builtin.io2.IO.isSeekable.impl : Handle + 276. builtin.io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 271. builtin.io2.IO.kill.impl : ThreadId + 277. builtin.io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 272. builtin.io2.IO.listen.impl : Socket + 278. builtin.io2.IO.listen.impl : Socket ->{IO} Either Failure () - 273. builtin.io2.Tls.newClient.impl : ClientConfig + 279. builtin.io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 274. builtin.io2.Tls.newServer.impl : ServerConfig + 280. builtin.io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 275. builtin.io2.IO.openFile.impl : Text + 281. builtin.io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 276. builtin.io2.MVar.put.impl : MVar a + 282. builtin.io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 277. builtin.io2.IO.putBytes.impl : Handle + 283. builtin.io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 278. builtin.io2.MVar.read.impl : MVar a + 284. builtin.io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 279. builtin.io2.Tls.receive.impl : Tls + 285. builtin.io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 280. builtin.io2.IO.removeDirectory.impl : Text + 286. builtin.io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 281. builtin.io2.IO.removeFile.impl : Text + 287. builtin.io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 282. builtin.io2.IO.renameDirectory.impl : Text + 288. builtin.io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 283. builtin.io2.IO.renameFile.impl : Text + 289. builtin.io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 284. builtin.io2.IO.seekHandle.impl : Handle + 290. builtin.io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 285. builtin.io2.Tls.send.impl : Tls + 291. builtin.io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 286. builtin.io2.IO.serverSocket.impl : Optional + 292. builtin.io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 287. builtin.io2.IO.setBuffering.impl : Handle + 293. builtin.io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 288. builtin.io2.IO.setCurrentDirectory.impl : Text + 294. builtin.io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 289. builtin.io2.IO.socketAccept.impl : Socket + 295. builtin.io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 290. builtin.io2.IO.socketPort.impl : Socket + 296. builtin.io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 291. builtin.io2.IO.socketReceive.impl : Socket + 297. builtin.io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 292. builtin.io2.IO.socketSend.impl : Socket + 298. builtin.io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 293. builtin.io2.MVar.swap.impl : MVar a + 299. builtin.io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 294. builtin.io2.IO.systemTime.impl : '{IO} Either + 300. builtin.io2.IO.systemTime.impl : '{IO} Either Failure Nat - 295. builtin.io2.MVar.take.impl : MVar a + 301. builtin.io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 296. builtin.io2.Tls.terminate.impl : Tls + 302. builtin.io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 297. builtin.io2.MVar.tryPut.impl : MVar a + 303. builtin.io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 298. builtin.io2.MVar.tryRead.impl : MVar a + 304. builtin.io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 299. builtin.Int.increment : Int + 305. builtin.Int.increment : Int -> Int - 300. builtin.Nat.increment : Nat + 306. builtin.Nat.increment : Nat -> Nat - 301. builtin.io2.MVar.isEmpty : MVar a + 307. builtin.io2.MVar.isEmpty : MVar a ->{IO} Boolean - 302. builtin.Int.isEven : Int + 308. builtin.Int.isEven : Int -> Boolean - 303. builtin.Nat.isEven : Nat + 309. builtin.Nat.isEven : Nat -> Boolean - 304. builtin.Code.isMissing : Term + 310. builtin.Pattern.isMatch : ##Pattern + a + -> a + -> Boolean + 311. builtin.Code.isMissing : Term ->{IO} Boolean - 305. builtin.Int.isOdd : Int + 312. builtin.Int.isOdd : Int -> Boolean - 306. builtin.Nat.isOdd : Nat + 313. builtin.Nat.isOdd : Nat -> Boolean - 307. builtin.metadata.isPropagated : IsPropagated - 308. builtin.metadata.isTest : IsTest - 309. builtin.Int.leadingZeros : Int + 314. builtin.metadata.isPropagated : IsPropagated + 315. builtin.metadata.isTest : IsTest + 316. builtin.Pattern.join : [##Pattern + a] + -> ##Pattern + a + 317. builtin.Int.leadingZeros : Int -> Nat - 310. builtin.Nat.leadingZeros : Nat + 318. builtin.Nat.leadingZeros : Nat -> Nat - 311. builtin.Value.load : Value + 319. builtin.Text.patterns.letter : ##Pattern + Text + 320. builtin.Text.patterns.literal : Text + -> ##Pattern + Text + 321. builtin.Value.load : Value ->{IO} Either [Term] a - 312. builtin.Float.log : Float + 322. builtin.Float.log : Float -> Float - 313. builtin.Float.logBase : Float + 323. builtin.Float.logBase : Float -> Float -> Float - 314. builtin.Code.lookup : Term + 324. builtin.Code.lookup : Term ->{IO} Optional Code - 315. builtin.Float.lt : Float + 325. builtin.Float.lt : Float -> Float -> Boolean - 316. builtin.Int.lt : Int + 326. builtin.Int.lt : Int -> Int -> Boolean - 317. builtin.Nat.lt : Nat + 327. builtin.Nat.lt : Nat -> Nat -> Boolean - 318. builtin.Text.lt : Text + 328. builtin.Text.lt : Text -> Text -> Boolean - 319. builtin.Float.lteq : Float + 329. builtin.Float.lteq : Float -> Float -> Boolean - 320. builtin.Int.lteq : Int + 330. builtin.Int.lteq : Int -> Int -> Boolean - 321. builtin.Nat.lteq : Nat + 331. builtin.Nat.lteq : Nat -> Nat -> Boolean - 322. builtin.Text.lteq : Text + 332. builtin.Text.lteq : Text -> Text -> Boolean - 323. builtin.Float.max : Float + 333. builtin.Pattern.many : ##Pattern + a + -> ##Pattern + a + 334. builtin.Float.max : Float -> Float -> Float - 324. builtin.Float.min : Float + 335. builtin.Float.min : Float -> Float -> Float - 325. builtin.Int.mod : Int + 336. builtin.Int.mod : Int -> Int -> Int - 326. builtin.Nat.mod : Nat + 337. builtin.Nat.mod : Nat -> Nat -> Nat - 327. builtin.io2.Clock.internals.monotonic : '{IO} Either + 338. builtin.io2.Clock.internals.monotonic : '{IO} Either Failure TimeSpec - 328. builtin.Int.negate : Int + 339. builtin.Int.negate : Int -> Int - 329. builtin.io2.MVar.new : a + 340. builtin.io2.MVar.new : a ->{IO} MVar a - 330. builtin.io2.TVar.new : a + 341. builtin.io2.TVar.new : a ->{STM} TVar a - 331. builtin.io2.MVar.newEmpty : '{IO} MVar + 342. builtin.io2.MVar.newEmpty : '{IO} MVar a - 332. builtin.io2.TVar.newIO : a + 343. builtin.io2.TVar.newIO : a ->{IO} TVar a - 333. builtin.Boolean.not : Boolean + 344. builtin.Boolean.not : Boolean -> Boolean - 334. builtin.io2.Clock.internals.nsec : TimeSpec + 345. builtin.Text.patterns.notCharIn : [Char] + -> ##Pattern + Text + 346. builtin.Text.patterns.notCharRange : Char + -> Char + -> ##Pattern + Text + 347. builtin.io2.Clock.internals.nsec : TimeSpec -> Nat - 335. builtin.Int.or : Int + 348. builtin.Int.or : Int -> Int -> Int - 336. builtin.Nat.or : Nat + 349. builtin.Nat.or : Nat -> Nat -> Nat - 337. builtin.Int.popCount : Int + 350. builtin.Pattern.or : ##Pattern + a + -> ##Pattern + a + -> ##Pattern + a + 351. builtin.Int.popCount : Int -> Nat - 338. builtin.Nat.popCount : Nat + 352. builtin.Nat.popCount : Nat -> Nat - 339. builtin.Float.pow : Float + 353. builtin.Float.pow : Float -> Float -> Float - 340. builtin.Int.pow : Int + 354. builtin.Int.pow : Int -> Nat -> Int - 341. builtin.Nat.pow : Nat + 355. builtin.Nat.pow : Nat -> Nat -> Nat - 342. builtin.io2.Clock.internals.processCPUTime : '{IO} Either + 356. builtin.io2.Clock.internals.processCPUTime : '{IO} Either Failure TimeSpec - 343. builtin.ImmutableArray.read : ImmutableArray + 357. builtin.Text.patterns.punctuation : ##Pattern + Text + 358. builtin.ImmutableArray.read : ImmutableArray a -> Nat ->{Exception} a - 344. builtin.MutableArray.read : MutableArray + 359. builtin.MutableArray.read : MutableArray g a -> Nat ->{g, Exception} a - 345. builtin.Ref.read : Ref g a + 360. builtin.Ref.read : Ref g a ->{g} a - 346. builtin.io2.TVar.read : TVar a + 361. builtin.io2.TVar.read : TVar a ->{STM} a - 347. builtin.ImmutableByteArray.read16be : ImmutableByteArray + 362. builtin.ImmutableByteArray.read16be : ImmutableByteArray -> Nat ->{Exception} Nat - 348. builtin.MutableByteArray.read16be : MutableByteArray + 363. builtin.MutableByteArray.read16be : MutableByteArray g -> Nat ->{g, Exception} Nat - 349. builtin.ImmutableByteArray.read24be : ImmutableByteArray + 364. builtin.ImmutableByteArray.read24be : ImmutableByteArray -> Nat ->{Exception} Nat - 350. builtin.MutableByteArray.read24be : MutableByteArray + 365. builtin.MutableByteArray.read24be : MutableByteArray g -> Nat ->{g, Exception} Nat - 351. builtin.ImmutableByteArray.read32be : ImmutableByteArray + 366. builtin.ImmutableByteArray.read32be : ImmutableByteArray -> Nat ->{Exception} Nat - 352. builtin.MutableByteArray.read32be : MutableByteArray + 367. builtin.MutableByteArray.read32be : MutableByteArray g -> Nat ->{g, Exception} Nat - 353. builtin.ImmutableByteArray.read40be : ImmutableByteArray + 368. builtin.ImmutableByteArray.read40be : ImmutableByteArray -> Nat ->{Exception} Nat - 354. builtin.MutableByteArray.read40be : MutableByteArray + 369. builtin.MutableByteArray.read40be : MutableByteArray g -> Nat ->{g, Exception} Nat - 355. builtin.ImmutableByteArray.read64be : ImmutableByteArray + 370. builtin.ImmutableByteArray.read64be : ImmutableByteArray -> Nat ->{Exception} Nat - 356. builtin.MutableByteArray.read64be : MutableByteArray + 371. builtin.MutableByteArray.read64be : MutableByteArray g -> Nat ->{g, Exception} Nat - 357. builtin.ImmutableByteArray.read8 : ImmutableByteArray + 372. builtin.ImmutableByteArray.read8 : ImmutableByteArray -> Nat ->{Exception} Nat - 358. builtin.MutableByteArray.read8 : MutableByteArray + 373. builtin.MutableByteArray.read8 : MutableByteArray g -> Nat ->{g, Exception} Nat - 359. builtin.io2.TVar.readIO : TVar a + 374. builtin.io2.TVar.readIO : TVar a ->{IO} a - 360. builtin.io2.Clock.internals.realtime : '{IO} Either + 375. builtin.io2.Clock.internals.realtime : '{IO} Either Failure TimeSpec - 361. builtin.io2.IO.ref : a + 376. builtin.io2.IO.ref : a ->{IO} Ref {IO} a - 362. builtin.Scope.ref : a + 377. builtin.Scope.ref : a ->{Scope s} Ref {Scope s} a - 363. builtin.Text.repeat : Nat + 378. builtin.Text.repeat : Nat -> Text -> Text - 364. builtin.io2.STM.retry : '{STM} a - 365. builtin.Float.round : Float + 379. builtin.Pattern.replicate : Nat + -> Nat + -> ##Pattern + a + -> ##Pattern + a + 380. builtin.io2.STM.retry : '{STM} a + 381. builtin.Text.reverse : Text + -> Text + 382. builtin.Float.round : Float -> Int - 366. builtin.Scope.run : (โˆ€ s. + 383. builtin.Pattern.run : ##Pattern + a + -> a + -> Optional + ( [a], + a) + 384. builtin.Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 367. builtin.io2.Clock.internals.sec : TimeSpec + 385. builtin.io2.Clock.internals.sec : TimeSpec -> Int - 368. builtin.Code.serialize : Code + 386. builtin.Code.serialize : Code -> Bytes - 369. builtin.Value.serialize : Value + 387. builtin.Value.serialize : Value -> Bytes - 370. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] + 388. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 371. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] + 389. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 372. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] + 390. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 373. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] + 391. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 374. builtin.io2.Tls.ClientConfig.versions.set : [Version] + 392. builtin.io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 375. builtin.io2.Tls.ServerConfig.versions.set : [Version] + 393. builtin.io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 376. builtin.Int.shiftLeft : Int + 394. builtin.Int.shiftLeft : Int -> Nat -> Int - 377. builtin.Nat.shiftLeft : Nat + 395. builtin.Nat.shiftLeft : Nat -> Nat -> Nat - 378. builtin.Int.shiftRight : Int + 396. builtin.Int.shiftRight : Int -> Nat -> Int - 379. builtin.Nat.shiftRight : Nat + 397. builtin.Nat.shiftRight : Nat -> Nat -> Nat - 380. builtin.Int.signum : Int + 398. builtin.Int.signum : Int -> Int - 381. builtin.Float.sin : Float + 399. builtin.Float.sin : Float -> Float - 382. builtin.Float.sinh : Float + 400. builtin.Float.sinh : Float -> Float - 383. builtin.Bytes.size : Bytes + 401. builtin.Bytes.size : Bytes -> Nat - 384. builtin.ImmutableArray.size : ImmutableArray + 402. builtin.ImmutableArray.size : ImmutableArray a -> Nat - 385. builtin.ImmutableByteArray.size : ImmutableByteArray + 403. builtin.ImmutableByteArray.size : ImmutableByteArray -> Nat - 386. builtin.List.size : [a] + 404. builtin.List.size : [a] -> Nat - 387. builtin.MutableArray.size : MutableArray + 405. builtin.MutableArray.size : MutableArray g a -> Nat - 388. builtin.MutableByteArray.size : MutableByteArray + 406. builtin.MutableByteArray.size : MutableByteArray g -> Nat - 389. builtin.Text.size : Text + 407. builtin.Text.size : Text -> Nat - 390. builtin.Float.sqrt : Float + 408. builtin.Text.patterns.space : ##Pattern + Text + 409. builtin.Float.sqrt : Float -> Float - 391. builtin.io2.IO.stdHandle : StdHandle + 410. builtin.io2.IO.stdHandle : StdHandle -> Handle - 392. builtin.Nat.sub : Nat + 411. builtin.Nat.sub : Nat -> Nat -> Int - 393. builtin.io2.TVar.swap : TVar a + 412. builtin.io2.TVar.swap : TVar a -> a ->{STM} a - 394. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int - 395. builtin.Bytes.take : Nat + 413. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int + 414. builtin.Bytes.take : Nat -> Bytes -> Bytes - 396. builtin.List.take : Nat + 415. builtin.List.take : Nat -> [a] -> [a] - 397. builtin.Text.take : Nat + 416. builtin.Text.take : Nat -> Text -> Text - 398. builtin.Float.tan : Float + 417. builtin.Float.tan : Float -> Float - 399. builtin.Float.tanh : Float + 418. builtin.Float.tanh : Float -> Float - 400. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either + 419. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either Failure TimeSpec - 401. builtin.Bytes.toBase16 : Bytes + 420. builtin.Bytes.toBase16 : Bytes -> Bytes - 402. builtin.Bytes.toBase32 : Bytes + 421. builtin.Bytes.toBase32 : Bytes -> Bytes - 403. builtin.Bytes.toBase64 : Bytes + 422. builtin.Bytes.toBase64 : Bytes -> Bytes - 404. builtin.Bytes.toBase64UrlUnpadded : Bytes + 423. builtin.Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 405. builtin.Text.toCharList : Text + 424. builtin.Text.toCharList : Text -> [Char] - 406. builtin.Int.toFloat : Int + 425. builtin.Int.toFloat : Int -> Float - 407. builtin.Nat.toFloat : Nat + 426. builtin.Nat.toFloat : Nat -> Float - 408. builtin.Nat.toInt : Nat + 427. builtin.Nat.toInt : Nat -> Int - 409. builtin.Bytes.toList : Bytes + 428. builtin.Bytes.toList : Bytes -> [Nat] - 410. builtin.Char.toNat : Char + 429. builtin.Text.toLowercase : Text + -> Text + 430. builtin.Char.toNat : Char -> Nat - 411. builtin.Float.toRepresentation : Float + 431. builtin.Float.toRepresentation : Float -> Nat - 412. builtin.Int.toRepresentation : Int + 432. builtin.Int.toRepresentation : Int -> Nat - 413. builtin.Char.toText : Char + 433. builtin.Char.toText : Char + -> Text + 434. builtin.Float.toText : Float -> Text - 414. builtin.Float.toText : Float + 435. builtin.Handle.toText : Handle -> Text - 415. builtin.Handle.toText : Handle + 436. builtin.Int.toText : Int -> Text - 416. builtin.Int.toText : Int + 437. builtin.Nat.toText : Nat -> Text - 417. builtin.Nat.toText : Nat + 438. builtin.Socket.toText : Socket -> Text - 418. builtin.Socket.toText : Socket + 439. builtin.Link.Term.toText : Term -> Text - 419. builtin.Link.Term.toText : Term + 440. builtin.ThreadId.toText : ThreadId -> Text - 420. builtin.ThreadId.toText : ThreadId + 441. builtin.Text.toUppercase : Text -> Text - 421. builtin.Text.toUtf8 : Text + 442. builtin.Text.toUtf8 : Text -> Bytes - 422. builtin.todo : a -> b - 423. builtin.Debug.trace : Text + 443. builtin.todo : a -> b + 444. builtin.Debug.trace : Text -> a -> () - 424. builtin.Int.trailingZeros : Int + 445. builtin.Int.trailingZeros : Int -> Nat - 425. builtin.Nat.trailingZeros : Nat + 446. builtin.Nat.trailingZeros : Nat -> Nat - 426. builtin.Float.truncate : Float + 447. builtin.Float.truncate : Float -> Int - 427. builtin.Int.truncate0 : Int + 448. builtin.Int.truncate0 : Int -> Nat - 428. builtin.io2.MVar.tryTake : MVar a + 449. builtin.io2.MVar.tryTake : MVar a ->{IO} Optional a - 429. builtin.Text.uncons : Text + 450. builtin.Text.uncons : Text -> Optional ( Char, Text) - 430. builtin.Any.unsafeExtract : Any + 451. builtin.Any.unsafeExtract : Any -> a - 431. builtin.Text.unsnoc : Text + 452. builtin.Text.unsnoc : Text -> Optional ( Text, Char) - 432. builtin.Code.validate : [( Term, + 453. builtin.Code.validate : [( Term, Code)] ->{IO} Optional Failure - 433. builtin.io2.validateSandboxed : [Term] + 454. builtin.io2.validateSandboxed : [Term] -> a -> Boolean - 434. builtin.Value.value : a + 455. builtin.Value.value : a -> Value - 435. builtin.Debug.watch : Text + 456. builtin.Debug.watch : Text -> a -> a - 436. builtin.MutableArray.write : MutableArray + 457. builtin.MutableArray.write : MutableArray g a -> Nat -> a ->{g, Exception} () - 437. builtin.Ref.write : Ref g a + 458. builtin.Ref.write : Ref g a -> a ->{g} () - 438. builtin.io2.TVar.write : TVar a + 459. builtin.io2.TVar.write : TVar a -> a ->{STM} () - 439. builtin.MutableByteArray.write16be : MutableByteArray + 460. builtin.MutableByteArray.write16be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 440. builtin.MutableByteArray.write32be : MutableByteArray + 461. builtin.MutableByteArray.write32be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 441. builtin.MutableByteArray.write64be : MutableByteArray + 462. builtin.MutableByteArray.write64be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 442. builtin.MutableByteArray.write8 : MutableByteArray + 463. builtin.MutableByteArray.write8 : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 443. builtin.Int.xor : Int + 464. builtin.Int.xor : Int -> Int -> Int - 444. builtin.Nat.xor : Nat + 465. builtin.Nat.xor : Nat -> Nat -> Nat diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index 3e87a253c7..3a03043f7a 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #6avukg1d7b .old` to make an old namespace + `fork #dp3c00s6bu .old` to make an old namespace accessible again, - `reset-root #6avukg1d7b` to reset the root namespace and + `reset-root #dp3c00s6bu` to reset the root namespace and its history to that of the specified namespace. - 1. #k5sfmp4o7j : add - 2. #6avukg1d7b : add - 3. #r2v7tldu09 : builtins.merge + 1. #s0i4jogmbi : add + 2. #dp3c00s6bu : add + 3. #plco106a95 : builtins.merge 4. #sg60bvjo91 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index c2be548b8e..9bc317939d 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - โ–ก 1. #86a70rllk7 (start of history) + โ–ก 1. #3hiroms1li (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #o7ieckac34 + โŠ™ 1. #rn55smunfv > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #62nvn4fabv + โŠ™ 2. #nh3q5fd2ad > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #86a70rllk7 (start of history) + โ–ก 3. #3hiroms1li (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #o7ieckac34 + โŠ™ 1. #rn55smunfv > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #62nvn4fabv + โŠ™ 2. #nh3q5fd2ad > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #86a70rllk7 (start of history) + โ–ก 3. #3hiroms1li (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - โ–ก 1. #86a70rllk7 (start of history) + โ–ก 1. #3hiroms1li (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #4aqembjjs5 + โŠ™ 1. #ophv2nnsma - Deletes: Nat.* Nat.+ - โ–ก 2. #86a70rllk7 (start of history) + โ–ก 2. #3hiroms1li (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From ecb8183b28a126b5a21ca009d33364bdfcb56012 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Fri, 1 Jul 2022 10:54:42 -0400 Subject: [PATCH 439/529] Apply suggestions from code review remove todos --- parser-typechecker/src/Unison/Builtin.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 01528f0317..30edea3c15 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -474,7 +474,6 @@ builtinsSrc = B "Text.toLowercase" $ text --> text, B "Text.toUtf8" $ text --> bytes, B "Text.fromUtf8.impl.v3" $ bytes --> eithert failure text, - -- TODO dolio these need implementation B "Text.patterns.eof" $ pat text, B "Text.patterns.anyChar" $ pat text, -- Bytes.patterns.literal : Bytes -> Pattern Bytes @@ -498,7 +497,6 @@ builtinsSrc = -- Pattern.run : Pattern a -> a -> Optional ([a], a) B "Pattern.run" $ forall1 "a" (\a -> pat a --> a --> optionalt (tuple [list a, a])), B "Pattern.isMatch" $ forall1 "a" (\a -> pat a --> a --> boolean), - -- end todo B "Char.toNat" $ char --> nat, B "Char.toText" $ char --> text, From 754c6b44bcb06075bc433d525d4c66308aafb007 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 1 Jul 2022 11:00:11 -0400 Subject: [PATCH 440/529] Text reverse, toUppercase, toLowercase Removed commpleted todo comments --- parser-typechecker/src/Unison/Builtin.hs | 4 ---- parser-typechecker/src/Unison/Runtime/Builtin.hs | 9 +++++++++ parser-typechecker/src/Unison/Util/Text.hs | 10 ++++++++++ 3 files changed, 19 insertions(+), 4 deletions(-) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 01528f0317..16670c50d1 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -468,13 +468,11 @@ builtinsSrc = B "Text.unsnoc" $ text --> optionalt (tuple [text, char]), B "Text.toCharList" $ text --> list char, B "Text.fromCharList" $ list char --> text, - -- Todo: implement me @dolio B "Text.reverse" $ text --> text, B "Text.toUppercase" $ text --> text, B "Text.toLowercase" $ text --> text, B "Text.toUtf8" $ text --> bytes, B "Text.fromUtf8.impl.v3" $ bytes --> eithert failure text, - -- TODO dolio these need implementation B "Text.patterns.eof" $ pat text, B "Text.patterns.anyChar" $ pat text, -- Bytes.patterns.literal : Bytes -> Pattern Bytes @@ -498,8 +496,6 @@ builtinsSrc = -- Pattern.run : Pattern a -> a -> Optional ([a], a) B "Pattern.run" $ forall1 "a" (\a -> pat a --> a --> optionalt (tuple [list a, a])), B "Pattern.isMatch" $ forall1 "a" (\a -> pat a --> a --> boolean), - -- end todo - B "Char.toNat" $ char --> nat, B "Char.toText" $ char --> text, B "Char.fromNat" $ nat --> char, diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 5b9d9d26d5..a2d22cd4ca 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -2210,6 +2210,15 @@ declareForeigns = do declareForeign Untracked "Text.repeat" (wordBoxDirect Ty.natRef) . mkForeign $ \(n :: Word64, txt :: Util.Text.Text) -> pure (Util.Text.replicate (fromIntegral n) txt) + declareForeign Untracked "Text.reverse" boxDirect . mkForeign $ + pure . Util.Text.reverse + + declareForeign Untracked "Text.toUppercase" boxDirect . mkForeign $ + pure . Util.Text.toUppercase + + declareForeign Untracked "Text.toLowercase" boxDirect . mkForeign $ + pure . Util.Text.toLowercase + declareForeign Untracked "Text.toUtf8" boxDirect . mkForeign $ pure . Util.Text.toUtf8 diff --git a/parser-typechecker/src/Unison/Util/Text.hs b/parser-typechecker/src/Unison/Util/Text.hs index 0b07421f0f..708adf102b 100644 --- a/parser-typechecker/src/Unison/Util/Text.hs +++ b/parser-typechecker/src/Unison/Util/Text.hs @@ -74,6 +74,16 @@ size (Text t) = R.size t reverse :: Text -> Text reverse (Text t) = Text (R.reverse t) +toUppercase :: Text -> Text +toUppercase (Text t) = Text (R.map up t) + where + up (Chunk n t) = Chunk n (T.toUpper t) + +toLowercase :: Text -> Text +toLowercase (Text t) = Text (R.map down t) + where + down (Chunk n t) = Chunk n (T.toLower t) + fromUtf8 :: B.Bytes -> Either String Text fromUtf8 bs = case T.decodeUtf8' (B.toByteString bs) of From 254ce6a8d5ba026e48a834e674cf181214119ed2 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 1 Jul 2022 13:39:46 -0400 Subject: [PATCH 441/529] fix `push.create`-to-nonempty-namespace error message --- .../src/Unison/CommandLine/OutputMessages.hs | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index b5cd60a141..9187a225c1 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1531,12 +1531,7 @@ notifyUser dir o = case o of ) RefusedToPush pushBehavior path -> (pure . P.warnCallout) case pushBehavior of - PushBehavior.RequireEmpty -> - P.lines - [ "The remote namespace is not empty.", - "", - "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" - ] + PushBehavior.RequireEmpty -> expectedEmptyPushDest path PushBehavior.RequireNonEmpty -> expectedNonEmptyPushDest path GistCreated remoteNamespace -> pure $ @@ -1592,8 +1587,10 @@ notifyUser dir o = case o of PrintVersion ucmVersion -> pure (P.text ucmVersion) ShareError x -> (pure . P.warnCallout) case x of ShareErrorCheckAndSetPush e -> case e of - (Share.CheckAndSetPushErrorHashMismatch Share.HashMismatch {path = sharePath, expectedHash = _expectedHash, actualHash = _actualHash}) -> - P.wrap $ P.text "It looks like someone modified" <> prettySharePath sharePath <> P.text "an instant before you. Pull and try again? ๐Ÿคž" + (Share.CheckAndSetPushErrorHashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash}) -> + case (expectedHash, actualHash) of + (Nothing, Just _) -> expectedEmptyPushDest (sharePathToWriteRemotePathShare sharePath) + _ -> P.wrap $ P.text "It looks like someone modified" <> prettySharePath sharePath <> P.text "an instant before you. Pull and try again? ๐Ÿคž" (Share.CheckAndSetPushErrorNoWritePermission sharePath) -> noWritePermission sharePath (Share.CheckAndSetPushErrorServerMissingDependencies hashes) -> missingDependencies hashes ShareErrorFastForwardPush e -> case e of @@ -1677,6 +1674,12 @@ notifyUser dir o = case o of IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" + expectedEmptyPushDest writeRemotePath = + P.lines + [ "The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is not empty.", + "", + "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" + ] expectedNonEmptyPushDest writeRemotePath = P.lines [ P.wrap ("The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is empty."), From 0a548748769bc311f417566f8e20bfe73c3436b8 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Fri, 1 Jul 2022 13:51:59 -0400 Subject: [PATCH 442/529] text pattern tests --- unison-src/transcripts/builtins.md | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/unison-src/transcripts/builtins.md b/unison-src/transcripts/builtins.md index 67ee5b8b0d..4faceaf28f 100644 --- a/unison-src/transcripts/builtins.md +++ b/unison-src/transcripts/builtins.md @@ -215,6 +215,28 @@ test> Text.tests.alignment = ] test> Text.tests.literalsEq = checks [":)" == ":)"] + +test> Text.tests.patterns = + use Pattern many or run isMatch capture join replicate + use Text.patterns literal digit letter anyChar space punctuation notCharIn charIn charRange notCharRange eof + l = literal + checks [ + run digit "1abc" == Some ([], "abc"), + run (capture (many digit)) "11234abc" == Some (["11234"], "abc"), + run (many letter) "abc11234abc" == Some ([], "11234abc"), + run (join [many space, capture (many anyChar)]) " abc123" == Some (["abc123"], ""), + run (many punctuation) "!!!!,,,..." == Some ([], ""), + run (charIn [?0,?1]) "0" == Some ([], ""), + run (notCharIn [?0,?1]) "0" == None, + run (many (notCharIn [?0,?1])) "asjdfskdfjlskdjflskdjf011" == Some ([], "011"), + run (capture (many (charRange ?a ?z))) "hi123" == Some (["hi"], "123"), + run (capture (many (notCharRange ?, ?,))) "abc123," == Some (["abc123"], ","), + run (capture (many (notCharIn [?,,]))) "abracadabra,123" == Some (["abracadabra"], ",123"), + -- this crashes with mismatched foreign calling convention for `Closure` + run (capture (many (or digit letter))) "11234abc,remainder" == Some (["11234abc"], ",remainder") + isMatch (join [l "abra", many (l "cadabra")]) "abracadabracadabra" == true, + + ] ``` ```ucm:hide From 74017804fbd25899c86c8b0f0f90c84ab6071cbc Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Fri, 1 Jul 2022 14:07:19 -0400 Subject: [PATCH 443/529] Fixed calling convention of Pattern.or Added a missing comma in test transcript --- .../src/Unison/Runtime/Builtin.hs | 2 +- unison-src/transcripts/builtins.md | 2 +- unison-src/transcripts/builtins.output.md | 25 ++++++++++++++++++- 3 files changed, 26 insertions(+), 3 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index a2d22cd4ca..f85eff14f6 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -2682,7 +2682,7 @@ declareForeigns = do \(TPat.CP p _) -> evaluate . TPat.cpattern $ TPat.Capture p declareForeign Untracked "Pattern.join" boxDirect . mkForeign $ \ps -> evaluate . TPat.cpattern . TPat.Join $ map (\(TPat.CP p _) -> p) ps - declareForeign Untracked "Pattern.or" boxDirect . mkForeign $ + declareForeign Untracked "Pattern.or" boxBoxDirect . mkForeign $ \(TPat.CP l _, TPat.CP r _) -> evaluate . TPat.cpattern $ TPat.Or l r declareForeign Untracked "Pattern.replicate" natNatBoxToBox . mkForeign $ \(m0 :: Word64, n0 :: Word64, TPat.CP p _) -> diff --git a/unison-src/transcripts/builtins.md b/unison-src/transcripts/builtins.md index 4faceaf28f..feae24ba2e 100644 --- a/unison-src/transcripts/builtins.md +++ b/unison-src/transcripts/builtins.md @@ -233,7 +233,7 @@ test> Text.tests.patterns = run (capture (many (notCharRange ?, ?,))) "abc123," == Some (["abc123"], ","), run (capture (many (notCharIn [?,,]))) "abracadabra,123" == Some (["abracadabra"], ",123"), -- this crashes with mismatched foreign calling convention for `Closure` - run (capture (many (or digit letter))) "11234abc,remainder" == Some (["11234abc"], ",remainder") + run (capture (many (or digit letter))) "11234abc,remainder" == Some (["11234abc"], ",remainder"), isMatch (join [l "abra", many (l "cadabra")]) "abracadabracadabra" == true, ] diff --git a/unison-src/transcripts/builtins.output.md b/unison-src/transcripts/builtins.output.md index 81c4307ab6..a751db42cf 100644 --- a/unison-src/transcripts/builtins.output.md +++ b/unison-src/transcripts/builtins.output.md @@ -196,6 +196,28 @@ test> Text.tests.alignment = ] test> Text.tests.literalsEq = checks [":)" == ":)"] + +test> Text.tests.patterns = + use Pattern many or run isMatch capture join replicate + use Text.patterns literal digit letter anyChar space punctuation notCharIn charIn charRange notCharRange eof + l = literal + checks [ + run digit "1abc" == Some ([], "abc"), + run (capture (many digit)) "11234abc" == Some (["11234"], "abc"), + run (many letter) "abc11234abc" == Some ([], "11234abc"), + run (join [many space, capture (many anyChar)]) " abc123" == Some (["abc123"], ""), + run (many punctuation) "!!!!,,,..." == Some ([], ""), + run (charIn [?0,?1]) "0" == Some ([], ""), + run (notCharIn [?0,?1]) "0" == None, + run (many (notCharIn [?0,?1])) "asjdfskdfjlskdjflskdjf011" == Some ([], "011"), + run (capture (many (charRange ?a ?z))) "hi123" == Some (["hi"], "123"), + run (capture (many (notCharRange ?, ?,))) "abc123," == Some (["abc123"], ","), + run (capture (many (notCharIn [?,,]))) "abracadabra,123" == Some (["abracadabra"], ",123"), + -- this crashes with mismatched foreign calling convention for `Closure` + run (capture (many (or digit letter))) "11234abc,remainder" == Some (["11234abc"], ",remainder"), + isMatch (join [l "abra", many (l "cadabra")]) "abracadabracadabra" == true, + + ] ``` ## `Bytes` functions @@ -343,10 +365,11 @@ Now that all the tests have been added to the codebase, let's view the test repo โ—‰ Sandbox.test3 Passed โ—‰ Text.tests.alignment Passed โ—‰ Text.tests.literalsEq Passed + โ—‰ Text.tests.patterns Passed โ—‰ Text.tests.repeat Passed โ—‰ Text.tests.takeDropAppend Passed - โœ… 20 test(s) passing + โœ… 21 test(s) passing Tip: Use view Any.test1 to view the source of a test. From 0f1218f8fc9d86abe83c08452c7b92f37a96cdfd Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Fri, 1 Jul 2022 14:47:08 -0400 Subject: [PATCH 444/529] moar tests! --- unison-src/transcripts/builtins.md | 4 +++- unison-src/transcripts/builtins.output.md | 4 +++- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/unison-src/transcripts/builtins.md b/unison-src/transcripts/builtins.md index feae24ba2e..f0a710f4c0 100644 --- a/unison-src/transcripts/builtins.md +++ b/unison-src/transcripts/builtins.md @@ -232,8 +232,10 @@ test> Text.tests.patterns = run (capture (many (charRange ?a ?z))) "hi123" == Some (["hi"], "123"), run (capture (many (notCharRange ?, ?,))) "abc123," == Some (["abc123"], ","), run (capture (many (notCharIn [?,,]))) "abracadabra,123" == Some (["abracadabra"], ",123"), - -- this crashes with mismatched foreign calling convention for `Closure` run (capture (many (or digit letter))) "11234abc,remainder" == Some (["11234abc"], ",remainder"), + run (capture (replicate 1 5 (or digit letter))) "1a2ba aaa" == Some (["1a2ba"], " aaa"), + isMatch (join [many letter, eof]) "aaaaabbbb" == true, + isMatch (join [many letter, eof]) "aaaaabbbb1" == false, isMatch (join [l "abra", many (l "cadabra")]) "abracadabracadabra" == true, ] diff --git a/unison-src/transcripts/builtins.output.md b/unison-src/transcripts/builtins.output.md index a751db42cf..a407c8abec 100644 --- a/unison-src/transcripts/builtins.output.md +++ b/unison-src/transcripts/builtins.output.md @@ -213,8 +213,10 @@ test> Text.tests.patterns = run (capture (many (charRange ?a ?z))) "hi123" == Some (["hi"], "123"), run (capture (many (notCharRange ?, ?,))) "abc123," == Some (["abc123"], ","), run (capture (many (notCharIn [?,,]))) "abracadabra,123" == Some (["abracadabra"], ",123"), - -- this crashes with mismatched foreign calling convention for `Closure` run (capture (many (or digit letter))) "11234abc,remainder" == Some (["11234abc"], ",remainder"), + run (capture (replicate 1 5 (or digit letter))) "1a2ba aaa" == Some (["1a2ba"], " aaa"), + isMatch (join [many letter, eof]) "aaaaabbbb" == true, + isMatch (join [many letter, eof]) "aaaaabbbb1" == false, isMatch (join [l "abra", many (l "cadabra")]) "abracadabracadabra" == true, ] From f783f58e10735fbc45fb2e553b3e5e2d1ad7aa16 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Fri, 1 Jul 2022 16:44:04 -0400 Subject: [PATCH 445/529] make sure `Pattern` type makes it into `builtins.merge` namespace --- parser-typechecker/src/Unison/Builtin.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 16670c50d1..180f0337e0 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -193,6 +193,7 @@ builtinTypesSrc = B' "Sequence" CT.Data, Rename' "Sequence" "List", B' "Text" CT.Data, + B' "Pattern" CT.Data, B' "Char" CT.Data, B' "Effect" CT.Data, Rename' "Effect" "Request", From 9394737ace3435d681c93aab84b04b5c472221ae Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Fri, 1 Jul 2022 16:48:17 -0400 Subject: [PATCH 446/529] refresh transcripts --- unison-src/transcripts/alias-many.output.md | 160 ++-- .../transcripts/api-namespace-list.output.md | 2 +- .../transcripts/builtins-merge.output.md | 53 +- .../transcripts/emptyCodebase.output.md | 4 +- unison-src/transcripts/merges.output.md | 12 +- .../transcripts/name-selection.output.md | 879 +++++++++--------- unison-src/transcripts/reflog.output.md | 10 +- unison-src/transcripts/squash.output.md | 20 +- 8 files changed, 569 insertions(+), 571 deletions(-) diff --git a/unison-src/transcripts/alias-many.output.md b/unison-src/transcripts/alias-many.output.md index b557b843e2..1597077e8b 100644 --- a/unison-src/transcripts/alias-many.output.md +++ b/unison-src/transcripts/alias-many.output.md @@ -547,94 +547,90 @@ Let's try it! 378. structural type Optional a 379. Optional.None : Optional a 380. Optional.Some : a -> Optional a - 381. Pattern.capture : ##Pattern a -> ##Pattern a - 382. Pattern.isMatch : ##Pattern a -> a -> Boolean - 383. Pattern.join : [##Pattern a] -> ##Pattern a - 384. Pattern.many : ##Pattern a -> ##Pattern a - 385. Pattern.or : ##Pattern a -> ##Pattern a -> ##Pattern a - 386. Pattern.replicate : Nat - -> Nat - -> ##Pattern a - -> ##Pattern a - 387. Pattern.run : ##Pattern a -> a -> Optional ([a], a) - 388. builtin type Ref - 389. Ref.read : Ref g a ->{g} a - 390. Ref.write : Ref g a -> a ->{g} () - 391. builtin type Request - 392. builtin type Scope - 393. Scope.array : Nat ->{Scope s} MutableArray (Scope s) a - 394. Scope.arrayOf : a + 381. builtin type Pattern + 382. Pattern.capture : Pattern a -> Pattern a + 383. Pattern.isMatch : Pattern a -> a -> Boolean + 384. Pattern.join : [Pattern a] -> Pattern a + 385. Pattern.many : Pattern a -> Pattern a + 386. Pattern.or : Pattern a -> Pattern a -> Pattern a + 387. Pattern.replicate : Nat -> Nat -> Pattern a -> Pattern a + 388. Pattern.run : Pattern a -> a -> Optional ([a], a) + 389. builtin type Ref + 390. Ref.read : Ref g a ->{g} a + 391. Ref.write : Ref g a -> a ->{g} () + 392. builtin type Request + 393. builtin type Scope + 394. Scope.array : Nat ->{Scope s} MutableArray (Scope s) a + 395. Scope.arrayOf : a -> Nat ->{Scope s} MutableArray (Scope s) a - 395. Scope.bytearray : Nat + 396. Scope.bytearray : Nat ->{Scope s} MutableByteArray (Scope s) - 396. Scope.bytearrayOf : Nat + 397. Scope.bytearrayOf : Nat -> Nat ->{Scope s} MutableByteArray (Scope s) - 397. Scope.ref : a ->{Scope s} Ref {Scope s} a - 398. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 399. structural type SeqView a b - 400. SeqView.VElem : a -> b -> SeqView a b - 401. SeqView.VEmpty : SeqView a b - 402. Socket.toText : Socket -> Text - 403. unique type Test.Result - 404. Test.Result.Fail : Text -> Result - 405. Test.Result.Ok : Text -> Result - 406. builtin type Text - 407. Text.!= : Text -> Text -> Boolean - 408. Text.++ : Text -> Text -> Text - 409. Text.drop : Nat -> Text -> Text - 410. Text.empty : Text - 411. Text.eq : Text -> Text -> Boolean - 412. Text.fromCharList : [Char] -> Text - 413. Text.fromUtf8.impl : Bytes -> Either Failure Text - 414. Text.gt : Text -> Text -> Boolean - 415. Text.gteq : Text -> Text -> Boolean - 416. Text.lt : Text -> Text -> Boolean - 417. Text.lteq : Text -> Text -> Boolean - 418. Text.patterns.anyChar : ##Pattern Text - 419. Text.patterns.charIn : [Char] -> ##Pattern Text - 420. Text.patterns.charRange : Char -> Char -> ##Pattern Text - 421. Text.patterns.digit : ##Pattern Text - 422. Text.patterns.eof : ##Pattern Text - 423. Text.patterns.letter : ##Pattern Text - 424. Text.patterns.literal : Text -> ##Pattern Text - 425. Text.patterns.notCharIn : [Char] -> ##Pattern Text - 426. Text.patterns.notCharRange : Char - -> Char - -> ##Pattern Text - 427. Text.patterns.punctuation : ##Pattern Text - 428. Text.patterns.space : ##Pattern Text - 429. Text.repeat : Nat -> Text -> Text - 430. Text.reverse : Text -> Text - 431. Text.size : Text -> Nat - 432. Text.take : Nat -> Text -> Text - 433. Text.toCharList : Text -> [Char] - 434. Text.toLowercase : Text -> Text - 435. Text.toUppercase : Text -> Text - 436. Text.toUtf8 : Text -> Bytes - 437. Text.uncons : Text -> Optional (Char, Text) - 438. Text.unsnoc : Text -> Optional (Text, Char) - 439. ThreadId.toText : ThreadId -> Text - 440. todo : a -> b - 441. structural type Tuple a b - 442. Tuple.Cons : a -> b -> Tuple a b - 443. structural type Unit - 444. Unit.Unit : () - 445. Universal.< : a -> a -> Boolean - 446. Universal.<= : a -> a -> Boolean - 447. Universal.== : a -> a -> Boolean - 448. Universal.> : a -> a -> Boolean - 449. Universal.>= : a -> a -> Boolean - 450. Universal.compare : a -> a -> Int - 451. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 452. builtin type Value - 453. Value.dependencies : Value -> [Term] - 454. Value.deserialize : Bytes -> Either Text Value - 455. Value.load : Value ->{IO} Either [Term] a - 456. Value.serialize : Value -> Bytes - 457. Value.value : a -> Value + 398. Scope.ref : a ->{Scope s} Ref {Scope s} a + 399. Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r + 400. structural type SeqView a b + 401. SeqView.VElem : a -> b -> SeqView a b + 402. SeqView.VEmpty : SeqView a b + 403. Socket.toText : Socket -> Text + 404. unique type Test.Result + 405. Test.Result.Fail : Text -> Result + 406. Test.Result.Ok : Text -> Result + 407. builtin type Text + 408. Text.!= : Text -> Text -> Boolean + 409. Text.++ : Text -> Text -> Text + 410. Text.drop : Nat -> Text -> Text + 411. Text.empty : Text + 412. Text.eq : Text -> Text -> Boolean + 413. Text.fromCharList : [Char] -> Text + 414. Text.fromUtf8.impl : Bytes -> Either Failure Text + 415. Text.gt : Text -> Text -> Boolean + 416. Text.gteq : Text -> Text -> Boolean + 417. Text.lt : Text -> Text -> Boolean + 418. Text.lteq : Text -> Text -> Boolean + 419. Text.patterns.anyChar : Pattern Text + 420. Text.patterns.charIn : [Char] -> Pattern Text + 421. Text.patterns.charRange : Char -> Char -> Pattern Text + 422. Text.patterns.digit : Pattern Text + 423. Text.patterns.eof : Pattern Text + 424. Text.patterns.letter : Pattern Text + 425. Text.patterns.literal : Text -> Pattern Text + 426. Text.patterns.notCharIn : [Char] -> Pattern Text + 427. Text.patterns.notCharRange : Char -> Char -> Pattern Text + 428. Text.patterns.punctuation : Pattern Text + 429. Text.patterns.space : Pattern Text + 430. Text.repeat : Nat -> Text -> Text + 431. Text.reverse : Text -> Text + 432. Text.size : Text -> Nat + 433. Text.take : Nat -> Text -> Text + 434. Text.toCharList : Text -> [Char] + 435. Text.toLowercase : Text -> Text + 436. Text.toUppercase : Text -> Text + 437. Text.toUtf8 : Text -> Bytes + 438. Text.uncons : Text -> Optional (Char, Text) + 439. Text.unsnoc : Text -> Optional (Text, Char) + 440. ThreadId.toText : ThreadId -> Text + 441. todo : a -> b + 442. structural type Tuple a b + 443. Tuple.Cons : a -> b -> Tuple a b + 444. structural type Unit + 445. Unit.Unit : () + 446. Universal.< : a -> a -> Boolean + 447. Universal.<= : a -> a -> Boolean + 448. Universal.== : a -> a -> Boolean + 449. Universal.> : a -> a -> Boolean + 450. Universal.>= : a -> a -> Boolean + 451. Universal.compare : a -> a -> Int + 452. unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b + 453. builtin type Value + 454. Value.dependencies : Value -> [Term] + 455. Value.deserialize : Bytes -> Either Text Value + 456. Value.load : Value ->{IO} Either [Term] a + 457. Value.serialize : Value -> Bytes + 458. Value.value : a -> Value .builtin> alias.many 94-104 .mylib diff --git a/unison-src/transcripts/api-namespace-list.output.md b/unison-src/transcripts/api-namespace-list.output.md index 97d6194d64..b62c949fa5 100644 --- a/unison-src/transcripts/api-namespace-list.output.md +++ b/unison-src/transcripts/api-namespace-list.output.md @@ -129,4 +129,4 @@ GET /api/list?namespace=names&relativeTo=nested "namespaceListingFQN": "nested.names", "namespaceListingHash": "#oms19b4f9s3c8tb5skeb8jii95ij35n3hdg038pu6rv5b0fikqe4gd7lnu6a1i6aq5tdh2opdo4s0sfrupvk6vfkr9lf0n752gbl8o0" } -``` +``` \ No newline at end of file diff --git a/unison-src/transcripts/builtins-merge.output.md b/unison-src/transcripts/builtins-merge.output.md index 99120176a0..1eb35d895a 100644 --- a/unison-src/transcripts/builtins-merge.output.md +++ b/unison-src/transcripts/builtins-merge.output.md @@ -51,31 +51,32 @@ The `builtins.merge` command adds the known builtins to a `builtin` subnamespace 40. Nat/ (28 definitions) 41. Optional (type) 42. Optional/ (2 definitions) - 43. Pattern/ (7 definitions) - 44. Ref (builtin type) - 45. Ref/ (2 definitions) - 46. Request (builtin type) - 47. Scope (builtin type) - 48. Scope/ (6 definitions) - 49. SeqView (type) - 50. SeqView/ (2 definitions) - 51. Socket/ (1 definition) - 52. Test/ (3 definitions) - 53. Text (builtin type) - 54. Text/ (32 definitions) - 55. ThreadId/ (1 definition) - 56. Tuple (type) - 57. Tuple/ (1 definition) - 58. Unit (type) - 59. Unit/ (1 definition) - 60. Universal/ (6 definitions) - 61. Value (builtin type) - 62. Value/ (5 definitions) - 63. bug (a -> b) - 64. crypto/ (13 definitions) - 65. io2/ (138 definitions) - 66. metadata/ (2 definitions) - 67. todo (a -> b) - 68. unsafe/ (1 definition) + 43. Pattern (builtin type) + 44. Pattern/ (7 definitions) + 45. Ref (builtin type) + 46. Ref/ (2 definitions) + 47. Request (builtin type) + 48. Scope (builtin type) + 49. Scope/ (6 definitions) + 50. SeqView (type) + 51. SeqView/ (2 definitions) + 52. Socket/ (1 definition) + 53. Test/ (3 definitions) + 54. Text (builtin type) + 55. Text/ (32 definitions) + 56. ThreadId/ (1 definition) + 57. Tuple (type) + 58. Tuple/ (1 definition) + 59. Unit (type) + 60. Unit/ (1 definition) + 61. Universal/ (6 definitions) + 62. Value (builtin type) + 63. Value/ (5 definitions) + 64. bug (a -> b) + 65. crypto/ (13 definitions) + 66. io2/ (138 definitions) + 67. metadata/ (2 definitions) + 68. todo (a -> b) + 69. unsafe/ (1 definition) ``` diff --git a/unison-src/transcripts/emptyCodebase.output.md b/unison-src/transcripts/emptyCodebase.output.md index 257a55d8c7..5b8a15dcf5 100644 --- a/unison-src/transcripts/emptyCodebase.output.md +++ b/unison-src/transcripts/emptyCodebase.output.md @@ -23,7 +23,7 @@ Technically, the definitions all exist, but they have no names. `builtins.merge` .foo> ls - 1. builtin/ (457 definitions) + 1. builtin/ (458 definitions) ``` And for a limited time, you can get even more builtin goodies: @@ -35,7 +35,7 @@ And for a limited time, you can get even more builtin goodies: .foo> ls - 1. builtin/ (643 definitions) + 1. builtin/ (644 definitions) ``` More typically, you'd start out by pulling `base. diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index c2282e9e81..e61756b93c 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -121,13 +121,13 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #r51pbp1b7j + โŠ™ 1. #kitgg6v3v9 - Deletes: feature1.y - โŠ™ 2. #nd43pcs43p + โŠ™ 2. #ib51mi2got + Adds / updates: @@ -138,26 +138,26 @@ We can also delete the fork if we're done with it. (Don't worry, it's still in t Original name New name(s) feature1.y master.y - โŠ™ 3. #dauj1n1sem + โŠ™ 3. #sdu80efbon + Adds / updates: feature1.y - โŠ™ 4. #asktmhscn9 + โŠ™ 4. #jpl72mj9k8 > Moves: Original name New name x master.x - โŠ™ 5. #1pf7k3nvca + โŠ™ 5. #b4mnqs7ovb + Adds / updates: x - โ–ก 6. #gm6pdauqrf (start of history) + โ–ก 6. #69vnfq66g3 (start of history) ``` To resurrect an old version of a namespace, you can learn its hash via the `history` command, then use `fork #namespacehash .newname`. diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md index ae7c67ba5e..dbaa3c73cb 100644 --- a/unison-src/transcripts/name-selection.output.md +++ b/unison-src/transcripts/name-selection.output.md @@ -124,293 +124,294 @@ d = c + 10 36. builtin type builtin.MutableByteArray 37. builtin type builtin.Nat 38. structural type builtin.Optional a - 39. builtin type builtin.io2.Tls.PrivateKey - 40. builtin type builtin.Ref - 41. builtin type builtin.Request - 42. unique type builtin.Test.Result - 43. builtin ability builtin.io2.STM - 44. builtin ability builtin.Scope - 45. unique type builtin.io2.SeekMode - 46. structural type builtin.SeqView a b - 47. builtin type builtin.io2.Tls.ServerConfig - 48. builtin type builtin.io2.Tls.SignedCert - 49. builtin type builtin.io2.Socket - 50. unique type builtin.io2.StdHandle - 51. builtin type builtin.io2.TVar - 52. builtin type builtin.Link.Term - 53. builtin type builtin.Text - 54. builtin type builtin.io2.ThreadId - 55. builtin type builtin.io2.Clock.internals.TimeSpec - 56. builtin type builtin.io2.Tls - 57. unique type builtin.io2.TlsFailure - 58. structural type builtin.Tuple a b - 59. builtin type builtin.Link.Type - 60. structural type builtin.Unit - 61. builtin type builtin.Value - 62. builtin type builtin.io2.Tls.Version - 63. builtin.io2.SeekMode.AbsoluteSeek : SeekMode - 64. builtin.io2.IOError.AlreadyExists : IOError - 65. builtin.io2.FileMode.Append : FileMode - 66. builtin.Doc.Blob : Text + 39. builtin type builtin.Pattern + 40. builtin type builtin.io2.Tls.PrivateKey + 41. builtin type builtin.Ref + 42. builtin type builtin.Request + 43. unique type builtin.Test.Result + 44. builtin ability builtin.io2.STM + 45. builtin ability builtin.Scope + 46. unique type builtin.io2.SeekMode + 47. structural type builtin.SeqView a b + 48. builtin type builtin.io2.Tls.ServerConfig + 49. builtin type builtin.io2.Tls.SignedCert + 50. builtin type builtin.io2.Socket + 51. unique type builtin.io2.StdHandle + 52. builtin type builtin.io2.TVar + 53. builtin type builtin.Link.Term + 54. builtin type builtin.Text + 55. builtin type builtin.io2.ThreadId + 56. builtin type builtin.io2.Clock.internals.TimeSpec + 57. builtin type builtin.io2.Tls + 58. unique type builtin.io2.TlsFailure + 59. structural type builtin.Tuple a b + 60. builtin type builtin.Link.Type + 61. structural type builtin.Unit + 62. builtin type builtin.Value + 63. builtin type builtin.io2.Tls.Version + 64. builtin.io2.SeekMode.AbsoluteSeek : SeekMode + 65. builtin.io2.IOError.AlreadyExists : IOError + 66. builtin.io2.FileMode.Append : FileMode + 67. builtin.Doc.Blob : Text -> Doc - 67. builtin.io2.BufferMode.BlockBuffering : BufferMode - 68. builtin.Tuple.Cons : a + 68. builtin.io2.BufferMode.BlockBuffering : BufferMode + 69. builtin.Tuple.Cons : a -> b -> Tuple a b - 69. builtin.io2.IOError.EOF : IOError - 70. builtin.Doc.Evaluate : Term + 70. builtin.io2.IOError.EOF : IOError + 71. builtin.Doc.Evaluate : Term -> Doc - 71. builtin.Test.Result.Fail : Text + 72. builtin.Test.Result.Fail : Text -> Result - 72. builtin.io2.Failure.Failure : Type + 73. builtin.io2.Failure.Failure : Type -> Text -> Any -> Failure - 73. builtin.io2.IOError.IllegalOperation : IOError - 74. builtin.IsPropagated.IsPropagated : IsPropagated - 75. builtin.IsTest.IsTest : IsTest - 76. builtin.Doc.Join : [Doc] + 74. builtin.io2.IOError.IllegalOperation : IOError + 75. builtin.IsPropagated.IsPropagated : IsPropagated + 76. builtin.IsTest.IsTest : IsTest + 77. builtin.Doc.Join : [Doc] -> Doc - 77. builtin.Either.Left : a + 78. builtin.Either.Left : a -> Either a b - 78. builtin.io2.BufferMode.LineBuffering : BufferMode - 79. builtin.Doc.Link : Link + 79. builtin.io2.BufferMode.LineBuffering : BufferMode + 80. builtin.Doc.Link : Link -> Doc - 80. builtin.io2.BufferMode.NoBuffering : BufferMode - 81. builtin.io2.IOError.NoSuchThing : IOError - 82. builtin.Optional.None : Optional + 81. builtin.io2.BufferMode.NoBuffering : BufferMode + 82. builtin.io2.IOError.NoSuchThing : IOError + 83. builtin.Optional.None : Optional a - 83. builtin.Test.Result.Ok : Text + 84. builtin.Test.Result.Ok : Text -> Result - 84. builtin.io2.IOError.PermissionDenied : IOError - 85. builtin.io2.FileMode.Read : FileMode - 86. builtin.io2.FileMode.ReadWrite : FileMode - 87. builtin.io2.SeekMode.RelativeSeek : SeekMode - 88. builtin.io2.IOError.ResourceBusy : IOError - 89. builtin.io2.IOError.ResourceExhausted : IOError - 90. builtin.Either.Right : b + 85. builtin.io2.IOError.PermissionDenied : IOError + 86. builtin.io2.FileMode.Read : FileMode + 87. builtin.io2.FileMode.ReadWrite : FileMode + 88. builtin.io2.SeekMode.RelativeSeek : SeekMode + 89. builtin.io2.IOError.ResourceBusy : IOError + 90. builtin.io2.IOError.ResourceExhausted : IOError + 91. builtin.Either.Right : b -> Either a b - 91. builtin.io2.SeekMode.SeekFromEnd : SeekMode - 92. builtin.Doc.Signature : Term + 92. builtin.io2.SeekMode.SeekFromEnd : SeekMode + 93. builtin.Doc.Signature : Term -> Doc - 93. builtin.io2.BufferMode.SizedBlockBuffering : Nat + 94. builtin.io2.BufferMode.SizedBlockBuffering : Nat -> BufferMode - 94. builtin.Optional.Some : a + 95. builtin.Optional.Some : a -> Optional a - 95. builtin.Doc.Source : Link + 96. builtin.Doc.Source : Link -> Doc - 96. builtin.io2.StdHandle.StdErr : StdHandle - 97. builtin.io2.StdHandle.StdIn : StdHandle - 98. builtin.io2.StdHandle.StdOut : StdHandle - 99. builtin.Link.Term : Term + 97. builtin.io2.StdHandle.StdErr : StdHandle + 98. builtin.io2.StdHandle.StdIn : StdHandle + 99. builtin.io2.StdHandle.StdOut : StdHandle + 100. builtin.Link.Term : Term -> Link - 100. builtin.Link.Type : Type + 101. builtin.Link.Type : Type -> Link - 101. builtin.Unit.Unit : () - 102. builtin.io2.IOError.UserError : IOError - 103. builtin.SeqView.VElem : a + 102. builtin.Unit.Unit : () + 103. builtin.io2.IOError.UserError : IOError + 104. builtin.SeqView.VElem : a -> b -> SeqView a b - 104. builtin.SeqView.VEmpty : SeqView + 105. builtin.SeqView.VEmpty : SeqView a b - 105. builtin.io2.FileMode.Write : FileMode - 106. builtin.Exception.raise : Failure + 106. builtin.io2.FileMode.Write : FileMode + 107. builtin.Exception.raise : Failure ->{Exception} x - 107. builtin.Text.!= : Text + 108. builtin.Text.!= : Text -> Text -> Boolean - 108. builtin.Float.* : Float + 109. builtin.Float.* : Float -> Float -> Float - 109. builtin.Int.* : Int + 110. builtin.Int.* : Int -> Int -> Int - 110. builtin.Nat.* : Nat + 111. builtin.Nat.* : Nat -> Nat -> Nat - 111. builtin.Float.+ : Float + 112. builtin.Float.+ : Float -> Float -> Float - 112. builtin.Int.+ : Int + 113. builtin.Int.+ : Int -> Int -> Int - 113. builtin.Nat.+ : Nat + 114. builtin.Nat.+ : Nat -> Nat -> Nat - 114. builtin.Bytes.++ : Bytes + 115. builtin.Bytes.++ : Bytes -> Bytes -> Bytes - 115. builtin.List.++ : [a] + 116. builtin.List.++ : [a] -> [a] -> [a] - 116. builtin.Text.++ : Text + 117. builtin.Text.++ : Text -> Text -> Text - 117. โ”Œ builtin.List.+: : a + 118. โ”Œ builtin.List.+: : a -> [a] -> [a] - 118. โ”” builtin.List.cons : a + 119. โ”” builtin.List.cons : a -> [a] -> [a] - 119. builtin.Float.- : Float + 120. builtin.Float.- : Float -> Float -> Float - 120. builtin.Int.- : Int + 121. builtin.Int.- : Int -> Int -> Int - 121. builtin.Float./ : Float + 122. builtin.Float./ : Float -> Float -> Float - 122. builtin.Int./ : Int + 123. builtin.Int./ : Int -> Int -> Int - 123. builtin.Nat./ : Nat + 124. builtin.Nat./ : Nat -> Nat -> Nat - 124. โ”Œ builtin.List.:+ : [a] + 125. โ”Œ builtin.List.:+ : [a] -> a -> [a] - 125. โ”” builtin.List.snoc : [a] + 126. โ”” builtin.List.snoc : [a] -> a -> [a] - 126. builtin.Universal.< : a + 127. builtin.Universal.< : a -> a -> Boolean - 127. builtin.Universal.<= : a + 128. builtin.Universal.<= : a -> a -> Boolean - 128. builtin.Universal.== : a + 129. builtin.Universal.== : a -> a -> Boolean - 129. builtin.Universal.> : a + 130. builtin.Universal.> : a -> a -> Boolean - 130. builtin.Universal.>= : a + 131. builtin.Universal.>= : a -> a -> Boolean - 131. builtin.Any.Any : a + 132. builtin.Any.Any : a -> Any - 132. builtin.crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm - 133. builtin.crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm - 134. builtin.crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm - 135. builtin.crypto.HashAlgorithm.Sha1 : HashAlgorithm - 136. builtin.crypto.HashAlgorithm.Sha2_256 : HashAlgorithm - 137. builtin.crypto.HashAlgorithm.Sha2_512 : HashAlgorithm - 138. builtin.crypto.HashAlgorithm.Sha3_256 : HashAlgorithm - 139. builtin.crypto.HashAlgorithm.Sha3_512 : HashAlgorithm - 140. builtin.Float.abs : Float + 133. builtin.crypto.HashAlgorithm.Blake2b_256 : HashAlgorithm + 134. builtin.crypto.HashAlgorithm.Blake2b_512 : HashAlgorithm + 135. builtin.crypto.HashAlgorithm.Blake2s_256 : HashAlgorithm + 136. builtin.crypto.HashAlgorithm.Sha1 : HashAlgorithm + 137. builtin.crypto.HashAlgorithm.Sha2_256 : HashAlgorithm + 138. builtin.crypto.HashAlgorithm.Sha2_512 : HashAlgorithm + 139. builtin.crypto.HashAlgorithm.Sha3_256 : HashAlgorithm + 140. builtin.crypto.HashAlgorithm.Sha3_512 : HashAlgorithm + 141. builtin.Float.abs : Float -> Float - 141. builtin.Float.acos : Float + 142. builtin.Float.acos : Float -> Float - 142. builtin.Float.acosh : Float + 143. builtin.Float.acosh : Float -> Float - 143. builtin.Int.and : Int + 144. builtin.Int.and : Int -> Int -> Int - 144. builtin.Nat.and : Nat + 145. builtin.Nat.and : Nat -> Nat -> Nat - 145. builtin.Text.patterns.anyChar : ##Pattern + 146. builtin.Text.patterns.anyChar : Pattern Text - 146. builtin.io2.IO.array : Nat + 147. builtin.io2.IO.array : Nat ->{IO} MutableArray {IO} a - 147. builtin.Scope.array : Nat + 148. builtin.Scope.array : Nat ->{Scope s} MutableArray (Scope s) a - 148. builtin.io2.IO.arrayOf : a + 149. builtin.io2.IO.arrayOf : a -> Nat ->{IO} MutableArray {IO} a - 149. builtin.Scope.arrayOf : a + 150. builtin.Scope.arrayOf : a -> Nat ->{Scope s} MutableArray (Scope s) a - 150. builtin.Float.asin : Float + 151. builtin.Float.asin : Float -> Float - 151. builtin.Float.asinh : Float + 152. builtin.Float.asinh : Float -> Float - 152. builtin.Bytes.at : Nat + 153. builtin.Bytes.at : Nat -> Bytes -> Optional Nat - 153. builtin.List.at : Nat + 154. builtin.List.at : Nat -> [a] -> Optional a - 154. builtin.Float.atan : Float + 155. builtin.Float.atan : Float -> Float - 155. builtin.Float.atan2 : Float + 156. builtin.Float.atan2 : Float -> Float -> Float - 156. builtin.Float.atanh : Float + 157. builtin.Float.atanh : Float -> Float - 157. builtin.io2.STM.atomically : '{STM} a + 158. builtin.io2.STM.atomically : '{STM} a ->{IO} a - 158. builtin.bug : a -> b - 159. builtin.io2.IO.bytearray : Nat + 159. builtin.bug : a -> b + 160. builtin.io2.IO.bytearray : Nat ->{IO} MutableByteArray {IO} - 160. builtin.Scope.bytearray : Nat + 161. builtin.Scope.bytearray : Nat ->{Scope s} MutableByteArray (Scope s) - 161. builtin.io2.IO.bytearrayOf : Nat + 162. builtin.io2.IO.bytearrayOf : Nat -> Nat ->{IO} MutableByteArray {IO} - 162. builtin.Scope.bytearrayOf : Nat + 163. builtin.Scope.bytearrayOf : Nat -> Nat ->{Scope s} MutableByteArray (Scope s) - 163. โ”Œ c#gjmq673r1v : Nat - 164. โ”” aaaa.tooManySegments : Nat - 165. builtin.Code.cache_ : [( Term, + 164. โ”Œ c#gjmq673r1v : Nat + 165. โ”” aaaa.tooManySegments : Nat + 166. builtin.Code.cache_ : [( Term, Code)] ->{IO} [Term] - 166. builtin.Pattern.capture : ##Pattern + 167. builtin.Pattern.capture : Pattern a - -> ##Pattern + -> Pattern a - 167. builtin.Float.ceiling : Float + 168. builtin.Float.ceiling : Float -> Int - 168. builtin.Text.patterns.charIn : [Char] - -> ##Pattern + 169. builtin.Text.patterns.charIn : [Char] + -> Pattern Text - 169. builtin.Text.patterns.charRange : Char + 170. builtin.Text.patterns.charRange : Char -> Char - -> ##Pattern + -> Pattern Text - 170. builtin.unsafe.coerceAbilities : (a + 171. builtin.unsafe.coerceAbilities : (a ->{e1} b) -> a ->{e2} b - 171. builtin.Universal.compare : a + 172. builtin.Universal.compare : a -> a -> Int - 172. builtin.Int.complement : Int + 173. builtin.Int.complement : Int -> Int - 173. builtin.Nat.complement : Nat + 174. builtin.Nat.complement : Nat -> Nat - 174. builtin.Bytes.gzip.compress : Bytes + 175. builtin.Bytes.gzip.compress : Bytes -> Bytes - 175. builtin.Bytes.zlib.compress : Bytes + 176. builtin.Bytes.zlib.compress : Bytes -> Bytes - 176. builtin.ImmutableArray.copyTo! : MutableArray + 177. builtin.ImmutableArray.copyTo! : MutableArray g a -> Nat -> ImmutableArray @@ -419,7 +420,7 @@ d = c + 10 -> Nat ->{g, Exception} () - 177. builtin.ImmutableByteArray.copyTo! : MutableByteArray + 178. builtin.ImmutableByteArray.copyTo! : MutableByteArray g -> Nat -> ImmutableByteArray @@ -427,7 +428,7 @@ d = c + 10 -> Nat ->{g, Exception} () - 178. builtin.MutableArray.copyTo! : MutableArray + 179. builtin.MutableArray.copyTo! : MutableArray g a -> Nat -> MutableArray @@ -436,7 +437,7 @@ d = c + 10 -> Nat ->{g, Exception} () - 179. builtin.MutableByteArray.copyTo! : MutableByteArray + 180. builtin.MutableByteArray.copyTo! : MutableByteArray g -> Nat -> MutableByteArray @@ -445,898 +446,898 @@ d = c + 10 -> Nat ->{g, Exception} () - 180. builtin.Float.cos : Float + 181. builtin.Float.cos : Float -> Float - 181. builtin.Float.cosh : Float + 182. builtin.Float.cosh : Float -> Float - 182. builtin.Bytes.decodeNat16be : Bytes + 183. builtin.Bytes.decodeNat16be : Bytes -> Optional ( Nat, Bytes) - 183. builtin.Bytes.decodeNat16le : Bytes + 184. builtin.Bytes.decodeNat16le : Bytes -> Optional ( Nat, Bytes) - 184. builtin.Bytes.decodeNat32be : Bytes + 185. builtin.Bytes.decodeNat32be : Bytes -> Optional ( Nat, Bytes) - 185. builtin.Bytes.decodeNat32le : Bytes + 186. builtin.Bytes.decodeNat32le : Bytes -> Optional ( Nat, Bytes) - 186. builtin.Bytes.decodeNat64be : Bytes + 187. builtin.Bytes.decodeNat64be : Bytes -> Optional ( Nat, Bytes) - 187. builtin.Bytes.decodeNat64le : Bytes + 188. builtin.Bytes.decodeNat64le : Bytes -> Optional ( Nat, Bytes) - 188. builtin.io2.Tls.decodePrivateKey : Bytes + 189. builtin.io2.Tls.decodePrivateKey : Bytes -> [PrivateKey] - 189. builtin.Bytes.gzip.decompress : Bytes + 190. builtin.Bytes.gzip.decompress : Bytes -> Either Text Bytes - 190. builtin.Bytes.zlib.decompress : Bytes + 191. builtin.Bytes.zlib.decompress : Bytes -> Either Text Bytes - 191. builtin.io2.Tls.ClientConfig.default : Text + 192. builtin.io2.Tls.ClientConfig.default : Text -> Bytes -> ClientConfig - 192. builtin.io2.Tls.ServerConfig.default : [SignedCert] + 193. builtin.io2.Tls.ServerConfig.default : [SignedCert] -> PrivateKey -> ServerConfig - 193. builtin.Code.dependencies : Code + 194. builtin.Code.dependencies : Code -> [Term] - 194. builtin.Value.dependencies : Value + 195. builtin.Value.dependencies : Value -> [Term] - 195. builtin.Code.deserialize : Bytes + 196. builtin.Code.deserialize : Bytes -> Either Text Code - 196. builtin.Value.deserialize : Bytes + 197. builtin.Value.deserialize : Bytes -> Either Text Value - 197. builtin.Text.patterns.digit : ##Pattern + 198. builtin.Text.patterns.digit : Pattern Text - 198. builtin.Code.display : Text + 199. builtin.Code.display : Text -> Code -> Text - 199. builtin.Bytes.drop : Nat + 200. builtin.Bytes.drop : Nat -> Bytes -> Bytes - 200. builtin.List.drop : Nat + 201. builtin.List.drop : Nat -> [a] -> [a] - 201. builtin.Nat.drop : Nat + 202. builtin.Nat.drop : Nat -> Nat -> Nat - 202. builtin.Text.drop : Nat + 203. builtin.Text.drop : Nat -> Text -> Text - 203. builtin.Bytes.empty : Bytes - 204. builtin.List.empty : [a] - 205. builtin.Text.empty : Text - 206. builtin.io2.Tls.encodeCert : SignedCert + 204. builtin.Bytes.empty : Bytes + 205. builtin.List.empty : [a] + 206. builtin.Text.empty : Text + 207. builtin.io2.Tls.encodeCert : SignedCert -> Bytes - 207. builtin.Bytes.encodeNat16be : Nat + 208. builtin.Bytes.encodeNat16be : Nat -> Bytes - 208. builtin.Bytes.encodeNat16le : Nat + 209. builtin.Bytes.encodeNat16le : Nat -> Bytes - 209. builtin.Bytes.encodeNat32be : Nat + 210. builtin.Bytes.encodeNat32be : Nat -> Bytes - 210. builtin.Bytes.encodeNat32le : Nat + 211. builtin.Bytes.encodeNat32le : Nat -> Bytes - 211. builtin.Bytes.encodeNat64be : Nat + 212. builtin.Bytes.encodeNat64be : Nat -> Bytes - 212. builtin.Bytes.encodeNat64le : Nat + 213. builtin.Bytes.encodeNat64le : Nat -> Bytes - 213. builtin.io2.Tls.encodePrivateKey : PrivateKey + 214. builtin.io2.Tls.encodePrivateKey : PrivateKey -> Bytes - 214. builtin.Text.patterns.eof : ##Pattern + 215. builtin.Text.patterns.eof : Pattern Text - 215. builtin.Float.eq : Float + 216. builtin.Float.eq : Float -> Float -> Boolean - 216. builtin.Int.eq : Int + 217. builtin.Int.eq : Int -> Int -> Boolean - 217. builtin.Nat.eq : Nat + 218. builtin.Nat.eq : Nat -> Nat -> Boolean - 218. builtin.Text.eq : Text + 219. builtin.Text.eq : Text -> Text -> Boolean - 219. builtin.Float.exp : Float + 220. builtin.Float.exp : Float -> Float - 220. builtin.Bytes.flatten : Bytes + 221. builtin.Bytes.flatten : Bytes -> Bytes - 221. builtin.Float.floor : Float + 222. builtin.Float.floor : Float -> Int - 222. builtin.io2.IO.forkComp : '{IO} a + 223. builtin.io2.IO.forkComp : '{IO} a ->{IO} ThreadId - 223. builtin.MutableArray.freeze : MutableArray + 224. builtin.MutableArray.freeze : MutableArray g a -> Nat -> Nat ->{g} ImmutableArray a - 224. builtin.MutableByteArray.freeze : MutableByteArray + 225. builtin.MutableByteArray.freeze : MutableByteArray g -> Nat -> Nat ->{g} ImmutableByteArray - 225. builtin.MutableArray.freeze! : MutableArray + 226. builtin.MutableArray.freeze! : MutableArray g a ->{g} ImmutableArray a - 226. builtin.MutableByteArray.freeze! : MutableByteArray + 227. builtin.MutableByteArray.freeze! : MutableByteArray g ->{g} ImmutableByteArray - 227. builtin.Bytes.fromBase16 : Bytes + 228. builtin.Bytes.fromBase16 : Bytes -> Either Text Bytes - 228. builtin.Bytes.fromBase32 : Bytes + 229. builtin.Bytes.fromBase32 : Bytes -> Either Text Bytes - 229. builtin.Bytes.fromBase64 : Bytes + 230. builtin.Bytes.fromBase64 : Bytes -> Either Text Bytes - 230. builtin.Bytes.fromBase64UrlUnpadded : Bytes + 231. builtin.Bytes.fromBase64UrlUnpadded : Bytes -> Either Text Bytes - 231. builtin.Text.fromCharList : [Char] + 232. builtin.Text.fromCharList : [Char] -> Text - 232. builtin.Bytes.fromList : [Nat] + 233. builtin.Bytes.fromList : [Nat] -> Bytes - 233. builtin.Char.fromNat : Nat + 234. builtin.Char.fromNat : Nat -> Char - 234. builtin.Float.fromRepresentation : Nat + 235. builtin.Float.fromRepresentation : Nat -> Float - 235. builtin.Int.fromRepresentation : Nat + 236. builtin.Int.fromRepresentation : Nat -> Int - 236. builtin.Float.fromText : Text + 237. builtin.Float.fromText : Text -> Optional Float - 237. builtin.Int.fromText : Text + 238. builtin.Int.fromText : Text -> Optional Int - 238. builtin.Nat.fromText : Text + 239. builtin.Nat.fromText : Text -> Optional Nat - 239. builtin.Float.gt : Float + 240. builtin.Float.gt : Float -> Float -> Boolean - 240. builtin.Int.gt : Int + 241. builtin.Int.gt : Int -> Int -> Boolean - 241. builtin.Nat.gt : Nat + 242. builtin.Nat.gt : Nat -> Nat -> Boolean - 242. builtin.Text.gt : Text + 243. builtin.Text.gt : Text -> Text -> Boolean - 243. builtin.Float.gteq : Float + 244. builtin.Float.gteq : Float -> Float -> Boolean - 244. builtin.Int.gteq : Int + 245. builtin.Int.gteq : Int -> Int -> Boolean - 245. builtin.Nat.gteq : Nat + 246. builtin.Nat.gteq : Nat -> Nat -> Boolean - 246. builtin.Text.gteq : Text + 247. builtin.Text.gteq : Text -> Text -> Boolean - 247. builtin.crypto.hash : HashAlgorithm + 248. builtin.crypto.hash : HashAlgorithm -> a -> Bytes - 248. builtin.crypto.hashBytes : HashAlgorithm + 249. builtin.crypto.hashBytes : HashAlgorithm -> Bytes -> Bytes - 249. builtin.crypto.hmac : HashAlgorithm + 250. builtin.crypto.hmac : HashAlgorithm -> Bytes -> a -> Bytes - 250. builtin.crypto.hmacBytes : HashAlgorithm + 251. builtin.crypto.hmacBytes : HashAlgorithm -> Bytes -> Bytes -> Bytes - 251. builtin.io2.IO.clientSocket.impl : Text + 252. builtin.io2.IO.clientSocket.impl : Text -> Text ->{IO} Either Failure Socket - 252. builtin.io2.IO.closeFile.impl : Handle + 253. builtin.io2.IO.closeFile.impl : Handle ->{IO} Either Failure () - 253. builtin.io2.IO.closeSocket.impl : Socket + 254. builtin.io2.IO.closeSocket.impl : Socket ->{IO} Either Failure () - 254. builtin.io2.IO.createDirectory.impl : Text + 255. builtin.io2.IO.createDirectory.impl : Text ->{IO} Either Failure () - 255. builtin.io2.IO.createTempDirectory.impl : Text + 256. builtin.io2.IO.createTempDirectory.impl : Text ->{IO} Either Failure Text - 256. builtin.io2.Tls.decodeCert.impl : Bytes + 257. builtin.io2.Tls.decodeCert.impl : Bytes -> Either Failure SignedCert - 257. builtin.io2.IO.delay.impl : Nat + 258. builtin.io2.IO.delay.impl : Nat ->{IO} Either Failure () - 258. builtin.io2.IO.directoryContents.impl : Text + 259. builtin.io2.IO.directoryContents.impl : Text ->{IO} Either Failure [Text] - 259. builtin.io2.IO.fileExists.impl : Text + 260. builtin.io2.IO.fileExists.impl : Text ->{IO} Either Failure Boolean - 260. builtin.Text.fromUtf8.impl : Bytes + 261. builtin.Text.fromUtf8.impl : Bytes -> Either Failure Text - 261. builtin.io2.IO.getArgs.impl : '{IO} Either + 262. builtin.io2.IO.getArgs.impl : '{IO} Either Failure [Text] - 262. builtin.io2.IO.getBuffering.impl : Handle + 263. builtin.io2.IO.getBuffering.impl : Handle ->{IO} Either Failure BufferMode - 263. builtin.io2.IO.getBytes.impl : Handle + 264. builtin.io2.IO.getBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 264. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either + 265. builtin.io2.IO.getCurrentDirectory.impl : '{IO} Either Failure Text - 265. builtin.io2.IO.getEnv.impl : Text + 266. builtin.io2.IO.getEnv.impl : Text ->{IO} Either Failure Text - 266. builtin.io2.IO.getFileSize.impl : Text + 267. builtin.io2.IO.getFileSize.impl : Text ->{IO} Either Failure Nat - 267. builtin.io2.IO.getFileTimestamp.impl : Text + 268. builtin.io2.IO.getFileTimestamp.impl : Text ->{IO} Either Failure Nat - 268. builtin.io2.IO.getLine.impl : Handle + 269. builtin.io2.IO.getLine.impl : Handle ->{IO} Either Failure Text - 269. builtin.io2.IO.getSomeBytes.impl : Handle + 270. builtin.io2.IO.getSomeBytes.impl : Handle -> Nat ->{IO} Either Failure Bytes - 270. builtin.io2.IO.getTempDirectory.impl : '{IO} Either + 271. builtin.io2.IO.getTempDirectory.impl : '{IO} Either Failure Text - 271. builtin.io2.IO.handlePosition.impl : Handle + 272. builtin.io2.IO.handlePosition.impl : Handle ->{IO} Either Failure Nat - 272. builtin.io2.Tls.handshake.impl : Tls + 273. builtin.io2.Tls.handshake.impl : Tls ->{IO} Either Failure () - 273. builtin.io2.IO.isDirectory.impl : Text + 274. builtin.io2.IO.isDirectory.impl : Text ->{IO} Either Failure Boolean - 274. builtin.io2.IO.isFileEOF.impl : Handle + 275. builtin.io2.IO.isFileEOF.impl : Handle ->{IO} Either Failure Boolean - 275. builtin.io2.IO.isFileOpen.impl : Handle + 276. builtin.io2.IO.isFileOpen.impl : Handle ->{IO} Either Failure Boolean - 276. builtin.io2.IO.isSeekable.impl : Handle + 277. builtin.io2.IO.isSeekable.impl : Handle ->{IO} Either Failure Boolean - 277. builtin.io2.IO.kill.impl : ThreadId + 278. builtin.io2.IO.kill.impl : ThreadId ->{IO} Either Failure () - 278. builtin.io2.IO.listen.impl : Socket + 279. builtin.io2.IO.listen.impl : Socket ->{IO} Either Failure () - 279. builtin.io2.Tls.newClient.impl : ClientConfig + 280. builtin.io2.Tls.newClient.impl : ClientConfig -> Socket ->{IO} Either Failure Tls - 280. builtin.io2.Tls.newServer.impl : ServerConfig + 281. builtin.io2.Tls.newServer.impl : ServerConfig -> Socket ->{IO} Either Failure Tls - 281. builtin.io2.IO.openFile.impl : Text + 282. builtin.io2.IO.openFile.impl : Text -> FileMode ->{IO} Either Failure Handle - 282. builtin.io2.MVar.put.impl : MVar a + 283. builtin.io2.MVar.put.impl : MVar a -> a ->{IO} Either Failure () - 283. builtin.io2.IO.putBytes.impl : Handle + 284. builtin.io2.IO.putBytes.impl : Handle -> Bytes ->{IO} Either Failure () - 284. builtin.io2.MVar.read.impl : MVar a + 285. builtin.io2.MVar.read.impl : MVar a ->{IO} Either Failure a - 285. builtin.io2.Tls.receive.impl : Tls + 286. builtin.io2.Tls.receive.impl : Tls ->{IO} Either Failure Bytes - 286. builtin.io2.IO.removeDirectory.impl : Text + 287. builtin.io2.IO.removeDirectory.impl : Text ->{IO} Either Failure () - 287. builtin.io2.IO.removeFile.impl : Text + 288. builtin.io2.IO.removeFile.impl : Text ->{IO} Either Failure () - 288. builtin.io2.IO.renameDirectory.impl : Text + 289. builtin.io2.IO.renameDirectory.impl : Text -> Text ->{IO} Either Failure () - 289. builtin.io2.IO.renameFile.impl : Text + 290. builtin.io2.IO.renameFile.impl : Text -> Text ->{IO} Either Failure () - 290. builtin.io2.IO.seekHandle.impl : Handle + 291. builtin.io2.IO.seekHandle.impl : Handle -> SeekMode -> Int ->{IO} Either Failure () - 291. builtin.io2.Tls.send.impl : Tls + 292. builtin.io2.Tls.send.impl : Tls -> Bytes ->{IO} Either Failure () - 292. builtin.io2.IO.serverSocket.impl : Optional + 293. builtin.io2.IO.serverSocket.impl : Optional Text -> Text ->{IO} Either Failure Socket - 293. builtin.io2.IO.setBuffering.impl : Handle + 294. builtin.io2.IO.setBuffering.impl : Handle -> BufferMode ->{IO} Either Failure () - 294. builtin.io2.IO.setCurrentDirectory.impl : Text + 295. builtin.io2.IO.setCurrentDirectory.impl : Text ->{IO} Either Failure () - 295. builtin.io2.IO.socketAccept.impl : Socket + 296. builtin.io2.IO.socketAccept.impl : Socket ->{IO} Either Failure Socket - 296. builtin.io2.IO.socketPort.impl : Socket + 297. builtin.io2.IO.socketPort.impl : Socket ->{IO} Either Failure Nat - 297. builtin.io2.IO.socketReceive.impl : Socket + 298. builtin.io2.IO.socketReceive.impl : Socket -> Nat ->{IO} Either Failure Bytes - 298. builtin.io2.IO.socketSend.impl : Socket + 299. builtin.io2.IO.socketSend.impl : Socket -> Bytes ->{IO} Either Failure () - 299. builtin.io2.MVar.swap.impl : MVar a + 300. builtin.io2.MVar.swap.impl : MVar a -> a ->{IO} Either Failure a - 300. builtin.io2.IO.systemTime.impl : '{IO} Either + 301. builtin.io2.IO.systemTime.impl : '{IO} Either Failure Nat - 301. builtin.io2.MVar.take.impl : MVar a + 302. builtin.io2.MVar.take.impl : MVar a ->{IO} Either Failure a - 302. builtin.io2.Tls.terminate.impl : Tls + 303. builtin.io2.Tls.terminate.impl : Tls ->{IO} Either Failure () - 303. builtin.io2.MVar.tryPut.impl : MVar a + 304. builtin.io2.MVar.tryPut.impl : MVar a -> a ->{IO} Either Failure Boolean - 304. builtin.io2.MVar.tryRead.impl : MVar a + 305. builtin.io2.MVar.tryRead.impl : MVar a ->{IO} Either Failure (Optional a) - 305. builtin.Int.increment : Int + 306. builtin.Int.increment : Int -> Int - 306. builtin.Nat.increment : Nat + 307. builtin.Nat.increment : Nat -> Nat - 307. builtin.io2.MVar.isEmpty : MVar a + 308. builtin.io2.MVar.isEmpty : MVar a ->{IO} Boolean - 308. builtin.Int.isEven : Int + 309. builtin.Int.isEven : Int -> Boolean - 309. builtin.Nat.isEven : Nat + 310. builtin.Nat.isEven : Nat -> Boolean - 310. builtin.Pattern.isMatch : ##Pattern + 311. builtin.Pattern.isMatch : Pattern a -> a -> Boolean - 311. builtin.Code.isMissing : Term + 312. builtin.Code.isMissing : Term ->{IO} Boolean - 312. builtin.Int.isOdd : Int + 313. builtin.Int.isOdd : Int -> Boolean - 313. builtin.Nat.isOdd : Nat + 314. builtin.Nat.isOdd : Nat -> Boolean - 314. builtin.metadata.isPropagated : IsPropagated - 315. builtin.metadata.isTest : IsTest - 316. builtin.Pattern.join : [##Pattern + 315. builtin.metadata.isPropagated : IsPropagated + 316. builtin.metadata.isTest : IsTest + 317. builtin.Pattern.join : [Pattern a] - -> ##Pattern + -> Pattern a - 317. builtin.Int.leadingZeros : Int + 318. builtin.Int.leadingZeros : Int -> Nat - 318. builtin.Nat.leadingZeros : Nat + 319. builtin.Nat.leadingZeros : Nat -> Nat - 319. builtin.Text.patterns.letter : ##Pattern + 320. builtin.Text.patterns.letter : Pattern Text - 320. builtin.Text.patterns.literal : Text - -> ##Pattern + 321. builtin.Text.patterns.literal : Text + -> Pattern Text - 321. builtin.Value.load : Value + 322. builtin.Value.load : Value ->{IO} Either [Term] a - 322. builtin.Float.log : Float + 323. builtin.Float.log : Float -> Float - 323. builtin.Float.logBase : Float + 324. builtin.Float.logBase : Float -> Float -> Float - 324. builtin.Code.lookup : Term + 325. builtin.Code.lookup : Term ->{IO} Optional Code - 325. builtin.Float.lt : Float + 326. builtin.Float.lt : Float -> Float -> Boolean - 326. builtin.Int.lt : Int + 327. builtin.Int.lt : Int -> Int -> Boolean - 327. builtin.Nat.lt : Nat + 328. builtin.Nat.lt : Nat -> Nat -> Boolean - 328. builtin.Text.lt : Text + 329. builtin.Text.lt : Text -> Text -> Boolean - 329. builtin.Float.lteq : Float + 330. builtin.Float.lteq : Float -> Float -> Boolean - 330. builtin.Int.lteq : Int + 331. builtin.Int.lteq : Int -> Int -> Boolean - 331. builtin.Nat.lteq : Nat + 332. builtin.Nat.lteq : Nat -> Nat -> Boolean - 332. builtin.Text.lteq : Text + 333. builtin.Text.lteq : Text -> Text -> Boolean - 333. builtin.Pattern.many : ##Pattern + 334. builtin.Pattern.many : Pattern a - -> ##Pattern + -> Pattern a - 334. builtin.Float.max : Float + 335. builtin.Float.max : Float -> Float -> Float - 335. builtin.Float.min : Float + 336. builtin.Float.min : Float -> Float -> Float - 336. builtin.Int.mod : Int + 337. builtin.Int.mod : Int -> Int -> Int - 337. builtin.Nat.mod : Nat + 338. builtin.Nat.mod : Nat -> Nat -> Nat - 338. builtin.io2.Clock.internals.monotonic : '{IO} Either + 339. builtin.io2.Clock.internals.monotonic : '{IO} Either Failure TimeSpec - 339. builtin.Int.negate : Int + 340. builtin.Int.negate : Int -> Int - 340. builtin.io2.MVar.new : a + 341. builtin.io2.MVar.new : a ->{IO} MVar a - 341. builtin.io2.TVar.new : a + 342. builtin.io2.TVar.new : a ->{STM} TVar a - 342. builtin.io2.MVar.newEmpty : '{IO} MVar + 343. builtin.io2.MVar.newEmpty : '{IO} MVar a - 343. builtin.io2.TVar.newIO : a + 344. builtin.io2.TVar.newIO : a ->{IO} TVar a - 344. builtin.Boolean.not : Boolean + 345. builtin.Boolean.not : Boolean -> Boolean - 345. builtin.Text.patterns.notCharIn : [Char] - -> ##Pattern + 346. builtin.Text.patterns.notCharIn : [Char] + -> Pattern Text - 346. builtin.Text.patterns.notCharRange : Char + 347. builtin.Text.patterns.notCharRange : Char -> Char - -> ##Pattern + -> Pattern Text - 347. builtin.io2.Clock.internals.nsec : TimeSpec + 348. builtin.io2.Clock.internals.nsec : TimeSpec -> Nat - 348. builtin.Int.or : Int + 349. builtin.Int.or : Int -> Int -> Int - 349. builtin.Nat.or : Nat + 350. builtin.Nat.or : Nat -> Nat -> Nat - 350. builtin.Pattern.or : ##Pattern + 351. builtin.Pattern.or : Pattern a - -> ##Pattern + -> Pattern a - -> ##Pattern + -> Pattern a - 351. builtin.Int.popCount : Int + 352. builtin.Int.popCount : Int -> Nat - 352. builtin.Nat.popCount : Nat + 353. builtin.Nat.popCount : Nat -> Nat - 353. builtin.Float.pow : Float + 354. builtin.Float.pow : Float -> Float -> Float - 354. builtin.Int.pow : Int + 355. builtin.Int.pow : Int -> Nat -> Int - 355. builtin.Nat.pow : Nat + 356. builtin.Nat.pow : Nat -> Nat -> Nat - 356. builtin.io2.Clock.internals.processCPUTime : '{IO} Either + 357. builtin.io2.Clock.internals.processCPUTime : '{IO} Either Failure TimeSpec - 357. builtin.Text.patterns.punctuation : ##Pattern + 358. builtin.Text.patterns.punctuation : Pattern Text - 358. builtin.ImmutableArray.read : ImmutableArray + 359. builtin.ImmutableArray.read : ImmutableArray a -> Nat ->{Exception} a - 359. builtin.MutableArray.read : MutableArray + 360. builtin.MutableArray.read : MutableArray g a -> Nat ->{g, Exception} a - 360. builtin.Ref.read : Ref g a + 361. builtin.Ref.read : Ref g a ->{g} a - 361. builtin.io2.TVar.read : TVar a + 362. builtin.io2.TVar.read : TVar a ->{STM} a - 362. builtin.ImmutableByteArray.read16be : ImmutableByteArray + 363. builtin.ImmutableByteArray.read16be : ImmutableByteArray -> Nat ->{Exception} Nat - 363. builtin.MutableByteArray.read16be : MutableByteArray + 364. builtin.MutableByteArray.read16be : MutableByteArray g -> Nat ->{g, Exception} Nat - 364. builtin.ImmutableByteArray.read24be : ImmutableByteArray + 365. builtin.ImmutableByteArray.read24be : ImmutableByteArray -> Nat ->{Exception} Nat - 365. builtin.MutableByteArray.read24be : MutableByteArray + 366. builtin.MutableByteArray.read24be : MutableByteArray g -> Nat ->{g, Exception} Nat - 366. builtin.ImmutableByteArray.read32be : ImmutableByteArray + 367. builtin.ImmutableByteArray.read32be : ImmutableByteArray -> Nat ->{Exception} Nat - 367. builtin.MutableByteArray.read32be : MutableByteArray + 368. builtin.MutableByteArray.read32be : MutableByteArray g -> Nat ->{g, Exception} Nat - 368. builtin.ImmutableByteArray.read40be : ImmutableByteArray + 369. builtin.ImmutableByteArray.read40be : ImmutableByteArray -> Nat ->{Exception} Nat - 369. builtin.MutableByteArray.read40be : MutableByteArray + 370. builtin.MutableByteArray.read40be : MutableByteArray g -> Nat ->{g, Exception} Nat - 370. builtin.ImmutableByteArray.read64be : ImmutableByteArray + 371. builtin.ImmutableByteArray.read64be : ImmutableByteArray -> Nat ->{Exception} Nat - 371. builtin.MutableByteArray.read64be : MutableByteArray + 372. builtin.MutableByteArray.read64be : MutableByteArray g -> Nat ->{g, Exception} Nat - 372. builtin.ImmutableByteArray.read8 : ImmutableByteArray + 373. builtin.ImmutableByteArray.read8 : ImmutableByteArray -> Nat ->{Exception} Nat - 373. builtin.MutableByteArray.read8 : MutableByteArray + 374. builtin.MutableByteArray.read8 : MutableByteArray g -> Nat ->{g, Exception} Nat - 374. builtin.io2.TVar.readIO : TVar a + 375. builtin.io2.TVar.readIO : TVar a ->{IO} a - 375. builtin.io2.Clock.internals.realtime : '{IO} Either + 376. builtin.io2.Clock.internals.realtime : '{IO} Either Failure TimeSpec - 376. builtin.io2.IO.ref : a + 377. builtin.io2.IO.ref : a ->{IO} Ref {IO} a - 377. builtin.Scope.ref : a + 378. builtin.Scope.ref : a ->{Scope s} Ref {Scope s} a - 378. builtin.Text.repeat : Nat + 379. builtin.Text.repeat : Nat -> Text -> Text - 379. builtin.Pattern.replicate : Nat + 380. builtin.Pattern.replicate : Nat -> Nat - -> ##Pattern + -> Pattern a - -> ##Pattern + -> Pattern a - 380. builtin.io2.STM.retry : '{STM} a - 381. builtin.Text.reverse : Text + 381. builtin.io2.STM.retry : '{STM} a + 382. builtin.Text.reverse : Text -> Text - 382. builtin.Float.round : Float + 383. builtin.Float.round : Float -> Int - 383. builtin.Pattern.run : ##Pattern + 384. builtin.Pattern.run : Pattern a -> a -> Optional ( [a], a) - 384. builtin.Scope.run : (โˆ€ s. + 385. builtin.Scope.run : (โˆ€ s. '{g, Scope s} r) ->{g} r - 385. builtin.io2.Clock.internals.sec : TimeSpec + 386. builtin.io2.Clock.internals.sec : TimeSpec -> Int - 386. builtin.Code.serialize : Code + 387. builtin.Code.serialize : Code -> Bytes - 387. builtin.Value.serialize : Value + 388. builtin.Value.serialize : Value -> Bytes - 388. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] + 389. builtin.io2.Tls.ClientConfig.certificates.set : [SignedCert] -> ClientConfig -> ClientConfig - 389. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] + 390. builtin.io2.Tls.ServerConfig.certificates.set : [SignedCert] -> ServerConfig -> ServerConfig - 390. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] + 391. builtin.io2.TLS.ClientConfig.ciphers.set : [Cipher] -> ClientConfig -> ClientConfig - 391. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] + 392. builtin.io2.Tls.ServerConfig.ciphers.set : [Cipher] -> ServerConfig -> ServerConfig - 392. builtin.io2.Tls.ClientConfig.versions.set : [Version] + 393. builtin.io2.Tls.ClientConfig.versions.set : [Version] -> ClientConfig -> ClientConfig - 393. builtin.io2.Tls.ServerConfig.versions.set : [Version] + 394. builtin.io2.Tls.ServerConfig.versions.set : [Version] -> ServerConfig -> ServerConfig - 394. builtin.Int.shiftLeft : Int + 395. builtin.Int.shiftLeft : Int -> Nat -> Int - 395. builtin.Nat.shiftLeft : Nat + 396. builtin.Nat.shiftLeft : Nat -> Nat -> Nat - 396. builtin.Int.shiftRight : Int + 397. builtin.Int.shiftRight : Int -> Nat -> Int - 397. builtin.Nat.shiftRight : Nat + 398. builtin.Nat.shiftRight : Nat -> Nat -> Nat - 398. builtin.Int.signum : Int + 399. builtin.Int.signum : Int -> Int - 399. builtin.Float.sin : Float + 400. builtin.Float.sin : Float -> Float - 400. builtin.Float.sinh : Float + 401. builtin.Float.sinh : Float -> Float - 401. builtin.Bytes.size : Bytes + 402. builtin.Bytes.size : Bytes -> Nat - 402. builtin.ImmutableArray.size : ImmutableArray + 403. builtin.ImmutableArray.size : ImmutableArray a -> Nat - 403. builtin.ImmutableByteArray.size : ImmutableByteArray + 404. builtin.ImmutableByteArray.size : ImmutableByteArray -> Nat - 404. builtin.List.size : [a] + 405. builtin.List.size : [a] -> Nat - 405. builtin.MutableArray.size : MutableArray + 406. builtin.MutableArray.size : MutableArray g a -> Nat - 406. builtin.MutableByteArray.size : MutableByteArray + 407. builtin.MutableByteArray.size : MutableByteArray g -> Nat - 407. builtin.Text.size : Text + 408. builtin.Text.size : Text -> Nat - 408. builtin.Text.patterns.space : ##Pattern + 409. builtin.Text.patterns.space : Pattern Text - 409. builtin.Float.sqrt : Float + 410. builtin.Float.sqrt : Float -> Float - 410. builtin.io2.IO.stdHandle : StdHandle + 411. builtin.io2.IO.stdHandle : StdHandle -> Handle - 411. builtin.Nat.sub : Nat + 412. builtin.Nat.sub : Nat -> Nat -> Int - 412. builtin.io2.TVar.swap : TVar a + 413. builtin.io2.TVar.swap : TVar a -> a ->{STM} a - 413. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int - 414. builtin.Bytes.take : Nat + 414. builtin.io2.IO.systemTimeMicroseconds : '{IO} Int + 415. builtin.Bytes.take : Nat -> Bytes -> Bytes - 415. builtin.List.take : Nat + 416. builtin.List.take : Nat -> [a] -> [a] - 416. builtin.Text.take : Nat + 417. builtin.Text.take : Nat -> Text -> Text - 417. builtin.Float.tan : Float + 418. builtin.Float.tan : Float -> Float - 418. builtin.Float.tanh : Float + 419. builtin.Float.tanh : Float -> Float - 419. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either + 420. builtin.io2.Clock.internals.threadCPUTime : '{IO} Either Failure TimeSpec - 420. builtin.Bytes.toBase16 : Bytes + 421. builtin.Bytes.toBase16 : Bytes -> Bytes - 421. builtin.Bytes.toBase32 : Bytes + 422. builtin.Bytes.toBase32 : Bytes -> Bytes - 422. builtin.Bytes.toBase64 : Bytes + 423. builtin.Bytes.toBase64 : Bytes -> Bytes - 423. builtin.Bytes.toBase64UrlUnpadded : Bytes + 424. builtin.Bytes.toBase64UrlUnpadded : Bytes -> Bytes - 424. builtin.Text.toCharList : Text + 425. builtin.Text.toCharList : Text -> [Char] - 425. builtin.Int.toFloat : Int + 426. builtin.Int.toFloat : Int -> Float - 426. builtin.Nat.toFloat : Nat + 427. builtin.Nat.toFloat : Nat -> Float - 427. builtin.Nat.toInt : Nat + 428. builtin.Nat.toInt : Nat -> Int - 428. builtin.Bytes.toList : Bytes + 429. builtin.Bytes.toList : Bytes -> [Nat] - 429. builtin.Text.toLowercase : Text + 430. builtin.Text.toLowercase : Text -> Text - 430. builtin.Char.toNat : Char + 431. builtin.Char.toNat : Char -> Nat - 431. builtin.Float.toRepresentation : Float + 432. builtin.Float.toRepresentation : Float -> Nat - 432. builtin.Int.toRepresentation : Int + 433. builtin.Int.toRepresentation : Int -> Nat - 433. builtin.Char.toText : Char + 434. builtin.Char.toText : Char -> Text - 434. builtin.Float.toText : Float + 435. builtin.Float.toText : Float -> Text - 435. builtin.Handle.toText : Handle + 436. builtin.Handle.toText : Handle -> Text - 436. builtin.Int.toText : Int + 437. builtin.Int.toText : Int -> Text - 437. builtin.Nat.toText : Nat + 438. builtin.Nat.toText : Nat -> Text - 438. builtin.Socket.toText : Socket + 439. builtin.Socket.toText : Socket -> Text - 439. builtin.Link.Term.toText : Term + 440. builtin.Link.Term.toText : Term -> Text - 440. builtin.ThreadId.toText : ThreadId + 441. builtin.ThreadId.toText : ThreadId -> Text - 441. builtin.Text.toUppercase : Text + 442. builtin.Text.toUppercase : Text -> Text - 442. builtin.Text.toUtf8 : Text + 443. builtin.Text.toUtf8 : Text -> Bytes - 443. builtin.todo : a -> b - 444. builtin.Debug.trace : Text + 444. builtin.todo : a -> b + 445. builtin.Debug.trace : Text -> a -> () - 445. builtin.Int.trailingZeros : Int + 446. builtin.Int.trailingZeros : Int -> Nat - 446. builtin.Nat.trailingZeros : Nat + 447. builtin.Nat.trailingZeros : Nat -> Nat - 447. builtin.Float.truncate : Float + 448. builtin.Float.truncate : Float -> Int - 448. builtin.Int.truncate0 : Int + 449. builtin.Int.truncate0 : Int -> Nat - 449. builtin.io2.MVar.tryTake : MVar a + 450. builtin.io2.MVar.tryTake : MVar a ->{IO} Optional a - 450. builtin.Text.uncons : Text + 451. builtin.Text.uncons : Text -> Optional ( Char, Text) - 451. builtin.Any.unsafeExtract : Any + 452. builtin.Any.unsafeExtract : Any -> a - 452. builtin.Text.unsnoc : Text + 453. builtin.Text.unsnoc : Text -> Optional ( Text, Char) - 453. builtin.Code.validate : [( Term, + 454. builtin.Code.validate : [( Term, Code)] ->{IO} Optional Failure - 454. builtin.io2.validateSandboxed : [Term] + 455. builtin.io2.validateSandboxed : [Term] -> a -> Boolean - 455. builtin.Value.value : a + 456. builtin.Value.value : a -> Value - 456. builtin.Debug.watch : Text + 457. builtin.Debug.watch : Text -> a -> a - 457. builtin.MutableArray.write : MutableArray + 458. builtin.MutableArray.write : MutableArray g a -> Nat -> a ->{g, Exception} () - 458. builtin.Ref.write : Ref g a + 459. builtin.Ref.write : Ref g a -> a ->{g} () - 459. builtin.io2.TVar.write : TVar a + 460. builtin.io2.TVar.write : TVar a -> a ->{STM} () - 460. builtin.MutableByteArray.write16be : MutableByteArray + 461. builtin.MutableByteArray.write16be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 461. builtin.MutableByteArray.write32be : MutableByteArray + 462. builtin.MutableByteArray.write32be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 462. builtin.MutableByteArray.write64be : MutableByteArray + 463. builtin.MutableByteArray.write64be : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 463. builtin.MutableByteArray.write8 : MutableByteArray + 464. builtin.MutableByteArray.write8 : MutableByteArray g -> Nat -> Nat ->{g, Exception} () - 464. builtin.Int.xor : Int + 465. builtin.Int.xor : Int -> Int -> Int - 465. builtin.Nat.xor : Nat + 466. builtin.Nat.xor : Nat -> Nat -> Nat diff --git a/unison-src/transcripts/reflog.output.md b/unison-src/transcripts/reflog.output.md index 3a03043f7a..283547b670 100644 --- a/unison-src/transcripts/reflog.output.md +++ b/unison-src/transcripts/reflog.output.md @@ -59,16 +59,16 @@ y = 2 most recent, along with the command that got us there. Try: `fork 2 .old` - `fork #dp3c00s6bu .old` to make an old namespace + `fork #tpbeffu5sn .old` to make an old namespace accessible again, - `reset-root #dp3c00s6bu` to reset the root namespace and + `reset-root #tpbeffu5sn` to reset the root namespace and its history to that of the specified namespace. - 1. #s0i4jogmbi : add - 2. #dp3c00s6bu : add - 3. #plco106a95 : builtins.merge + 1. #dki4d2cqnk : add + 2. #tpbeffu5sn : add + 3. #1a0f7cshrd : builtins.merge 4. #sg60bvjo91 : (initial reflogged namespace) ``` diff --git a/unison-src/transcripts/squash.output.md b/unison-src/transcripts/squash.output.md index 9bc317939d..6685569f00 100644 --- a/unison-src/transcripts/squash.output.md +++ b/unison-src/transcripts/squash.output.md @@ -13,7 +13,7 @@ Let's look at some examples. We'll start with a namespace with just the builtins - โ–ก 1. #3hiroms1li (start of history) + โ–ก 1. #21vp8s20gr (start of history) .> fork builtin builtin2 @@ -42,21 +42,21 @@ Now suppose we `fork` a copy of builtin, then rename `Nat.+` to `frobnicate`, th Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #rn55smunfv + โŠ™ 1. #ouocj2th2j > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #nh3q5fd2ad + โŠ™ 2. #t7d9ktrbhr > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #3hiroms1li (start of history) + โ–ก 3. #21vp8s20gr (start of history) ``` If we merge that back into `builtin`, we get that same chain of history: @@ -71,21 +71,21 @@ If we merge that back into `builtin`, we get that same chain of history: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #rn55smunfv + โŠ™ 1. #ouocj2th2j > Moves: Original name New name Nat.frobnicate Nat.+ - โŠ™ 2. #nh3q5fd2ad + โŠ™ 2. #t7d9ktrbhr > Moves: Original name New name Nat.+ Nat.frobnicate - โ–ก 3. #3hiroms1li (start of history) + โ–ก 3. #21vp8s20gr (start of history) ``` Let's try again, but using a `merge.squash` (or just `squash`) instead. The history will be unchanged: @@ -106,7 +106,7 @@ Let's try again, but using a `merge.squash` (or just `squash`) instead. The hist - โ–ก 1. #3hiroms1li (start of history) + โ–ก 1. #21vp8s20gr (start of history) ``` The churn that happened in `mybuiltin` namespace ended up back in the same spot, so the squash merge of that namespace with our original namespace had no effect. @@ -485,13 +485,13 @@ This checks to see that squashing correctly preserves deletions: Note: The most recent namespace hash is immediately below this message. - โŠ™ 1. #ophv2nnsma + โŠ™ 1. #degsnsvcf0 - Deletes: Nat.* Nat.+ - โ–ก 2. #3hiroms1li (start of history) + โ–ก 2. #21vp8s20gr (start of history) ``` Notice that `Nat.+` and `Nat.*` are deleted by the squash, and we see them deleted in one atomic step in the history. From ad3f6f80f70f759923c1e127d7d8a620644225e7 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Sun, 3 Jul 2022 16:21:49 -0400 Subject: [PATCH 447/529] Use appendUnbalanced judiciously when walking the text --- parser-typechecker/src/Unison/Util/Text.hs | 3 +++ parser-typechecker/src/Unison/Util/Text/Pattern.hs | 7 ++++++- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/Util/Text.hs b/parser-typechecker/src/Unison/Util/Text.hs index 708adf102b..c8be0b92b2 100644 --- a/parser-typechecker/src/Unison/Util/Text.hs +++ b/parser-typechecker/src/Unison/Util/Text.hs @@ -29,6 +29,9 @@ one, singleton :: Char -> Text one ch = Text (R.one (chunk (T.singleton ch))) singleton = one +appendUnbalanced :: Text -> Text -> Text +appendUnbalanced (Text t1) (Text t2) = Text (R.two t1 t2) + threshold :: Int threshold = 512 diff --git a/parser-typechecker/src/Unison/Util/Text/Pattern.hs b/parser-typechecker/src/Unison/Util/Text/Pattern.hs index 3c1d6972b7..5a5d425e47 100644 --- a/parser-typechecker/src/Unison/Util/Text/Pattern.hs +++ b/parser-typechecker/src/Unison/Util/Text/Pattern.hs @@ -130,7 +130,12 @@ compile (Many p) !_ !success = case p of Just (Text.chunkToText -> txt, t) -> case DT.dropWhile ok txt of rem | DT.null rem -> go acc t - | otherwise -> success acc (Text.fromText rem <> t) + | otherwise -> + -- moving the remainder to the root of the tree is much more efficient + -- since the next uncons will be O(1) rather than O(log n) + -- this can't unbalance the tree too badly since these promoted chunks + -- are being consumed and will get removed by a subsequent uncons + success acc (Text.appendUnbalanced (Text.fromText rem) t) {-# INLINE walker #-} compile (Replicate m n p) !err !success = case p of AnyChar -> \acc t -> From 49a997d4f0a84147e9a8239d2afd69ea451597b0 Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Sun, 3 Jul 2022 16:44:27 -0600 Subject: [PATCH 448/529] Upgrade terminal-size to fix apple m1 terminal bug Fixes text wrapping bug on apple m1 (previous version reported 0 width terminal) --- stack.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack.yaml b/stack.yaml index 9dc1813b4a..bb4caa95a8 100644 --- a/stack.yaml +++ b/stack.yaml @@ -57,6 +57,7 @@ extra-deps: - recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 - lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 - http-client-0.7.11 +- terminal-size-0.3.3 ghc-options: # All packages From 5115a3c383126d243d27ab3a8f3a3b69e5609065 Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Sun, 3 Jul 2022 18:56:49 -0400 Subject: [PATCH 449/529] Update stack.yaml --- stack.yaml | 1 + 1 file changed, 1 insertion(+) diff --git a/stack.yaml b/stack.yaml index bb4caa95a8..8c67cb2a2a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -57,6 +57,7 @@ extra-deps: - recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 - lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 - http-client-0.7.11 +# lts 18.28 provides 0.3.2.1 but we need at least 0.3.3 - terminal-size-0.3.3 ghc-options: From 47af38756f1071d4227a83559a916b289568abd5 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Mon, 4 Jul 2022 07:24:42 -0400 Subject: [PATCH 450/529] ci(Mergify): configuration update Signed-off-by: Paul Chiusano --- .mergify.yml | 1 - 1 file changed, 1 deletion(-) diff --git a/.mergify.yml b/.mergify.yml index a2f1e51d2b..0092234c9f 100644 --- a/.mergify.yml +++ b/.mergify.yml @@ -4,7 +4,6 @@ pull_request_rules: - status-success=ubuntu-20.04 # - status-success=ubuntu-18.04 - status-success=macOS-11.0 - - status-success=macOS-10.15 - status-success=windows-2019 - label=ready-to-merge - "#approved-reviews-by>=1" From 4158fefc05845155a472f89e2617f32c13a8d8d0 Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Mon, 4 Jul 2022 12:42:19 -0600 Subject: [PATCH 451/529] Fixing haskeline dep to the version that fixes apple m1 bugs --- stack.yaml | 3 ++ stack.yaml.lock | 90 +++++++++++++++++++++++++++++-------------------- 2 files changed, 57 insertions(+), 36 deletions(-) diff --git a/stack.yaml b/stack.yaml index 8c67cb2a2a..a610527183 100644 --- a/stack.yaml +++ b/stack.yaml @@ -44,6 +44,9 @@ extra-deps: commit: 563e96238dfe392dccf68d93953c8f30fd53bec8 subdirs: - ki +# lts 18.28 provides 0.8.2 but we need un-released version that fixes apple m1 bug +- github: judah/haskeline + commit: 7a83e7659211049f3bd167e7a13bc1cb4c42c91b - guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 - prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 - sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 diff --git a/stack.yaml.lock b/stack.yaml.lock index 85c999523c..28b8517234 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -5,120 +5,138 @@ packages: - completed: + sha256: d4fd87fb7bfc5d8e9fbc3e4ee7302c6b1500cdc00fdb9b659d0f4849b6ebe2d5 + name: configurator size: 15989 url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz - name: configurator - version: 0.3.0.0 - sha256: d4fd87fb7bfc5d8e9fbc3e4ee7302c6b1500cdc00fdb9b659d0f4849b6ebe2d5 pantry-tree: - size: 955 sha256: 90547cd983fd15ebdc803e057d3ef8735fe93a75e29a00f8a74eadc13ee0f6e9 + size: 955 + version: 0.3.0.0 original: url: https://github.com/unisonweb/configurator/archive/e47e9e9fe1f576f8c835183b9def52d73c01327a.tar.gz - completed: + sha256: 6e642163070a217cc3363bdbefde571ff6c1878f4fc3d92e9c910db7fa88eaf2 + name: shellmet size: 10460 url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz - name: shellmet - version: 0.0.4.0 - sha256: 6e642163070a217cc3363bdbefde571ff6c1878f4fc3d92e9c910db7fa88eaf2 pantry-tree: - size: 654 sha256: 05a169a7a6b68100630e885054dc1821d31cd06571b0317ec90c75ac2c41aeb7 + size: 654 + version: 0.0.4.0 original: url: https://github.com/unisonweb/shellmet/archive/2fd348592c8f51bb4c0ca6ba4bc8e38668913746.tar.gz - completed: - size: 15840 + sha256: a45eb3dbe7333c108aef4afce7f763c7661919b09641ef9d241c7ca4a78bf735 + name: ki subdir: ki + size: 15840 url: https://github.com/awkward-squad/ki/archive/563e96238dfe392dccf68d93953c8f30fd53bec8.tar.gz - name: ki - version: 1.0.0 - sha256: a45eb3dbe7333c108aef4afce7f763c7661919b09641ef9d241c7ca4a78bf735 pantry-tree: - size: 704 sha256: c63220c438c076818e09061b117c56055e154f6abb66ea9bc44a3900fcabd654 + size: 704 + version: 1.0.0 original: subdir: ki url: https://github.com/awkward-squad/ki/archive/563e96238dfe392dccf68d93953c8f30fd53bec8.tar.gz - completed: - hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 + sha256: da4411964018337065d6e4685e19e9d4ddb5a46eca125cab4127381dcb4aabab + name: haskeline + size: 75107 + url: https://github.com/judah/haskeline/archive/7a83e7659211049f3bd167e7a13bc1cb4c42c91b.tar.gz + pantry-tree: + sha256: 914a0401902a9c2f3cb48b9ddc6a24db3a864cba38bbae17752b3e40c6c513a8 + size: 3656 + version: 0.8.1.2 + original: + url: https://github.com/judah/haskeline/archive/7a83e7659211049f3bd167e7a13bc1cb4c42c91b.tar.gz +- completed: pantry-tree: - size: 364 sha256: a33838b7b1c54f6ac3e1b436b25674948713a4189658e4d82e639b9a689bc90d + size: 364 + hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 original: hackage: guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 - completed: - hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 pantry-tree: - size: 476 sha256: a03f60a1250c9d0daaf208ba58ccf24e05e0807f2e3dc7892fad3f2f3a196f7f + size: 476 + hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 original: hackage: prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 - completed: - hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 pantry-tree: - size: 3455 sha256: 5ca7ce4bc22ab9d4427bb149b5e283ab9db43375df14f7131fdfd48775f36350 + size: 3455 + hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 original: hackage: sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 - completed: - hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 pantry-tree: - size: 212 sha256: 876e5a679244143e2a7e74357427c7522a8d61f68a4cc3ae265fe4960b75a2e2 + size: 212 + hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 original: hackage: strings-1.1@sha256:0285dec4c8ab262359342b3e5ef1eb567074669461b9b38404f1cb870c881c5c,1617 - completed: - hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 pantry-tree: - size: 542 sha256: 0e6c6d4f89083c8385de5adc4f36ad01b2b0ff45261b47f7d90d919969c8b5ed + size: 542 + hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 original: hackage: fuzzyfind-3.0.0@sha256:d79a5d3ed194dd436c6b839bf187211d880cf773b2febaca456e5ccf93f5ac65,1814 - completed: - hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 pantry-tree: - size: 713 sha256: 8e049bd12ce2bd470909578f2ee8eb80b89d5ff88860afa30e29dd4eafecfa3e + size: 713 + hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 original: hackage: monad-validate-1.2.0.0@sha256:9850f408431098b28806dd464b6825a88a0b56c84f380d7fe0454c1df9d6f881,3505 - completed: - hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 pantry-tree: - size: 363 sha256: d33d603a2f0d1a220ff0d5e7edb6273def89120e6bb958c2d836cae89e788334 + size: 363 + hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 original: hackage: NanoID-3.1.0@sha256:9118ab00e8650b5a56a10c90295d357eb77a8057a598b7e56dfedc9c6d53c77d,1524 - completed: - hackage: direct-sqlite-2.3.27@sha256:94207d3018da3bda84bc6ce00d2c0236ced7edb37afbd726ed2a0bfa236e149b,3771 pantry-tree: - size: 770 sha256: c7f5afe70db567e2cf9f3119b49f4b402705e6bd08ed8ba98747a64a8a0bef41 + size: 770 + hackage: direct-sqlite-2.3.27@sha256:94207d3018da3bda84bc6ce00d2c0236ced7edb37afbd726ed2a0bfa236e149b,3771 original: hackage: direct-sqlite-2.3.27 - completed: - hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 pantry-tree: - size: 2410 sha256: d87d84c3f760c1b2540f74e4a301cd4e8294df891e8e4262e8bdd313bc8e0bfd + size: 2410 + hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 original: hackage: recover-rtti-0.4.0.0@sha256:2ce1e031ec0e34d736fa45f0149bbd55026f614939dc90ffd14a9c5d24093ff4,4423 - completed: - hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 pantry-tree: - size: 718 sha256: 3634593ce191e82793ea0e060598ab3cf67f2ef2fe1d65345dc9335ad529d25f + size: 718 + hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 original: hackage: lock-file-0.7.0.0@sha256:3ad84b5e454145e1d928063b56abb96db24a99a21b493989520e58fa0ab37b00,4484 - completed: - hackage: http-client-0.7.11@sha256:3f59ac8ffe2a3768846cdda040a0d1df2a413960529ba61c839861c948871967,5756 pantry-tree: - size: 2547 sha256: 8372e84e9c710097f4f80f2016ca15a5a0cd7884b8ac5ce70f26b3110f4401bd + size: 2547 + hackage: http-client-0.7.11@sha256:3f59ac8ffe2a3768846cdda040a0d1df2a413960529ba61c839861c948871967,5756 original: hackage: http-client-0.7.11 +- completed: + pantry-tree: + sha256: 2a9669ed392657d34ec2e180ddac68c9ef657e54bf4b5fbc9b9efaa7b1d341be + size: 580 + hackage: terminal-size-0.3.3@sha256:bd5f02333982bc8d6017db257b2a0b91870a295b4a37142a0c0525d8f533a48f,1255 + original: + hackage: terminal-size-0.3.3 snapshots: - completed: + sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 size: 590100 url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml - sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 original: lts-18.28 From a0c45bedb71521c784fe7f49a9a1a04207568ba4 Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Mon, 4 Jul 2022 13:18:36 -0600 Subject: [PATCH 452/529] Fixing just the terminal-size dep --- stack.yaml | 3 --- stack.yaml.lock | 11 ----------- 2 files changed, 14 deletions(-) diff --git a/stack.yaml b/stack.yaml index a610527183..8c67cb2a2a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -44,9 +44,6 @@ extra-deps: commit: 563e96238dfe392dccf68d93953c8f30fd53bec8 subdirs: - ki -# lts 18.28 provides 0.8.2 but we need un-released version that fixes apple m1 bug -- github: judah/haskeline - commit: 7a83e7659211049f3bd167e7a13bc1cb4c42c91b - guid-0.1.0@sha256:a7c975be473f6f142d5cc1b39bc807a99043d20b1bb0873fdfe7a3ce84d2faf1,1078 - prelude-extras-0.4.0.3@sha256:1c10b0123ea13a6423d74a8fcbaeb2d5249b472588abde418a36b47b7c4f48c8,1163 - sandi-0.5@sha256:b278d072ca717706ea38f9bd646e023f7f2576a778fb43565b434f93638849aa,3010 diff --git a/stack.yaml.lock b/stack.yaml.lock index 28b8517234..120b391811 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -39,17 +39,6 @@ packages: original: subdir: ki url: https://github.com/awkward-squad/ki/archive/563e96238dfe392dccf68d93953c8f30fd53bec8.tar.gz -- completed: - sha256: da4411964018337065d6e4685e19e9d4ddb5a46eca125cab4127381dcb4aabab - name: haskeline - size: 75107 - url: https://github.com/judah/haskeline/archive/7a83e7659211049f3bd167e7a13bc1cb4c42c91b.tar.gz - pantry-tree: - sha256: 914a0401902a9c2f3cb48b9ddc6a24db3a864cba38bbae17752b3e40c6c513a8 - size: 3656 - version: 0.8.1.2 - original: - url: https://github.com/judah/haskeline/archive/7a83e7659211049f3bd167e7a13bc1cb4c42c91b.tar.gz - completed: pantry-tree: sha256: a33838b7b1c54f6ac3e1b436b25674948713a4189658e4d82e639b9a689bc90d From 75bccb7700cd450017bedec1db6e3df276b13406 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 5 Jul 2022 12:33:45 -0400 Subject: [PATCH 453/529] go back to using show --- codebase2/core/U/Core/ABT.hs | 9 ++++- parser-typechecker/package.yaml | 1 - parser-typechecker/src/Unison/PrintError.hs | 3 +- parser-typechecker/src/Unison/Runtime/ANF.hs | 7 ++-- parser-typechecker/src/Unison/TermParser.hs | 13 ++++---- parser-typechecker/src/Unison/TermPrinter.hs | 7 ++-- .../src/Unison/Typechecker/Context.hs | 33 +++++++++---------- .../unison-parser-typechecker.cabal | 2 -- unison-core/src/Unison/Term.hs | 4 +-- unison-core/src/Unison/Type.hs | 2 +- 10 files changed, 40 insertions(+), 41 deletions(-) diff --git a/codebase2/core/U/Core/ABT.hs b/codebase2/core/U/Core/ABT.hs index 11e28d042d..ae8b170301 100644 --- a/codebase2/core/U/Core/ABT.hs +++ b/codebase2/core/U/Core/ABT.hs @@ -4,6 +4,7 @@ module U.Core.ABT where import Control.Monad (join) import qualified Data.Foldable as Foldable +import Data.Functor.Classes (Show1, showsPrec1) import Data.Functor.Identity (Identity (runIdentity)) import Data.Maybe (fromMaybe) import Data.Set (Set) @@ -23,7 +24,13 @@ data ABT f v r data Term f v a = Term {freeVars :: Set v, annotation :: a, out :: ABT f v (Term f v a)} deriving (Functor, Foldable, Generic, Traversable) -deriving instance (forall q. Show q => Show (f q), Show v, Show a) => Show (Term f v a) +instance (forall a. Show a => Show (f a), Show v) => Show (Term f v a) where + -- annotations not shown + showsPrec p (Term _ _ out) = case out of + Var v -> showParen (p >= 9) $ \x -> "Var " ++ show v ++ x + Cycle body -> ("Cycle " ++) . showsPrec p body + Abs v body -> showParen True $ (show v ++) . showString ". " . showsPrec p body + Tm f -> showsPrec p f amap :: (Functor f, Foldable f) => (a -> a') -> Term f v a -> Term f v a' amap = fmap diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index f93545a04a..6bf659ccb2 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -77,7 +77,6 @@ dependencies: - process - random >= 1.2.0 - raw-strings-qq - - recover-rtti - regex-base - regex-tdfa - safe diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 0c23268e25..b72c41b7d4 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -17,7 +17,6 @@ import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NES import qualified Data.Text as Text -import Debug.RecoverRTTI (anythingToString) import qualified Text.Megaparsec as P import qualified Unison.ABT as ABT import Unison.Builtin.Decls (pattern TupleType') @@ -935,7 +934,7 @@ renderType env f t = renderType0 env f (0 :: Int) (Type.removePureEffects t) then go 0 body else "forall " <> spaces renderVar vs <> " . " <> go 1 body Type.Var' v -> renderVar v - _ -> error $ "pattern match failure in PrintError.renderType " ++ anythingToString t + _ -> error $ "pattern match failure in PrintError.renderType " ++ show t where go = renderType0 env f diff --git a/parser-typechecker/src/Unison/Runtime/ANF.hs b/parser-typechecker/src/Unison/Runtime/ANF.hs index 55b73dab03..befffdc9b2 100644 --- a/parser-typechecker/src/Unison/Runtime/ANF.hs +++ b/parser-typechecker/src/Unison/Runtime/ANF.hs @@ -81,7 +81,6 @@ import Data.List hiding (and, or) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Data.Text -import Debug.RecoverRTTI (anythingToString) import GHC.Stack (CallStack, callStack) import qualified Unison.ABT as ABT import qualified Unison.ABT.Normalized as ABTN @@ -1084,7 +1083,7 @@ toSuperNormal :: Var v => Term v a -> ANFM v (SuperNormal v) toSuperNormal tm = do grp <- groupVars if not . Set.null . (Set.\\ grp) $ freeVars tm - then internalBug $ "free variables in supercombinator: " ++ anythingToString tm + then internalBug $ "free variables in supercombinator: " ++ show tm else Lambda (BX <$ vs) . ABTN.TAbss vs . snd <$> bindLocal vs (anfTerm body) @@ -1355,7 +1354,7 @@ anfBlock (TypeLink' r) = pure (mempty, pure . TLit $ LY r) anfBlock (List' as) = fmap (pure . TPrm BLDS) <$> anfArgs tms where tms = toList as -anfBlock t = internalBug $ "anf: unhandled term: " ++ anythingToString t +anfBlock t = internalBug $ "anf: unhandled term: " ++ show t -- Note: this assumes that patterns have already been translated -- to a state in which every case matches a single layer of data, @@ -1717,7 +1716,7 @@ prettyBranches ind bs = case bs of s (mapToList $ snd <$> m) ) - (prettyCase ind (prettyReq (0 :: Int) (0 :: Int)) df id) + (prettyCase ind (prettyReq (0::Int) (0::Int)) df id) (Map.toList bs) MatchSum bs -> foldr diff --git a/parser-typechecker/src/Unison/TermParser.hs b/parser-typechecker/src/Unison/TermParser.hs index dda04ac03a..57b0cde812 100644 --- a/parser-typechecker/src/Unison/TermParser.hs +++ b/parser-typechecker/src/Unison/TermParser.hs @@ -19,7 +19,6 @@ import qualified Data.Sequence as Sequence import qualified Data.Set as Set import qualified Data.Text as Text import qualified Data.Tuple.Extra as TupleE -import Debug.RecoverRTTI (anythingToString) import qualified Text.Megaparsec as P import qualified Unison.ABT as ABT import qualified Unison.Builtin.Decls as DD @@ -658,7 +657,7 @@ docNormalize tm = case tm of (normalize seqs) where - _ -> error $ "unexpected doc structure: " ++ anythingToString tm + _ -> error $ "unexpected doc structure: " ++ show tm where normalize = Sequence.fromList . (map TupleE.fst3) @@ -806,7 +805,7 @@ docNormalize tm = case tm of -- See test2 in transcript doc-formatting.md for an example of how -- this looks when there is whitespace immediately following @[source] -- or @[evaluate]. - lastLines :: Sequence.Seq (Term v a) -> [Maybe UnbreakCase] + lastLines :: Show v => Sequence.Seq (Term v a) -> [Maybe UnbreakCase] lastLines tms = (flip fmap) (toList tms) $ \case DD.DocBlob txt -> unbreakCase txt DD.DocLink _ -> Nothing @@ -814,7 +813,7 @@ docNormalize tm = case tm of DD.DocSignature _ -> Nothing DD.DocEvaluate _ -> Nothing Term.Var' _ -> Nothing -- @[include] - e@_ -> error ("unexpected doc element: " ++ anythingToString e) + e@_ -> error ("unexpected doc element: " ++ show e) -- Work out whether the last line of this blob is indented (or maybe -- terminated by a newline.) unbreakCase :: Text -> Maybe UnbreakCase @@ -875,7 +874,7 @@ docNormalize tm = case tm of DD.DocSignature _ -> False DD.DocEvaluate _ -> False Term.Var' _ -> False -- @[include] - _ -> error ("unexpected doc element" ++ anythingToString tm) + _ -> error ("unexpected doc element" ++ show tm) -- A list whose entries match those of tms. Can the subsequent entry by a -- line continuation of this one? followingLines tms = drop 1 ((continuesLine tms) ++ [False]) @@ -884,9 +883,9 @@ docNormalize tm = case tm of [] -> [] x : rest -> (fFirst x) : (map fRest rest) mapExceptLast fRest fLast = reverse . (mapExceptFirst fRest fLast) . reverse - tracing :: [Char] -> a -> a + tracing :: Show a => [Char] -> a -> a tracing when x = - (const id $ trace ("at " ++ when ++ ": " ++ anythingToString x ++ "\n")) x + (const id $ trace ("at " ++ when ++ ": " ++ (show x) ++ "\n")) x blob aa ac at txt = Term.app aa (Term.constructor ac (ConstructorReference DD.docRef DD.docBlobId)) (Term.text at txt) join aa ac as segs = diff --git a/parser-typechecker/src/Unison/TermPrinter.hs b/parser-typechecker/src/Unison/TermPrinter.hs index 63734bcc13..fd4550746d 100644 --- a/parser-typechecker/src/Unison/TermPrinter.hs +++ b/parser-typechecker/src/Unison/TermPrinter.hs @@ -13,7 +13,6 @@ import qualified Data.Set as Set import Data.Text (unpack) import qualified Data.Text as Text import Data.Vector () -import Debug.RecoverRTTI (anythingToString) import qualified Text.Show.Unicode as U import Unison.ABT (annotation, reannotateUp, pattern AbsN') import qualified Unison.ABT as ABT @@ -790,7 +789,7 @@ prettyBinding0 env a@AmbientContext {imports = im, docContext = doc} v term = in PP.group $ PP.group (defnLhs v vs <> fmt S.BindingEquals " =") `hang` uses [pretty0 env (ac (-1) Block im' doc) body'] - t -> l "error: " <> l (anythingToString t) + t -> l "error: " <> l (show t) where defnLhs v vs | infix' = case vs of @@ -853,7 +852,7 @@ prettyDoc n im term = go (DD.DocEvaluate (TermLink' r)) = atKeyword "evaluate" <> fmtTerm r go (Ref' r) = atKeyword "include" <> fmtTerm (Referent.Ref r) - go _ = l $ "(invalid doc literal: " ++ anythingToString term ++ ")" + go _ = l $ "(invalid doc literal: " ++ show term ++ ")" fmtName s = styleHashQualified'' (fmt $ S.HashQualifier s) $ elideFQN im s fmtTerm r = fmtName $ PrettyPrintEnv.termName n r fmtType r = fmtName $ PrettyPrintEnv.typeName n r @@ -1358,7 +1357,7 @@ immediateChildBlockTerms = \case handleDelay _ = [] doLet (v, Ann' tm _) = doLet (v, tm) doLet (v, LamsNamedOpt' _ body) = [body | not (isBlank $ Var.nameStr v)] - doLet t = error (anythingToString t) [] + doLet t = error (show t) [] -- Matches with a single case, no variable shadowing, and where the pattern -- has no literals are treated as destructuring bind, for instance: diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index b58f383404..05beacecf1 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -63,7 +63,6 @@ import Data.Sequence.NonEmpty (NESeq) import qualified Data.Sequence.NonEmpty as NESeq import qualified Data.Set as Set import qualified Data.Text as Text -import Debug.RecoverRTTI (anythingToString) import qualified Unison.ABT as ABT import qualified Unison.Blank as B import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) @@ -624,7 +623,7 @@ wellformedType c t = case t of Type.Forall' t' -> let (v, ctx2) = extendUniversal c in wellformedType ctx2 (ABT.bind t' (universal' (ABT.annotation t) v)) - _ -> error $ "Match failure in wellformedType: " ++ anythingToString t + _ -> error $ "Match failure in wellformedType: " ++ show t where -- Extend this `Context` with a single variable, guaranteed fresh extendUniversal ctx = @@ -660,14 +659,14 @@ extend' e c@(Context ctx) = Context . (: ctx) . (e,) <$> i' -- SolvedEvarCtx - ensure `v` is fresh, and the solution is well-formed wrt the context Solved _ v sa@(Type.getPolytype -> t) | Set.member v vs -> crash $ "variable " <> show v <> " already defined in the context" - | not (wellformedType c t) -> crash $ "type " <> anythingToString t <> " is not well-formed wrt the context" + | not (wellformedType c t) -> crash $ "type " <> show t <> " is not well-formed wrt the context" | otherwise -> pure $ Info (Set.insert v es) (Map.insert v sa ses) us uas (Set.insert v vs) pvs -- VarCtx - ensure `v` is fresh, and annotation is well-formed wrt the context Ann v t | Set.member v vs -> crash $ "variable " <> show v <> " already defined in the context" - | not (wellformedType c t) -> crash $ "type " <> anythingToString t <> " is not well-formed wrt the context" + | not (wellformedType c t) -> crash $ "type " <> show t <> " is not well-formed wrt the context" | otherwise -> pure $ Info @@ -819,7 +818,7 @@ apply' solvedExistentials t = go t Type.Effects' es -> Type.effects a (map go es) Type.ForallNamed' v t' -> Type.forall a v (go t') Type.IntroOuterNamed' v t' -> Type.introOuter a v (go t') - _ -> error $ "Match error in Context.apply': " ++ anythingToString t + _ -> error $ "Match error in Context.apply': " ++ show t where a = ABT.annotation t @@ -864,7 +863,7 @@ synthesizeApp :: (Term v loc, Int) -> M v loc (Type v loc, Wanted v loc) synthesizeApp _ ft arg - | debugEnabled && traceShow ("synthesizeApp" :: String, anythingToString ft, anythingToString arg) False = + | debugEnabled && traceShow ("synthesizeApp" :: String, ft, arg) False = undefined synthesizeApp fun (Type.stripIntroOuters -> Type.Effect'' es ft) argp@(arg, argNum) = scope (InSynthesizeApp ft arg argNum) $ do @@ -979,7 +978,7 @@ synthesize :: Ord loc => Term v loc -> M v loc (Type v loc, Wanted v loc) -synthesize e | debugShow ("synthesize" :: String, anythingToString e) = undefined +synthesize e | debugShow ("synthesize" :: String, e) = undefined synthesize e = scope (InSynthesize e) $ case minimize' e of Left es -> failWith (DuplicateDefinitions es) @@ -1308,7 +1307,7 @@ checkPattern :: Type v loc -> Pattern loc -> StateT [v] (M v loc) [(v, v)] -checkPattern tx ty | (debugEnabled || debugPatternsEnabled) && traceShow ("checkPattern" :: String, anythingToString tx, anythingToString ty) False = undefined +checkPattern tx ty | (debugEnabled || debugPatternsEnabled) && traceShow ("checkPattern" :: String, tx, ty) False = undefined checkPattern scrutineeType p = case p of Pattern.Unbound _ -> pure [] @@ -1971,7 +1970,7 @@ defaultAbility _ = pure False -- Expects a fully substituted type, so that it is unnecessary to -- check if an existential in the type has been solved. discardCovariant :: Var v => Set v -> Type v loc -> Type v loc -discardCovariant _ ty | debugShow ("discardCovariant" :: Text, anythingToString ty) = undefined +discardCovariant _ ty | debugShow ("discardCovariant" :: Text, ty) = undefined discardCovariant gens ty = ABT.rewriteDown (strip $ keepVarsT True ty) ty where @@ -2146,7 +2145,7 @@ check :: Term v loc -> Type v loc -> M v loc (Wanted v loc) -check m t | debugShow ("check" :: String, anythingToString m, anythingToString t) = undefined +check m t | debugShow ("check" :: String, m, t) = undefined check m0 t0 = scope (InCheck m0 t0) $ do ctx <- getContext case minimize' m0 of @@ -2162,7 +2161,7 @@ check m0 t0 = scope (InCheck m0 t0) $ do -- | `subtype ctx t1 t2` returns successfully if `t1` is a subtype of `t2`. -- This may have the effect of altering the context. subtype :: forall v loc. (Var v, Ord loc) => Type v loc -> Type v loc -> M v loc () -subtype tx ty | debugEnabled && traceShow ("subtype" :: String, anythingToString tx, anythingToString ty) False = undefined +subtype tx ty | debugEnabled && traceShow ("subtype" :: String, tx, ty) False = undefined subtype tx ty = scope (InSubtype tx ty) $ do ctx <- getContext go (ctx :: Context v loc) (Type.stripIntroOuters tx) (Type.stripIntroOuters ty) @@ -2315,7 +2314,7 @@ equate0 y1 y2 = do -- a subtype of the given type, updating the context -- in the process. instantiateL :: (Var v, Ord loc) => B.Blank loc -> v -> Type v loc -> M v loc () -instantiateL _ v t | debugEnabled && traceShow ("instantiateL" :: String, v, anythingToString t) False = undefined +instantiateL _ v t | debugEnabled && traceShow ("instantiateL" :: String, v, t) False = undefined instantiateL blank v (Type.stripIntroOuters -> t) = scope (InInstantiateL v t) $ getContext >>= \ctx -> case Type.monotype t of @@ -2414,7 +2413,7 @@ refineEffectVar :: Type v loc -> M v loc () refineEffectVar _ es _ v _ - | debugShow ("refineEffectVar" :: Text, anythingToString es, v) = undefined + | debugShow ("refineEffectVar" :: Text, es, v) = undefined refineEffectVar _ [] _ _ _ = pure () refineEffectVar l es blank v tv | ev <- TypeVar.Existential blank v, @@ -2436,7 +2435,7 @@ refineEffectVar l es blank v tv -- a supertype of the given type, updating the context -- in the process. instantiateR :: (Var v, Ord loc) => Type v loc -> B.Blank loc -> v -> M v loc () -instantiateR t _ v | debugEnabled && traceShow ("instantiateR" :: String, anythingToString t, v) False = undefined +instantiateR t _ v | debugEnabled && traceShow ("instantiateR" :: String, t, v) False = undefined instantiateR (Type.stripIntroOuters -> t) blank v = scope (InInstantiateR t v) $ getContext >>= \ctx -> case Type.monotype t of @@ -2624,7 +2623,7 @@ pruneAbilities :: [Type v loc] -> M v loc (Wanted v loc) pruneAbilities want0 have0 - | debugShow ("pruneAbilities" :: Text, anythingToString want0, anythingToString have0) = undefined + | debugShow ("pruneAbilities" :: Text, want0, have0) = undefined pruneAbilities want0 have0 = do pwant <- pruneConcrete missing [] want0 have0 if pwant /= want0 @@ -2674,7 +2673,7 @@ equateAbilities :: [Type v loc] -> M v loc () equateAbilities abs1 abs2 - | debugShow ("equateAbilities" :: Text, anythingToString abs1, anythingToString abs2) = undefined + | debugShow ("equateAbilities" :: Text, abs1, abs2) = undefined equateAbilities ls rs = matchAbilities ls rs >>= \(com, ls, rs) -> let (vls, cls) = partition isExistential ls @@ -2740,7 +2739,7 @@ subAbilities :: [Type v loc] -> M v loc () subAbilities want have - | debugShow ("subAbilities" :: Text, anythingToString want, anythingToString have) = undefined + | debugShow ("subAbilities" :: Text, want, have) = undefined subAbilities want have = do want <- expandWanted want have <- expandAbilities have diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index dfe2214f07..0104b7c478 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -244,7 +244,6 @@ library , process , random >=1.2.0 , raw-strings-qq - , recover-rtti , regex-base , regex-tdfa , safe @@ -426,7 +425,6 @@ test-suite parser-typechecker-tests , process , random >=1.2.0 , raw-strings-qq - , recover-rtti , regex-base , regex-tdfa , safe diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index c5eccfe497..c200a18fd8 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -1203,7 +1203,7 @@ fromReferent a = \case instance (Eq a, ABT.Var v) => Eq1 (F v a p) where (==#) = (==) -instance (Show a, Show v) => Show1 (F v a p) where showsPrec1 = showsPrec +instance (Show v) => Show1 (F v a p) where showsPrec1 = showsPrec instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where Int x == Int y = x == y @@ -1232,7 +1232,7 @@ instance (ABT.Var vt, Eq at, Eq a) => Eq (F vt at p a) where Match scrutinee cases == Match s2 cs2 = scrutinee == s2 && cases == cs2 _ == _ = False -instance (Show v, Show ta, Show a) => Show (F v ta p a) where +instance (Show v, Show a) => Show (F v a0 p a) where showsPrec = go where go _ (Int n) = (if n >= 0 then s "+" else s "") <> shows n diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index eb6f8eab4f..b470af0d9e 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -80,7 +80,7 @@ bindReferences keepFree ns t = newtype Monotype v a = Monotype {getPolytype :: Type v a} deriving (Eq) -instance (Show a, Show v) => Show (Monotype v a) where +instance (Show v) => Show (Monotype v a) where show = show . getPolytype -- Smart constructor which checks if a `Type` has no `Forall` quantifiers. From 31d48e37f2b5a93964b53fda6cfd27b51688cf74 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 5 Jul 2022 12:43:42 -0400 Subject: [PATCH 454/529] delete abt conversions --- .../src/Unison/Hashing/V2/Convert2.hs | 21 ++------ hie.yaml | 6 +-- .../Codebase/SqliteCodebase/Conversions.hs | 51 +++++-------------- 3 files changed, 21 insertions(+), 57 deletions(-) diff --git a/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs b/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs index d7ca2f9ba1..e32c0217eb 100644 --- a/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs +++ b/codebase2/codebase-sqlite-hashing-v2/src/Unison/Hashing/V2/Convert2.hs @@ -12,11 +12,8 @@ import qualified U.Codebase.Reference as V2 import qualified U.Codebase.Referent as V2.Referent import qualified U.Codebase.Term as V2 (F, F' (..), MatchCase (..), Pattern (..), SeqOp (..), TermRef, TypeRef) import qualified U.Codebase.Type as V2.Type -import qualified U.Core.ABT as V2 -import qualified U.Core.ABT as V2.ABT +import qualified U.Core.ABT as ABT import qualified U.Util.Hash as V2 (Hash) -import qualified Unison.ABT as H2 (transform) -import qualified Unison.ABT as V1.ABT import qualified Unison.Hashing.V2.Kind as H2 import qualified Unison.Hashing.V2.Pattern as H2.Pattern import qualified Unison.Hashing.V2.Reference as H2 @@ -25,18 +22,8 @@ import qualified Unison.Hashing.V2.Term as H2 import qualified Unison.Hashing.V2.Type as H2.Type import Unison.Prelude --- | Delete me ASAP. I am defined elsewhere. -abt2to1 :: Functor f => V2.ABT.Term f v a -> V1.ABT.Term f v a -abt2to1 (V2.ABT.Term fv a out) = V1.ABT.Term fv a (go out) - where - go = \case - V2.ABT.Cycle body -> V1.ABT.Cycle (abt2to1 body) - V2.ABT.Abs v body -> V1.ABT.Abs v (abt2to1 body) - V2.ABT.Var v -> V1.ABT.Var v - V2.ABT.Tm tm -> V1.ABT.Tm (abt2to1 <$> tm) - -v2ToH2Term :: forall v. Ord v => V2.Hash -> V2.Term (V2.F v) v () -> H2.Term v () -v2ToH2Term thisTermComponentHash = H2.transform convertF . abt2to1 +v2ToH2Term :: forall v. Ord v => V2.Hash -> ABT.Term (V2.F v) v () -> H2.Term v () +v2ToH2Term thisTermComponentHash = ABT.transform convertF where convertF :: forall x. V2.F v x -> H2.F v () () x convertF = \case @@ -118,7 +105,7 @@ v2ToH2TypeD :: forall v. Ord v => V2.Hash -> V2.Type.TypeD v -> H2.Type.Type v ( v2ToH2TypeD defaultHash = v2ToH2Type' (convertReference' (convertId defaultHash)) v2ToH2Type' :: forall r v. Ord v => (r -> H2.Reference) -> V2.Type.TypeR r v -> H2.Type.Type v () -v2ToH2Type' mkReference = H2.transform convertF . abt2to1 +v2ToH2Type' mkReference = ABT.transform convertF where convertF :: forall a. V2.Type.F' r a -> H2.Type.F a convertF = \case diff --git a/hie.yaml b/hie.yaml index 047a3173b8..f4b632137b 100644 --- a/hie.yaml +++ b/hie.yaml @@ -6,6 +6,9 @@ cradle: - path: "codebase2/codebase-sqlite/./" component: "unison-codebase-sqlite:lib" + - path: "codebase2/codebase-sqlite-hashing-v2/src" + component: "unison-codebase-sqlite-hashing-v2:lib" + - path: "codebase2/codebase-sync/./" component: "unison-codebase-sync:lib" @@ -96,9 +99,6 @@ cradle: - path: "unison-hashing-v2/src" component: "unison-hashing-v2:lib" - - path: "unison-hashing-v2/src" - component: "unison-hashing-v2:lib" - - path: "unison-share-api/src" component: "unison-share-api:lib" diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs index 1a9f9adfda..0a9bbd633c 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs @@ -25,10 +25,9 @@ import qualified U.Codebase.Type as V2.Type import qualified U.Codebase.TypeEdit as V2.TypeEdit import qualified U.Codebase.WatchKind as V2 import qualified U.Codebase.WatchKind as V2.WatchKind -import qualified U.Core.ABT as V2.ABT +import qualified U.Core.ABT as ABT import qualified U.Util.Hash as V2 import qualified U.Util.Hash as V2.Hash -import qualified Unison.ABT as V1.ABT import qualified Unison.Codebase.Branch as V1.Branch import qualified Unison.Codebase.Causal.Type as V1.Causal import qualified Unison.Codebase.Metadata as V1.Metadata @@ -85,10 +84,9 @@ watchKind2to1 = \case term1to2 :: Hash -> V1.Term.Term V1.Symbol Ann -> V2.Term.Term V2.Symbol term1to2 h = - V2.ABT.transform termF1to2 - . V2.ABT.vmap symbol1to2 - . V2.ABT.amap (const ()) - . abt1to2 + ABT.transform termF1to2 + . ABT.vmap symbol1to2 + . ABT.amap (const ()) where termF1to2 :: V1.Term.F V1.Symbol Ann Ann a -> V2.Term.F V2.Symbol a termF1to2 = go @@ -147,11 +145,10 @@ term1to2 h = V1.Pattern.Concat -> V2.Term.PConcat term2to1 :: forall m. Monad m => Hash -> (V2.Reference -> m CT.ConstructorType) -> V2.Term.Term V2.Symbol -> m (V1.Term.Term V1.Symbol Ann) -term2to1 h lookupCT tm = - V1.ABT.transformM (termF2to1 h lookupCT) - . V1.ABT.vmap symbol2to1 - . V1.ABT.amap (const Ann.External) - $ abt2to1 tm +term2to1 h lookupCT = + ABT.transformM (termF2to1 h lookupCT) + . ABT.vmap symbol2to1 + . ABT.amap (const Ann.External) where termF2to1 :: forall m a. Monad m => Hash -> (V2.Reference -> m CT.ConstructorType) -> V2.Term.F V2.Symbol a -> m (V1.Term.F V1.Symbol Ann Ann a) termF2to1 h lookupCT = go @@ -250,24 +247,6 @@ shortHashSuffix1to2 = -- todo: move suffix parsing to frontend either error id . V1.Reference.readSuffix -abt2to1 :: Functor f => V2.ABT.Term f v a -> V1.ABT.Term f v a -abt2to1 (V2.ABT.Term fv a out) = V1.ABT.Term fv a (go out) - where - go = \case - V2.ABT.Cycle body -> V1.ABT.Cycle (abt2to1 body) - V2.ABT.Abs v body -> V1.ABT.Abs v (abt2to1 body) - V2.ABT.Var v -> V1.ABT.Var v - V2.ABT.Tm tm -> V1.ABT.Tm (abt2to1 <$> tm) - -abt1to2 :: Functor f => V1.ABT.Term f v a -> V2.ABT.Term f v a -abt1to2 (V1.ABT.Term fv a out) = V2.ABT.Term fv a (go out) - where - go = \case - V1.ABT.Cycle body -> V2.ABT.Cycle (abt1to2 body) - V1.ABT.Abs v body -> V2.ABT.Abs v (abt1to2 body) - V1.ABT.Var v -> V2.ABT.Var v - V1.ABT.Tm tm -> V2.ABT.Tm (abt1to2 <$> tm) - rreference2to1 :: Hash -> V2.Reference' Text (Maybe V2.Hash) -> V1.Reference rreference2to1 h = \case V2.ReferenceBuiltin t -> V1.Reference.Builtin t @@ -371,10 +350,9 @@ dtype2to1 h = type2to1' (rreference2to1 h) type2to1' :: (r -> V1.Reference) -> V2.Type.TypeR r V2.Symbol -> V1.Type.Type V1.Symbol Ann type2to1' convertRef = - V1.ABT.transform (typeF2to1 convertRef) - . V1.ABT.vmap symbol2to1 - . V1.ABT.amap (const Ann.External) - . abt2to1 + ABT.transform (typeF2to1 convertRef) + . ABT.vmap symbol2to1 + . ABT.amap (const Ann.External) where typeF2to1 :: (r -> V1.Reference) -> V2.Type.F' r a -> (V1.Type.F a) typeF2to1 convertRef = \case @@ -399,10 +377,9 @@ ttype1to2 = type1to2' reference1to2 type1to2' :: (V1.Reference -> r) -> V1.Type.Type V1.Symbol a -> V2.Type.TypeR r V2.Symbol type1to2' convertRef = - V2.ABT.transform (typeF1to2' convertRef) - . V2.ABT.vmap symbol1to2 - . V2.ABT.amap (const ()) - . abt1to2 + ABT.transform (typeF1to2' convertRef) + . ABT.vmap symbol1to2 + . ABT.amap (const ()) where typeF1to2' :: (V1.Reference -> r) -> V1.Type.F a -> V2.Type.F' r a typeF1to2' convertRef = \case From df4a7de48a9a0c77f424aec0a1f49d104e2a2635 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 5 Jul 2022 12:49:59 -0400 Subject: [PATCH 455/529] delete unused import --- codebase2/core/U/Core/ABT.hs | 1 - 1 file changed, 1 deletion(-) diff --git a/codebase2/core/U/Core/ABT.hs b/codebase2/core/U/Core/ABT.hs index ae8b170301..cbc69d48b9 100644 --- a/codebase2/core/U/Core/ABT.hs +++ b/codebase2/core/U/Core/ABT.hs @@ -4,7 +4,6 @@ module U.Core.ABT where import Control.Monad (join) import qualified Data.Foldable as Foldable -import Data.Functor.Classes (Show1, showsPrec1) import Data.Functor.Identity (Identity (runIdentity)) import Data.Maybe (fromMaybe) import Data.Set (Set) From 4c77f57f42674741495bb5a1a7e4ac285bc9a587 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 5 Jul 2022 13:04:57 -0400 Subject: [PATCH 456/529] hide timing output behind UNISON_DEBUG=timing --- codebase2/util/package.yaml | 1 + codebase2/util/src/U/Util/Timing.hs | 56 +++++++++++++------------- codebase2/util/unison-util.cabal | 2 + lib/unison-prelude/src/Unison/Debug.hs | 38 ++++++++++------- 4 files changed, 55 insertions(+), 42 deletions(-) diff --git a/codebase2/util/package.yaml b/codebase2/util/package.yaml index da6bdb3a3b..8cb683d825 100644 --- a/codebase2/util/package.yaml +++ b/codebase2/util/package.yaml @@ -32,6 +32,7 @@ dependencies: - safe - text - time + - unison-prelude - unison-util-relation - unliftio - vector diff --git a/codebase2/util/src/U/Util/Timing.hs b/codebase2/util/src/U/Util/Timing.hs index 7bb9c45da1..db4f0c00f8 100644 --- a/codebase2/util/src/U/Util/Timing.hs +++ b/codebase2/util/src/U/Util/Timing.hs @@ -7,35 +7,37 @@ import Data.Time.Clock.System (getSystemTime, systemToTAITime) import Data.Time.Clock.TAI (diffAbsoluteTime) import System.CPUTime (getCPUTime) import System.IO.Unsafe (unsafePerformIO) +import qualified Unison.Debug as Debug import UnliftIO (MonadIO, liftIO) -enabled :: Bool -enabled = True - time :: MonadIO m => String -> m a -> m a -time _ ma | not enabled = ma -time label ma = do - systemStart <- liftIO getSystemTime - cpuPicoStart <- liftIO getCPUTime - liftIO $ putStrLn $ "Timing " ++ label ++ "..." - a <- ma - cpuPicoEnd <- liftIO getCPUTime - systemEnd <- liftIO getSystemTime - let systemDiff = diffAbsoluteTime (systemToTAITime systemEnd) (systemToTAITime systemStart) - let cpuDiff = picosecondsToDiffTime (cpuPicoEnd - cpuPicoStart) - liftIO $ putStrLn $ "Finished " ++ label ++ " in " ++ show cpuDiff ++ " (cpu), " ++ show systemDiff ++ " (system)" - pure a +time label ma = + if Debug.shouldDebug Debug.Timing + then do + systemStart <- liftIO getSystemTime + cpuPicoStart <- liftIO getCPUTime + liftIO $ putStrLn $ "Timing " ++ label ++ "..." + a <- ma + cpuPicoEnd <- liftIO getCPUTime + systemEnd <- liftIO getSystemTime + let systemDiff = diffAbsoluteTime (systemToTAITime systemEnd) (systemToTAITime systemStart) + let cpuDiff = picosecondsToDiffTime (cpuPicoEnd - cpuPicoStart) + liftIO $ putStrLn $ "Finished " ++ label ++ " in " ++ show cpuDiff ++ " (cpu), " ++ show systemDiff ++ " (system)" + pure a + else ma unsafeTime :: Monad m => String -> m a -> m a -unsafeTime _ ma | not enabled = ma -unsafeTime label ma = do - let !systemStart = unsafePerformIO getSystemTime - !cpuPicoStart = unsafePerformIO getCPUTime - !_ = unsafePerformIO $ putStrLn $ "Timing " ++ label ++ "..." - a <- ma - let !cpuPicoEnd = unsafePerformIO getCPUTime - !systemEnd = unsafePerformIO getSystemTime - let systemDiff = diffAbsoluteTime (systemToTAITime systemEnd) (systemToTAITime systemStart) - let cpuDiff = picosecondsToDiffTime (cpuPicoEnd - cpuPicoStart) - let !_ = unsafePerformIO $ putStrLn $ "Finished " ++ label ++ " in " ++ show cpuDiff ++ " (cpu), " ++ show systemDiff ++ " (system)" - pure a +unsafeTime label ma = + if Debug.shouldDebug Debug.Timing + then do + let !systemStart = unsafePerformIO getSystemTime + !cpuPicoStart = unsafePerformIO getCPUTime + !_ = unsafePerformIO $ putStrLn $ "Timing " ++ label ++ "..." + a <- ma + let !cpuPicoEnd = unsafePerformIO getCPUTime + !systemEnd = unsafePerformIO getSystemTime + let systemDiff = diffAbsoluteTime (systemToTAITime systemEnd) (systemToTAITime systemStart) + let cpuDiff = picosecondsToDiffTime (cpuPicoEnd - cpuPicoStart) + let !_ = unsafePerformIO $ putStrLn $ "Finished " ++ label ++ " in " ++ show cpuDiff ++ " (cpu), " ++ show systemDiff ++ " (system)" + pure a + else ma diff --git a/codebase2/util/unison-util.cabal b/codebase2/util/unison-util.cabal index 8758b1250b..59f51f624d 100644 --- a/codebase2/util/unison-util.cabal +++ b/codebase2/util/unison-util.cabal @@ -54,6 +54,7 @@ library , safe , text , time + , unison-prelude , unison-util-relation , unliftio , vector @@ -94,6 +95,7 @@ benchmark bench , sandi , text , time + , unison-prelude , unison-util , unison-util-base32hex , unison-util-relation diff --git a/lib/unison-prelude/src/Unison/Debug.hs b/lib/unison-prelude/src/Unison/Debug.hs index da1dfc337b..44935d7321 100644 --- a/lib/unison-prelude/src/Unison/Debug.hs +++ b/lib/unison-prelude/src/Unison/Debug.hs @@ -21,13 +21,15 @@ import System.IO.Unsafe (unsafePerformIO) import UnliftIO.Environment (lookupEnv) data DebugFlag - = Git - | Sqlite + = Auth | Codebase - | Auth - | Migration + | Git | Integrity + | Migration + | Sqlite | Sync + | -- | Timing how long things take + Timing deriving (Eq, Ord, Show, Bounded, Enum) debugFlags :: Set DebugFlag @@ -39,13 +41,14 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of Just s -> Set.fromList $ do w <- (Text.splitOn "," . Text.pack $ s) case Text.toUpper . Text.strip $ w of - "GIT" -> pure Git - "SQLITE" -> pure Sqlite - "CODEBASE" -> pure Codebase "AUTH" -> pure Auth - "MIGRATION" -> pure Migration + "CODEBASE" -> pure Codebase + "GIT" -> pure Git "INTEGRITY" -> pure Integrity + "MIGRATION" -> pure Migration + "SQLITE" -> pure Sqlite "SYNC" -> pure Sync + "TIMING" -> pure Timing _ -> empty {-# NOINLINE debugFlags #-} @@ -77,6 +80,10 @@ debugSync :: Bool debugSync = Sync `Set.member` debugFlags {-# NOINLINE debugSync #-} +debugTiming :: Bool +debugTiming = Timing `Set.member` debugFlags +{-# NOINLINE debugTiming #-} + -- | Use for trace-style selective debugging. -- E.g. 1 + (debug Git "The second number" 2) -- @@ -96,19 +103,19 @@ debug flag msg a = -- ... debugM :: (Show a, Monad m) => DebugFlag -> String -> a -> m () debugM flag msg a = - when (shouldDebug flag) $ do + whenDebug flag do pTraceM (msg <> ":\n") pTraceShowM a debugLog :: DebugFlag -> String -> a -> a debugLog flag msg = - if (shouldDebug flag) + if shouldDebug flag then pTrace msg else id debugLogM :: (Monad m) => DebugFlag -> String -> m () debugLogM flag msg = - when (shouldDebug flag) $ pTraceM msg + whenDebug flag $ pTraceM msg -- | A 'when' block which is triggered if the given flag is being debugged. whenDebug :: Monad m => DebugFlag -> m () -> m () @@ -117,10 +124,11 @@ whenDebug flag action = do shouldDebug :: DebugFlag -> Bool shouldDebug = \case - Git -> debugGit - Sqlite -> debugSqlite - Codebase -> debugCodebase Auth -> debugAuth - Migration -> debugMigration + Codebase -> debugCodebase + Git -> debugGit Integrity -> debugIntegrity + Migration -> debugMigration + Sqlite -> debugSqlite Sync -> debugSync + Timing -> debugTiming From 9623359a683503d7f6d77fd5adc080296c1beeb2 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 5 Jul 2022 11:06:01 -0600 Subject: [PATCH 457/529] Add combinator to compute minimal unique suffixes. --- unison-core/src/Unison/Names.hs | 42 +++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) diff --git a/unison-core/src/Unison/Names.hs b/unison-core/src/Unison/Names.hs index e862b5174e..b8f9547635 100644 --- a/unison-core/src/Unison/Names.hs +++ b/unison-core/src/Unison/Names.hs @@ -49,9 +49,12 @@ module Unison.Names isEmpty, hashQualifyTypesRelation, hashQualifyTermsRelation, + minimalUniqueSuffix, ) where +import Control.Lens.Cons (snoc, unsnoc) +import Data.Bifunctor (first) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text @@ -64,6 +67,7 @@ import Unison.LabeledDependency (LabeledDependency) import qualified Unison.LabeledDependency as LD import Unison.Name (Name) import qualified Unison.Name as Name +import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Reference (Reference) import qualified Unison.Reference as Reference @@ -71,6 +75,7 @@ import Unison.Referent (Referent) import qualified Unison.Referent as Referent import Unison.ShortHash (ShortHash) import qualified Unison.ShortHash as SH +import qualified Unison.Util.List as List import Unison.Util.Relation (Relation) import qualified Unison.Util.Relation as R import qualified Unison.Util.Relation as Relation @@ -102,6 +107,43 @@ instance Show (Names) where ++ foldMap (\(n, r) -> " " ++ show n ++ " -> " ++ show r ++ "\n") (R.toList types) ++ "\n" +-- | Abbreviate all names to their minimal unique suffix. +-- +-- E.g. +-- ["base.List.map", "base.Bag.map"] -> ["List.map", "Bag.map"] +-- ["base.List.filter", "base.List.map"] -> ["filter", "map"] +minimalUniqueSuffix :: Names -> Names +minimalUniqueSuffix (Names {terms, types}) = + Names {terms = abbreviateR terms, types = abbreviateR types} + where + abbreviateR :: Ord r => Relation Name r -> Relation Name r + abbreviateR = R.fromMultimap . Map.fromAscList . abbreviate . Map.toAscList . R.domain + + --- >>> abbreviate [("base.List.map", Set.singleton 1)] + -- [(map,fromList [1])] + --- >>> abbreviate [("base.List.map", Set.singleton 1), ("base.Map.map", Set.singleton 2), ("base.List.filter", Set.singleton 2)] + -- [(List.map,fromList [1]),(Map.map,fromList [2]),(filter,fromList [2])] + abbreviate :: Ord r => [(Name, Set r)] -> [(Name, Set r)] + abbreviate ns = + ns + & List.groupMap getSuffixKey + & concatMap recurse + + recurse :: Ord r => (Maybe NameSegment, [(Name, Set r)]) -> [(Name, Set r)] + recurse = \case + -- If the name was a single segment, we can't abbreviate it. + (Nothing, ns) -> ns + -- If the current suffix only has a single definition, we can discard the remaining prefix name prefix. + (Just suffix, [(_, rs)]) -> [(Name.fromSegment suffix, rs)] + -- If there are still multiple names with current suffix, recurse. + (Just suffix, ns) -> abbreviate ns <&> first (`snoc` suffix) + + getSuffixKey :: ((Name, r) -> (Maybe NameSegment, (Name, r))) + getSuffixKey (name, ref) = + case unsnoc name of + Nothing -> (Nothing, (name, ref)) + Just (remainder, suff) -> (Just suff, (remainder, ref)) + isEmpty :: Names -> Bool isEmpty n = R.null (terms n) && R.null (types n) From 89e42f2b2d5ce982e714a71042bf051366520c68 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 5 Jul 2022 13:08:57 -0400 Subject: [PATCH 458/529] one ABT.Var class --- unison-core/src/Unison/ABT.hs | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) diff --git a/unison-core/src/Unison/ABT.hs b/unison-core/src/Unison/ABT.hs index 43b5ca626a..e119d102b8 100644 --- a/unison-core/src/Unison/ABT.hs +++ b/unison-core/src/Unison/ABT.hs @@ -113,6 +113,7 @@ import U.Core.ABT pattern Var', ) import qualified U.Core.ABT +import U.Core.ABT.Var (Var (freshIn)) import Unison.Prelude import qualified Unison.Util.Components as Components import Prelude hiding (abs, cycle) @@ -135,13 +136,6 @@ baseFunctor_ f t = -- deriving instance (Data a, Data v, Typeable f, Data (f (Term f v a)), Ord v) => Data (Term f v a) --- | A class for variables. --- --- * `Set.notMember (freshIn vs v) vs`: --- `freshIn` returns a variable not used in the `Set` -class Ord v => Var v where - freshIn :: Set v -> v -> v - data V v = Free v | Bound v deriving (Eq, Ord, Show, Functor) unvar :: V v -> v From 94ed4b09ee587080708c67cf441a907bb7fa62a6 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 5 Jul 2022 13:26:14 -0400 Subject: [PATCH 459/529] move orphan instances, and de-dupe more Var helper functions --- codebase2/core/U/Core/ABT.hs | 115 +++++++++++++++++++++++++++++++ codebase2/core/U/Core/ABT/Var.hs | 69 ------------------- unison-core/src/Unison/ABT.hs | 112 ++---------------------------- 3 files changed, 121 insertions(+), 175 deletions(-) diff --git a/codebase2/core/U/Core/ABT.hs b/codebase2/core/U/Core/ABT.hs index cbc69d48b9..780b4862f8 100644 --- a/codebase2/core/U/Core/ABT.hs +++ b/codebase2/core/U/Core/ABT.hs @@ -9,6 +9,7 @@ import Data.Maybe (fromMaybe) import Data.Set (Set) import qualified Data.Set as Set import GHC.Generics (Generic) +import U.Core.ABT.Var (Var (freshIn)) import Prelude hiding (abs, cycle) data ABT f v r @@ -23,6 +24,50 @@ data ABT f v r data Term f v a = Term {freeVars :: Set v, annotation :: a, out :: ABT f v (Term f v a)} deriving (Functor, Foldable, Generic, Traversable) +instance (Foldable f, Functor f, forall a. Eq a => Eq (f a), Var v) => Eq (Term f v a) where + -- alpha equivalence, works by renaming any aligned Abs ctors to use a common fresh variable + t1 == t2 = go (out t1) (out t2) + where + go :: ABT f v (Term f v a) -> ABT f v (Term f v a) -> Bool + go (Var v) (Var v2) | v == v2 = True + go (Cycle t1) (Cycle t2) = t1 == t2 + go (Abs v1 body1) (Abs v2 body2) = + if v1 == v2 + then body1 == body2 + else + let v3 = freshInBoth body1 body2 v1 + in rename v1 v3 body1 == rename v2 v3 body2 + go (Tm f1) (Tm f2) = f1 == f2 + go _ _ = False + +instance + ( forall a. Eq a => Eq (f a), + Foldable f, + Functor f, + forall a. Ord a => Ord (f a), + Var v + ) => + Ord (Term f v a) + where + -- alpha equivalence, works by renaming any aligned Abs ctors to use a common fresh variable + t1 `compare` t2 = go (out t1) (out t2) + where + go :: ABT f v (Term f v a) -> ABT f v (Term f v a) -> Ordering + go (Var v) (Var v2) = v `compare` v2 + go (Cycle t1) (Cycle t2) = t1 `compare` t2 + go (Abs v1 body1) (Abs v2 body2) = + if v1 == v2 + then body1 `compare` body2 + else + let v3 = freshInBoth body1 body2 v1 + in rename v1 v3 body1 `compare` rename v2 v3 body2 + go (Tm f1) (Tm f2) = compare f1 f2 + go t1 t2 = tag t1 `compare` tag t2 + tag (Var _) = 0 :: Word + tag (Tm _) = 1 + tag (Abs _ _) = 2 + tag (Cycle _) = 3 + instance (forall a. Show a => Show (f a), Show v) => Show (Term f v a) where -- annotations not shown showsPrec p (Term _ _ out) = case out of @@ -163,3 +208,73 @@ unabs :: Term f v a -> ([v], Term f v a) unabs (Term _ _ (Abs hd body)) = let (tl, body') = unabs body in (hd : tl, body') unabs t = ([], t) + +-- | Produce a variable which is free in both terms +freshInBoth :: Var v => Term f v a -> Term f v a -> v -> v +freshInBoth t1 t2 = freshIn $ Set.union (freeVars t1) (freeVars t2) + +substsInheritAnnotation :: + (Foldable f, Functor f, Var v) => + [(v, Term f v b)] -> + Term f v a -> + Term f v a +substsInheritAnnotation replacements body = + foldr (uncurry substInheritAnnotation) body (reverse replacements) + +-- Like `subst`, but the annotation of the replacement is inherited from +-- the previous annotation at each replacement point. +substInheritAnnotation :: + (Foldable f, Functor f, Var v) => + v -> + Term f v b -> + Term f v a -> + Term f v a +substInheritAnnotation v r = + subst' (\ann -> const ann <$> r) v (freeVars r) + +-- Slightly generalized version of `subst`, the replacement action is handled +-- by the function `replace`, which is given the annotation `a` at the point +-- of replacement. `r` should be the set of free variables contained in the +-- term returned by `replace`. See `substInheritAnnotation` for an example usage. +subst' :: (Foldable f, Functor f, Var v) => (a -> Term f v a) -> v -> Set v -> Term f v a -> Term f v a +subst' replace v r t2@(Term fvs ann body) + | Set.notMember v fvs = t2 -- subtrees not containing the var can be skipped + | otherwise = case body of + Var v' + | v == v' -> replace ann -- var match; perform replacement + | otherwise -> t2 -- var did not match one being substituted; ignore + Cycle body -> cycle ann (subst' replace v r body) + Abs x _ | x == v -> t2 -- x shadows v; ignore subtree + Abs x e -> abs ann x' e' + where + x' = freshIn (fvs `Set.union` r) x + -- rename x to something that cannot be captured by `r` + e' = + if x /= x' + then subst' replace v r (rename x x' e) + else subst' replace v r e + Tm body -> tm ann (fmap (subst' replace v r) body) + +-- | renames `old` to `new` in the given term, ignoring subtrees that bind `old` +rename :: (Foldable f, Functor f, Var v) => v -> v -> Term f v a -> Term f v a +rename old new t0@(Term fvs ann t) = + if Set.notMember old fvs + then t0 + else case t of + Var v -> if v == old then var ann new else t0 + Cycle body -> cycle ann (rename old new body) + Abs v body -> + -- v shadows old, so skip this subtree + if v == old + then abs ann v body + else -- the rename would capture new, freshen this Abs + -- to make that no longer true, then proceed with + -- renaming `old` to `new` + + if v == new + then + let v' = freshIn (Set.fromList [new, old] <> freeVars body) v + in abs ann v' (rename old new (rename v v' body)) + else -- nothing special, just rename inside body of Abs + abs ann v (rename old new body) + Tm v -> tm ann (fmap (rename old new) v) diff --git a/codebase2/core/U/Core/ABT/Var.hs b/codebase2/core/U/Core/ABT/Var.hs index e3fc21bbf1..3a70eb7363 100644 --- a/codebase2/core/U/Core/ABT/Var.hs +++ b/codebase2/core/U/Core/ABT/Var.hs @@ -1,9 +1,6 @@ module U.Core.ABT.Var where import Data.Set (Set) -import qualified Data.Set as Set -import U.Core.ABT -import Prelude hiding (abs, cycle) -- | A class for avoiding accidental variable capture -- @@ -11,69 +8,3 @@ import Prelude hiding (abs, cycle) -- `freshIn` returns a variable not used in the `Set` class Ord v => Var v where freshIn :: Set v -> v -> v - -substsInheritAnnotation :: - (Foldable f, Functor f, Var v) => - [(v, Term f v b)] -> - Term f v a -> - Term f v a -substsInheritAnnotation replacements body = - foldr (uncurry substInheritAnnotation) body (reverse replacements) - --- Like `subst`, but the annotation of the replacement is inherited from --- the previous annotation at each replacement point. -substInheritAnnotation :: - (Foldable f, Functor f, Var v) => - v -> - Term f v b -> - Term f v a -> - Term f v a -substInheritAnnotation v r = - subst' (\ann -> const ann <$> r) v (freeVars r) - --- Slightly generalized version of `subst`, the replacement action is handled --- by the function `replace`, which is given the annotation `a` at the point --- of replacement. `r` should be the set of free variables contained in the --- term returned by `replace`. See `substInheritAnnotation` for an example usage. -subst' :: (Foldable f, Functor f, Var v) => (a -> Term f v a) -> v -> Set v -> Term f v a -> Term f v a -subst' replace v r t2@(Term fvs ann body) - | Set.notMember v fvs = t2 -- subtrees not containing the var can be skipped - | otherwise = case body of - Var v' - | v == v' -> replace ann -- var match; perform replacement - | otherwise -> t2 -- var did not match one being substituted; ignore - Cycle body -> cycle ann (subst' replace v r body) - Abs x _ | x == v -> t2 -- x shadows v; ignore subtree - Abs x e -> abs ann x' e' - where - x' = freshIn (fvs `Set.union` r) x - -- rename x to something that cannot be captured by `r` - e' = - if x /= x' - then subst' replace v r (rename x x' e) - else subst' replace v r e - Tm body -> tm ann (fmap (subst' replace v r) body) - --- | renames `old` to `new` in the given term, ignoring subtrees that bind `old` -rename :: (Foldable f, Functor f, Var v) => v -> v -> Term f v a -> Term f v a -rename old new t0@(Term fvs ann t) = - if Set.notMember old fvs - then t0 - else case t of - Var v -> if v == old then var ann new else t0 - Cycle body -> cycle ann (rename old new body) - Abs v body -> - -- v shadows old, so skip this subtree - if v == old - then abs ann v body - else -- the rename would capture new, freshen this Abs - -- to make that no longer true, then proceed with - -- renaming `old` to `new` - - if v == new - then - let v' = freshIn (Set.fromList [new, old] <> freeVars body) v - in abs ann v' (rename old new (rename v v' body)) - else -- nothing special, just rename inside body of Abs - abs ann v (rename old new body) - Tm v -> tm ann (fmap (rename old new) v) diff --git a/unison-core/src/Unison/ABT.hs b/unison-core/src/Unison/ABT.hs index e119d102b8..c4ba36a98e 100644 --- a/unison-core/src/Unison/ABT.hs +++ b/unison-core/src/Unison/ABT.hs @@ -95,17 +95,21 @@ import qualified Data.Foldable as Foldable import Data.List hiding (cycle, find) import qualified Data.Map as Map import qualified Data.Set as Set -import Prelude.Extras (Eq1 (..), Ord1 (..)) import U.Core.ABT ( ABT (..), Term (..), foreachSubterm, + freshInBoth, + rename, + subst', + substInheritAnnotation, + substsInheritAnnotation, subterms, transform, transformM, unabs, - visit, visit', + visit, visitPure, vmap, pattern AbsN', @@ -273,30 +277,6 @@ cycler' a vs t = cycle' a $ foldr (absr' a) t vs cycler :: (Functor f, Foldable f, Var v) => [v] -> Term f (V v) () -> Term f (V v) () cycler = cycler' () --- | renames `old` to `new` in the given term, ignoring subtrees that bind `old` -rename :: (Foldable f, Functor f, Var v) => v -> v -> Term f v a -> Term f v a -rename old new t0@(Term fvs ann t) = - if Set.notMember old fvs - then t0 - else case t of - Var v -> if v == old then annotatedVar ann new else t0 - Cycle body -> cycle' ann (rename old new body) - Abs v body -> - -- v shadows old, so skip this subtree - if v == old - then abs' ann v body - else -- the rename would capture new, freshen this Abs - -- to make that no longer true, then proceed with - -- renaming `old` to `new` - - if v == new - then - let v' = freshIn (Set.fromList [new, old] <> freeVars body) v - in abs' ann v' (rename old new (rename v v' body)) - else -- nothing special, just rename inside body of Abs - abs' ann v (rename old new body) - Tm v -> tm' ann (fmap (rename old new) v) - renames :: (Foldable f, Functor f, Var v) => Map v v -> @@ -344,10 +324,6 @@ changeVars m t = case out t of Just v -> annotatedVar (annotation t) v Tm v -> tm' (annotation t) (changeVars m <$> v) --- | Produce a variable which is free in both terms -freshInBoth :: Var v => Term f v a -> Term f v a -> v -> v -freshInBoth t1 t2 = freshIn $ Set.union (freeVars t1) (freeVars t2) - fresh :: Var v => Term f v a -> v -> v fresh t = freshIn (freeVars t) @@ -382,48 +358,6 @@ subst :: Term f v a subst v r = subst' (const r) v (freeVars r) --- Slightly generalized version of `subst`, the replacement action is handled --- by the function `replace`, which is given the annotation `a` at the point --- of replacement. `r` should be the set of free variables contained in the --- term returned by `replace`. See `substInheritAnnotation` for an example usage. -subst' :: (Foldable f, Functor f, Var v) => (a -> Term f v a) -> v -> Set v -> Term f v a -> Term f v a -subst' replace v r t2@(Term fvs ann body) - | Set.notMember v fvs = t2 -- subtrees not containing the var can be skipped - | otherwise = case body of - Var v' - | v == v' -> replace ann -- var match; perform replacement - | otherwise -> t2 -- var did not match one being substituted; ignore - Cycle body -> cycle' ann (subst' replace v r body) - Abs x _ | x == v -> t2 -- x shadows v; ignore subtree - Abs x e -> abs' ann x' e' - where - x' = freshIn (fvs `Set.union` r) x - -- rename x to something that cannot be captured by `r` - e' = - if x /= x' - then subst' replace v r (rename x x' e) - else subst' replace v r e - Tm body -> tm' ann (fmap (subst' replace v r) body) - --- Like `subst`, but the annotation of the replacement is inherited from --- the previous annotation at each replacement point. -substInheritAnnotation :: - (Foldable f, Functor f, Var v) => - v -> - Term f v b -> - Term f v a -> - Term f v a -substInheritAnnotation v r = - subst' (\ann -> const ann <$> r) v (freeVars r) - -substsInheritAnnotation :: - (Foldable f, Functor f, Var v) => - [(v, Term f v b)] -> - Term f v a -> - Term f v a -substsInheritAnnotation replacements body = - foldr (uncurry substInheritAnnotation) body (reverse replacements) - -- | `substs [(t1,v1), (t2,v2), ...] body` performs multiple simultaneous -- substitutions, avoiding capture substs :: @@ -570,40 +504,6 @@ find' :: [Term f v a] find' p = Unison.ABT.find (\t -> if p t then Found t else Continue) -instance (Foldable f, Functor f, Eq1 f, Var v) => Eq (Term f v a) where - -- alpha equivalence, works by renaming any aligned Abs ctors to use a common fresh variable - t1 == t2 = go (out t1) (out t2) - where - go (Var v) (Var v2) | v == v2 = True - go (Cycle t1) (Cycle t2) = t1 == t2 - go (Abs v1 body1) (Abs v2 body2) = - if v1 == v2 - then body1 == body2 - else - let v3 = freshInBoth body1 body2 v1 - in rename v1 v3 body1 == rename v2 v3 body2 - go (Tm f1) (Tm f2) = f1 ==# f2 - go _ _ = False - -instance (Foldable f, Functor f, Ord1 f, Var v) => Ord (Term f v a) where - -- alpha equivalence, works by renaming any aligned Abs ctors to use a common fresh variable - t1 `compare` t2 = go (out t1) (out t2) - where - go (Var v) (Var v2) = v `compare` v2 - go (Cycle t1) (Cycle t2) = t1 `compare` t2 - go (Abs v1 body1) (Abs v2 body2) = - if v1 == v2 - then body1 `compare` body2 - else - let v3 = freshInBoth body1 body2 v1 - in rename v1 v3 body1 `compare` rename v2 v3 body2 - go (Tm f1) (Tm f2) = compare1 f1 f2 - go t1 t2 = tag t1 `compare` tag t2 - tag (Var _) = 0 :: Word - tag (Tm _) = 1 - tag (Abs _ _) = 2 - tag (Cycle _) = 3 - components :: Var v => [(v, Term f v a)] -> [[(v, Term f v a)]] components = Components.components freeVars From a2e57861f73a4c5e5f4bb164836fd5ed736adb33 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simon=20H=C3=B8jberg?= Date: Tue, 5 Jul 2022 16:57:03 -0400 Subject: [PATCH 460/529] Use unison-local-ui over codebase-ui Migrate to use the new Unison Local UI repository from [unison-local-ui](https://github.com/unisonweb/unison-local-ui) instead of [codebase-ui](https://github.com/unisonweb/codebase-ui). --- .github/workflows/pre-release.yaml | 8 ++++---- .github/workflows/release.yaml | 12 ++++++------ README.md | 4 ++-- dev-ui-install.sh | 2 +- 4 files changed, 13 insertions(+), 13 deletions(-) diff --git a/.github/workflows/pre-release.yaml b/.github/workflows/pre-release.yaml index f6f9d808fd..57667e4521 100644 --- a/.github/workflows/pre-release.yaml +++ b/.github/workflows/pre-release.yaml @@ -28,12 +28,12 @@ jobs: - name: build run: stack --no-terminal build --flag unison-parser-typechecker:optimized - - name: fetch latest codebase-ui and package with ucm + - name: fetch latest Unison Local UI and package with ucm run: | mkdir -p /tmp/ucm/ui UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison cp $UCM /tmp/ucm/ucm - wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip + wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/unison-local-ui/releases/download/latest/unisonLocal.zip unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip tar -c -z -f ucm-linux.tar.gz -C /tmp/ucm . @@ -67,12 +67,12 @@ jobs: - name: build run: stack --no-terminal build --flag unison-parser-typechecker:optimized - - name: fetch latest codebase-ui and package with ucm + - name: fetch latest Unison Local UI and package with ucm run: | mkdir -p /tmp/ucm/ui UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison cp $UCM /tmp/ucm/ucm - wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip + wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/unison-local-ui/releases/download/latest/unisonLocal.zip unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip tar -c -z -f ucm-macos.tar.gz -C /tmp/ucm . diff --git a/.github/workflows/release.yaml b/.github/workflows/release.yaml index 5ee1df95f3..53ec8e8f2e 100644 --- a/.github/workflows/release.yaml +++ b/.github/workflows/release.yaml @@ -54,12 +54,12 @@ jobs: - name: build run: stack --no-terminal build --flag unison-parser-typechecker:optimized - - name: fetch latest codebase-ui and package with ucm + - name: fetch latest Unison Local UI and package with ucm run: | mkdir -p /tmp/ucm/ui UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison cp $UCM /tmp/ucm/ucm - wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip + wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/unison-local-ui/releases/download/latest/unisonLocal.zip unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip tar -c -z -f ucm-linux.tar.gz -C /tmp/ucm . @@ -87,12 +87,12 @@ jobs: - name: build run: stack --no-terminal build --flag unison-parser-typechecker:optimized - - name: fetch latest codebase-ui and package with ucm + - name: fetch latest Unison Local UI and package with ucm run: | mkdir -p /tmp/ucm/ui UCM=$(stack path | awk '/local-install-root/{print $2}')/bin/unison cp $UCM /tmp/ucm/ucm - wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip + wget -O/tmp/unisonLocal.zip https://github.com/unisonweb/unison-local-ui/releases/download/latest/unisonLocal.zip unzip -d /tmp/ucm/ui /tmp/unisonLocal.zip tar -c -z -f ucm-macos.tar.gz -C /tmp/ucm . @@ -112,14 +112,14 @@ jobs: - name: build run: stack --no-terminal build --flag unison-parser-typechecker:optimized - - name: fetch latest codebase-ui and package with ucm + - name: fetch latest Unison Local UI and package with ucm # Powershell run: | mkdir -p tmp\ui mkdir -p release\ui $UCM = stack exec -- where unison cp $UCM .\release\ucm.exe - Invoke-WebRequest -Uri https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip -OutFile tmp\unisonLocal.zip + Invoke-WebRequest -Uri https://github.com/unisonweb/unison-local-ui/releases/download/latest/unisonLocal.zip -OutFile tmp\unisonLocal.zip Expand-Archive -Path tmp\unisonLocal.zip -DestinationPath release\ui Compress-Archive -Path .\release\* -DestinationPath ucm-windows.zip diff --git a/README.md b/README.md index 4588e0e8f1..0934093db8 100644 --- a/README.md +++ b/README.md @@ -40,7 +40,7 @@ $ stack --version # we'll want to know this version if you run into trouble $ stack build --fast --test && stack exec unison ``` -To run a local codebase-ui while building from source, you can use the `/dev-ui-install.sh` script. It will download the latest release of the codebase-ui and put it in the expected location for the unison executable created by `stack build`. When you start unison, you'll see a url where the codebase-ui is running. +To run the Unison Local UI while building from source, you can use the `/dev-ui-install.sh` script. It will download the latest release of [unison-local-ui](https://github.com/unisonweb/unison-local-ui) and put it in the expected location for the unison executable created by `stack build`. When you start unison, you'll see a url where Unison Local UI is running. See [`development.markdown`](development.markdown) for a list of build commands you'll likely use during development. @@ -48,7 +48,7 @@ Codebase Server --------------- When `ucm` starts it starts a Codebase web server that is used by the -[Codebase UI](https://github.com/unisonweb/codebase-ui). It selects a random +[Unison Local UI](https://github.com/unisonweb/unison-local-ui). It selects a random port and a unique token that must be used when starting the UI to correctly connect to the server. diff --git a/dev-ui-install.sh b/dev-ui-install.sh index 12417a706e..a9f3d5d64d 100755 --- a/dev-ui-install.sh +++ b/dev-ui-install.sh @@ -4,7 +4,7 @@ echo "executable built by stack." echo "" stack build -curl -L https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip --output unisonLocal.zip +curl -L https://github.com/unisonweb/unison-local-ui/releases/download/latest/unisonLocal.zip --output unisonLocal.zip parent_dir="$(dirname -- $(stack exec which unison))" mkdir -p "$parent_dir/ui" unzip -o unisonLocal.zip -d "$parent_dir/ui" From 5ea90e7811d60a00e43baca24aee8b3a64996e5a Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 5 Jul 2022 15:50:55 -0600 Subject: [PATCH 461/529] WIP - More strict definition by name --- .../U/Codebase/Sqlite/Operations.hs | 32 ++++++++--- .../U/Codebase/Sqlite/Queries.hs | 36 ++++++++----- .../Codebase/SqliteCodebase/Operations.hs | 53 ++++++++++--------- unison-core/src/Unison/NamesWithHistory.hs | 2 +- unison-share-api/src/Unison/Server/Backend.hs | 18 +++---- .../src/Unison/Server/Endpoints/FuzzyFind.hs | 2 +- .../Server/Endpoints/NamespaceDetails.hs | 2 +- 7 files changed, 91 insertions(+), 54 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 67d89e62df..a0c26ffac4 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -64,7 +64,8 @@ module U.Codebase.Sqlite.Operations -- ** name lookup index rebuildNameIndex, - rootBranchNames, + rootNamesByPath, + NamesByPath (..), -- * low-level stuff expectDbBranch, @@ -1030,9 +1031,28 @@ rebuildNameIndex termNames typeNames = do Q.insertTermNames ((fmap (c2sTextReferent *** fmap c2sConstructorType) <$> termNames)) Q.insertTypeNames ((fmap c2sTextReference <$> typeNames)) +data NamesByPath = NamesByPath + { termNamesInPath :: [S.NamedRef (C.Referent, Maybe C.ConstructorType)], + termNamesExternalToPath :: [S.NamedRef (C.Referent, Maybe C.ConstructorType)], + typeNamesInPath :: [S.NamedRef C.Reference], + typeNamesExternalToPath :: [S.NamedRef C.Reference] + } + -- | Get all the term and type names for the root namespace from the lookup table. -rootBranchNames :: Transaction ([S.NamedRef (C.Referent, Maybe C.ConstructorType)], [S.NamedRef C.Reference]) -rootBranchNames = do - termNames <- Q.rootTermNames - typeNames <- Q.rootTypeNames - pure (fmap (bimap s2cTextReferent (fmap s2cConstructorType)) <$> termNames, fmap s2cTextReference <$> typeNames) +rootNamesByPath :: + -- | A relative namespace string, e.g. Just "base.List" + Maybe Text -> + Transaction NamesByPath +rootNamesByPath path = do + (termNamesInPath, termNamesExternalToPath) <- Q.rootTermNamesByPath path + (typeNamesInPath, typeNamesExternalToPath) <- Q.rootTypeNamesByPath path + pure $ + NamesByPath + { termNamesInPath = convertTerms <$> termNamesInPath, + termNamesExternalToPath = convertTerms <$> termNamesExternalToPath, + typeNamesInPath = convertTypes <$> typeNamesInPath, + typeNamesExternalToPath = convertTypes <$> typeNamesExternalToPath + } + where + convertTerms = fmap (bimap s2cTextReferent (fmap s2cConstructorType)) + convertTypes = fmap s2cTextReference diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 42d7b5e045..5257b8ce86 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -127,8 +127,8 @@ module U.Codebase.Sqlite.Queries resetNameLookupTables, insertTermNames, insertTypeNames, - rootTermNames, - rootTypeNames, + rootTermNamesByPath, + rootTypeNamesByPath, getNamespaceDefinitionCount, -- * garbage collection @@ -1495,26 +1495,38 @@ insertTypeNames names = |] -- | Get the list of a term names in the root namespace according to the name lookup index -rootTermNames :: Transaction [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)] -rootTermNames = do - (fmap . fmap) unRow <$> queryListRow_ sql +rootTermNamesByPath :: Maybe Text -> Transaction ([NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)], [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)]) +rootTermNamesByPath mayNamespace = do + let (namespace, subnamespace) = case mayNamespace of + Nothing -> ("", "*") + Just namespace -> (namespace, globEscape namespace <> ".*") + results :: [Only Bool :. NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- queryListRow sql (subnamespace, namespace, subnamespace, namespace) + let (namesInNamespace, namesOutsideNamespace) = span (\(Only inNamespace :. _) -> inNamespace) results + pure (fmap unRow . dropTag <$> namesInNamespace, fmap unRow . dropTag <$> namesOutsideNamespace) where + dropTag (_ :. name) = name unRow (a :. Only b) = (a, b) sql = [here| - SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type FROM term_name_lookup - ORDER BY reversed_name ASC + SELECT namespace GLOB ? OR namespace = ?, reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type FROM term_name_lookup + ORDER BY (namespace GLOB ? OR namespace = ?) DESC |] -- | Get the list of a type names in the root namespace according to the name lookup index -rootTypeNames :: Transaction [NamedRef Reference.TextReference] -rootTypeNames = do - queryListRow_ sql +rootTypeNamesByPath :: Maybe Text -> Transaction ([NamedRef Reference.TextReference], [NamedRef Reference.TextReference]) +rootTypeNamesByPath mayNamespace = do + let (namespace, subnamespace) = case mayNamespace of + Nothing -> ("", "*") + Just namespace -> (namespace, globEscape namespace <> ".*") + results :: [Only Bool :. NamedRef Reference.TextReference] <- queryListRow sql (subnamespace, namespace, subnamespace, namespace) + let (namesInNamespace, namesOutsideNamespace) = span (\(Only inNamespace :. _) -> inNamespace) results + pure (dropTag <$> namesInNamespace, dropTag <$> namesOutsideNamespace) where + dropTag (_ :. name) = name sql = [here| - SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index FROM type_name_lookup - ORDER BY reversed_name ASC + SELECT namespace GLOB ? OR namespace = ?, reversed_name, reference_builtin, reference_component_hash, reference_component_index FROM type_name_lookup + ORDER BY (namespace GLOB ? OR namespace = ?) DESC |] before :: CausalHashId -> CausalHashId -> Transaction Bool diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 6b575bfa71..b110ce1720 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -25,6 +25,7 @@ import qualified U.Codebase.Referent as C.Referent import U.Codebase.Sqlite.DbId (ObjectId) import qualified U.Codebase.Sqlite.NamedRef as S import qualified U.Codebase.Sqlite.ObjectType as OT +import U.Codebase.Sqlite.Operations (NamesByPath (..)) import qualified U.Codebase.Sqlite.Operations as Ops import qualified U.Codebase.Sqlite.Queries as Q import U.Codebase.Sqlite.V2.Decl (saveDeclComponent) @@ -552,29 +553,28 @@ namesAtPath :: Path -> Transaction ScopedNames namesAtPath path = do - (termNames, typeNames) <- Ops.rootBranchNames + let namespace = if path == Path.empty then Nothing else Just $ tShow path + NamesByPath {termNamesInPath, termNamesExternalToPath, typeNamesInPath, typeNamesExternalToPath} <- Ops.rootNamesByPath namespace + let termsInPath = convertTerms termNamesInPath + let typesInPath = convertTypes typeNamesInPath + let termsOutsidePath = convertTerms termNamesExternalToPath + let typesOutsidePath = convertTypes typeNamesExternalToPath let allTerms :: [(Name, Referent.Referent)] - allTerms = - termNames <&> \(S.NamedRef {reversedSegments, ref = (ref, ct)}) -> - let v1ref = runIdentity $ Cv.referent2to1 (const . pure . Cv.constructorType2to1 . fromMaybe (error "Required constructor type for constructor but it was null") $ ct) ref - in (Name.fromReverseSegments (coerce reversedSegments), v1ref) + allTerms = termsInPath <> termsOutsidePath let allTypes :: [(Name, Reference.Reference)] - allTypes = - typeNames <&> \(S.NamedRef {reversedSegments, ref}) -> - (Name.fromReverseSegments (coerce reversedSegments), Cv.reference2to1 ref) + allTypes = typesInPath <> typesOutsidePath let rootTerms = Rel.fromList allTerms let rootTypes = Rel.fromList allTypes let absoluteRootNames = Names {terms = rootTerms, types = rootTypes} - let (relativeScopedNames, absoluteExternalNames) = + let absoluteExternalNames = Names {terms = Rel.fromList termsOutsidePath, types = Rel.fromList typesOutsidePath} + let relativeScopedNames = case path of - Path.Empty -> (absoluteRootNames, mempty) + Path.Empty -> (absoluteRootNames) p -> let reversedPathSegments = reverse . Path.toList $ p - (relativeTerms, externalTerms) = foldMap (partitionByPathPrefix reversedPathSegments) allTerms - (relativeTypes, externalTypes) = foldMap (partitionByPathPrefix reversedPathSegments) allTypes - in ( Names {terms = Rel.fromList relativeTerms, types = Rel.fromList relativeTypes}, - Names {terms = Rel.fromList externalTerms, types = Rel.fromList externalTypes} - ) + relativeTerms = stripPathPrefix reversedPathSegments <$> termsInPath + relativeTypes = stripPathPrefix reversedPathSegments <$> typesInPath + in (Names {terms = Rel.fromList relativeTerms, types = Rel.fromList relativeTypes}) pure $ ScopedNames { absoluteExternalNames, @@ -582,18 +582,23 @@ namesAtPath path = do absoluteRootNames } where + convertTypes names = + names <&> \(S.NamedRef {reversedSegments, ref}) -> + (Name.fromReverseSegments (coerce reversedSegments), Cv.reference2to1 ref) + convertTerms names = + names <&> \(S.NamedRef {reversedSegments, ref = (ref, ct)}) -> + let v1ref = runIdentity $ Cv.referent2to1 (const . pure . Cv.constructorType2to1 . fromMaybe (error "Required constructor type for constructor but it was null") $ ct) ref + in (Name.fromReverseSegments (coerce reversedSegments), v1ref) + -- If the given prefix matches the given name, the prefix is stripped and it's collected -- on the left, otherwise it's left as-is and collected on the right. - -- >>> partitionByPathPrefix ["b", "a"] ("a.b.c", ()) - -- ([(c,())],[]) - -- - -- >>> partitionByPathPrefix ["y", "x"] ("a.b.c", ()) - -- ([],[(a.b.c,())]) - partitionByPathPrefix :: [NameSegment] -> (Name, r) -> ([(Name, r)], [(Name, r)]) - partitionByPathPrefix reversedPathSegments (n, ref) = + -- >>> stripPathPrefix ["b", "a"] ("a.b.c", ()) + -- ([(c,())]) + stripPathPrefix :: [NameSegment] -> (Name, r) -> (Name, r) + stripPathPrefix reversedPathSegments (n, ref) = case Name.stripReversedPrefix n reversedPathSegments of - Nothing -> (mempty, [(n, ref)]) - Just stripped -> ([(Name.makeRelative stripped, ref)], mempty) + Nothing -> error $ "Expected name to be in namespace" <> show (n, reverse reversedPathSegments) + Just stripped -> (Name.makeRelative stripped, ref) -- | Update the root namespace names index which is used by the share server for serving api -- requests. diff --git a/unison-core/src/Unison/NamesWithHistory.hs b/unison-core/src/Unison/NamesWithHistory.hs index 31e3621cb3..3c727208c5 100644 --- a/unison-core/src/Unison/NamesWithHistory.hs +++ b/unison-core/src/Unison/NamesWithHistory.hs @@ -274,7 +274,7 @@ suffixedTermName :: Int -> Referent -> NamesWithHistory -> [HQ'.HashQualified Na isHQ'd = R.manyDom fqn rel -- it is conflicted hq n = HQ'.take length (hq' n r) hqn = if isHQ'd then hq n' else HQ'.fromName n' - in (isHQ'd, Name.countSegments fqn, Name.isAbsolute n', hqn) + in (isHQ'd, Name.countSegments n', Name.isAbsolute n', hqn) -- Set HashQualified -> Branch m -> Action' m v Names -- Set HashQualified -> Branch m -> Free (Command m i v) Names diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index d2de690443..bf6c554260 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -160,9 +160,9 @@ suffixifyNames hashLength names = PPE.suffixifiedPPE . PPE.fromNamesDecl hashLength $ NamesWithHistory.fromCurrentNames names -- implementation detail of parseNamesForBranch and prettyNamesForBranch -prettyAndParseNamesForBranch :: Branch m -> NameScoping -> (Names, Names) +prettyAndParseNamesForBranch :: Branch m -> NameScoping -> (Names, Names, Names) prettyAndParseNamesForBranch root scope = - (parseNames0, prettyPrintNames0) + (parseNames0, prettyPrintNames0, currentPathNames) where path :: Path includeAllNames :: Bool @@ -199,10 +199,10 @@ basicSuffixifiedNames hashLength root nameScope = in suffixifyNames hashLength names0 parseNamesForBranch :: Branch m -> NameScoping -> Names -parseNamesForBranch root = fst . prettyAndParseNamesForBranch root +parseNamesForBranch root = prettyAndParseNamesForBranch root <&> \(n, _, _) -> n prettyNamesForBranch :: Branch m -> NameScoping -> Names -prettyNamesForBranch root = snd . prettyAndParseNamesForBranch root +prettyNamesForBranch root = prettyAndParseNamesForBranch root <&> \(_, n, _) -> n shallowPPE :: Monad m => Codebase m v a -> V2Branch.Branch m -> m PPE.PrettyPrintEnv shallowPPE codebase b = do @@ -818,9 +818,9 @@ prettyDefinitionsBySuffixes :: Backend IO DefinitionDisplayResults prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase query = do hqLength <- lift $ Codebase.hashLength codebase - (_parseNames, printNames) <- scopedNamesForBranchHash codebase root path + (_parseNames, printNames, localNamesOnly) <- scopedNamesForBranchHash codebase root path let nameSearch :: NameSearch - nameSearch = makeNameSearch hqLength (NamesWithHistory.fromCurrentNames printNames) + nameSearch = makeNameSearch hqLength (NamesWithHistory.fromCurrentNames localNamesOnly) DefinitionResults terms types misses <- lift (definitionsBySuffixes codebase nameSearch DontIncludeCycles query) -- We might like to make sure that the user search terms get used as @@ -1070,7 +1070,7 @@ bestNameForType ppe width = . TypePrinter.pretty0 @v ppe mempty (-1) . Type.ref () -scopedNamesForBranchHash :: forall m v a. Monad m => Codebase m v a -> Maybe (Branch.CausalHash) -> Path -> Backend m (Names, Names) +scopedNamesForBranchHash :: forall m v a. Monad m => Codebase m v a -> Maybe (Branch.CausalHash) -> Path -> Backend m (Names, Names, Names) scopedNamesForBranchHash codebase mbh path = do shouldUseNamesIndex <- asks useNamesIndex case mbh of @@ -1085,10 +1085,10 @@ scopedNamesForBranchHash codebase mbh path = do then indexPrettyAndParseNames else flip prettyAndParseNamesForBranch (AllNames path) <$> resolveCausalHash (Just bh) codebase where - indexPrettyAndParseNames :: Backend m (Names, Names) + indexPrettyAndParseNames :: Backend m (Names, Names, Names) indexPrettyAndParseNames = do names <- lift $ Codebase.namesAtPath codebase path - pure (ScopedNames.parseNames names, ScopedNames.prettyNames names) + pure (ScopedNames.parseNames names, Names.minimalUniqueSuffix $ ScopedNames.prettyNames names, ScopedNames.namesAtPath names) resolveCausalHash :: Monad m => Maybe (Branch.CausalHash) -> Codebase m v a -> Backend m (Branch m) diff --git a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs index 8cd79dd433..7d29a24785 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs @@ -142,7 +142,7 @@ serveFuzzyFind codebase mayRoot relativePath limit typeWidth query = <$> traverse (parsePath . Text.unpack) relativePath hashLength <- lift $ Codebase.hashLength codebase rootHash <- traverse (Backend.expandShortBranchHash codebase) mayRoot - (_parseNames, prettyNames) <- Backend.scopedNamesForBranchHash codebase rootHash rel + (_parseNames, prettyNames, _localNamesOnly) <- Backend.scopedNamesForBranchHash codebase rootHash rel let alignments :: ( [ ( FZF.Alignment, UnisonName, diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs index dc13c32f0e..1eca472703 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs @@ -96,7 +96,7 @@ namespaceDetails runtime codebase namespaceName maySBH mayWidth = namespaceCausal <- Backend.getShallowCausalAtPathFromRootHash codebase mayRootHash namespacePath shallowBranch <- lift $ V2Causal.value namespaceCausal namespaceDetails <- do - (_parseNames, printNames) <- Backend.scopedNamesForBranchHash codebase mayRootHash namespacePath + (_parseNames, printNames, _localNamesOnly) <- Backend.scopedNamesForBranchHash codebase mayRootHash namespacePath readme <- Backend.findShallowReadmeInBranchAndRender width From 5982fc20110622ceef42b639ccfd54f3b4b71894 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 5 Jul 2022 17:41:08 -0600 Subject: [PATCH 462/529] Add escapes for "LIKE" (#3170) * Add escapes for "LIKE" * Cleanup --- .../U/Codebase/Sqlite/Queries.hs | 34 ++++++++++++++++--- 1 file changed, 30 insertions(+), 4 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 42d7b5e045..e3abddbe97 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -1338,26 +1338,26 @@ getDependencyIdsForDependent dependent@(C.Reference.Id oid0 _) = oid0 /= oid1 objectIdByBase32Prefix :: ObjectType -> Text -> Transaction [ObjectId] -objectIdByBase32Prefix objType prefix = queryListCol sql (objType, prefix <> "%") where sql = [here| +objectIdByBase32Prefix objType prefix = queryListCol sql (objType, likeEscape '\\' prefix <> "%") where sql = [here| SELECT object.id FROM object INNER JOIN hash_object ON hash_object.object_id = object.id INNER JOIN hash ON hash_object.hash_id = hash.id WHERE object.type_id = ? - AND hash.base32 LIKE ? + AND hash.base32 LIKE ? ESCAPE '\' |] causalHashIdByBase32Prefix :: Text -> Transaction [CausalHashId] causalHashIdByBase32Prefix prefix = queryListCol sql (Only $ prefix <> "%") where sql = [here| SELECT self_hash_id FROM causal INNER JOIN hash ON id = self_hash_id - WHERE base32 LIKE ? + WHERE base32 LIKE ? ESCAPE '\' |] namespaceHashIdByBase32Prefix :: Text -> Transaction [BranchHashId] namespaceHashIdByBase32Prefix prefix = queryListCol sql (Only $ prefix <> "%") where sql = [here| SELECT value_hash_id FROM causal INNER JOIN hash ON id = value_hash_id - WHERE base32 LIKE ? + WHERE base32 LIKE ? ESCAPE '\' |] -- | Finds all causals that refer to a branch for which we don't have an object stored. @@ -1466,6 +1466,32 @@ globEscape = ']' -> "[]]" c -> Text.singleton c +-- | Escape special characters for "LIKE" matches. +-- +-- Prepared statements prevent sql injection, but it's still possible some user +-- may be able to craft a query using a fake "hash" that would let them see more than they +-- ought to. +-- +-- You still need to provide the escape char in the sql query, E.g. +-- +-- @@ +-- SELECT * FROM table +-- WHERE txt LIKE ? ESCAPE '\' +-- @@ +-- +-- >>> likeEscape '\\' "Nat.%" +-- "Nat.\%" +likeEscape :: Char -> Text -> Text +likeEscape '%' _ = error "Can't use % or _ as escape characters" +likeEscape '_' _ = error "Can't use % or _ as escape characters" +likeEscape escapeChar pat = + flip Text.concatMap pat \case + '%' -> Text.pack [escapeChar, '%'] + '_' -> Text.pack [escapeChar, '_'] + c + | c == escapeChar -> Text.pack [escapeChar, escapeChar] + | otherwise -> Text.singleton c + -- | Gets the count of all definitions within the given namespace. -- NOTE: This requires a working name lookup index. getNamespaceDefinitionCount :: Text -> Transaction Int From a875ec0dbb719501ae40ede8095977de069f2877 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 5 Jul 2022 20:00:09 -0400 Subject: [PATCH 463/529] make codebase object thread-safe --- parser-typechecker/src/Unison/Codebase.hs | 12 +- .../src/Unison/Codebase/SqliteCodebase.hs | 690 ++++++++++-------- .../src/Unison/Codebase/Type.hs | 13 +- .../Unison/Codebase/Editor/HandleCommand.hs | 4 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 80 +- 5 files changed, 428 insertions(+), 371 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index f968dbbb0f..f6f97cb3a4 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -90,8 +90,10 @@ module Unison.Codebase CodebasePath, SyncToDir, - -- * Sqlite escape hatch - connection, + -- * Direct codebase access + runTransaction, + withConnection, + withConnectionIO, -- * Misc (organize these better) addDefsToCodebase, @@ -154,6 +156,12 @@ import qualified Unison.UnisonFile as UF import qualified Unison.Util.Relation as Rel import Unison.Var (Var) import qualified Unison.WatchKind as WK +import qualified Unison.Sqlite as Sqlite + +-- | Run a transaction on a codebase. +runTransaction :: MonadIO m => Codebase m v a -> Sqlite.Transaction b -> m b +runTransaction Codebase{withConnection} action = + withConnection \conn -> Sqlite.runTransaction conn action -- | Get the shallow representation of the root branches without loading the children or -- history. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 4aae8f20f9..5b973478a1 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -56,6 +56,7 @@ import qualified Unison.Codebase.Init as Codebase import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1 import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase1 import Unison.Codebase.Patch (Patch) +import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Reflog as Reflog import Unison.Codebase.ShortBranchHash (ShortBranchHash) import qualified Unison.Codebase.SqliteCodebase.Branch.Dependencies as BD @@ -70,6 +71,7 @@ import Unison.Codebase.Type (LocalOrRemote (..), PushGitBranchOpts (..)) import qualified Unison.Codebase.Type as C import Unison.DataDeclaration (Decl) import Unison.Hash (Hash) +import Unison.Names.Scoped (ScopedNames) import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Reference (Reference) @@ -195,321 +197,377 @@ sqliteCodebase :: ((Codebase m Symbol Ann, Sqlite.Connection) -> m r) -> m (Either Codebase1.OpenCodebaseError r) sqliteCodebase debugName root localOrRemote action = do - Monad.when debug $ traceM $ "sqliteCodebase " ++ debugName ++ " " ++ root - withConnection debugName root \conn -> do - termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable - typeOfTermCache <- Cache.semispaceCache 8192 - declCache <- Cache.semispaceCache 1024 - rootBranchCache <- newTVarIO Nothing - getDeclType <- CodebaseOps.mkGetDeclType - -- The v1 codebase interface has operations to read and write individual definitions - -- whereas the v2 codebase writes them as complete components. These two fields buffer - -- the individual definitions until a complete component has been written. - termBuffer :: TVar (Map Hash CodebaseOps.TermBufferEntry) <- newTVarIO Map.empty - declBuffer :: TVar (Map Hash CodebaseOps.DeclBufferEntry) <- newTVarIO Map.empty - let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann)) - getTerm id = - Sqlite.runTransaction conn (CodebaseOps.getTerm getDeclType id) - - getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann)) - getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined - getTypeOfTermImpl id = - Sqlite.runTransaction conn (CodebaseOps.getTypeOfTermImpl id) - - getTermComponentWithTypes :: Hash -> m (Maybe [(Term Symbol Ann, Type Symbol Ann)]) - getTermComponentWithTypes h = - Sqlite.runTransaction conn (CodebaseOps.getTermComponentWithTypes getDeclType h) - - getTypeDeclaration :: Reference.Id -> m (Maybe (Decl Symbol Ann)) - getTypeDeclaration id = - Sqlite.runTransaction conn (CodebaseOps.getTypeDeclaration id) - - getDeclComponent :: Hash -> m (Maybe [Decl Symbol Ann]) - getDeclComponent h = - Sqlite.runTransaction conn (CodebaseOps.getDeclComponent h) - - getCycleLength :: Hash -> m (Maybe Reference.CycleSize) - getCycleLength h = - Sqlite.runTransaction conn (CodebaseOps.getCycleLength h) - - -- putTermComponent :: MonadIO m => Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> m () - -- putTerms :: MonadIO m => Map Reference.Id (Term Symbol Ann, Type Symbol Ann) -> m () -- dies horribly if missing dependencies? - - -- option 1: tweak putTerm to incrementally notice the cycle length until each component is full - -- option 2: switch codebase interface from putTerm to putTerms -- buffering can be local to the function - -- option 3: switch from putTerm to putTermComponent -- needs to buffer dependencies non-locally (or require application to manage + die horribly) - - putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m () - putTerm id tm tp | debug && trace ("SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined - putTerm id tm tp = - Sqlite.runTransaction conn (CodebaseOps.putTerm termBuffer declBuffer id tm tp) - - putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> m () - putTypeDeclaration id decl = - Sqlite.runTransaction conn (CodebaseOps.putTypeDeclaration termBuffer declBuffer id decl) - - getRootBranchHash :: MonadIO m => m V2Branch.CausalHash - getRootBranchHash = do - Sqlite.runReadOnlyTransaction conn \run -> - run Ops.expectRootCausalHash - - getShallowBranchForHash :: MonadIO m => V2Branch.CausalHash -> m (V2Branch.CausalBranch m) - getShallowBranchForHash bh = - Sqlite.runReadOnlyTransaction conn \run -> do - V2Branch.hoistCausalBranch run <$> run (Ops.expectCausalBranchByCausalHash bh) - - getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> m (Branch m) - getRootBranch rootBranchCache = - Sqlite.runReadOnlyTransaction conn \run -> - Branch.transform run <$> run (CodebaseOps.getRootBranch getDeclType rootBranchCache) - - getRootBranchExists :: m Bool - getRootBranchExists = - Sqlite.runTransaction conn CodebaseOps.getRootBranchExists - - putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> Branch m -> m () - putRootBranch rootBranchCache branch1 = do - withRunInIO \runInIO -> do - Sqlite.runTransaction conn do - CodebaseOps.putRootBranch rootBranchCache (Branch.transform (Sqlite.unsafeIO . runInIO) branch1) - - rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.CausalHash)) - rootBranchUpdates _rootBranchCache = do - -- branchHeadChanges <- TQueue.newIO - -- (cancelWatch, watcher) <- Watch.watchDirectory' (v2dir root) - -- watcher1 <- - -- liftIO . forkIO - -- $ forever - -- $ do - -- -- void ignores the name and time of the changed file, - -- -- and assume 'unison.sqlite3' has changed - -- (filename, time) <- watcher - -- traceM $ "SqliteCodebase.watcher " ++ show (filename, time) - -- readTVarIO rootBranchCache >>= \case - -- Nothing -> pure () - -- Just (v, _) -> do - -- -- this use of `conn` in a separate thread may be problematic. - -- -- hopefully sqlite will produce an obvious error message if it is. - -- v' <- runDB conn Ops.dataVersion - -- if v /= v' then - -- atomically - -- . TQueue.enqueue branchHeadChanges =<< runDB conn Ops.loadRootCausalHash - -- else pure () - - -- -- case hashFromFilePath filePath of - -- -- Nothing -> failWith $ CantParseBranchHead filePath - -- -- Just h -> - -- -- atomically . TQueue.enqueue branchHeadChanges $ Branch.CausalHash h - -- -- smooth out intermediate queue - -- pure - -- ( cancelWatch >> killThread watcher1 - -- , Set.fromList <$> Watch.collectUntilPause branchHeadChanges 400000 - -- ) - pure (cleanup, liftIO newRootsDiscovered) - where - newRootsDiscovered = do - Control.Concurrent.threadDelay maxBound -- hold off on returning - pure mempty -- returning nothing - cleanup = pure () - - -- if this blows up on cromulent hashes, then switch from `hashToHashId` - -- to one that returns Maybe. - getBranchForHash :: Branch.CausalHash -> m (Maybe (Branch m)) - getBranchForHash h = - Sqlite.runReadOnlyTransaction conn \run -> - fmap (Branch.transform run) <$> run (CodebaseOps.getBranchForHash getDeclType h) - - putBranch :: Branch m -> m () - putBranch branch = - withRunInIO \runInIO -> - Sqlite.runTransaction conn (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch)) - - isCausalHash :: Branch.CausalHash -> m Bool - isCausalHash h = - Sqlite.runTransaction conn (CodebaseOps.isCausalHash h) - - getPatch :: Branch.EditHash -> m (Maybe Patch) - getPatch h = - Sqlite.runTransaction conn (CodebaseOps.getPatch h) - - putPatch :: Branch.EditHash -> Patch -> m () - putPatch h p = - Sqlite.runTransaction conn (CodebaseOps.putPatch h p) - - patchExists :: Branch.EditHash -> m Bool - patchExists h = - Sqlite.runTransaction conn (CodebaseOps.patchExists h) - - dependentsImpl :: Reference -> m (Set Reference.Id) - dependentsImpl r = - Sqlite.runTransaction conn (CodebaseOps.dependentsImpl r) - - dependentsOfComponentImpl :: Hash -> m (Set Reference.Id) - dependentsOfComponentImpl h = - Sqlite.runTransaction conn (CodebaseOps.dependentsOfComponentImpl h) - - syncFromDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m () - syncFromDirectory srcRoot _syncMode b = do - withConnection (debugName ++ ".sync.src") srcRoot $ \srcConn -> do - progressStateRef <- liftIO (newIORef emptySyncProgressState) - Sqlite.runReadOnlyTransaction srcConn \runSrc -> - Sqlite.runWriteTransaction conn \runDest -> do - syncInternal (syncProgress progressStateRef) runSrc runDest b - - syncToDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m () - syncToDirectory destRoot _syncMode b = - withConnection (debugName ++ ".sync.dest") destRoot $ \destConn -> do - progressStateRef <- liftIO (newIORef emptySyncProgressState) - initSchemaIfNotExist destRoot - Sqlite.runReadOnlyTransaction conn \runSrc -> - Sqlite.runWriteTransaction destConn \runDest -> do - syncInternal (syncProgress progressStateRef) runSrc runDest b - - watches :: UF.WatchKind -> m [Reference.Id] - watches w = - Sqlite.runTransaction conn (CodebaseOps.watches w) - - getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann)) - getWatch k r = - Sqlite.runTransaction conn (CodebaseOps.getWatch getDeclType k r) - - putWatch :: UF.WatchKind -> Reference.Id -> Term Symbol Ann -> m () - putWatch k r tm = - Sqlite.runTransaction conn (CodebaseOps.putWatch k r tm) - - clearWatches :: m () - clearWatches = - Sqlite.runTransaction conn CodebaseOps.clearWatches - - getReflog :: m [Reflog.Entry Branch.CausalHash] - getReflog = - liftIO $ - ( do - contents <- TextIO.readFile (reflogPath root) - let lines = Text.lines contents - let entries = parseEntry <$> lines - pure entries - ) - `catchIO` const (pure []) - where - parseEntry t = fromMaybe (err t) (Reflog.fromText t) - err t = - error $ - "I couldn't understand this line in " ++ reflogPath root ++ "\n\n" - ++ Text.unpack t - - appendReflog :: Text -> Branch m -> Branch m -> m () - appendReflog reason old new = - liftIO $ TextIO.appendFile (reflogPath root) (t <> "\n") - where - t = Reflog.toText $ Reflog.Entry (Branch.headHash old) (Branch.headHash new) reason - - reflogPath :: CodebasePath -> FilePath - reflogPath root = root "reflog" - - termsOfTypeImpl :: Reference -> m (Set Referent.Id) - termsOfTypeImpl r = - Sqlite.runTransaction conn (CodebaseOps.termsOfTypeImpl getDeclType r) - - termsMentioningTypeImpl :: Reference -> m (Set Referent.Id) - termsMentioningTypeImpl r = - Sqlite.runTransaction conn (CodebaseOps.termsMentioningTypeImpl getDeclType r) - - hashLength :: m Int - hashLength = - Sqlite.runTransaction conn CodebaseOps.hashLength - - branchHashLength :: m Int - branchHashLength = - Sqlite.runTransaction conn CodebaseOps.branchHashLength - - termReferencesByPrefix :: ShortHash -> m (Set Reference.Id) - termReferencesByPrefix sh = - Sqlite.runTransaction conn (CodebaseOps.termReferencesByPrefix sh) - - declReferencesByPrefix :: ShortHash -> m (Set Reference.Id) - declReferencesByPrefix sh = - Sqlite.runTransaction conn (CodebaseOps.declReferencesByPrefix sh) - - referentsByPrefix :: ShortHash -> m (Set Referent.Id) - referentsByPrefix sh = - Sqlite.runTransaction conn (CodebaseOps.referentsByPrefix getDeclType sh) - - branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.CausalHash) - branchHashesByPrefix sh = - Sqlite.runTransaction conn (CodebaseOps.branchHashesByPrefix sh) - - sqlLca :: Branch.CausalHash -> Branch.CausalHash -> m (Maybe (Branch.CausalHash)) - sqlLca h1 h2 = - Sqlite.runTransaction conn (CodebaseOps.sqlLca h1 h2) - let codebase = - C.Codebase - { getTerm = (Cache.applyDefined termCache getTerm), - getTypeOfTermImpl = (Cache.applyDefined typeOfTermCache getTypeOfTermImpl), - getTypeDeclaration = (Cache.applyDefined declCache getTypeDeclaration), - getDeclType = \r -> Sqlite.runReadOnlyTransaction conn \run -> run (getDeclType r), - putTerm = putTerm, - putTypeDeclaration = putTypeDeclaration, - getTermComponentWithTypes = getTermComponentWithTypes, - getDeclComponent = getDeclComponent, - getComponentLength = getCycleLength, - getRootBranch = (getRootBranch rootBranchCache), - getRootBranchHash = getRootBranchHash, - getRootBranchExists = getRootBranchExists, - putRootBranch = (putRootBranch rootBranchCache), - rootBranchUpdates = (rootBranchUpdates rootBranchCache), - getShallowBranchForHash = getShallowBranchForHash, - getBranchForHashImpl = getBranchForHash, - putBranch = putBranch, - branchExists = isCausalHash, - getPatch = getPatch, - putPatch = putPatch, - patchExists = patchExists, - dependentsImpl = dependentsImpl, - dependentsOfComponentImpl = dependentsOfComponentImpl, - syncFromDirectory = syncFromDirectory, - syncToDirectory = syncToDirectory, - viewRemoteBranch' = viewRemoteBranch', - pushGitBranch = pushGitBranch conn, - watches = watches, - getWatch = getWatch, - putWatch = putWatch, - clearWatches = clearWatches, - getReflog = getReflog, - appendReflog = appendReflog, - termsOfTypeImpl = termsOfTypeImpl, - termsMentioningTypeImpl = termsMentioningTypeImpl, - hashLength = hashLength, - termReferencesByPrefix = termReferencesByPrefix, - typeReferencesByPrefix = declReferencesByPrefix, - termReferentsByPrefix = referentsByPrefix, - branchHashLength = branchHashLength, - branchHashesByPrefix = branchHashesByPrefix, - lcaImpl = (Just sqlLca), - beforeImpl = (Just \l r -> Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r), - namesAtPath = \path -> Sqlite.runReadOnlyTransaction conn \runTx -> - runTx (CodebaseOps.namesAtPath path), - updateNameLookup = Sqlite.runTransaction conn (CodebaseOps.updateNameLookupIndexFromV2Root getDeclType), - connection = conn, - withConnection = withConnection debugName root - } - let finalizer :: MonadIO m => m () - finalizer = do - decls <- readTVarIO declBuffer - terms <- readTVarIO termBuffer - let printBuffer header b = - liftIO - if b /= mempty - then putStrLn header >> putStrLn "" >> print b - else pure () - printBuffer "Decls:" decls - printBuffer "Terms:" terms - - flip finally finalizer $ do - -- Migrate if necessary. - ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer conn >>= \case - Left err -> pure $ Left err - Right () -> Right <$> action (codebase, conn) + termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable + typeOfTermCache <- Cache.semispaceCache 8192 + declCache <- Cache.semispaceCache 1024 + rootBranchCache <- newTVarIO Nothing + getDeclType <- CodebaseOps.mkGetDeclType + -- The v1 codebase interface has operations to read and write individual definitions + -- whereas the v2 codebase writes them as complete components. These two fields buffer + -- the individual definitions until a complete component has been written. + termBuffer :: TVar (Map Hash CodebaseOps.TermBufferEntry) <- newTVarIO Map.empty + declBuffer :: TVar (Map Hash CodebaseOps.DeclBufferEntry) <- newTVarIO Map.empty + + let finalizer :: MonadIO m => m () + finalizer = do + decls <- readTVarIO declBuffer + terms <- readTVarIO termBuffer + let printBuffer header b = + liftIO + if b /= mempty + then putStrLn header >> putStrLn "" >> print b + else pure () + printBuffer "Decls:" decls + printBuffer "Terms:" terms + + flip finally finalizer do + -- Migrate if necessary. + result <- + withConn \conn -> + ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer conn + + case result of + Left err -> pure $ Left err + Right () -> do + let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann)) + getTerm id = + withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getTerm getDeclType id) + + getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann)) + getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined + getTypeOfTermImpl id = + withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getTypeOfTermImpl id) + + getTermComponentWithTypes :: Hash -> m (Maybe [(Term Symbol Ann, Type Symbol Ann)]) + getTermComponentWithTypes h = + withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getTermComponentWithTypes getDeclType h) + + getTypeDeclaration :: Reference.Id -> m (Maybe (Decl Symbol Ann)) + getTypeDeclaration id = + withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getTypeDeclaration id) + + getDeclComponent :: Hash -> m (Maybe [Decl Symbol Ann]) + getDeclComponent h = + withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getDeclComponent h) + + getCycleLength :: Hash -> m (Maybe Reference.CycleSize) + getCycleLength h = + withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getCycleLength h) + + -- putTermComponent :: MonadIO m => Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> m () + -- putTerms :: MonadIO m => Map Reference.Id (Term Symbol Ann, Type Symbol Ann) -> m () -- dies horribly if missing dependencies? + + -- option 1: tweak putTerm to incrementally notice the cycle length until each component is full + -- option 2: switch codebase interface from putTerm to putTerms -- buffering can be local to the function + -- option 3: switch from putTerm to putTermComponent -- needs to buffer dependencies non-locally (or require application to manage + die horribly) + + putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m () + putTerm id tm tp | debug && trace ("SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined + putTerm id tm tp = + withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.putTerm termBuffer declBuffer id tm tp) + + putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> m () + putTypeDeclaration id decl = + withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.putTypeDeclaration termBuffer declBuffer id decl) + + getRootBranchHash :: MonadIO m => m V2Branch.CausalHash + getRootBranchHash = do + withConn \conn -> + Sqlite.runReadOnlyTransaction conn \run -> + run Ops.expectRootCausalHash + + getShallowBranchForHash :: MonadIO m => V2Branch.CausalHash -> m (V2Branch.CausalBranch m) + getShallowBranchForHash bh = + withConn \conn -> + Sqlite.runReadOnlyTransaction conn \run -> do + V2Branch.hoistCausalBranch run <$> run (Ops.expectCausalBranchByCausalHash bh) + + getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> m (Branch m) + getRootBranch rootBranchCache = + withConn \conn -> + Sqlite.runReadOnlyTransaction conn \run -> + Branch.transform run <$> run (CodebaseOps.getRootBranch getDeclType rootBranchCache) + + getRootBranchExists :: m Bool + getRootBranchExists = + withConn \conn -> + Sqlite.runTransaction conn CodebaseOps.getRootBranchExists + + putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> Branch m -> m () + putRootBranch rootBranchCache branch1 = do + withConn \conn -> + withRunInIO \runInIO -> do + Sqlite.runTransaction conn do + CodebaseOps.putRootBranch rootBranchCache (Branch.transform (Sqlite.unsafeIO . runInIO) branch1) + + rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.CausalHash)) + rootBranchUpdates _rootBranchCache = do + -- branchHeadChanges <- TQueue.newIO + -- (cancelWatch, watcher) <- Watch.watchDirectory' (v2dir root) + -- watcher1 <- + -- liftIO . forkIO + -- $ forever + -- $ do + -- -- void ignores the name and time of the changed file, + -- -- and assume 'unison.sqlite3' has changed + -- (filename, time) <- watcher + -- traceM $ "SqliteCodebase.watcher " ++ show (filename, time) + -- readTVarIO rootBranchCache >>= \case + -- Nothing -> pure () + -- Just (v, _) -> do + -- -- this use of `conn` in a separate thread may be problematic. + -- -- hopefully sqlite will produce an obvious error message if it is. + -- v' <- runDB conn Ops.dataVersion + -- if v /= v' then + -- atomically + -- . TQueue.enqueue branchHeadChanges =<< runDB conn Ops.loadRootCausalHash + -- else pure () + + -- -- case hashFromFilePath filePath of + -- -- Nothing -> failWith $ CantParseBranchHead filePath + -- -- Just h -> + -- -- atomically . TQueue.enqueue branchHeadChanges $ Branch.CausalHash h + -- -- smooth out intermediate queue + -- pure + -- ( cancelWatch >> killThread watcher1 + -- , Set.fromList <$> Watch.collectUntilPause branchHeadChanges 400000 + -- ) + pure (cleanup, liftIO newRootsDiscovered) + where + newRootsDiscovered = do + Control.Concurrent.threadDelay maxBound -- hold off on returning + pure mempty -- returning nothing + cleanup = pure () + + -- if this blows up on cromulent hashes, then switch from `hashToHashId` + -- to one that returns Maybe. + getBranchForHash :: Branch.CausalHash -> m (Maybe (Branch m)) + getBranchForHash h = + withConn \conn -> + Sqlite.runReadOnlyTransaction conn \run -> + fmap (Branch.transform run) <$> run (CodebaseOps.getBranchForHash getDeclType h) + + putBranch :: Branch m -> m () + putBranch branch = + withConn \conn -> + withRunInIO \runInIO -> + Sqlite.runTransaction conn (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch)) + + isCausalHash :: Branch.CausalHash -> m Bool + isCausalHash h = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.isCausalHash h) + + getPatch :: Branch.EditHash -> m (Maybe Patch) + getPatch h = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.getPatch h) + + putPatch :: Branch.EditHash -> Patch -> m () + putPatch h p = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.putPatch h p) + + patchExists :: Branch.EditHash -> m Bool + patchExists h = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.patchExists h) + + dependentsImpl :: Reference -> m (Set Reference.Id) + dependentsImpl r = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.dependentsImpl r) + + dependentsOfComponentImpl :: Hash -> m (Set Reference.Id) + dependentsOfComponentImpl h = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.dependentsOfComponentImpl h) + + syncFromDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m () + syncFromDirectory srcRoot _syncMode b = + withConnection (debugName ++ ".sync.src") srcRoot \srcConn -> + withConn \conn -> do + progressStateRef <- liftIO (newIORef emptySyncProgressState) + Sqlite.runReadOnlyTransaction srcConn \runSrc -> + Sqlite.runWriteTransaction conn \runDest -> do + syncInternal (syncProgress progressStateRef) runSrc runDest b + + syncToDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m () + syncToDirectory destRoot _syncMode b = + withConn \conn -> + withConnection (debugName ++ ".sync.dest") destRoot \destConn -> do + progressStateRef <- liftIO (newIORef emptySyncProgressState) + initSchemaIfNotExist destRoot + Sqlite.runReadOnlyTransaction conn \runSrc -> + Sqlite.runWriteTransaction destConn \runDest -> do + syncInternal (syncProgress progressStateRef) runSrc runDest b + + watches :: UF.WatchKind -> m [Reference.Id] + watches w = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.watches w) + + getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann)) + getWatch k r = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.getWatch getDeclType k r) + + putWatch :: UF.WatchKind -> Reference.Id -> Term Symbol Ann -> m () + putWatch k r tm = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.putWatch k r tm) + + clearWatches :: m () + clearWatches = + withConn \conn -> + Sqlite.runTransaction conn CodebaseOps.clearWatches + + getReflog :: m [Reflog.Entry Branch.CausalHash] + getReflog = + liftIO $ + ( do + contents <- TextIO.readFile (reflogPath root) + let lines = Text.lines contents + let entries = parseEntry <$> lines + pure entries + ) + `catchIO` const (pure []) + where + parseEntry t = fromMaybe (err t) (Reflog.fromText t) + err t = + error $ + "I couldn't understand this line in " ++ reflogPath root ++ "\n\n" + ++ Text.unpack t + + appendReflog :: Text -> Branch m -> Branch m -> m () + appendReflog reason old new = + liftIO $ TextIO.appendFile (reflogPath root) (t <> "\n") + where + t = Reflog.toText $ Reflog.Entry (Branch.headHash old) (Branch.headHash new) reason + + reflogPath :: CodebasePath -> FilePath + reflogPath root = root "reflog" + + termsOfTypeImpl :: Reference -> m (Set Referent.Id) + termsOfTypeImpl r = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.termsOfTypeImpl getDeclType r) + + termsMentioningTypeImpl :: Reference -> m (Set Referent.Id) + termsMentioningTypeImpl r = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.termsMentioningTypeImpl getDeclType r) + + hashLength :: m Int + hashLength = + withConn \conn -> + Sqlite.runTransaction conn CodebaseOps.hashLength + + branchHashLength :: m Int + branchHashLength = + withConn \conn -> + Sqlite.runTransaction conn CodebaseOps.branchHashLength + + termReferencesByPrefix :: ShortHash -> m (Set Reference.Id) + termReferencesByPrefix sh = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.termReferencesByPrefix sh) + + declReferencesByPrefix :: ShortHash -> m (Set Reference.Id) + declReferencesByPrefix sh = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.declReferencesByPrefix sh) + + referentsByPrefix :: ShortHash -> m (Set Referent.Id) + referentsByPrefix sh = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.referentsByPrefix getDeclType sh) + + branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.CausalHash) + branchHashesByPrefix sh = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.branchHashesByPrefix sh) + + sqlLca :: Branch.CausalHash -> Branch.CausalHash -> m (Maybe (Branch.CausalHash)) + sqlLca h1 h2 = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.sqlLca h1 h2) + + beforeImpl :: Maybe (Branch.CausalHash -> Branch.CausalHash -> m Bool) + beforeImpl = + Just \l r -> + withConn \conn -> + Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r + + namesAtPath :: Path -> m ScopedNames + namesAtPath path = + withConn \conn -> + Sqlite.runReadOnlyTransaction conn \runTx -> + runTx (CodebaseOps.namesAtPath path) + + updateNameLookup :: m () + updateNameLookup = + withConn \conn -> + Sqlite.runTransaction conn (CodebaseOps.updateNameLookupIndexFromV2Root getDeclType) + + let codebase = + C.Codebase + { getTerm = Cache.applyDefined termCache getTerm, + getTypeOfTermImpl = Cache.applyDefined typeOfTermCache getTypeOfTermImpl, + getTypeDeclaration = Cache.applyDefined declCache getTypeDeclaration, + getDeclType = + \r -> + withConn \conn -> + Sqlite.runReadOnlyTransaction conn \run -> run (getDeclType r), + putTerm, + putTypeDeclaration, + getTermComponentWithTypes, + getDeclComponent, + getComponentLength = getCycleLength, + getRootBranch = getRootBranch rootBranchCache, + getRootBranchHash, + getRootBranchExists, + putRootBranch = putRootBranch rootBranchCache, + rootBranchUpdates = rootBranchUpdates rootBranchCache, + getShallowBranchForHash, + getBranchForHashImpl = getBranchForHash, + putBranch, + branchExists = isCausalHash, + getPatch, + putPatch, + patchExists, + dependentsImpl, + dependentsOfComponentImpl, + syncFromDirectory, + syncToDirectory, + viewRemoteBranch', + pushGitBranch = \repo opts action -> withConn \conn -> pushGitBranch conn repo opts action, + watches, + getWatch, + putWatch, + clearWatches, + getReflog, + appendReflog, + termsOfTypeImpl, + termsMentioningTypeImpl, + hashLength, + termReferencesByPrefix, + typeReferencesByPrefix = declReferencesByPrefix, + termReferentsByPrefix = referentsByPrefix, + branchHashLength, + branchHashesByPrefix, + lcaImpl = Just sqlLca, + beforeImpl, + namesAtPath, + updateNameLookup, + withConnection = withConn, + withConnectionIO = withConnection debugName root + } + Right <$> action (codebase, undefined) + where + withConn :: (Sqlite.Connection -> m a) -> m a + withConn = + withConnection debugName root syncInternal :: forall m. @@ -729,7 +787,7 @@ viewRemoteBranch' ReadGitRemoteNamespace {repo, sbh, path} gitBranchBehavior act -- the existing root. pushGitBranch :: forall m e. - (MonadUnliftIO m) => + MonadUnliftIO m => Sqlite.Connection -> WriteGitRepo -> PushGitBranchOpts -> diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index a3e4c4f518..5bba16b128 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -176,15 +176,10 @@ data Codebase m v a = Codebase -- Updates the root namespace names index. -- This isn't run automatically because it can be a bit slow. updateNameLookup :: m (), - -- | The SQLite connection this codebase closes over. - -- - -- At one time the codebase was meant to abstract over the storage layer, but it has been cumbersome. Now we prefer - -- to interact with SQLite directly, and so provide this temporary escape hatch, until we can eliminate this - -- interface entirely. - connection :: Sqlite.Connection, - -- | Another escape hatch like the above connection, but this one makes a new connection to the same underlying - -- database file. This allows code (like pull-from-share) to use more than one connection concurrently. - withConnection :: forall x. (Sqlite.Connection -> IO x) -> IO x + -- | Acquire a new connection to the same underlying database file this codebase object connects to. + withConnection :: forall x. (Sqlite.Connection -> m x) -> m x, + -- | Acquire a new connection to the same underlying database file this codebase object connects to. + withConnectionIO :: forall x. (Sqlite.Connection -> IO x) -> IO x } -- | Whether a codebase is local or remote. diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs index 33af1a7e00..a7ea503080 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs @@ -43,7 +43,6 @@ import qualified Unison.Reference as Reference import qualified Unison.Result as Result import qualified Unison.Server.Backend as Backend import qualified Unison.Server.CodebaseServer as Server -import qualified Unison.Sqlite as Sqlite import Unison.Symbol (Symbol) import Unison.Term (Term) import qualified Unison.Term as Term @@ -243,8 +242,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour UnliftIO.UnliftIO toIO -> toIO . Free.fold go pure runF UCMVersion -> pure ucmVersion - AnalyzeCodebaseIntegrity -> do - Sqlite.runTransaction (Codebase.connection codebase) integrityCheckFullCodebase + AnalyzeCodebaseIntegrity -> lift (Codebase.runTransaction codebase integrityCheckFullCodebase) watchCache :: Reference.Id -> IO (Maybe (Term Symbol ())) watchCache h = do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index e236f7d8d0..dcce1d8958 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -99,7 +99,7 @@ import qualified Unison.Codebase.SyncMode as SyncMode import Unison.Codebase.TermEdit (TermEdit (..)) import qualified Unison.Codebase.TermEdit as TermEdit import qualified Unison.Codebase.TermEdit.Typing as TermEdit -import Unison.Codebase.Type (Codebase (..), GitError) +import Unison.Codebase.Type (GitError) import qualified Unison.Codebase.TypeEdit as TypeEdit import qualified Unison.Codebase.Verbosity as Verbosity import qualified Unison.CommandLine.DisplayValues as DisplayValues @@ -149,7 +149,6 @@ import qualified Unison.Share.Sync as Share import qualified Unison.Share.Sync.Types as Sync import Unison.Share.Types (codeserverBaseURL) import qualified Unison.ShortHash as SH -import qualified Unison.Sqlite as Sqlite import Unison.Symbol (Symbol) import qualified Unison.Sync.Types as Share (Path (..)) import Unison.Term (Term) @@ -1865,45 +1864,44 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l let sharePath = Share.Path (repo Nel.:| pathToSegments remotePath) ensureAuthenticatedWithCodeserver codeserver - LoopState.Env {authHTTPClient, codebase = Codebase {connection, withConnection}} <- ask + LoopState.Env {authHTTPClient, codebase} <- ask -- doesn't handle the case where a non-existent path is supplied - Sqlite.runTransaction connection (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath))) - >>= \case - Nothing -> respond (BranchNotFound . Path.absoluteToPath' $ localPath) - Just localCausalHash -> - case behavior of - PushBehavior.RequireEmpty -> do - let push :: IO (Either (Sync.SyncError Share.CheckAndSetPushError) ()) - push = - withEntitiesUploadedProgressCallbacks \callbacks -> - Share.checkAndSetPush - authHTTPClient - baseURL - withConnection - sharePath - Nothing - localCausalHash - callbacks - liftIO push >>= \case - Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorCheckAndSetPush err)) - Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err)) - Right () -> pure () - PushBehavior.RequireNonEmpty -> do - let push :: IO (Either (Sync.SyncError Share.FastForwardPushError) ()) - push = do - withEntitiesUploadedProgressCallbacks \callbacks -> - Share.fastForwardPush - authHTTPClient - baseURL - withConnection - sharePath - localCausalHash - callbacks - liftIO push >>= \case - Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorFastForwardPush err)) - Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err)) - Right () -> pure () + eval (Eval (Codebase.runTransaction codebase (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath))))) >>= \case + Nothing -> respond (BranchNotFound . Path.absoluteToPath' $ localPath) + Just localCausalHash -> + case behavior of + PushBehavior.RequireEmpty -> do + let push :: IO (Either (Sync.SyncError Share.CheckAndSetPushError) ()) + push = + withEntitiesUploadedProgressCallbacks \callbacks -> + Share.checkAndSetPush + authHTTPClient + baseURL + (Codebase.withConnectionIO codebase) + sharePath + Nothing + localCausalHash + callbacks + liftIO push >>= \case + Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorCheckAndSetPush err)) + Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err)) + Right () -> pure () + PushBehavior.RequireNonEmpty -> do + let push :: IO (Either (Sync.SyncError Share.FastForwardPushError) ()) + push = do + withEntitiesUploadedProgressCallbacks \callbacks -> + Share.fastForwardPush + authHTTPClient + baseURL + (Codebase.withConnectionIO codebase) + sharePath + localCausalHash + callbacks + liftIO push >>= \case + Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorFastForwardPush err)) + Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err)) + Right () -> pure () where pathToSegments :: Path -> [Text] pathToSegments = @@ -2322,14 +2320,14 @@ importRemoteShareBranch rrn@(ReadShareRemoteNamespace {server, repo, path}) = do when (not $ RemoteRepo.isPublic rrn) $ ensureAuthenticatedWithCodeserver codeserver mapLeft Output.ShareError <$> do let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) - LoopState.Env {authHTTPClient, codebase = codebase@Codebase {withConnection}} <- ask + LoopState.Env {authHTTPClient, codebase} <- ask let pull :: IO (Either (Sync.SyncError Share.PullError) CausalHash) pull = withEntitiesDownloadedProgressCallbacks \callbacks -> Share.pull authHTTPClient baseURL - withConnection + (Codebase.withConnectionIO codebase) shareFlavoredPath callbacks liftIO pull >>= \case From 23e51294855411985ec7807b12f6b284410912f2 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 5 Jul 2022 20:08:04 -0400 Subject: [PATCH 464/529] push finalizer down --- .../src/Unison/Codebase/SqliteCodebase.hs | 42 +++++++++---------- 1 file changed, 21 insertions(+), 21 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 5b973478a1..2fe70bd697 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -208,27 +208,27 @@ sqliteCodebase debugName root localOrRemote action = do termBuffer :: TVar (Map Hash CodebaseOps.TermBufferEntry) <- newTVarIO Map.empty declBuffer :: TVar (Map Hash CodebaseOps.DeclBufferEntry) <- newTVarIO Map.empty - let finalizer :: MonadIO m => m () - finalizer = do - decls <- readTVarIO declBuffer - terms <- readTVarIO termBuffer - let printBuffer header b = - liftIO - if b /= mempty - then putStrLn header >> putStrLn "" >> print b - else pure () - printBuffer "Decls:" decls - printBuffer "Terms:" terms - - flip finally finalizer do - -- Migrate if necessary. - result <- - withConn \conn -> - ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer conn - - case result of - Left err -> pure $ Left err - Right () -> do + -- Migrate if necessary. + result <- + withConn \conn -> + ensureCodebaseIsUpToDate localOrRemote root getDeclType termBuffer declBuffer conn + + case result of + Left err -> pure $ Left err + Right () -> do + let finalizer :: MonadIO m => m () + finalizer = do + decls <- readTVarIO declBuffer + terms <- readTVarIO termBuffer + let printBuffer header b = + liftIO + if b /= mempty + then putStrLn header >> putStrLn "" >> print b + else pure () + printBuffer "Decls:" decls + printBuffer "Terms:" terms + + flip finally finalizer do let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann)) getTerm id = withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getTerm getDeclType id) From 014363abc5aa4217c07241606c949e5d4ba1ee59 Mon Sep 17 00:00:00 2001 From: Cody Allen Date: Wed, 6 Jul 2022 08:23:26 -0400 Subject: [PATCH 465/529] Attempt to add Windows artifacts to development builds --- .github/workflows/pre-release.yaml | 27 +++++++++++++++++++++++++++ 1 file changed, 27 insertions(+) diff --git a/.github/workflows/pre-release.yaml b/.github/workflows/pre-release.yaml index f6f9d808fd..4a59d67780 100644 --- a/.github/workflows/pre-release.yaml +++ b/.github/workflows/pre-release.yaml @@ -83,6 +83,32 @@ jobs: name: build-macos path: ucm-macos.tar.gz + build_windows: + name: "build_windows" + runs-on: windows-2019 + + steps: + - uses: actions/checkout@v2 + - name: build + run: stack --no-terminal build --flag unison-parser-typechecker:optimized + + - name: fetch latest codebase-ui and package with ucm + # Powershell + run: | + mkdir -p tmp\ui + mkdir -p release\ui + $UCM = stack exec -- where unison + cp $UCM .\release\ucm.exe + Invoke-WebRequest -Uri https://github.com/unisonweb/codebase-ui/releases/download/latest/unisonLocal.zip -OutFile tmp\unisonLocal.zip + Expand-Archive -Path tmp\unisonLocal.zip -DestinationPath release\ui + Compress-Archive -Path .\release\* -DestinationPath ucm-windows.zip + + - name: Upload windows artifact + uses: actions/upload-artifact@v2 + with: + if-no-files-found: error + name: build-windows + path: ucm-windows.zip release: name: "create_release" @@ -90,6 +116,7 @@ jobs: needs: - build_linux - build_macos + - build_windows steps: - name: make download dir From 7dbe6be8f1c772bf8423cc01fc3064a41140bbbd Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 6 Jul 2022 09:38:23 -0400 Subject: [PATCH 466/529] remove undefined --- .../src/Unison/Codebase/SqliteCodebase.hs | 25 ++++++++----------- 1 file changed, 11 insertions(+), 14 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 2fe70bd697..49fd5d0dd1 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -96,12 +96,9 @@ init :: HasCallStack => (MonadUnliftIO m) => Codebase.Init m Symbol Ann init = Codebase.Init { withOpenCodebase = withCodebaseOrError, - withCreatedCodebase = withCreatedCodebase', + withCreatedCodebase = createCodebaseOrError, codebasePath = makeCodebaseDirPath } - where - withCreatedCodebase' debugName path action = - createCodebaseOrError debugName path (action . fst) data CodebaseStatus = ExistingCodebase @@ -114,7 +111,7 @@ withOpenOrCreateCodebase :: Codebase.DebugName -> CodebasePath -> LocalOrRemote -> - ((CodebaseStatus, Codebase m Symbol Ann, Sqlite.Connection) -> m r) -> + ((CodebaseStatus, Codebase m Symbol Ann) -> m r) -> m (Either Codebase1.OpenCodebaseError r) withOpenOrCreateCodebase debugName codebasePath localOrRemote action = do createCodebaseOrError debugName codebasePath (action' CreatedCodebase) >>= \case @@ -122,14 +119,14 @@ withOpenOrCreateCodebase debugName codebasePath localOrRemote action = do sqliteCodebase debugName codebasePath localOrRemote (action' ExistingCodebase) Right r -> pure (Right r) where - action' openOrCreate (codebase, conn) = action (openOrCreate, codebase, conn) + action' openOrCreate codebase = action (openOrCreate, codebase) -- | Create a codebase at the given location. createCodebaseOrError :: (MonadUnliftIO m) => Codebase.DebugName -> CodebasePath -> - ((Codebase m Symbol Ann, Sqlite.Connection) -> m r) -> + (Codebase m Symbol Ann -> m r) -> m (Either Codebase1.CreateCodebaseError r) createCodebaseOrError debugName path action = do ifM @@ -159,8 +156,7 @@ withCodebaseOrError :: withCodebaseOrError debugName dir action = do doesFileExist (makeCodebasePath dir) >>= \case False -> pure (Left Codebase1.OpenCodebaseDoesntExist) - True -> - sqliteCodebase debugName dir Local (action . fst) + True -> sqliteCodebase debugName dir Local action initSchemaIfNotExist :: MonadIO m => FilePath -> m () initSchemaIfNotExist path = liftIO do @@ -194,7 +190,7 @@ sqliteCodebase :: CodebasePath -> -- | When local, back up the existing codebase before migrating, in case there's a catastrophic bug in the migration. LocalOrRemote -> - ((Codebase m Symbol Ann, Sqlite.Connection) -> m r) -> + (Codebase m Symbol Ann -> m r) -> m (Either Codebase1.OpenCodebaseError r) sqliteCodebase debugName root localOrRemote action = do termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable @@ -563,7 +559,7 @@ sqliteCodebase debugName root localOrRemote action = do withConnection = withConn, withConnectionIO = withConnection debugName root } - Right <$> action (codebase, undefined) + Right <$> action codebase where withConn :: (Sqlite.Connection -> m a) -> m a withConn = @@ -761,7 +757,7 @@ viewRemoteBranch' ReadGitRemoteNamespace {repo, sbh, path} gitBranchBehavior act then throwIO (C.GitSqliteCodebaseError (GitError.NoDatabaseFile repo remotePath)) else throwIO exception - result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath Remote \(codebase, _conn) -> do + result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath Remote \codebase -> do -- try to load the requested branch from it branch <- time "Git fetch (sbh)" $ case sbh of -- no sub-branch was specified, so use the root. @@ -812,7 +808,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift throwEitherMWith C.GitProtocolError . withRepo readRepo Git.CreateBranchIfMissing $ \pushStaging -> do newBranchOrErr <- throwEitherMWith (C.GitSqliteCodebaseError . C.gitErrorFromOpenCodebaseError (Git.gitDirToPath pushStaging) readRepo) . withOpenOrCreateCodebase "push.dest" (Git.gitDirToPath pushStaging) Remote - $ \(codebaseStatus, destCodebase, destConn) -> do + $ \(codebaseStatus, destCodebase) -> do currentRootBranch <- C.getRootBranchExists destCodebase >>= \case False -> pure Branch.empty @@ -820,7 +816,8 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift action currentRootBranch >>= \case Left e -> pure $ Left e Right newBranch -> do - doSync codebaseStatus (Git.gitDirToPath pushStaging) destConn newBranch + C.withConnection destCodebase \destConn -> + doSync codebaseStatus (Git.gitDirToPath pushStaging) destConn newBranch pure (Right newBranch) for newBranchOrErr $ push pushStaging repo pure newBranchOrErr From 2c442264bfd9ea2b0029406a5455eb093ea073dd Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 6 Jul 2022 11:19:25 -0400 Subject: [PATCH 467/529] fix bugs in getBranch-like things --- .../src/Unison/Codebase/SqliteCodebase.hs | 127 +++++++----------- 1 file changed, 49 insertions(+), 78 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 49fd5d0dd1..710e4ab3a1 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -227,28 +227,28 @@ sqliteCodebase debugName root localOrRemote action = do flip finally finalizer do let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann)) getTerm id = - withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getTerm getDeclType id) + runTransaction (CodebaseOps.getTerm getDeclType id) getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann)) getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined getTypeOfTermImpl id = - withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getTypeOfTermImpl id) + runTransaction (CodebaseOps.getTypeOfTermImpl id) getTermComponentWithTypes :: Hash -> m (Maybe [(Term Symbol Ann, Type Symbol Ann)]) getTermComponentWithTypes h = - withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getTermComponentWithTypes getDeclType h) + runTransaction (CodebaseOps.getTermComponentWithTypes getDeclType h) getTypeDeclaration :: Reference.Id -> m (Maybe (Decl Symbol Ann)) getTypeDeclaration id = - withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getTypeDeclaration id) + runTransaction (CodebaseOps.getTypeDeclaration id) getDeclComponent :: Hash -> m (Maybe [Decl Symbol Ann]) getDeclComponent h = - withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getDeclComponent h) + runTransaction (CodebaseOps.getDeclComponent h) getCycleLength :: Hash -> m (Maybe Reference.CycleSize) getCycleLength h = - withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.getCycleLength h) + runTransaction (CodebaseOps.getCycleLength h) -- putTermComponent :: MonadIO m => Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> m () -- putTerms :: MonadIO m => Map Reference.Id (Term Symbol Ann, Type Symbol Ann) -> m () -- dies horribly if missing dependencies? @@ -260,40 +260,33 @@ sqliteCodebase debugName root localOrRemote action = do putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m () putTerm id tm tp | debug && trace ("SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined putTerm id tm tp = - withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.putTerm termBuffer declBuffer id tm tp) + runTransaction (CodebaseOps.putTerm termBuffer declBuffer id tm tp) putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> m () putTypeDeclaration id decl = - withConn \conn -> Sqlite.runTransaction conn (CodebaseOps.putTypeDeclaration termBuffer declBuffer id decl) + runTransaction (CodebaseOps.putTypeDeclaration termBuffer declBuffer id decl) getRootBranchHash :: MonadIO m => m V2Branch.CausalHash - getRootBranchHash = do - withConn \conn -> - Sqlite.runReadOnlyTransaction conn \run -> - run Ops.expectRootCausalHash + getRootBranchHash = + runTransaction Ops.expectRootCausalHash getShallowBranchForHash :: MonadIO m => V2Branch.CausalHash -> m (V2Branch.CausalBranch m) getShallowBranchForHash bh = - withConn \conn -> - Sqlite.runReadOnlyTransaction conn \run -> do - V2Branch.hoistCausalBranch run <$> run (Ops.expectCausalBranchByCausalHash bh) + V2Branch.hoistCausalBranch runTransaction <$> runTransaction (Ops.expectCausalBranchByCausalHash bh) getRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> m (Branch m) getRootBranch rootBranchCache = - withConn \conn -> - Sqlite.runReadOnlyTransaction conn \run -> - Branch.transform run <$> run (CodebaseOps.getRootBranch getDeclType rootBranchCache) + Branch.transform runTransaction <$> runTransaction (CodebaseOps.getRootBranch getDeclType rootBranchCache) getRootBranchExists :: m Bool getRootBranchExists = - withConn \conn -> - Sqlite.runTransaction conn CodebaseOps.getRootBranchExists + runTransaction CodebaseOps.getRootBranchExists putRootBranch :: TVar (Maybe (Sqlite.DataVersion, Branch Sqlite.Transaction)) -> Branch m -> m () putRootBranch rootBranchCache branch1 = do - withConn \conn -> - withRunInIO \runInIO -> do - Sqlite.runTransaction conn do + withRunInIO \runInIO -> do + runInIO do + runTransaction do CodebaseOps.putRootBranch rootBranchCache (Branch.transform (Sqlite.unsafeIO . runInIO) branch1) rootBranchUpdates :: MonadIO m => TVar (Maybe (Sqlite.DataVersion, a)) -> m (IO (), IO (Set Branch.CausalHash)) @@ -339,84 +332,71 @@ sqliteCodebase debugName root localOrRemote action = do -- to one that returns Maybe. getBranchForHash :: Branch.CausalHash -> m (Maybe (Branch m)) getBranchForHash h = - withConn \conn -> - Sqlite.runReadOnlyTransaction conn \run -> - fmap (Branch.transform run) <$> run (CodebaseOps.getBranchForHash getDeclType h) + fmap (Branch.transform runTransaction) <$> runTransaction (CodebaseOps.getBranchForHash getDeclType h) putBranch :: Branch m -> m () putBranch branch = - withConn \conn -> - withRunInIO \runInIO -> - Sqlite.runTransaction conn (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch)) + withRunInIO \runInIO -> + runInIO (runTransaction (CodebaseOps.putBranch (Branch.transform (Sqlite.unsafeIO . runInIO) branch))) isCausalHash :: Branch.CausalHash -> m Bool isCausalHash h = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.isCausalHash h) + runTransaction (CodebaseOps.isCausalHash h) getPatch :: Branch.EditHash -> m (Maybe Patch) getPatch h = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.getPatch h) + runTransaction (CodebaseOps.getPatch h) putPatch :: Branch.EditHash -> Patch -> m () putPatch h p = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.putPatch h p) + runTransaction (CodebaseOps.putPatch h p) patchExists :: Branch.EditHash -> m Bool patchExists h = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.patchExists h) + runTransaction (CodebaseOps.patchExists h) dependentsImpl :: Reference -> m (Set Reference.Id) dependentsImpl r = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.dependentsImpl r) + runTransaction (CodebaseOps.dependentsImpl r) dependentsOfComponentImpl :: Hash -> m (Set Reference.Id) dependentsOfComponentImpl h = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.dependentsOfComponentImpl h) + runTransaction (CodebaseOps.dependentsOfComponentImpl h) syncFromDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m () syncFromDirectory srcRoot _syncMode b = withConnection (debugName ++ ".sync.src") srcRoot \srcConn -> - withConn \conn -> do + withConn \destConn -> do progressStateRef <- liftIO (newIORef emptySyncProgressState) Sqlite.runReadOnlyTransaction srcConn \runSrc -> - Sqlite.runWriteTransaction conn \runDest -> do + Sqlite.runWriteTransaction destConn \runDest -> do syncInternal (syncProgress progressStateRef) runSrc runDest b syncToDirectory :: Codebase1.CodebasePath -> SyncMode -> Branch m -> m () syncToDirectory destRoot _syncMode b = - withConn \conn -> + withConn \srcConn -> withConnection (debugName ++ ".sync.dest") destRoot \destConn -> do progressStateRef <- liftIO (newIORef emptySyncProgressState) initSchemaIfNotExist destRoot - Sqlite.runReadOnlyTransaction conn \runSrc -> + Sqlite.runReadOnlyTransaction srcConn \runSrc -> Sqlite.runWriteTransaction destConn \runDest -> do syncInternal (syncProgress progressStateRef) runSrc runDest b watches :: UF.WatchKind -> m [Reference.Id] watches w = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.watches w) + runTransaction (CodebaseOps.watches w) getWatch :: UF.WatchKind -> Reference.Id -> m (Maybe (Term Symbol Ann)) getWatch k r = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.getWatch getDeclType k r) + runTransaction (CodebaseOps.getWatch getDeclType k r) putWatch :: UF.WatchKind -> Reference.Id -> Term Symbol Ann -> m () putWatch k r tm = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.putWatch k r tm) + runTransaction (CodebaseOps.putWatch k r tm) clearWatches :: m () clearWatches = - withConn \conn -> - Sqlite.runTransaction conn CodebaseOps.clearWatches + runTransaction CodebaseOps.clearWatches getReflog :: m [Reflog.Entry Branch.CausalHash] getReflog = @@ -446,65 +426,52 @@ sqliteCodebase debugName root localOrRemote action = do termsOfTypeImpl :: Reference -> m (Set Referent.Id) termsOfTypeImpl r = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.termsOfTypeImpl getDeclType r) + runTransaction (CodebaseOps.termsOfTypeImpl getDeclType r) termsMentioningTypeImpl :: Reference -> m (Set Referent.Id) termsMentioningTypeImpl r = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.termsMentioningTypeImpl getDeclType r) + runTransaction (CodebaseOps.termsMentioningTypeImpl getDeclType r) hashLength :: m Int hashLength = - withConn \conn -> - Sqlite.runTransaction conn CodebaseOps.hashLength + runTransaction CodebaseOps.hashLength branchHashLength :: m Int branchHashLength = - withConn \conn -> - Sqlite.runTransaction conn CodebaseOps.branchHashLength + runTransaction CodebaseOps.branchHashLength termReferencesByPrefix :: ShortHash -> m (Set Reference.Id) termReferencesByPrefix sh = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.termReferencesByPrefix sh) + runTransaction (CodebaseOps.termReferencesByPrefix sh) declReferencesByPrefix :: ShortHash -> m (Set Reference.Id) declReferencesByPrefix sh = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.declReferencesByPrefix sh) + runTransaction (CodebaseOps.declReferencesByPrefix sh) referentsByPrefix :: ShortHash -> m (Set Referent.Id) referentsByPrefix sh = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.referentsByPrefix getDeclType sh) + runTransaction (CodebaseOps.referentsByPrefix getDeclType sh) branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.CausalHash) branchHashesByPrefix sh = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.branchHashesByPrefix sh) + runTransaction (CodebaseOps.branchHashesByPrefix sh) sqlLca :: Branch.CausalHash -> Branch.CausalHash -> m (Maybe (Branch.CausalHash)) sqlLca h1 h2 = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.sqlLca h1 h2) + runTransaction (CodebaseOps.sqlLca h1 h2) beforeImpl :: Maybe (Branch.CausalHash -> Branch.CausalHash -> m Bool) beforeImpl = Just \l r -> - withConn \conn -> - Sqlite.runTransaction conn $ fromJust <$> CodebaseOps.before l r + runTransaction $ fromJust <$> CodebaseOps.before l r namesAtPath :: Path -> m ScopedNames namesAtPath path = - withConn \conn -> - Sqlite.runReadOnlyTransaction conn \runTx -> - runTx (CodebaseOps.namesAtPath path) + runTransaction (CodebaseOps.namesAtPath path) updateNameLookup :: m () updateNameLookup = - withConn \conn -> - Sqlite.runTransaction conn (CodebaseOps.updateNameLookupIndexFromV2Root getDeclType) + runTransaction (CodebaseOps.updateNameLookupIndexFromV2Root getDeclType) let codebase = C.Codebase @@ -565,6 +532,10 @@ sqliteCodebase debugName root localOrRemote action = do withConn = withConnection debugName root + runTransaction :: Sqlite.Transaction a -> m a + runTransaction action = + withConn \conn -> Sqlite.runTransaction conn action + syncInternal :: forall m. MonadUnliftIO m => From be8d2fd4b9245d6440e3a999398bdb5151c81e8c Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Wed, 6 Jul 2022 12:42:04 -0400 Subject: [PATCH 468/529] Fix a problem with equating ability rows where one is concrete --- .../src/Unison/Typechecker/Context.hs | 11 ++-- unison-src/transcripts/fix3196.md | 32 ++++++++++++ unison-src/transcripts/fix3196.output.md | 52 +++++++++++++++++++ 3 files changed, 87 insertions(+), 8 deletions(-) create mode 100644 unison-src/transcripts/fix3196.md create mode 100644 unison-src/transcripts/fix3196.output.md diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 05beacecf1..960acb7237 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -2696,15 +2696,10 @@ equateAbilities ls rs = refine True [(loc t, bc, cv)] [cls ++ crs] | [] <- com, null rs, null cls -> for_ vls defaultAbility | [] <- com, null ls, null crs -> for_ vrs defaultAbility - | otherwise -> do - mrefine mlSlack ls rs - mrefine mrSlack rs ls + | [] <- com, Just pl <- mlSlack, null cls -> refine False [pl] [rs] + | [] <- com, Just pr <- mrSlack, null crs -> refine False [pr] [ls] + | otherwise -> getContext >>= failWith . AbilityCheckFailure ls rs where - mrefine (Just p) _ es = refine False [p] [es] - mrefine Nothing _ [] = pure () - mrefine Nothing hs es = - getContext >>= failWith . AbilityCheckFailure hs es - refine common lbvs ess = do cv <- traverse freshenVar cn ctx <- getContext diff --git a/unison-src/transcripts/fix3196.md b/unison-src/transcripts/fix3196.md new file mode 100644 index 0000000000..d04592aa6c --- /dev/null +++ b/unison-src/transcripts/fix3196.md @@ -0,0 +1,32 @@ + +```ucm:hide +.> builtins.merge +``` + +Tests ability checking in scenarios where one side is concrete and the other is +a variable. This was supposed to be covered, but the method wasn't actually +symmetric, so doing `equate l r` might work, but not `equate r l`. + +Below were cases that caused the failing order. + +```unison +structural type W es = W + +unique ability Zoot where + zoot : () + +woot : W {g} -> '{g, Zoot} a ->{Zoot} a +woot w a = todo () + +ex = do + w = (W : W {Zoot}) + woot w do bug "why don't you typecheck?" + +w1 : W {Zoot} +w1 = W + +w2 : W {g} -> W {g} +w2 = cases W -> W + +> w2 w1 +``` diff --git a/unison-src/transcripts/fix3196.output.md b/unison-src/transcripts/fix3196.output.md new file mode 100644 index 0000000000..c40e236345 --- /dev/null +++ b/unison-src/transcripts/fix3196.output.md @@ -0,0 +1,52 @@ + +Tests ability checking in scenarios where one side is concrete and the other is +a variable. This was supposed to be covered, but the method wasn't actually +symmetric, so doing `equate l r` might work, but not `equate r l`. + +Below were cases that caused the failing order. + +```unison +structural type W es = W + +unique ability Zoot where + zoot : () + +woot : W {g} -> '{g, Zoot} a ->{Zoot} a +woot w a = todo () + +ex = do + w = (W : W {Zoot}) + woot w do bug "why don't you typecheck?" + +w1 : W {Zoot} +w1 = W + +w2 : W {g} -> W {g} +w2 = cases W -> W + +> w2 w1 +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + structural type W es + unique ability Zoot + ex : '{Zoot} r + w1 : W {Zoot} + w2 : W {g} -> W {g} + woot : W {g} -> '{g, Zoot} a ->{Zoot} a + + Now evaluating any watch expressions (lines starting with + `>`)... Ctrl+C cancels. + + 19 | > w2 w1 + โงฉ + W + +``` From c0efe662e9f7d208a9c6ecb24a124af5d12ee90a Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 6 Jul 2022 11:26:46 -0600 Subject: [PATCH 469/529] Prefer using PPE over names --- unison-share-api/src/Unison/Server/Backend.hs | 59 +++++++++++-------- .../src/Unison/Server/Endpoints/FuzzyFind.hs | 10 ++-- .../Server/Endpoints/NamespaceDetails.hs | 5 +- 3 files changed, 40 insertions(+), 34 deletions(-) diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index bf6c554260..da27bfbeb0 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -322,13 +322,11 @@ findShallowReadmeInBranchAndRender :: Width -> Rt.Runtime Symbol -> Codebase IO Symbol Ann -> - NamesWithHistory -> + PPE.PrettyPrintEnvDecl -> V2Branch.Branch m -> Backend IO (Maybe Doc.Doc) -findShallowReadmeInBranchAndRender width runtime codebase printNames namespaceBranch = - let ppe hqLen = PPE.fromNamesDecl hqLen printNames - - renderReadme :: PPE.PrettyPrintEnvDecl -> Reference -> IO Doc.Doc +findShallowReadmeInBranchAndRender width runtime codebase ppe namespaceBranch = + let renderReadme :: PPE.PrettyPrintEnvDecl -> Reference -> IO Doc.Doc renderReadme ppe docReference = do (_, _, doc) <- renderDoc ppe width runtime codebase docReference pure doc @@ -348,8 +346,7 @@ findShallowReadmeInBranchAndRender width runtime codebase printNames namespaceBr where termsMap = V2Branch.terms namespaceBranch in liftIO $ do - hqLen <- Codebase.hashLength codebase - traverse (renderReadme (ppe hqLen)) readme + traverse (renderReadme ppe) readme isDoc :: Monad m => Codebase m Symbol Ann -> Referent -> m Bool isDoc codebase ref = do @@ -818,24 +815,25 @@ prettyDefinitionsBySuffixes :: Backend IO DefinitionDisplayResults prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase query = do hqLength <- lift $ Codebase.hashLength codebase - (_parseNames, printNames, localNamesOnly) <- scopedNamesForBranchHash codebase root path + -- We might like to make sure that the user search terms get used as + -- the names in the pretty-printer, but the current implementation + -- doesn't. + (_parseNames, _printNames, localNamesOnly, ppe) <- scopedNamesForBranchHash codebase root path + traceShowM ("PATH" :: String, path) + traceShowM ("QUERY" :: String, query) + traceShowM ("LOCALNAMES" :: String, localNamesOnly) + traceShowM ("PRINTNAMES" :: String, _printNames) let nameSearch :: NameSearch nameSearch = makeNameSearch hqLength (NamesWithHistory.fromCurrentNames localNamesOnly) DefinitionResults terms types misses <- lift (definitionsBySuffixes codebase nameSearch DontIncludeCycles query) - -- We might like to make sure that the user search terms get used as - -- the names in the pretty-printer, but the current implementation - -- doesn't. - let ppe = - PPE.fromNamesDecl hqLength (NamesWithHistory.fromCurrentNames printNames) - - width = + let width = mayDefaultWidth renderWidth termFqns :: Map Reference (Set Text) termFqns = Map.mapWithKey f terms where - rel = Names.terms printNames + rel = Names.terms localNamesOnly f k _ = Set.fromList . fmap Name.toText . toList $ R.lookupRan (Referent.Ref k) rel @@ -843,7 +841,7 @@ prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase typeFqns :: Map Reference (Set Text) typeFqns = Map.mapWithKey f types where - rel = Names.types printNames + rel = Names.types localNamesOnly f k _ = Set.fromList . fmap Name.toText . toList $ R.lookupRan k rel @@ -867,7 +865,7 @@ prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase -- you get both its source and its rendered form docResults :: [Reference] -> [Name] -> IO [(HashQualifiedName, UnisonHash, Doc.Doc)] docResults rs0 docs = do - let refsFor n = NamesWithHistory.lookupHQTerm (HQ.NameOnly n) (NamesWithHistory.fromCurrentNames printNames) + let refsFor n = NamesWithHistory.lookupHQTerm (HQ.NameOnly n) (NamesWithHistory.fromCurrentNames localNamesOnly) let rs = Set.unions (refsFor <$> docs) <> Set.fromList (Referent.Ref <$> rs0) -- lookup the type of each, make sure it's a doc docs <- selectDocs (toList rs) @@ -893,7 +891,7 @@ prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase referent (HQ'.NameOnly (NameSegment bn)) ) - docs <- lift (docResults [r] $ docNames (NamesWithHistory.termName hqLength (Referent.Ref r) (NamesWithHistory.fromCurrentNames printNames))) + docs <- lift (docResults [r] $ docNames (NamesWithHistory.termName hqLength (Referent.Ref r) (NamesWithHistory.fromCurrentNames localNamesOnly))) mk docs ts bn tag where mk _ Nothing _ _ = throwError $ MissingSignatureForTerm r @@ -914,7 +912,7 @@ prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase codebase r (HQ'.NameOnly (NameSegment bn)) - docs <- docResults [] $ docNames (NamesWithHistory.typeName hqLength r (NamesWithHistory.fromCurrentNames printNames)) + docs <- docResults [] $ docNames (NamesWithHistory.typeName hqLength r (NamesWithHistory.fromCurrentNames localNamesOnly)) pure $ TypeDefinition (flatten $ Map.lookup r typeFqns) @@ -1070,10 +1068,11 @@ bestNameForType ppe width = . TypePrinter.pretty0 @v ppe mempty (-1) . Type.ref () -scopedNamesForBranchHash :: forall m v a. Monad m => Codebase m v a -> Maybe (Branch.CausalHash) -> Path -> Backend m (Names, Names, Names) +scopedNamesForBranchHash :: forall m v a. Monad m => Codebase m v a -> Maybe (Branch.CausalHash) -> Path -> Backend m (Names, Names, Names, PPE.PrettyPrintEnvDecl) scopedNamesForBranchHash codebase mbh path = do shouldUseNamesIndex <- asks useNamesIndex - case mbh of + hashLen <- lift $ Codebase.hashLength codebase + (parseNames, prettyNames, localNames) <- case mbh of Nothing | shouldUseNamesIndex -> indexPrettyAndParseNames | otherwise -> do @@ -1083,12 +1082,22 @@ scopedNamesForBranchHash codebase mbh path = do rootHash <- lift $ Codebase.getRootBranchHash codebase if (Causal.unCausalHash bh == V2.Hash.unCausalHash rootHash) && shouldUseNamesIndex then indexPrettyAndParseNames - else flip prettyAndParseNamesForBranch (AllNames path) <$> resolveCausalHash (Just bh) codebase + else do + flip prettyAndParseNamesForBranch (AllNames path) <$> resolveCausalHash (Just bh) codebase + + let localPPE = PPE.fromNamesDecl hashLen (NamesWithHistory.fromCurrentNames localNames) + let globalPPE = PPE.fromNamesDecl hashLen (NamesWithHistory.fromCurrentNames parseNames) + pure (parseNames, prettyNames, localNames, mkPPE localPPE globalPPE) where + mkPPE :: PPE.PrettyPrintEnvDecl -> PPE.PrettyPrintEnvDecl -> PPE.PrettyPrintEnvDecl + mkPPE primary fallback = + PPE.PrettyPrintEnvDecl + (PPE.unsuffixifiedPPE primary <> PPE.unsuffixifiedPPE fallback) + (PPE.suffixifiedPPE primary <> PPE.suffixifiedPPE fallback) indexPrettyAndParseNames :: Backend m (Names, Names, Names) indexPrettyAndParseNames = do - names <- lift $ Codebase.namesAtPath codebase path - pure (ScopedNames.parseNames names, Names.minimalUniqueSuffix $ ScopedNames.prettyNames names, ScopedNames.namesAtPath names) + scopedNames <- lift $ Codebase.namesAtPath codebase path + pure (ScopedNames.parseNames scopedNames, ScopedNames.prettyNames scopedNames, ScopedNames.namesAtPath scopedNames) resolveCausalHash :: Monad m => Maybe (Branch.CausalHash) -> Codebase m v a -> Backend m (Branch m) diff --git a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs index 7d29a24785..420acbdee8 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs @@ -28,7 +28,6 @@ import Servant.Docs import Servant.OpenApi () import qualified Text.FuzzyFind as FZF import Unison.Codebase (Codebase) -import qualified Unison.Codebase as Codebase import Unison.Codebase.Editor.DisplayObject import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Path.Parse as Path @@ -37,6 +36,7 @@ import qualified Unison.HashQualified' as HQ' import Unison.NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude +import qualified Unison.PrettyPrintEnvDecl as PPE import qualified Unison.Server.Backend as Backend import Unison.Server.Syntax (SyntaxText) import Unison.Server.Types @@ -140,9 +140,8 @@ serveFuzzyFind codebase mayRoot relativePath limit typeWidth query = rel <- maybe mempty Path.fromPath' <$> traverse (parsePath . Text.unpack) relativePath - hashLength <- lift $ Codebase.hashLength codebase rootHash <- traverse (Backend.expandShortBranchHash codebase) mayRoot - (_parseNames, prettyNames, _localNamesOnly) <- Backend.scopedNamesForBranchHash codebase rootHash rel + (_parseNames, _prettyNames, localNamesOnly, ppe) <- Backend.scopedNamesForBranchHash codebase rootHash rel let alignments :: ( [ ( FZF.Alignment, UnisonName, @@ -151,9 +150,8 @@ serveFuzzyFind codebase mayRoot relativePath limit typeWidth query = ] ) alignments = - take (fromMaybe 10 limit) $ Backend.fuzzyFind prettyNames (fromMaybe "" query) - ppe = Backend.suffixifyNames hashLength prettyNames - lift (join <$> traverse (loadEntry ppe) alignments) + take (fromMaybe 10 limit) $ Backend.fuzzyFind localNamesOnly (fromMaybe "" query) + lift (join <$> traverse (loadEntry (PPE.suffixifiedPPE ppe)) alignments) where loadEntry ppe (a, HQ'.NameOnly . NameSegment -> n, refs) = for refs $ diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs index 1eca472703..5459b4b601 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs @@ -22,7 +22,6 @@ import qualified Unison.Codebase.Path as Path import Unison.Codebase.Path.Parse (parsePath') import qualified Unison.Codebase.Runtime as Rt import Unison.Codebase.ShortBranchHash (ShortBranchHash) -import qualified Unison.NamesWithHistory as NamesWithHistory import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Server.Backend @@ -96,13 +95,13 @@ namespaceDetails runtime codebase namespaceName maySBH mayWidth = namespaceCausal <- Backend.getShallowCausalAtPathFromRootHash codebase mayRootHash namespacePath shallowBranch <- lift $ V2Causal.value namespaceCausal namespaceDetails <- do - (_parseNames, printNames, _localNamesOnly) <- Backend.scopedNamesForBranchHash codebase mayRootHash namespacePath + (_parseNames, _printNames, _localNamesOnly, ppe) <- Backend.scopedNamesForBranchHash codebase mayRootHash namespacePath readme <- Backend.findShallowReadmeInBranchAndRender width runtime codebase - (NamesWithHistory.fromCurrentNames printNames) + ppe shallowBranch let causalHash = v2CausalBranchToUnisonHash namespaceCausal pure $ NamespaceDetails namespaceName causalHash readme From 783d9880c735a2535f855582e36d55347cc58d18 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 6 Jul 2022 11:42:09 -0600 Subject: [PATCH 470/529] Docs --- unison-share-api/src/Unison/Server/Backend.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index da27bfbeb0..fbcfc33ae8 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -1068,6 +1068,13 @@ bestNameForType ppe width = . TypePrinter.pretty0 @v ppe mempty (-1) . Type.ref () +-- | Returns (parse, pretty, local, ppe) where: +-- +-- - 'parse' includes ALL fully qualified names from the root, and ALSO all names from within the provided path, relative to that path. +-- - 'pretty' includes names within the provided path, relative to that path, and also all globally scoped names _outside_ of the path +-- - 'local' includes ONLY the names within the provided path +-- - 'ppe' is a ppe which searches for a name within the path first, but falls back to a global name search. +-- The 'suffixified' component of this ppe will search for the shortest unambiguous suffix within the scope in which the name is found (local, falling back to global) scopedNamesForBranchHash :: forall m v a. Monad m => Codebase m v a -> Maybe (Branch.CausalHash) -> Path -> Backend m (Names, Names, Names, PPE.PrettyPrintEnvDecl) scopedNamesForBranchHash codebase mbh path = do shouldUseNamesIndex <- asks useNamesIndex From 715d624dcf8b91bd7d884825f9bc789d57cd1c0d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 6 Jul 2022 11:46:38 -0600 Subject: [PATCH 471/529] Remove traces --- unison-share-api/src/Unison/Server/Backend.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index fbcfc33ae8..4b4a08fd5c 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -819,10 +819,6 @@ prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase -- the names in the pretty-printer, but the current implementation -- doesn't. (_parseNames, _printNames, localNamesOnly, ppe) <- scopedNamesForBranchHash codebase root path - traceShowM ("PATH" :: String, path) - traceShowM ("QUERY" :: String, query) - traceShowM ("LOCALNAMES" :: String, localNamesOnly) - traceShowM ("PRINTNAMES" :: String, _printNames) let nameSearch :: NameSearch nameSearch = makeNameSearch hqLength (NamesWithHistory.fromCurrentNames localNamesOnly) DefinitionResults terms types misses <- From e1deb6a5281674def418ee4672aee9079fcea11e Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 6 Jul 2022 15:00:29 -0400 Subject: [PATCH 472/529] print request id when we get an unexpected response --- .../src/Unison/CommandLine/OutputMessages.hs | 69 ++++++++++++------- unison-cli/src/Unison/Share/Sync.hs | 52 +++++++------- unison-cli/src/Unison/Share/Sync/Types.hs | 8 +-- 3 files changed, 72 insertions(+), 57 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 9187a225c1..0eb44b5df1 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -10,6 +10,7 @@ import Control.Monad.State import qualified Control.Monad.State.Strict as State import Control.Monad.Trans.Writer.CPS import Data.Bifunctor (first, second) +import qualified Data.ByteString.Lazy as LazyByteString import qualified Data.Foldable as Foldable import Data.List (sort, stripPrefix) import qualified Data.List as List @@ -20,8 +21,10 @@ import qualified Data.Sequence as Seq import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text import Data.Tuple (swap) import Data.Tuple.Extra (dupe) +import qualified Network.HTTP.Types as Http import Network.URI (URI) import qualified Servant.Client as Servant import System.Directory @@ -640,8 +643,8 @@ notifyUser dir o = case o of CachedTests 0 _ -> pure . P.callout "๐Ÿ˜ถ" $ "No tests to run." CachedTests n n' | n == n' -> - pure $ - P.lines [cache, "", displayTestResults True ppe oks fails] + pure $ + P.lines [cache, "", displayTestResults True ppe oks fails] CachedTests _n m -> pure $ if m == 0 @@ -650,6 +653,7 @@ notifyUser dir o = case o of P.indentN 2 $ P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "โœ… "] where + NewlyComputed -> do clearCurrentLine pure $ @@ -1585,7 +1589,7 @@ notifyUser dir o = case o of "Host names should NOT include a schema or path." ] PrintVersion ucmVersion -> pure (P.text ucmVersion) - ShareError x -> (pure . P.warnCallout) case x of + ShareError x -> (pure . P.fatalCallout) case x of ShareErrorCheckAndSetPush e -> case e of (Share.CheckAndSetPushErrorHashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash}) -> case (expectedHash, actualHash) of @@ -1598,12 +1602,10 @@ notifyUser dir o = case o of expectedNonEmptyPushDest (sharePathToWriteRemotePathShare sharePath) (Share.FastForwardPushErrorNoReadPermission sharePath) -> noReadPermission sharePath (Share.FastForwardPushInvalidParentage parent child) -> - P.fatalCallout - ( P.lines - [ "The server detected an error in the history being pushed, please report this as a bug in ucm.", - "The history in question is the hash: " <> prettyHash32 child <> " with the ancestor: " <> prettyHash32 parent - ] - ) + P.lines + [ "The server detected an error in the history being pushed, please report this as a bug in ucm.", + "The history in question is the hash: " <> prettyHash32 child <> " with the ancestor: " <> prettyHash32 parent + ] Share.FastForwardPushErrorNotFastForward sharePath -> P.lines $ [ P.wrap $ @@ -1627,24 +1629,41 @@ notifyUser dir o = case o of P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err ShareErrorTransport te -> case te of + DecodeFailure msg _resp -> + "The server sent a response that we couldn't decode: " <> P.text msg Unauthenticated codeServerURL -> - P.fatalCallout $ - P.wrap . P.lines $ - [ "Authentication with this code server (" <> P.string (Servant.showBaseUrl codeServerURL) <> ") is missing or expired.", - "Please run " <> makeExample' IP.authLogin <> "." - ] - PermissionDenied msg -> P.fatalCallout $ P.hang "Permission denied:" (P.text msg) + P.wrap . P.lines $ + [ "Authentication with this code server (" <> P.string (Servant.showBaseUrl codeServerURL) <> ") is missing or expired.", + "Please run " <> makeExample' IP.authLogin <> "." + ] + PermissionDenied msg -> P.hang "Permission denied:" (P.text msg) UnreachableCodeserver codeServerURL -> P.lines $ [ P.wrap $ "Unable to reach the code server hosted at:" <> P.string (Servant.showBaseUrl codeServerURL), "", P.wrap "Please check your network, ensure you've provided the correct location, or try again later." ] - InvalidResponse resp -> P.fatalCallout $ P.hang "Invalid response received from codeserver:" (P.shown resp) - RateLimitExceeded -> P.warnCallout "Rate limit exceeded, please try again later." - InternalServerError -> P.fatalCallout "The code server encountered an error. Please try again later or report an issue if the problem persists." - Timeout -> P.fatalCallout "The code server timed-out when responding to your request. Please try again later or report an issue if the problem persists." + RateLimitExceeded -> "Rate limit exceeded, please try again later." + Timeout -> "The code server timed-out when responding to your request. Please try again later or report an issue if the problem persists." + UnexpectedResponse resp -> + P.lines + ( catMaybes + [ Just + ( "The server sent a " + <> P.red (P.shown (Http.statusCode (Servant.responseStatusCode resp))) + <> " that we didn't expect." + ), + let body = Text.decodeUtf8 (LazyByteString.toStrict (Servant.responseBody resp)) + in if Text.null body then Nothing else Just (P.newline <> "Response body: " <> P.text body), + responseRequestId resp <&> \responseId -> P.newline <> "Request ID: " <> P.blue (P.text responseId) + ] + ) where + -- Dig the request id out of a response header. + responseRequestId :: Servant.Response -> Maybe Text + responseRequestId = + fmap Text.decodeUtf8 . List.lookup "X-RequestId" . Foldable.toList @Seq . Servant.responseHeaders + prettySharePath = prettyRelative . Path.Relative @@ -1675,11 +1694,11 @@ notifyUser dir o = case o of where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" expectedEmptyPushDest writeRemotePath = - P.lines - [ "The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is not empty.", - "", - "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" - ] + P.lines + [ "The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is not empty.", + "", + "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" + ] expectedNonEmptyPushDest writeRemotePath = P.lines [ P.wrap ("The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is empty."), @@ -2293,7 +2312,7 @@ showDiffNamespace :: (Pretty, NumberedArgs) showDiffNamespace _ _ _ _ diffOutput | OBD.isEmpty diffOutput = - ("The namespaces are identical.", mempty) + ("The namespaces are identical.", mempty) showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = (P.sepNonEmpty "\n\n" p, toList args) where diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index 184560f406..78a19fbf55 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -63,6 +63,7 @@ import Unison.Sync.Common (causalHashToHash32, entityToTempEntity, expectEntity, import qualified Unison.Sync.Types as Share import Unison.Util.Monoid (foldMapM) import qualified UnliftIO +import UnliftIO.Exception (throwIO) ------------------------------------------------------------------------------------------------------------------------ -- Pile of constants @@ -851,34 +852,31 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt go httpUploadEntities ) where - hoist :: Servant.ClientM a -> ReaderT (BaseUrl, Servant.ClientEnv) IO a + hoist :: Servant.ClientM a -> ReaderT Servant.ClientEnv IO a hoist m = do - (shareURL, clientEnv) <- Reader.ask - throwEitherM $ - liftIO (Servant.runClientM m clientEnv) >>= \case - Right a -> pure $ Right a - Left err -> do - Debug.debugLogM Debug.Sync (show err) - pure . Left $ case err of - Servant.FailureResponse _req resp -> case HTTP.statusCode $ Servant.responseStatusCode resp of - 401 -> Unauthenticated shareURL + clientEnv <- Reader.ask + liftIO (Servant.runClientM m clientEnv) >>= \case + Right a -> pure a + Left err -> do + Debug.debugLogM Debug.Sync (show err) + throwIO case err of + Servant.FailureResponse _req resp -> + case HTTP.statusCode $ Servant.responseStatusCode resp of + 401 -> Unauthenticated (Servant.baseUrl clientEnv) -- The server should provide semantically relevant permission-denied messages -- when possible, but this should catch any we miss. 403 -> PermissionDenied (Text.Lazy.toStrict . Text.Lazy.decodeUtf8 $ Servant.responseBody resp) 408 -> Timeout 429 -> RateLimitExceeded - 500 -> InternalServerError 504 -> Timeout - code - | code >= 500 -> InternalServerError - | otherwise -> InvalidResponse resp - Servant.DecodeFailure _msg resp -> InvalidResponse resp - Servant.UnsupportedContentType _ct resp -> InvalidResponse resp - Servant.InvalidContentTypeHeader resp -> InvalidResponse resp - Servant.ConnectionError {} -> UnreachableCodeserver shareURL + _ -> UnexpectedResponse resp + Servant.DecodeFailure msg resp -> DecodeFailure msg resp + Servant.UnsupportedContentType _ct resp -> UnexpectedResponse resp + Servant.InvalidContentTypeHeader resp -> UnexpectedResponse resp + Servant.ConnectionError _ -> UnreachableCodeserver (Servant.baseUrl clientEnv) go :: - (req -> ReaderT (BaseUrl, Servant.ClientEnv) IO resp) -> + (req -> ReaderT Servant.ClientEnv IO resp) -> Auth.AuthenticatedHttpClient -> BaseUrl -> req -> @@ -886,15 +884,13 @@ httpUploadEntities :: Auth.AuthenticatedHttpClient -> BaseUrl -> Share.UploadEnt go f (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req = runReaderT (f req) - ( unisonShareUrl, - (Servant.mkClientEnv httpClient unisonShareUrl) - { Servant.makeClientRequest = \url request -> - -- Disable client-side timeouts - (Servant.defaultMakeClientRequest url request) - { Http.Client.responseTimeout = Http.Client.responseTimeoutNone - } - } - ) + (Servant.mkClientEnv httpClient unisonShareUrl) + { Servant.makeClientRequest = \url request -> + -- Disable client-side timeouts + (Servant.defaultMakeClientRequest url request) + { Http.Client.responseTimeout = Http.Client.responseTimeoutNone + } + } catchSyncErrors :: IO (Either e a) -> IO (Either (SyncError e) a) catchSyncErrors action = diff --git a/unison-cli/src/Unison/Share/Sync/Types.hs b/unison-cli/src/Unison/Share/Sync/Types.hs index d596e2dcb7..3d9903457f 100644 --- a/unison-cli/src/Unison/Share/Sync/Types.hs +++ b/unison-cli/src/Unison/Share/Sync/Types.hs @@ -42,15 +42,15 @@ data GetCausalHashByPathError -- | Generic Codeserver transport errors data CodeserverTransportError - = Unauthenticated Servant.BaseUrl + = DecodeFailure Text Servant.Response | -- We try to catch permission failures in the endpoint's response type, but if any slip -- through they'll be translated as a PermissionDenied. PermissionDenied Text - | UnreachableCodeserver Servant.BaseUrl - | InvalidResponse Servant.Response | RateLimitExceeded - | InternalServerError | Timeout + | Unauthenticated Servant.BaseUrl + | UnexpectedResponse Servant.Response + | UnreachableCodeserver Servant.BaseUrl deriving stock (Show) deriving anyclass (Exception) From b1e45584d1ec2c674b8c4ecd637299abc8c9010a Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 6 Jul 2022 14:44:38 -0600 Subject: [PATCH 473/529] Filter out hashes which are outside of perspective for definition apis --- .../src/Unison/Codebase/Editor/HandleInput.hs | 5 +- unison-share-api/src/Unison/Server/Backend.hs | 16 +++- unison-src/transcripts/api-getDefinition.md | 2 +- .../transcripts/api-getDefinition.output.md | 92 +------------------ .../transcripts/api-namespace-list.output.md | 2 +- .../transcripts/duplicate-names.output.md | 2 +- .../transcripts/isPropagated-exists.output.md | 3 - .../transcripts/name-selection.output.md | 2 +- 8 files changed, 24 insertions(+), 100 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index e236f7d8d0..475c7d2d92 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -3378,7 +3378,8 @@ basicNames' :: (Functor m) => (Path -> Backend.NameScoping) -> Action m i v (Nam basicNames' nameScoping = do root' <- use LoopState.root currentPath' <- use LoopState.currentPath - pure $ Backend.prettyAndParseNamesForBranch root' (nameScoping $ Path.unabsolute currentPath') + let (parse, pretty, _local) = Backend.prettyAndParseNamesForBranch root' (nameScoping $ Path.unabsolute currentPath') + pure (parse, pretty) data AddRunMainResult v = NoTermWithThatName @@ -3498,7 +3499,7 @@ diffHelperCmd :: diffHelperCmd currentRoot currentPath before after = do hqLength <- eval CodebaseHashLength diff <- eval . Eval $ BranchDiff.diff0 before after - let (_parseNames, prettyNames0) = Backend.prettyAndParseNamesForBranch currentRoot (Backend.AllNames $ Path.unabsolute currentPath) + let (_parseNames, prettyNames0, _local) = Backend.prettyAndParseNamesForBranch currentRoot (Backend.AllNames $ Path.unabsolute currentPath) ppe <- PPE.suffixifiedPPE <$> prettyPrintEnvDecl (NamesWithHistory prettyNames0 mempty) (ppe,) <$> OBranchDiff.toOutput diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 4b4a08fd5c..437f21f045 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -1133,7 +1133,8 @@ definitionsBySuffixes :: [HQ.HashQualified Name] -> m (DefinitionResults Symbol) definitionsBySuffixes codebase nameSearch includeCycles query = do - QueryResult misses results <- hqNameQuery codebase nameSearch query + QueryResult misses allResults <- hqNameQuery codebase nameSearch query + let results = resultsInScope allResults -- todo: remember to replace this with getting components directly, -- and maybe even remove getComponentLength from Codebase interface altogether terms <- do @@ -1189,6 +1190,19 @@ definitionsBySuffixes codebase nameSearch includeCycles query = do decl <- Codebase.unsafeGetTypeDeclaration codebase rid pure (UserObject decl) + -- We already only search for results in the current scope, + -- but queries by Hash-only will still find results outside of the current namespace + resultsInScope :: [SR.SearchResult] -> [SR.SearchResult] + resultsInScope = mapMaybe \sr -> case sr of + SR.Tp tr -> + case lookupNames (typeSearch nameSearch) (SR.reference tr) of + Empty -> Nothing + _matches -> Just sr + SR.Tm tr -> + case lookupNames (termSearch nameSearch) (SR.referent tr) of + Empty -> Nothing + _matches -> Just sr + termsToSyntax :: Var v => Ord a => diff --git a/unison-src/transcripts/api-getDefinition.md b/unison-src/transcripts/api-getDefinition.md index 0ac910b441..8db3569684 100644 --- a/unison-src/transcripts/api-getDefinition.md +++ b/unison-src/transcripts/api-getDefinition.md @@ -23,6 +23,6 @@ GET /api/getDefinition?names=x&relativeTo=nested -- Should find definitions by hash, names should be relative GET /api/getDefinition?names=%23qkhkl0n238&relativeTo=nested --- Should find definitions by hash, using global names if no names in specified path. +-- Should filter out any definitions which aren't in the provided namespace even if the hash matches. GET /api/getDefinition?names=%23qkhkl0n238&relativeTo=emptypath ``` diff --git a/unison-src/transcripts/api-getDefinition.output.md b/unison-src/transcripts/api-getDefinition.output.md index 2c612abd43..ef167c5264 100644 --- a/unison-src/transcripts/api-getDefinition.output.md +++ b/unison-src/transcripts/api-getDefinition.output.md @@ -312,99 +312,11 @@ GET /api/getDefinition?names=%23qkhkl0n238&relativeTo=nested }, "typeDefinitions": {} } --- Should find definitions by hash, using global names if no names in specified path. +-- Should filter out any definitions which aren't in the provided namespace even if the hash matches. GET /api/getDefinition?names=%23qkhkl0n238&relativeTo=emptypath { "missingDefinitions": [], - "termDefinitions": { - "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": { - "bestTermName": "x", - "defnTermTag": null, - "signature": [ - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - } - ], - "termDefinition": { - "contents": [ - { - "annotation": { - "contents": "x", - "tag": "HashQualifier" - }, - "segment": "x" - }, - { - "annotation": { - "tag": "TypeAscriptionColon" - }, - "segment": " :" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "contents": "##Nat", - "tag": "TypeReference" - }, - "segment": "Nat" - }, - { - "annotation": null, - "segment": "\n" - }, - { - "annotation": { - "contents": "x", - "tag": "HashQualifier" - }, - "segment": "x" - }, - { - "annotation": { - "tag": "BindingEquals" - }, - "segment": " =" - }, - { - "annotation": null, - "segment": " " - }, - { - "annotation": { - "tag": "NumericLiteral" - }, - "segment": "42" - } - ], - "tag": "UserObject" - }, - "termDocs": [ - [ - "doc", - "#ulr9f75rpcrv79d7sfo2ep2tvbntu3e360lfomird2bdpj4bnea230e8o5j0b9our8vggocpa7eck3pus14fcfajlttat1bg71t6rbg", - { - "contents": [ - { - "contents": "Documentation", - "tag": "Word" - } - ], - "tag": "Paragraph" - } - ] - ], - "termNames": [ - ".nested.names.x" - ] - } - }, + "termDefinitions": {}, "typeDefinitions": {} } ``` \ No newline at end of file diff --git a/unison-src/transcripts/api-namespace-list.output.md b/unison-src/transcripts/api-namespace-list.output.md index 97d6194d64..b62c949fa5 100644 --- a/unison-src/transcripts/api-namespace-list.output.md +++ b/unison-src/transcripts/api-namespace-list.output.md @@ -129,4 +129,4 @@ GET /api/list?namespace=names&relativeTo=nested "namespaceListingFQN": "nested.names", "namespaceListingHash": "#oms19b4f9s3c8tb5skeb8jii95ij35n3hdg038pu6rv5b0fikqe4gd7lnu6a1i6aq5tdh2opdo4s0sfrupvk6vfkr9lf0n752gbl8o0" } -``` +``` \ No newline at end of file diff --git a/unison-src/transcripts/duplicate-names.output.md b/unison-src/transcripts/duplicate-names.output.md index 311202b91a..2e83ccdaf0 100644 --- a/unison-src/transcripts/duplicate-names.output.md +++ b/unison-src/transcripts/duplicate-names.output.md @@ -125,7 +125,7 @@ X = () .> view X - structural type X = Z + structural type X = Unit X : () X = () diff --git a/unison-src/transcripts/isPropagated-exists.output.md b/unison-src/transcripts/isPropagated-exists.output.md index 950ba13c48..c0f7936c36 100644 --- a/unison-src/transcripts/isPropagated-exists.output.md +++ b/unison-src/transcripts/isPropagated-exists.output.md @@ -39,9 +39,6 @@ x = 4 .> view 1 - #cb9e3iosob : #c23jofurce - #cb9e3iosob = #c23jofurce#0 - ``` Well, it's hard to tell from those hashes, but those are right. We can confirm by running `builtins.merge` to have UCM add names for them. diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md index 42e4b481ec..b25b85867d 100644 --- a/unison-src/transcripts/name-selection.output.md +++ b/unison-src/transcripts/name-selection.output.md @@ -1298,7 +1298,7 @@ At this point, `a3` is conflicted for symbols `c` and `d`, but the original `a2` a2.d : Nat a2.d = use Nat + - a2.c + 10 + tooManySegments + 10 a3.c#dcgdua2lj6 : Nat a3.c#dcgdua2lj6 = 2 From c8a0ab26b9406ae2fd931e3b40ad84bd04739107 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 6 Jul 2022 15:10:01 -0600 Subject: [PATCH 474/529] Move names filtering up to API level --- unison-core/src/Unison/NamesWithHistory.hs | 11 ++++---- unison-share-api/src/Unison/Server/Backend.hs | 25 ++++++------------- .../transcripts/duplicate-names.output.md | 2 +- .../transcripts/isPropagated-exists.output.md | 3 +++ 4 files changed, 18 insertions(+), 23 deletions(-) diff --git a/unison-core/src/Unison/NamesWithHistory.hs b/unison-core/src/Unison/NamesWithHistory.hs index 3c727208c5..dfae45adb2 100644 --- a/unison-core/src/Unison/NamesWithHistory.hs +++ b/unison-core/src/Unison/NamesWithHistory.hs @@ -2,7 +2,7 @@ module Unison.NamesWithHistory where -import Control.Lens (view, _4) +import Control.Lens (view, _5) import Data.List.Extra (nubOrd, sort) import qualified Data.Map as Map import qualified Data.Set as Set @@ -264,17 +264,18 @@ suffixedTermName :: Int -> Referent -> NamesWithHistory -> [HQ'.HashQualified Na where -- Orders names, using these criteria, in this order: -- 1. NameOnly comes before HashQualified, - -- 2. Shorter names (in terms of segment count) come before longer ones - -- 3. If same on attributes 1 and 2, compare alphabetically + -- 2. Names with shorter fully-qualified names (in terms of segment count) come before longer ones + -- 3. Shorter _suffixified_ names (in terms of segment count) come before longer ones + -- 4. If same on all other attributes, compare alphabetically go :: [Name] -> [HQ'.HashQualified Name] - go fqns = map (view _4) . sort $ map f fqns + go fqns = map (view _5) . sort $ map f fqns where f fqn = let n' = Name.shortestUniqueSuffix fqn r rel isHQ'd = R.manyDom fqn rel -- it is conflicted hq n = HQ'.take length (hq' n r) hqn = if isHQ'd then hq n' else HQ'.fromName n' - in (isHQ'd, Name.countSegments n', Name.isAbsolute n', hqn) + in (isHQ'd, Name.countSegments n', Name.countSegments fqn, Name.isAbsolute n', hqn) -- Set HashQualified -> Branch m -> Action' m v Names -- Set HashQualified -> Branch m -> Free (Command m i v) Names diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 437f21f045..cef6252842 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -821,8 +821,7 @@ prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase (_parseNames, _printNames, localNamesOnly, ppe) <- scopedNamesForBranchHash codebase root path let nameSearch :: NameSearch nameSearch = makeNameSearch hqLength (NamesWithHistory.fromCurrentNames localNamesOnly) - DefinitionResults terms types misses <- - lift (definitionsBySuffixes codebase nameSearch DontIncludeCycles query) + DefinitionResults terms types misses <- restrictDefinitionsToScope localNamesOnly <$> lift (definitionsBySuffixes codebase nameSearch DontIncludeCycles query) let width = mayDefaultWidth renderWidth @@ -931,6 +930,12 @@ prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase renderedDisplayTerms renderedDisplayTypes renderedMisses + where + restrictDefinitionsToScope :: Names -> DefinitionResults Symbol -> DefinitionResults Symbol + restrictDefinitionsToScope localNames (DefinitionResults terms types misses) = + let filteredTerms = Map.restrictKeys terms (Names.termReferences localNames) + filteredTypes = Map.restrictKeys types (Names.typeReferences localNames) + in DefinitionResults filteredTerms filteredTypes misses renderDoc :: PPE.PrettyPrintEnvDecl -> @@ -1133,8 +1138,7 @@ definitionsBySuffixes :: [HQ.HashQualified Name] -> m (DefinitionResults Symbol) definitionsBySuffixes codebase nameSearch includeCycles query = do - QueryResult misses allResults <- hqNameQuery codebase nameSearch query - let results = resultsInScope allResults + QueryResult misses results <- hqNameQuery codebase nameSearch query -- todo: remember to replace this with getting components directly, -- and maybe even remove getComponentLength from Codebase interface altogether terms <- do @@ -1190,19 +1194,6 @@ definitionsBySuffixes codebase nameSearch includeCycles query = do decl <- Codebase.unsafeGetTypeDeclaration codebase rid pure (UserObject decl) - -- We already only search for results in the current scope, - -- but queries by Hash-only will still find results outside of the current namespace - resultsInScope :: [SR.SearchResult] -> [SR.SearchResult] - resultsInScope = mapMaybe \sr -> case sr of - SR.Tp tr -> - case lookupNames (typeSearch nameSearch) (SR.reference tr) of - Empty -> Nothing - _matches -> Just sr - SR.Tm tr -> - case lookupNames (termSearch nameSearch) (SR.referent tr) of - Empty -> Nothing - _matches -> Just sr - termsToSyntax :: Var v => Ord a => diff --git a/unison-src/transcripts/duplicate-names.output.md b/unison-src/transcripts/duplicate-names.output.md index 2e83ccdaf0..311202b91a 100644 --- a/unison-src/transcripts/duplicate-names.output.md +++ b/unison-src/transcripts/duplicate-names.output.md @@ -125,7 +125,7 @@ X = () .> view X - structural type X = Unit + structural type X = Z X : () X = () diff --git a/unison-src/transcripts/isPropagated-exists.output.md b/unison-src/transcripts/isPropagated-exists.output.md index c0f7936c36..950ba13c48 100644 --- a/unison-src/transcripts/isPropagated-exists.output.md +++ b/unison-src/transcripts/isPropagated-exists.output.md @@ -39,6 +39,9 @@ x = 4 .> view 1 + #cb9e3iosob : #c23jofurce + #cb9e3iosob = #c23jofurce#0 + ``` Well, it's hard to tell from those hashes, but those are right. We can confirm by running `builtins.merge` to have UCM add names for them. From c8a680245070cbaa8452347b0af4e989f64813e1 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 6 Jul 2022 15:28:04 -0600 Subject: [PATCH 475/529] Flip name selection priority --- unison-core/src/Unison/NamesWithHistory.hs | 2 +- unison-src/transcripts/name-selection.output.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-core/src/Unison/NamesWithHistory.hs b/unison-core/src/Unison/NamesWithHistory.hs index dfae45adb2..5f21bdca2f 100644 --- a/unison-core/src/Unison/NamesWithHistory.hs +++ b/unison-core/src/Unison/NamesWithHistory.hs @@ -275,7 +275,7 @@ suffixedTermName :: Int -> Referent -> NamesWithHistory -> [HQ'.HashQualified Na isHQ'd = R.manyDom fqn rel -- it is conflicted hq n = HQ'.take length (hq' n r) hqn = if isHQ'd then hq n' else HQ'.fromName n' - in (isHQ'd, Name.countSegments n', Name.countSegments fqn, Name.isAbsolute n', hqn) + in (isHQ'd, Name.countSegments fqn, Name.countSegments n', Name.isAbsolute n', hqn) -- Set HashQualified -> Branch m -> Action' m v Names -- Set HashQualified -> Branch m -> Free (Command m i v) Names diff --git a/unison-src/transcripts/name-selection.output.md b/unison-src/transcripts/name-selection.output.md index b25b85867d..42e4b481ec 100644 --- a/unison-src/transcripts/name-selection.output.md +++ b/unison-src/transcripts/name-selection.output.md @@ -1298,7 +1298,7 @@ At this point, `a3` is conflicted for symbols `c` and `d`, but the original `a2` a2.d : Nat a2.d = use Nat + - tooManySegments + 10 + a2.c + 10 a3.c#dcgdua2lj6 : Nat a3.c#dcgdua2lj6 = 2 From 6884c258485d9c668cee8265b187fcbdf3bb8240 Mon Sep 17 00:00:00 2001 From: Cody Allen Date: Thu, 7 Jul 2022 08:27:26 -0400 Subject: [PATCH 476/529] Attempt to include Windows artifact in dev build --- .github/workflows/pre-release.yaml | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.github/workflows/pre-release.yaml b/.github/workflows/pre-release.yaml index 3310e2fbe1..d77644683b 100644 --- a/.github/workflows/pre-release.yaml +++ b/.github/workflows/pre-release.yaml @@ -135,4 +135,6 @@ jobs: automatic_release_tag: "latest" prerelease: true title: "Development Build" - files: /tmp/ucm/**/*.tar.gz + files: | + /tmp/ucm/**/*.tar.gz + /tmp/ucm/**/*.zip From cc71ee0352403904667b945b22b8ac3c81116acb Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 7 Jul 2022 13:08:42 -0400 Subject: [PATCH 477/529] minor cleanup --- codebase2/core/U/Core/ABT.hs | 2 +- unison-core/src/Unison/ABT.hs | 7 ------- 2 files changed, 1 insertion(+), 8 deletions(-) diff --git a/codebase2/core/U/Core/ABT.hs b/codebase2/core/U/Core/ABT.hs index 780b4862f8..a3d03b6886 100644 --- a/codebase2/core/U/Core/ABT.hs +++ b/codebase2/core/U/Core/ABT.hs @@ -76,7 +76,7 @@ instance (forall a. Show a => Show (f a), Show v) => Show (Term f v a) where Abs v body -> showParen True $ (show v ++) . showString ". " . showsPrec p body Tm f -> showsPrec p f -amap :: (Functor f, Foldable f) => (a -> a') -> Term f v a -> Term f v a' +amap :: Functor f => (a -> a') -> Term f v a -> Term f v a' amap = fmap vmap :: (Functor f, Foldable f, Ord v') => (v -> v') -> Term f v a -> Term f v' a diff --git a/unison-core/src/Unison/ABT.hs b/unison-core/src/Unison/ABT.hs index c4ba36a98e..ecbb4428ec 100644 --- a/unison-core/src/Unison/ABT.hs +++ b/unison-core/src/Unison/ABT.hs @@ -200,13 +200,6 @@ amap' f t@(Term _ a out) = case out of Cycle r -> cycle' (f t a) (amap' f r) Abs v body -> abs' (f t a) v (amap' f body) --- amap :: (Functor f, Foldable f) => (a -> a') -> Term f v a -> Term f v a' --- amap f (Term fv a out) = Term fv (f a) $ case out of --- Var v -> Var v --- Tm fa -> Tm (amap f <$> fa) --- Cycle r -> Cycle (amap f r) --- Abs v body -> Abs v (amap f body) - extraMap :: Functor g => (forall k. f k -> g k) -> Term f v a -> Term g v a extraMap p (Term fvs a sub) = Term fvs a (go p sub) where From 528471817b825e88bab7c3ea5a1370d3dc17f039 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 7 Jul 2022 15:26:50 -0400 Subject: [PATCH 478/529] add test.all alias for test, and pull test handler out to top level --- .../src/Unison/Codebase/Editor/HandleInput.hs | 127 ++++++++++-------- .../src/Unison/Codebase/Editor/Input.hs | 15 ++- .../src/Unison/CommandLine/InputPatterns.hs | 27 +++- 3 files changed, 107 insertions(+), 62 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 02d2218357..8fdced40ae 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1319,63 +1319,7 @@ loop = do TodoI patchPath branchPath' -> do patch <- getPatchAt (fromMaybe defaultPatchPath patchPath) doShowTodoOutput patch $ resolveToAbsolute branchPath' - TestI showOk showFail -> do - let testTerms = - Map.keys . R4.d1 . uncurry R4.selectD34 isTest - . Branch.deepTermMetadata - $ currentBranch0 - testRefs = Set.fromList [r | Referent.Ref r <- toList testTerms] - oks results = - [ (r, msg) - | (r, Term.List' ts) <- Map.toList results, - Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts, - cid == DD.okConstructorId && ref == DD.testResultRef - ] - fails results = - [ (r, msg) - | (r, Term.List' ts) <- Map.toList results, - Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts, - cid == DD.failConstructorId && ref == DD.testResultRef - ] - cachedTests <- fmap Map.fromList . eval $ LoadWatches WK.TestWatch testRefs - let stats = Output.CachedTests (Set.size testRefs) (Map.size cachedTests) - names <- - makePrintNamesFromLabeled' $ - LD.referents testTerms - <> LD.referents [DD.okConstructorReferent, DD.failConstructorReferent] - ppe <- fqnPPE names - respond $ - TestResults - stats - ppe - showOk - showFail - (oks cachedTests) - (fails cachedTests) - let toCompute = Set.difference testRefs (Map.keysSet cachedTests) - unless (Set.null toCompute) $ do - let total = Set.size toCompute - computedTests <- fmap join . for (toList toCompute `zip` [1 ..]) $ \(r, n) -> - case r of - Reference.DerivedId rid -> do - tm <- eval $ LoadTerm rid - case tm of - Nothing -> [] <$ respond (TermNotFound' . SH.take hqLength . Reference.toShortHash $ Reference.DerivedId rid) - Just tm -> do - respond $ TestIncrementalOutputStart ppe (n, total) r tm - -- v don't cache; test cache populated below - tm' <- eval $ Evaluate1 ppe False tm - case tm' of - Left e -> respond (EvaluationFailure e) $> [] - Right tm' -> do - -- After evaluation, cache the result of the test - eval $ PutWatch WK.TestWatch rid tm' - respond $ TestIncrementalOutputEnd ppe (n, total) r tm' - pure [(r, tm')] - r -> error $ "unpossible, tests can't be builtins: " <> show r - - let m = Map.fromList computedTests - respond $ TestResults Output.NewlyComputed ppe showOk showFail (oks m) (fails m) + TestI testInput -> handleTest testInput PropagatePatchI patchPath scopePath -> do patch <- getPatchAt patchPath updated <- propagatePatch inputDescription patch (resolveToAbsolute scopePath) @@ -2000,6 +1944,75 @@ handleShowDefinition outputLoc inputQuery = do Nothing -> Just "scratch.u" Just (path, _) -> Just path +-- | Handle a @test@ command. +handleTest :: Monad m => TestInput -> Action' m v () +handleTest TestInput {showFailures, showSuccesses} = do + testTerms <- do + currentPath' <- use LoopState.currentPath + currentBranch' <- getAt currentPath' + currentBranch' + & Branch.head + & Branch.deepTermMetadata + & uncurry R4.selectD34 isTest + & R4.d1 + & Map.keys + & pure + let testRefs = Set.fromList [r | Referent.Ref r <- testTerms] + oks results = + [ (r, msg) + | (r, Term.List' ts) <- Map.toList results, + Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts, + cid == DD.okConstructorId && ref == DD.testResultRef + ] + fails results = + [ (r, msg) + | (r, Term.List' ts) <- Map.toList results, + Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts, + cid == DD.failConstructorId && ref == DD.testResultRef + ] + cachedTests <- fmap Map.fromList . eval $ LoadWatches WK.TestWatch testRefs + let stats = Output.CachedTests (Set.size testRefs) (Map.size cachedTests) + names <- + makePrintNamesFromLabeled' $ + LD.referents testTerms + <> LD.referents [DD.okConstructorReferent, DD.failConstructorReferent] + ppe <- fqnPPE names + respond $ + TestResults + stats + ppe + showSuccesses + showFailures + (oks cachedTests) + (fails cachedTests) + let toCompute = Set.difference testRefs (Map.keysSet cachedTests) + unless (Set.null toCompute) do + let total = Set.size toCompute + computedTests <- fmap join . for (toList toCompute `zip` [1 ..]) $ \(r, n) -> + case r of + Reference.DerivedId rid -> do + tm <- eval $ LoadTerm rid + case tm of + Nothing -> do + hqLength <- eval CodebaseHashLength + respond (TermNotFound' . SH.take hqLength . Reference.toShortHash $ Reference.DerivedId rid) + pure [] + Just tm -> do + respond $ TestIncrementalOutputStart ppe (n, total) r tm + -- v don't cache; test cache populated below + tm' <- eval $ Evaluate1 ppe False tm + case tm' of + Left e -> respond (EvaluationFailure e) $> [] + Right tm' -> do + -- After evaluation, cache the result of the test + eval $ PutWatch WK.TestWatch rid tm' + respond $ TestIncrementalOutputEnd ppe (n, total) r tm' + pure [(r, tm')] + r -> error $ "unpossible, tests can't be builtins: " <> show r + + let m = Map.fromList computedTests + respond $ TestResults Output.NewlyComputed ppe showSuccesses showFailures (oks m) (fails m) + -- | Handle an @update@ command. handleUpdate :: forall m v. (Monad m, Var v) => Input -> OptionalPatch -> Set Name -> Action' m v () handleUpdate input optionalPatch requestedNames = do diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 59ba8a92d5..8504edc575 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -1,6 +1,7 @@ module Unison.Codebase.Editor.Input ( Input (..), GistInput (..), + TestInput (..), Event (..), OutputLocation (..), PatchPath, @@ -144,10 +145,10 @@ data Input IOTestI (HQ.HashQualified Name) | -- make a standalone binary file MakeStandaloneI String (HQ.HashQualified Name) - | TestI Bool Bool -- TestI showSuccesses showFailures - -- metadata - -- `link metadata definitions` (adds metadata to all of `definitions`) - | LinkI (HQ.HashQualified Name) [Path.HQSplit'] + | TestI TestInput + | -- metadata + -- `link metadata definitions` (adds metadata to all of `definitions`) + LinkI (HQ.HashQualified Name) [Path.HQSplit'] | -- `unlink metadata definitions` (removes metadata from all of `definitions`) UnlinkI (HQ.HashQualified Name) [Path.HQSplit'] | -- links from @@ -194,6 +195,12 @@ data GistInput = GistInput } deriving stock (Eq, Show) +data TestInput = TestInput + { showFailures :: Bool, + showSuccesses :: Bool + } + deriving stock (Eq, Show) + -- Some commands, like `view`, can dump output to either console or a file. data OutputLocation = ConsoleLocation diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index d4d53c4a62..902fbde6bf 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1898,7 +1898,31 @@ test = I.Visible [] "`test` runs unit tests for the current branch." - (const $ pure $ Input.TestI True True) + ( const $ + pure $ + Input.TestI + Input.TestInput + { showFailures = True, + showSuccesses = True + } + ) + +testAll :: InputPattern +testAll = + InputPattern + "test.all" + [] + I.Visible + [] + "`test.all` runs unit tests for the current branch, including dependencies." + ( const $ + pure $ + Input.TestI + Input.TestInput + { showFailures = True, + showSuccesses = True + } + ) docsToHtml :: InputPattern docsToHtml = @@ -2138,6 +2162,7 @@ validInputs = deleteTermReplacement, deleteTypeReplacement, test, + testAll, ioTest, execute, viewReflog, From 86ac76b6b87fb82c4d90e55510a2e859550361b1 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 7 Jul 2022 16:22:43 -0400 Subject: [PATCH 479/529] start implementing test.all --- .../src/Unison/Util/Relation4.hs | 10 ++++++++++ .../src/Unison/Codebase/Editor/HandleInput.hs | 15 +++++++++++---- unison-core/src/Unison/Referent.hs | 12 +++++++++--- 3 files changed, 30 insertions(+), 7 deletions(-) diff --git a/lib/unison-util-relation/src/Unison/Util/Relation4.hs b/lib/unison-util-relation/src/Unison/Util/Relation4.hs index 503c8ca590..d16ba2525a 100644 --- a/lib/unison-util-relation/src/Unison/Util/Relation4.hs +++ b/lib/unison-util-relation/src/Unison/Util/Relation4.hs @@ -79,6 +79,16 @@ selectD34 c d r = (Map.lookup c (d3 r)) ] +restrict34d12 :: + (Ord a, Ord b, Ord c, Ord d) => + (c, d) -> + Relation4 a b c d -> + Relation a b +restrict34d12 (c, d) Relation4{d3} = + fromMaybe R.empty do + abd <- Map.lookup c d3 + Map.lookup d (R3.d3 abd) + keys :: Relation4 a b c d -> (Set a, Set b, Set c, Set d) keys Relation4 {d1, d2, d3, d4} = (Map.keysSet d1, Map.keysSet d2, Map.keysSet d3, Map.keysSet d4) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 8fdced40ae..6d3caea09c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -169,6 +169,7 @@ import qualified Unison.Util.Pretty as P import qualified Unison.Util.Relation as R import qualified Unison.Util.Relation as Relation import qualified Unison.Util.Relation4 as R4 +import qualified Unison.Util.Set as Set import qualified Unison.Util.Star3 as Star3 import Unison.Util.TransitiveClosure (transitiveClosure) import Unison.Var (Var) @@ -1953,11 +1954,11 @@ handleTest TestInput {showFailures, showSuccesses} = do currentBranch' & Branch.head & Branch.deepTermMetadata - & uncurry R4.selectD34 isTest - & R4.d1 - & Map.keys + & R4.restrict34d12 isTest + & (if True then id else R.filterRan (not . isInLibNamespace)) + & R.dom & pure - let testRefs = Set.fromList [r | Referent.Ref r <- testTerms] + let testRefs = Set.mapMaybe Referent.toTermReference testTerms oks results = [ (r, msg) | (r, Term.List' ts) <- Map.toList results, @@ -2012,6 +2013,12 @@ handleTest TestInput {showFailures, showSuccesses} = do let m = Map.fromList computedTests respond $ TestResults Output.NewlyComputed ppe showSuccesses showFailures (oks m) (fails m) + where + isInLibNamespace :: Name -> Bool + isInLibNamespace name = + case Name.segments name of + "lib" Nel.:| _ : _ -> True + _ -> False -- | Handle an @update@ command. handleUpdate :: forall m v. (Monad m, Var v) => Input -> OptionalPatch -> Set Name -> Action' m v () diff --git a/unison-core/src/Unison/Referent.hs b/unison-core/src/Unison/Referent.hs index 6c6da98cb1..cad521fed2 100644 --- a/unison-core/src/Unison/Referent.hs +++ b/unison-core/src/Unison/Referent.hs @@ -11,6 +11,7 @@ module Unison.Referent fold, toReference, toReferenceId, + toTermReference, fromTermReference, fromTermReferenceId, fromText, @@ -34,7 +35,7 @@ import Unison.ConstructorType (ConstructorType) import qualified Unison.ConstructorType as CT import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.Prelude hiding (fold) -import Unison.Reference (Reference, TermReference) +import Unison.Reference (Reference, TermReference, TermReferenceId) import qualified Unison.Reference as R import qualified Unison.Reference as Reference import Unison.Referent' (Referent' (..), reference_, toReference') @@ -99,11 +100,16 @@ toReference = toReference' toReferenceId :: Referent -> Maybe Reference.Id toReferenceId = Reference.toId . toReference +toTermReference :: Referent -> Maybe TermReference +toTermReference = \case + Con' _ _ -> Nothing + Ref' reference -> Just reference + -- | Inject a Term Reference into a Referent -fromTermReference :: Reference -> Referent +fromTermReference :: TermReference -> Referent fromTermReference r = Ref r -fromTermReferenceId :: Reference.Id -> Referent +fromTermReferenceId :: TermReferenceId -> Referent fromTermReferenceId = fromTermReference . Reference.fromId isPrefixOf :: ShortHash -> Referent -> Bool From 1f636bccb4d7cea900ec7d66b4659a9e0540787f Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Thu, 7 Jul 2022 16:29:50 -0400 Subject: [PATCH 480/529] self-contained find --- .../src/Unison/Codebase/Editor/HandleInput.hs | 132 +++++++++++------- .../src/Unison/Codebase/Editor/Input.hs | 9 +- .../src/Unison/CommandLine/InputPatterns.hs | 22 ++- 3 files changed, 104 insertions(+), 59 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index c5f10399c0..6373ba7bde 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -514,7 +514,6 @@ loop = do updateAtM = Unison.Codebase.Editor.HandleInput.updateAtM inputDescription importRemoteGitBranch ns mode preprocess = ExceptT . eval $ ImportRemoteGitBranch ns mode preprocess - loadSearchResults = eval . LoadSearchResults saveAndApplyPatch patchPath'' patchName patch' = do stepAtM Branch.CompressHistory @@ -1116,52 +1115,8 @@ loop = do p | last p == '.' -> p ++ s p -> p ++ "." ++ s pathArgStr = show pathArg - FindI isVerbose global ws -> do - let prettyPrintNames = basicPrettyPrintNames - unlessError do - results <- case ws of - -- no query, list everything - [] -> pure . listBranch $ Branch.head currentBranch' - -- type query - ":" : ws -> - ExceptT (parseSearchType (show input) (unwords ws)) >>= \typ -> - ExceptT $ do - let named = Branch.deepReferents root0 - matches <- - fmap (filter (`Set.member` named) . toList) $ - eval $ GetTermsOfType typ - matches <- - if null matches - then do - respond NoExactTypeMatches - fmap (filter (`Set.member` named) . toList) $ - eval $ GetTermsMentioningType typ - else pure matches - let results = - -- in verbose mode, aliases are shown, so we collapse all - -- aliases to a single search result; in non-verbose mode, - -- a separate result may be shown for each alias - (if isVerbose then uniqueBy SR.toReferent else id) $ - searchResultsFor prettyPrintNames matches [] - pure . pure $ results - - -- name query - (map HQ.unsafeFromString -> qs) -> do - ns <- - lift $ - if not global - then basicParseNames - else fst <$> basicNames' Backend.AllNames - let srs = searchBranchScored ns fuzzyNameDistance qs - pure $ uniqueBy SR.toReferent srs - lift do - LoopState.numberedArgs .= fmap searchResultToHQString results - results' <- loadSearchResults results - ppe <- - suffixifiedPPE - =<< makePrintNamesFromLabeled' - (foldMap SR'.labeledDependencies results') - respond $ ListOfDefinitions ppe isVerbose results' + FindI isVerbose fscope ws -> + handleFindI isVerbose fscope ws input ResolveTypeNameI hq -> zeroOneOrMore (getHQ'Types hq) (typeNotFound hq) go (typeConflicted hq) where @@ -1726,6 +1681,85 @@ handleCreatePullRequest baseRepo0 headRepo0 = do diff <- mergeAndDiff baseBranch headBranch respondNumbered diff +handleFindI + :: (Monad m, Var v) + => Bool + -> FindScope + -> [String] + -> Input + -> Action' m v () +handleFindI isVerbose fscope ws input = do + root' <- use LoopState.root + currentPath' <- use LoopState.currentPath + currentBranch' <- getAt currentPath' + let currentBranch0 = Branch.head currentBranch' + getNames :: FindScope -> Names + getNames findScope = + let namesWithinCurrentPath = Backend.prettyNamesForBranch root' nameScope + cp = Path.unabsolute currentPath' + nameScope = case findScope of + Local -> Backend.Within cp + LocalAndDeps -> Backend.Within cp + Global -> Backend.AllNames cp + scopeFilter = case findScope of + Local -> + let f n = + case Name.segments n of + "lib" Nel.:| _ : _ -> False + _ -> True + in Names.filter f + Global -> id + LocalAndDeps -> + let f n = + case Name.segments n of + "lib" Nel.:| (_ : "lib" : _) -> False + _ -> True + in Names.filter f + in scopeFilter namesWithinCurrentPath + unlessError do + let getResults names = do + case ws of + [] -> pure (List.sortOn (\s -> (SR.name s, s)) (SR.fromNames names)) + -- type query + ":" : ws -> + ExceptT (parseSearchType (show input) (unwords ws)) >>= \typ -> + ExceptT $ do + let named = Branch.deepReferents currentBranch0 + matches <- + fmap (filter (`Set.member` named) . toList) $ + eval $ GetTermsOfType typ + matches <- + if null matches + then do + respond NoExactTypeMatches + fmap (filter (`Set.member` named) . toList) $ + eval $ GetTermsMentioningType typ + else pure matches + let results = + -- in verbose mode, aliases are shown, so we collapse all + -- aliases to a single search result; in non-verbose mode, + -- a separate result may be shown for each alias + (if isVerbose then uniqueBy SR.toReferent else id) $ + searchResultsFor names matches [] + pure . pure $ results + + -- name query + (map HQ.unsafeFromString -> qs) -> do + let srs = searchBranchScored names fuzzyNameDistance qs + pure $ uniqueBy SR.toReferent srs + let respondResults results = lift do + LoopState.numberedArgs .= fmap searchResultToHQString results + results' <- eval $ LoadSearchResults results + ppe <- + suffixifiedPPE + =<< makePrintNamesFromLabeled' + (foldMap SR'.labeledDependencies results') + respond $ ListOfDefinitions ppe isVerbose results' + results <- getResults (getNames fscope) + case (results, fscope) of + ([],Local) -> respondResults =<< getResults (getNames LocalAndDeps) + _ -> respondResults results + handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v () handleDependents hq = do hqLength <- eval CodebaseHashLength @@ -2588,10 +2622,6 @@ confirmedCommand i = do i0 <- use LoopState.lastInput pure $ Just i == i0 -listBranch :: Branch0 m -> [SearchResult] -listBranch (Branch.toNames -> b) = - List.sortOn (\s -> (SR.name s, s)) (SR.fromNames b) - -- | restores the full hash to these search results, for _numberedArgs purposes searchResultToHQString :: SearchResult -> String searchResultToHQString = \case diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 59ba8a92d5..227dae7737 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -11,6 +11,7 @@ module Unison.Codebase.Editor.Input Insistence (..), PullMode (..), OptionalPatch (..), + FindScope (..), IsGlobal, ) where @@ -158,7 +159,7 @@ data Input | -- Display docs for provided terms. If list is empty, prompt a fuzzy search. DocsI [Path.HQSplit'] | -- other - FindI Bool IsGlobal [String] -- FindI isVerbose global query + FindI Bool FindScope [String] -- FindI isVerbose findScope query | FindShallowI Path' | FindPatchI | -- Show provided definitions. If list is empty, prompt a fuzzy search. @@ -201,3 +202,9 @@ data OutputLocation | FileLocation FilePath -- ClipboardLocation deriving (Eq, Show) + +data FindScope + = Local + | LocalAndDeps + | Global + deriving stock (Eq, Show) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index d4d53c4a62..436c6cd159 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -432,13 +432,16 @@ viewByPrefix = ) find :: InputPattern -find = find' "find" False +find = find' "find" Input.Local + +findAll :: InputPattern +findAll = find' "find.all" Input.LocalAndDeps findGlobal :: InputPattern -findGlobal = find' "find.global" True +findGlobal = find' "find.global" Input.Global -find' :: String -> Bool -> InputPattern -find' cmd global = +find' :: String -> Input.FindScope -> InputPattern +find' cmd fscope = InputPattern cmd [] @@ -448,18 +451,22 @@ find' cmd global = [ ("`find`", "lists all definitions in the current namespace."), ( "`find foo`", "lists all definitions with a name similar to 'foo' in the current " - <> "namespace." + <> "namespace. Falls back to `find.all` if no matches are found." ), ( "`find foo bar`", "lists all definitions with a name similar to 'foo' or 'bar' in the " <> "current namespace." ), + ( "find.all foo", + "lists all definitions with a name similar to 'foo' in the current " + <> "namespace or direct dependencies." + ), ( "find.global foo", "lists all definitions with a name similar to 'foo' in any namespace" ) ] ) - (pure . Input.FindI False global) + (pure . Input.FindI False fscope) findShallow :: InputPattern findShallow = @@ -492,7 +499,7 @@ findVerbose = ( "`find.verbose` searches for definitions like `find`, but includes hashes " <> "and aliases in the results." ) - (pure . Input.FindI True False) + (pure . Input.FindI True Input.Local) findPatch :: InputPattern findPatch = @@ -2107,6 +2114,7 @@ validInputs = copyPatch, find, findGlobal, + findAll, findShallow, findVerbose, view, From 88bf9ceb5f5b79059f36ab73c9295ca019dbea04 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 8 Jul 2022 11:39:51 -0400 Subject: [PATCH 481/529] pipe through new includeLibNamespace bool --- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 4 ++-- unison-cli/src/Unison/Codebase/Editor/Input.hs | 4 +++- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 8 +++++--- 3 files changed, 10 insertions(+), 6 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 6d3caea09c..74e952f08e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1947,7 +1947,7 @@ handleShowDefinition outputLoc inputQuery = do -- | Handle a @test@ command. handleTest :: Monad m => TestInput -> Action' m v () -handleTest TestInput {showFailures, showSuccesses} = do +handleTest TestInput {includeLibNamespace, showFailures, showSuccesses} = do testTerms <- do currentPath' <- use LoopState.currentPath currentBranch' <- getAt currentPath' @@ -1955,7 +1955,7 @@ handleTest TestInput {showFailures, showSuccesses} = do & Branch.head & Branch.deepTermMetadata & R4.restrict34d12 isTest - & (if True then id else R.filterRan (not . isInLibNamespace)) + & (if includeLibNamespace then id else R.filterRan (not . isInLibNamespace)) & R.dom & pure let testRefs = Set.mapMaybe Referent.toTermReference testTerms diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 8504edc575..ba7161f6b3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -196,7 +196,9 @@ data GistInput = GistInput deriving stock (Eq, Show) data TestInput = TestInput - { showFailures :: Bool, + { -- | Should we run tests in the `lib` namespace? + includeLibNamespace :: Bool, + showFailures :: Bool, showSuccesses :: Bool } deriving stock (Eq, Show) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 902fbde6bf..2c24b58434 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1902,7 +1902,8 @@ test = pure $ Input.TestI Input.TestInput - { showFailures = True, + { includeLibNamespace = False, + showFailures = True, showSuccesses = True } ) @@ -1914,12 +1915,13 @@ testAll = [] I.Visible [] - "`test.all` runs unit tests for the current branch, including dependencies." + "`test.all` runs unit tests for the current branch (including the `lib` namespace)." ( const $ pure $ Input.TestI Input.TestInput - { showFailures = True, + { includeLibNamespace = True, + showFailures = True, showSuccesses = True } ) From 82d8aed9c577fd56c5a376dff9a2e92ad728afa2 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 8 Jul 2022 13:02:09 -0400 Subject: [PATCH 482/529] add unison symlink for supporting hereFile in or out of enlil --- unison | 1 + 1 file changed, 1 insertion(+) create mode 120000 unison diff --git a/unison b/unison new file mode 120000 index 0000000000..945c9b46d6 --- /dev/null +++ b/unison @@ -0,0 +1 @@ +. \ No newline at end of file From e60f12ab4f4a833ba5b3e10599f4400e02300e5c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 8 Jul 2022 12:11:32 -0600 Subject: [PATCH 483/529] Fix base-pull location --- unison-cli/src/Unison/Codebase/Editor/VersionParser.hs | 10 +++++----- unison-cli/tests/Unison/Test/VersionParser.hs | 4 ++-- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index d5d1c930bc..0782dcd190 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -14,18 +14,18 @@ import qualified Unison.Codebase.Path as Path -- | Parse git version strings into valid unison namespaces. -- -- >>> parseMaybe defaultBaseLib "release/M1j" --- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.dev.base.releases._M1j}) +-- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.base.releases._M1j}) -- -- >>> parseMaybe defaultBaseLib "release/M1j.2" --- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.dev.base.releases._M1j_2}) +-- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.base.releases._M1j_2}) -- -- >>> parseMaybe defaultBaseLib "latest-1234" --- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.dev.base.trunk}) +-- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.base.latest}) defaultBaseLib :: Parsec Void Text ReadShareRemoteNamespace defaultBaseLib = fmap makeNS $ latest <|> release where latest, release, version :: Parsec Void Text Text - latest = "latest-" *> many anySingle *> eof $> "trunk" + latest = "latest-" *> many anySingle *> eof $> "latest" release = fmap ("releases._" <>) $ "release/" *> version <* eof version = do Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) @@ -34,5 +34,5 @@ defaultBaseLib = fmap makeNS $ latest <|> release ReadShareRemoteNamespace { server = DefaultCodeserver, repo = "unison", - path = "public" Path.:< "dev" Path.:< "base" Path.:< Path.fromText t + path = "public" Path.:< "base" Path.:< Path.fromText t } diff --git a/unison-cli/tests/Unison/Test/VersionParser.hs b/unison-cli/tests/Unison/Test/VersionParser.hs index 3417e84b48..05caeb348a 100644 --- a/unison-cli/tests/Unison/Test/VersionParser.hs +++ b/unison-cli/tests/Unison/Test/VersionParser.hs @@ -15,7 +15,7 @@ test = scope "versionparser" . tests . fmap makeTest $ [ ("release/M1j", "releases._M1j"), ("release/M1j.2", "releases._M1j_2"), - ("latest-abc", "trunk"), + ("latest-abc", "latest"), ("release/M2i_3", "releases._M2i_3"), ("release/M2i-HOTFIX", "releases._M2i_HOTFIX") ] @@ -29,7 +29,7 @@ makeTest (version, path) = ( ReadShareRemoteNamespace { server = DefaultCodeserver, repo = "unison", - path = Path.fromList ["public", "dev", "base"] <> Path.fromText path + path = Path.fromList ["public", "base"] <> Path.fromText path } ) ) From 79aa93fd225360404dbeabf9cdfad6d1ddcbd363 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 8 Jul 2022 13:47:30 -0600 Subject: [PATCH 484/529] latest -> main --- unison-cli/src/Unison/Codebase/Editor/VersionParser.hs | 4 ++-- unison-cli/tests/Unison/Test/VersionParser.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index 0782dcd190..315f08ece9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -20,12 +20,12 @@ import qualified Unison.Codebase.Path as Path -- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.base.releases._M1j_2}) -- -- >>> parseMaybe defaultBaseLib "latest-1234" --- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.base.latest}) +-- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.base.main}) defaultBaseLib :: Parsec Void Text ReadShareRemoteNamespace defaultBaseLib = fmap makeNS $ latest <|> release where latest, release, version :: Parsec Void Text Text - latest = "latest-" *> many anySingle *> eof $> "latest" + latest = "latest-" *> many anySingle *> eof $> "main" release = fmap ("releases._" <>) $ "release/" *> version <* eof version = do Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) diff --git a/unison-cli/tests/Unison/Test/VersionParser.hs b/unison-cli/tests/Unison/Test/VersionParser.hs index 05caeb348a..bf779fdbba 100644 --- a/unison-cli/tests/Unison/Test/VersionParser.hs +++ b/unison-cli/tests/Unison/Test/VersionParser.hs @@ -15,7 +15,7 @@ test = scope "versionparser" . tests . fmap makeTest $ [ ("release/M1j", "releases._M1j"), ("release/M1j.2", "releases._M1j_2"), - ("latest-abc", "latest"), + ("latest-abc", "main"), ("release/M2i_3", "releases._M2i_3"), ("release/M2i-HOTFIX", "releases._M2i_HOTFIX") ] From 7053ad1f1d2cdf9016d66912a030a9473e7b1645 Mon Sep 17 00:00:00 2001 From: Alvaro Carrasco Date: Sun, 10 Jul 2022 13:17:49 -0600 Subject: [PATCH 485/529] Downgrade haskeline (somehow it fixes navigation issues on arm64) --- stack.yaml | 1 + stack.yaml.lock | 7 +++++++ 2 files changed, 8 insertions(+) diff --git a/stack.yaml b/stack.yaml index 8c67cb2a2a..8e32428ad9 100644 --- a/stack.yaml +++ b/stack.yaml @@ -59,6 +59,7 @@ extra-deps: - http-client-0.7.11 # lts 18.28 provides 0.3.2.1 but we need at least 0.3.3 - terminal-size-0.3.3 +- haskeline-0.8.1.3 ghc-options: # All packages diff --git a/stack.yaml.lock b/stack.yaml.lock index 120b391811..cbc9824be8 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -123,6 +123,13 @@ packages: hackage: terminal-size-0.3.3@sha256:bd5f02333982bc8d6017db257b2a0b91870a295b4a37142a0c0525d8f533a48f,1255 original: hackage: terminal-size-0.3.3 +- completed: + pantry-tree: + sha256: 90969690d0f9b49bdd6f02e5dd6ab005851f70c5778eff40043ce00cba655eaa + size: 2955 + hackage: haskeline-0.8.1.3@sha256:a1ecc7bcaa959ecd751b2eec1c5466aa2db6697471d7e35ea8f1803faad8e985,6011 + original: + hackage: haskeline-0.8.1.3 snapshots: - completed: sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 From e81da9ba22ea9f7673c17301f204aeb946147ccb Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Mon, 11 Jul 2022 10:33:23 -0400 Subject: [PATCH 486/529] Update docs --- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 436c6cd159..0b50916ac0 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -451,15 +451,15 @@ find' cmd fscope = [ ("`find`", "lists all definitions in the current namespace."), ( "`find foo`", "lists all definitions with a name similar to 'foo' in the current " - <> "namespace. Falls back to `find.all` if no matches are found." + <> "namespace (excluding those under 'lib')." ), ( "`find foo bar`", "lists all definitions with a name similar to 'foo' or 'bar' in the " - <> "current namespace." + <> "current namespace (excluding those under 'lib')." ), ( "find.all foo", "lists all definitions with a name similar to 'foo' in the current " - <> "namespace or direct dependencies." + <> "namespace (including one level of 'lib')." ), ( "find.global foo", "lists all definitions with a name similar to 'foo' in any namespace" From c36f4c9a4eb3460e429226edb8393dd0bc67b705 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Mon, 11 Jul 2022 10:33:56 -0400 Subject: [PATCH 487/529] notify when falling back to find.all --- .../src/Unison/Codebase/Editor/HandleInput.hs | 4 +++- unison-cli/src/Unison/Codebase/Editor/Output.hs | 2 ++ unison-cli/src/Unison/CommandLine/OutputMessages.hs | 13 ++++++++----- 3 files changed, 13 insertions(+), 6 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 6373ba7bde..9d7433cfe7 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1757,7 +1757,9 @@ handleFindI isVerbose fscope ws input = do respond $ ListOfDefinitions ppe isVerbose results' results <- getResults (getNames fscope) case (results, fscope) of - ([],Local) -> respondResults =<< getResults (getNames LocalAndDeps) + ([],Local) -> do + respond FindNoLocalMatches + respondResults =<< getResults (getNames LocalAndDeps) _ -> respondResults results handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v () diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index edaebc887d..b8cad7c431 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -132,6 +132,7 @@ data Output v | LoadPullRequest ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path' | CreatedNewBranch Path.Absolute | BranchAlreadyExists Path' + | FindNoLocalMatches | PatchAlreadyExists Path.Split' | NoExactTypeMatches | TypeAlreadyExists Path.Split' (Set Reference) @@ -306,6 +307,7 @@ isFailure o = case o of BadMainFunction {} -> True CreatedNewBranch {} -> False BranchAlreadyExists {} -> True + FindNoLocalMatches {} -> True PatchAlreadyExists {} -> True NoExactTypeMatches -> True BranchEmpty {} -> True diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 9187a225c1..591f7ca2ad 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -650,6 +650,7 @@ notifyUser dir o = case o of P.indentN 2 $ P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "โœ… "] where + NewlyComputed -> do clearCurrentLine pure $ @@ -926,6 +927,8 @@ notifyUser dir o = case o of Input.UpdateI {} -> True _ -> False in pure $ SlurpResult.pretty isPast ppe s + FindNoLocalMatches -> + pure . P.callout "โ˜๏ธ" $ P.wrap "I couldn't find matches in this namespace, searching in 'lib'..." NoExactTypeMatches -> pure . P.callout "โ˜๏ธ" $ P.wrap "I couldn't find exact type matches, resorting to fuzzy matching..." TypeParseError src e -> @@ -1675,11 +1678,11 @@ notifyUser dir o = case o of where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" expectedEmptyPushDest writeRemotePath = - P.lines - [ "The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is not empty.", - "", - "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" - ] + P.lines + [ "The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is not empty.", + "", + "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" + ] expectedNonEmptyPushDest writeRemotePath = P.lines [ P.wrap ("The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is empty."), From cb1c8512441c5941f7e12d8c1069c0d53937299d Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 11 Jul 2022 10:50:12 -0400 Subject: [PATCH 488/529] add request id to decodefailure message --- .../src/Unison/CommandLine/OutputMessages.hs | 29 ++++++++++--------- 1 file changed, 15 insertions(+), 14 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 0eb44b5df1..5225163db9 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1629,8 +1629,11 @@ notifyUser dir o = case o of P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err ShareErrorTransport te -> case te of - DecodeFailure msg _resp -> - "The server sent a response that we couldn't decode: " <> P.text msg + DecodeFailure msg resp -> + (P.lines . catMaybes) + [ Just ("The server sent a response that we couldn't decode: " <> P.text msg), + responseRequestId resp <&> \responseId -> P.newline <> "Request ID: " <> P.blue (P.text responseId) + ] Unauthenticated codeServerURL -> P.wrap . P.lines $ [ "Authentication with this code server (" <> P.string (Servant.showBaseUrl codeServerURL) <> ") is missing or expired.", @@ -1646,18 +1649,16 @@ notifyUser dir o = case o of RateLimitExceeded -> "Rate limit exceeded, please try again later." Timeout -> "The code server timed-out when responding to your request. Please try again later or report an issue if the problem persists." UnexpectedResponse resp -> - P.lines - ( catMaybes - [ Just - ( "The server sent a " - <> P.red (P.shown (Http.statusCode (Servant.responseStatusCode resp))) - <> " that we didn't expect." - ), - let body = Text.decodeUtf8 (LazyByteString.toStrict (Servant.responseBody resp)) - in if Text.null body then Nothing else Just (P.newline <> "Response body: " <> P.text body), - responseRequestId resp <&> \responseId -> P.newline <> "Request ID: " <> P.blue (P.text responseId) - ] - ) + (P.lines . catMaybes) + [ Just + ( "The server sent a " + <> P.red (P.shown (Http.statusCode (Servant.responseStatusCode resp))) + <> " that we didn't expect." + ), + let body = Text.decodeUtf8 (LazyByteString.toStrict (Servant.responseBody resp)) + in if Text.null body then Nothing else Just (P.newline <> "Response body: " <> P.text body), + responseRequestId resp <&> \responseId -> P.newline <> "Request ID: " <> P.blue (P.text responseId) + ] where -- Dig the request id out of a response header. responseRequestId :: Servant.Response -> Maybe Text From a5c0b18e7b50d197d27274537885c10140becca3 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Mon, 11 Jul 2022 11:10:04 -0400 Subject: [PATCH 489/529] Add transcript --- unison-src/transcripts/find-command.md | 21 ++++++ unison-src/transcripts/find-command.output.md | 65 +++++++++++++++++++ 2 files changed, 86 insertions(+) create mode 100644 unison-src/transcripts/find-command.md create mode 100644 unison-src/transcripts/find-command.output.md diff --git a/unison-src/transcripts/find-command.md b/unison-src/transcripts/find-command.md new file mode 100644 index 0000000000..61826c8cc2 --- /dev/null +++ b/unison-src/transcripts/find-command.md @@ -0,0 +1,21 @@ +```unison +foo = 1 +lib.foo = 2 +lib.bar = 3 +``` + +```ucm +.> add +``` + +```ucm +.> find foo +``` + +```ucm:error +.> find bar +``` + +```ucm:error +.> find baz +``` diff --git a/unison-src/transcripts/find-command.output.md b/unison-src/transcripts/find-command.output.md new file mode 100644 index 0000000000..bf524a96aa --- /dev/null +++ b/unison-src/transcripts/find-command.output.md @@ -0,0 +1,65 @@ +```unison +foo = 1 +lib.foo = 2 +lib.bar = 3 +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + foo : ##Nat + lib.bar : ##Nat + lib.foo : ##Nat + +``` +```ucm +.> add + + โŸ I've added these definitions: + + foo : ##Nat + lib.bar : ##Nat + lib.foo : ##Nat + +``` +```ucm +.> find foo + + 1. foo : ##Nat + + +``` +```ucm +.> find bar + + โ˜๏ธ + + I couldn't find matches in this namespace, searching in + 'lib'... + + 1. lib.bar : ##Nat + + +``` +```ucm +.> find baz + + โ˜๏ธ + + I couldn't find matches in this namespace, searching in + 'lib'... + + ๐Ÿ˜ถ + + No results. Check your spelling, or try using tab completion + to supply command arguments. + + `find.global` can be used to search outside the current + namespace. + +``` From 63b12175a2c5bc072bc8a92970574c165650ac28 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 11 Jul 2022 11:23:31 -0400 Subject: [PATCH 490/529] add transcript for `test` / `test.all` --- unison-src/transcripts/test-command.md | 41 ++++++++ unison-src/transcripts/test-command.output.md | 94 +++++++++++++++++++ 2 files changed, 135 insertions(+) create mode 100644 unison-src/transcripts/test-command.md create mode 100644 unison-src/transcripts/test-command.output.md diff --git a/unison-src/transcripts/test-command.md b/unison-src/transcripts/test-command.md new file mode 100644 index 0000000000..3b46a4e9c3 --- /dev/null +++ b/unison-src/transcripts/test-command.md @@ -0,0 +1,41 @@ +Merge builtins so we get enough names for the testing stuff. + +```ucm:hide +.> builtins.merge +``` + +The `test` command should run all of the tests in the current directory. + +(Just so we don't have to pull in `.base` into this transcript, we make a fakey test just by giving it the right type, +and manually linking it to the builtin `isTest` value). + +```unison +test1 : [Result] +test1 = [Ok "test1"] +``` + +```ucm:hide +.> add +.> link .builtin.metadata.isTest test1 +``` + +```ucm +.> test +``` + +`test` won't descend into the `lib` namespace, but `test.all` will. + +```unison +test2 : [Result] +test2 = [Ok "test2"] +``` + +```ucm:hide +.lib> add +.lib> link .builtin.metadata.isTest test2 +``` + +```ucm +.> test +.> test.all +``` diff --git a/unison-src/transcripts/test-command.output.md b/unison-src/transcripts/test-command.output.md new file mode 100644 index 0000000000..1b5f6abca0 --- /dev/null +++ b/unison-src/transcripts/test-command.output.md @@ -0,0 +1,94 @@ +Merge builtins so we get enough names for the testing stuff. + +The `test` command should run all of the tests in the current directory. + +(Just so we don't have to pull in `.base` into this transcript, we make a fakey test just by giving it the right type, +and manually linking it to the builtin `isTest` value). + +```unison +test1 : [Result] +test1 = [Ok "test1"] +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + test1 : [Result] + +``` +```ucm +.> test + + โœ… + + + + + + New test results: + + โ—‰ test1 test1 + + โœ… 1 test(s) passing + + Tip: Use view test1 to view the source of a test. + +``` +`test` won't descend into the `lib` namespace, but `test.all` will. + +```unison +test2 : [Result] +test2 = [Ok "test2"] +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + test2 : [Result] + +``` +```ucm +.> test + + Cached test results (`help testcache` to learn more) + + โ—‰ test1 test1 + + โœ… 1 test(s) passing + + Tip: Use view test1 to view the source of a test. + +.> test.all + + + Cached test results (`help testcache` to learn more) + + โ—‰ test1 test1 + + โœ… 1 test(s) passing + + โœ… + + + + + + New test results: + + โ—‰ lib.test2 test2 + + โœ… 1 test(s) passing + + Tip: Use view lib.test2 to view the source of a test. + +``` From 2e94d163e737f8c344fdfd9fad246a33bfc9d530 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Mon, 11 Jul 2022 11:42:20 -0400 Subject: [PATCH 491/529] remove ls.verbose, add find.all.verbose --- .../src/Unison/CommandLine/InputPatterns.hs | 15 ++++++++++++++- unison-src/transcripts/empty-namespaces.md | 2 +- unison-src/transcripts/empty-namespaces.output.md | 12 +++++++++++- 3 files changed, 26 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 0b50916ac0..e910717349 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -493,7 +493,7 @@ findVerbose :: InputPattern findVerbose = InputPattern "find.verbose" - ["list.verbose", "ls.verbose"] + [] I.Visible [(ZeroPlus, fuzzyDefinitionQueryArg)] ( "`find.verbose` searches for definitions like `find`, but includes hashes " @@ -501,6 +501,18 @@ findVerbose = ) (pure . Input.FindI True Input.Local) +findVerboseAll :: InputPattern +findVerboseAll = + InputPattern + "find.all.verbose" + [] + I.Visible + [(ZeroPlus, fuzzyDefinitionQueryArg)] + ( "`find.all.verbose` searches for definitions like `find.all`, but includes hashes " + <> "and aliases in the results." + ) + (pure . Input.FindI True Input.LocalAndDeps) + findPatch :: InputPattern findPatch = InputPattern @@ -2117,6 +2129,7 @@ validInputs = findAll, findShallow, findVerbose, + findVerboseAll, view, display, displayTo, diff --git a/unison-src/transcripts/empty-namespaces.md b/unison-src/transcripts/empty-namespaces.md index 2fe17204e9..9b552bdd53 100644 --- a/unison-src/transcripts/empty-namespaces.md +++ b/unison-src/transcripts/empty-namespaces.md @@ -14,7 +14,7 @@ The deleted namespace shouldn't appear in `ls` output. .> ls ``` ```ucm:error -.> ls.verbose +.> find.verbose ``` ```ucm:error .> find mynamespace diff --git a/unison-src/transcripts/empty-namespaces.output.md b/unison-src/transcripts/empty-namespaces.output.md index 306ee11e48..7c682827f6 100644 --- a/unison-src/transcripts/empty-namespaces.output.md +++ b/unison-src/transcripts/empty-namespaces.output.md @@ -12,7 +12,12 @@ The deleted namespace shouldn't appear in `ls` output. ``` ```ucm -.> ls.verbose +.> find.verbose + + โ˜๏ธ + + I couldn't find matches in this namespace, searching in + 'lib'... ๐Ÿ˜ถ @@ -26,6 +31,11 @@ The deleted namespace shouldn't appear in `ls` output. ```ucm .> find mynamespace + โ˜๏ธ + + I couldn't find matches in this namespace, searching in + 'lib'... + ๐Ÿ˜ถ No results. Check your spelling, or try using tab completion From 1240b8f6f22c518b865f543a795d7fec28f263f7 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 11 Jul 2022 12:01:59 -0400 Subject: [PATCH 492/529] make bag of arguments for @push@ --- .../src/Unison/Codebase/Editor/HandleInput.hs | 30 ++++------- .../src/Unison/Codebase/Editor/Input.hs | 14 ++++- .../src/Unison/CommandLine/InputPatterns.hs | 54 ++++++++++++++++--- 3 files changed, 70 insertions(+), 28 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 02d2218357..459e42ea74 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1541,7 +1541,7 @@ loop = do if didUpdate then respond $ PullSuccessful ns path else respond unchangedMsg - PushRemoteBranchI mayRepo path pushBehavior syncMode -> handlePushRemoteBranch mayRepo path pushBehavior syncMode + PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput ListDependentsI hq -> handleDependents hq ListDependenciesI hq -> -- todo: add flag to handle transitive efficiently @@ -1767,26 +1767,14 @@ handleGist (GistInput repo) = doPushRemoteBranch (GistyPush repo) Path.relativeEmpty' SyncMode.ShortCircuit -- | Handle a @push@ command. -handlePushRemoteBranch :: - forall m v. - MonadUnliftIO m => - -- | The repo to push to. If missing, it is looked up in `.unisonConfig`. - Maybe WriteRemotePath -> - -- | The local path to push. If relative, it's resolved relative to the current path (`cd`). - Path' -> - -- | The push behavior (whether the remote branch is required to be empty or non-empty). - PushBehavior -> - SyncMode.SyncMode -> - Action' m v () -handlePushRemoteBranch mayRepo path pushBehavior syncMode = - time - "handlePushRemoteBranch" - case mayRepo of - Nothing -> - runExceptT (resolveConfiguredUrl Push path) >>= \case - Left output -> respond output - Right repo -> push repo - Just repo -> push repo +handlePushRemoteBranch :: forall m v. MonadUnliftIO m => PushRemoteBranchInput -> Action' m v () +handlePushRemoteBranch PushRemoteBranchInput {maybeRemoteRepo = mayRepo, localPath = path, pushBehavior, syncMode} = + time "handlePushRemoteBranch" case mayRepo of + Nothing -> + runExceptT (resolveConfiguredUrl Push path) >>= \case + Left output -> respond output + Right repo -> push repo + Just repo -> push repo where push repo = doPushRemoteBranch (NormalPush repo pushBehavior) path syncMode diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 59ba8a92d5..28328182fd 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -1,6 +1,7 @@ module Unison.Codebase.Editor.Input ( Input (..), GistInput (..), + PushRemoteBranchInput (..), Event (..), OutputLocation (..), PatchPath, @@ -81,7 +82,7 @@ data Input | PreviewMergeLocalBranchI Path' Path' | DiffNamespaceI BranchId BranchId -- old new | PullRemoteBranchI (Maybe ReadRemoteNamespace) Path' SyncMode PullMode Verbosity - | PushRemoteBranchI (Maybe WriteRemotePath) Path' PushBehavior SyncMode + | PushRemoteBranchI PushRemoteBranchInput | CreatePullRequestI ReadRemoteNamespace ReadRemoteNamespace | LoadPullRequestI ReadRemoteNamespace ReadRemoteNamespace Path' | ResetRootI (Either ShortBranchHash Path') @@ -194,6 +195,17 @@ data GistInput = GistInput } deriving stock (Eq, Show) +data PushRemoteBranchInput = PushRemoteBranchInput + { -- | The local path to push. If relative, it's resolved relative to the current path (`cd`). + localPath :: Path', + -- | The repo to push to. If missing, it is looked up in `.unisonConfig`. + maybeRemoteRepo :: Maybe WriteRemotePath, + -- | The push behavior (whether the remote branch is required to be empty or non-empty). + pushBehavior :: PushBehavior, + syncMode :: SyncMode + } + deriving stock (Eq, Show) + -- Some commands, like `view`, can dump output to either console or a file. data OutputLocation = ConsoleLocation diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index d4d53c4a62..25ba78224a 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1096,14 +1096,28 @@ push = ) ( \case [] -> - Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireNonEmpty SyncMode.ShortCircuit + Right $ + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { localPath = Path.relativeEmpty', + maybeRemoteRepo = Nothing, + pushBehavior = PushBehavior.RequireNonEmpty, + syncMode = SyncMode.ShortCircuit + } url : rest -> do pushPath <- parseWriteRemotePath "remote-path" url p <- case rest of [] -> Right Path.relativeEmpty' [path] -> first fromString $ Path.parsePath' path _ -> Left (I.help push) - Right $ Input.PushRemoteBranchI (Just pushPath) p PushBehavior.RequireNonEmpty SyncMode.ShortCircuit + Right $ + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { localPath = p, + maybeRemoteRepo = Just pushPath, + pushBehavior = PushBehavior.RequireNonEmpty, + syncMode = SyncMode.ShortCircuit + } ) pushCreate :: InputPattern @@ -1137,14 +1151,28 @@ pushCreate = ) ( \case [] -> - Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireEmpty SyncMode.ShortCircuit + Right $ + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { localPath = Path.relativeEmpty', + maybeRemoteRepo = Nothing, + pushBehavior = PushBehavior.RequireEmpty, + syncMode = SyncMode.ShortCircuit + } url : rest -> do pushPath <- parseWriteRemotePath "remote-path" url p <- case rest of [] -> Right Path.relativeEmpty' [path] -> first fromString $ Path.parsePath' path _ -> Left (I.help push) - Right $ Input.PushRemoteBranchI (Just pushPath) p PushBehavior.RequireEmpty SyncMode.ShortCircuit + Right $ + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { localPath = p, + maybeRemoteRepo = Just pushPath, + pushBehavior = PushBehavior.RequireEmpty, + syncMode = SyncMode.ShortCircuit + } ) pushExhaustive :: InputPattern @@ -1165,14 +1193,28 @@ pushExhaustive = ) ( \case [] -> - Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireNonEmpty SyncMode.Complete + Right $ + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { localPath = Path.relativeEmpty', + maybeRemoteRepo = Nothing, + pushBehavior = PushBehavior.RequireNonEmpty, + syncMode = SyncMode.Complete + } url : rest -> do pushPath <- parseWriteRemotePath "remote-path" url p <- case rest of [] -> Right Path.relativeEmpty' [path] -> first fromString $ Path.parsePath' path _ -> Left (I.help push) - Right $ Input.PushRemoteBranchI (Just pushPath) p PushBehavior.RequireNonEmpty SyncMode.Complete + Right $ + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { localPath = p, + maybeRemoteRepo = Just pushPath, + pushBehavior = PushBehavior.RequireNonEmpty, + syncMode = SyncMode.Complete + } ) createPullRequest :: InputPattern From a01be40b31ff568b1eabe4827a3d1ed2b96a9743 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 11 Jul 2022 15:18:50 -0400 Subject: [PATCH 493/529] work a bit on force push (this commit doesnt build) --- .../src/Unison/Codebase/PushBehavior.hs | 4 ++- .../src/Unison/Codebase/SqliteCodebase.hs | 35 +++++++++---------- .../src/Unison/Codebase/Type.hs | 17 ++++++++- .../src/Unison/Codebase/Editor/HandleInput.hs | 19 +++++++--- 4 files changed, 51 insertions(+), 24 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/PushBehavior.hs b/parser-typechecker/src/Unison/Codebase/PushBehavior.hs index e336a9c457..f1d8e9f67a 100644 --- a/parser-typechecker/src/Unison/Codebase/PushBehavior.hs +++ b/parser-typechecker/src/Unison/Codebase/PushBehavior.hs @@ -6,7 +6,9 @@ where -- | How a `push` behaves. data PushBehavior - = -- | The namespace being pushed to is required to be empty. + = -- Force-push over what's there. + ForcePush + | -- | The namespace being pushed to is required to be empty. RequireEmpty | -- | The namespace being pushed to is required to be non-empty RequireNonEmpty diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 710e4ab3a1..2a78587984 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -761,7 +761,7 @@ pushGitBranch :: -- An action which accepts the current root branch on the remote and computes a new branch. (Branch m -> m (Either e (Branch m))) -> m (Either C.GitError (Either e (Branch m))) -pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = UnliftIO.try do +pushGitBranch srcConn repo (PushGitBranchOpts forcePush setRoot _syncMode) action = UnliftIO.try do -- Pull the latest remote into our git cache -- Use a local git clone to copy this git repo into a temp-dir -- Delete the codebase in our temp-dir @@ -812,23 +812,22 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift let newBranchHash = Branch.headHash newBranch case codebaseStatus of ExistingCodebase -> do - -- the call to runDB "handles" the possible DB error by bombing - maybeOldRootHash <- fmap Cv.causalHash2to1 <$> run Ops.loadRootCausalHash - case maybeOldRootHash of - Nothing -> run (setRepoRoot newBranchHash) - Just oldRootHash -> do - run (CodebaseOps.before oldRootHash newBranchHash) >>= \case - Nothing -> - error $ - "I couldn't find the hash " ++ show newBranchHash - ++ " that I just synced to the cached copy of " - ++ repoString - ++ " in " - ++ show remotePath - ++ "." - Just False -> - throwIO . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo - Just True -> pure () + when (not forcePush) do + -- the call to runDB "handles" the possible DB error by bombing + run Ops.loadRootCausalHash >>= \case + Nothing -> pure () + Just oldRootHash -> do + run (CodebaseOps.before (Cv.causalHash2to1 oldRootHash) newBranchHash) >>= \case + Nothing -> + error $ + "I couldn't find the hash " ++ show newBranchHash + ++ " that I just synced to the cached copy of " + ++ repoString + ++ " in " + ++ show remotePath + ++ "." + Just False -> throwIO . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo + Just True -> pure () CreatedCodebase -> pure () run (setRepoRoot newBranchHash) repoString = Text.unpack $ printWriteGitRepo repo diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 5bba16b128..f52b966df6 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -5,6 +5,7 @@ module Unison.Codebase.Type ( Codebase (..), CodebasePath, PushGitBranchOpts (..), + GitPushBehavior (..), GitError (..), SyncToDir, LocalOrRemote (..), @@ -189,11 +190,25 @@ data LocalOrRemote deriving (Show, Eq, Ord) data PushGitBranchOpts = PushGitBranchOpts - { -- | Set the branch as root? + { -- | Should we perform a local `before` check, or just force-push? + forcePush :: Bool, + -- | Set the branch as root? setRoot :: Bool, syncMode :: SyncMode } +data GitPushBehavior + = -- | Don't set root, just sync entities. + GitPushBehaviorGist + | -- | After syncing entities, do a fast-forward check, then set the root. + GitPushBehaviorFf + | -- | After syncing entities, just set the root (force-pushy). + GitPushBehaviorForce + +-- valid: dont set root, +-- set root, fast-forward +-- set root, force push + data GitError = GitProtocolError GitProtocolError | GitCodebaseError (GitCodebaseError Branch.CausalHash) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 459e42ea74..26e7616427 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1811,7 +1811,16 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do Branch.modifyAtM remotePath f remoteRoot & \case Nothing -> pure (Left $ RefusedToPush pushBehavior writeRemotePath) Just newRemoteRoot -> pure (Right newRemoteRoot) - let opts = PushGitBranchOpts {setRoot = True, syncMode} + let opts = + PushGitBranchOpts + { forcePush = + case pushBehavior of + PushBehavior.ForcePush -> True + PushBehavior.RequireEmpty -> False + PushBehavior.RequireNonEmpty -> False, + setRoot = True, + syncMode + } runExceptT (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case Left gitErr -> respond (Output.GitError gitErr) Right (Left errOutput) -> respond errOutput @@ -1820,7 +1829,7 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do handlePushToUnisonShare sharePath localPath pushBehavior GistyPush repo -> do sourceBranch <- getAt localPath - let opts = PushGitBranchOpts {setRoot = False, syncMode} + let opts = PushGitBranchOpts {forcePush = False, setRoot = False, syncMode} runExceptT (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))) >>= \case Left gitErr -> respond (Output.GitError gitErr) Right (Left errOutput) -> respond errOutput @@ -1838,11 +1847,13 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do where -- Per `pushBehavior`, we are either: -- - -- (1) updating an empty branch, which fails if the branch isn't empty (`push.create`) - -- (2) updating a non-empty branch, which fails if the branch is empty (`push`) + -- (1) force-pushing, in which case the remote branch state doesn't matter + -- (2) updating an empty branch, which fails if the branch isn't empty (`push.create`) + -- (3) updating a non-empty branch, which fails if the branch is empty (`push`) shouldPushTo :: PushBehavior -> Branch m -> Bool shouldPushTo pushBehavior remoteBranch = case pushBehavior of + PushBehavior.ForcePush -> True PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch) PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) From 881411f934d041d00943ce530c91a3dcbc9c0a16 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 11 Jul 2022 14:32:21 -0600 Subject: [PATCH 494/529] Properly parse versions with the dirty flag. --- unison-cli/src/Unison/Codebase/Editor/VersionParser.hs | 8 +++++++- unison-cli/src/Unison/CommandLine/Welcome.hs | 3 +++ unison-cli/unison/Main.hs | 4 ++-- 3 files changed, 12 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index 315f08ece9..74e756858a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -21,6 +21,10 @@ import qualified Unison.Codebase.Path as Path -- -- >>> parseMaybe defaultBaseLib "latest-1234" -- Just (ReadShareRemoteNamespace {server = DefaultCodeserver, repo = "unison", path = public.base.main}) +-- +-- A version with the 'dirty' flag +-- >>> parseMaybe defaultBaseLib "release/M3-409-gbcdf68db3'" +-- Nothing defaultBaseLib :: Parsec Void Text ReadShareRemoteNamespace defaultBaseLib = fmap makeNS $ latest <|> release where @@ -28,7 +32,9 @@ defaultBaseLib = fmap makeNS $ latest <|> release latest = "latest-" *> many anySingle *> eof $> "main" release = fmap ("releases._" <>) $ "release/" *> version <* eof version = do - Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) + v <- Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) + _dirty <- optional (char '\'') + pure v makeNS :: Text -> ReadShareRemoteNamespace makeNS t = ReadShareRemoteNamespace diff --git a/unison-cli/src/Unison/CommandLine/Welcome.hs b/unison-cli/src/Unison/CommandLine/Welcome.hs index 1b3eccf216..dc30ebe167 100644 --- a/unison-cli/src/Unison/CommandLine/Welcome.hs +++ b/unison-cli/src/Unison/CommandLine/Welcome.hs @@ -27,6 +27,7 @@ data Welcome = Welcome data DownloadBase = DownloadBase ReadShareRemoteNamespace | DontDownloadBase + deriving (Show, Eq) -- Previously Created is different from Previously Onboarded because a user can -- 1.) create a new codebase @@ -35,6 +36,7 @@ data DownloadBase data CodebaseInitStatus = NewlyCreatedCodebase -- Can transition to [Base, Author, Finished] | PreviouslyCreatedCodebase -- Can transition to [Base, Author, Finished, PreviouslyOnboarded]. + deriving (Show, Eq) data Onboarding = Init CodebaseInitStatus -- Can transition to [DownloadingBase, Author, Finished, PreviouslyOnboarded] @@ -43,6 +45,7 @@ data Onboarding -- End States | Finished | PreviouslyOnboarded + deriving (Show, Eq) welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> Text -> Welcome welcome initStatus downloadBase filePath unisonVersion = diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index bfb92dd584..7eb0218f79 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -13,9 +13,9 @@ import ArgParse Command (Init, Launch, PrintVersion, Run, Transcript), GlobalOptions (GlobalOptions, codebasePathOption, exitOption), IsHeadless (Headless, WithCLI), - ShouldExit(Exit, DoNotExit), RunSource (..), ShouldDownloadBase (..), + ShouldExit (DoNotExit, Exit), ShouldForkCodebase (..), ShouldSaveCodebase (..), UsageRenderer, @@ -212,7 +212,7 @@ main = withCP65001 do getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do runtime <- RTI.startRuntime RTI.Persistent Version.gitDescribeWithDate Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts runtime theCodebase $ \baseUrl -> do - case exitOption of + case exitOption of DoNotExit -> do case isHeadless of Headless -> do From 28040228d8865d9cc32981a52b7dd6c051415c8d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 11 Jul 2022 14:33:46 -0600 Subject: [PATCH 495/529] Remove unused minimalUniqueSuffix for Names --- unison-core/src/Unison/Names.hs | 38 --------------------------------- 1 file changed, 38 deletions(-) diff --git a/unison-core/src/Unison/Names.hs b/unison-core/src/Unison/Names.hs index b8f9547635..2e7ad5450a 100644 --- a/unison-core/src/Unison/Names.hs +++ b/unison-core/src/Unison/Names.hs @@ -49,7 +49,6 @@ module Unison.Names isEmpty, hashQualifyTypesRelation, hashQualifyTermsRelation, - minimalUniqueSuffix, ) where @@ -107,43 +106,6 @@ instance Show (Names) where ++ foldMap (\(n, r) -> " " ++ show n ++ " -> " ++ show r ++ "\n") (R.toList types) ++ "\n" --- | Abbreviate all names to their minimal unique suffix. --- --- E.g. --- ["base.List.map", "base.Bag.map"] -> ["List.map", "Bag.map"] --- ["base.List.filter", "base.List.map"] -> ["filter", "map"] -minimalUniqueSuffix :: Names -> Names -minimalUniqueSuffix (Names {terms, types}) = - Names {terms = abbreviateR terms, types = abbreviateR types} - where - abbreviateR :: Ord r => Relation Name r -> Relation Name r - abbreviateR = R.fromMultimap . Map.fromAscList . abbreviate . Map.toAscList . R.domain - - --- >>> abbreviate [("base.List.map", Set.singleton 1)] - -- [(map,fromList [1])] - --- >>> abbreviate [("base.List.map", Set.singleton 1), ("base.Map.map", Set.singleton 2), ("base.List.filter", Set.singleton 2)] - -- [(List.map,fromList [1]),(Map.map,fromList [2]),(filter,fromList [2])] - abbreviate :: Ord r => [(Name, Set r)] -> [(Name, Set r)] - abbreviate ns = - ns - & List.groupMap getSuffixKey - & concatMap recurse - - recurse :: Ord r => (Maybe NameSegment, [(Name, Set r)]) -> [(Name, Set r)] - recurse = \case - -- If the name was a single segment, we can't abbreviate it. - (Nothing, ns) -> ns - -- If the current suffix only has a single definition, we can discard the remaining prefix name prefix. - (Just suffix, [(_, rs)]) -> [(Name.fromSegment suffix, rs)] - -- If there are still multiple names with current suffix, recurse. - (Just suffix, ns) -> abbreviate ns <&> first (`snoc` suffix) - - getSuffixKey :: ((Name, r) -> (Maybe NameSegment, (Name, r))) - getSuffixKey (name, ref) = - case unsnoc name of - Nothing -> (Nothing, (name, ref)) - Just (remainder, suff) -> (Just suff, (remainder, ref)) - isEmpty :: Names -> Bool isEmpty n = R.null (terms n) && R.null (types n) From de778d4b7de277f90b94baa71168b351b32cad0c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 11 Jul 2022 14:45:48 -0600 Subject: [PATCH 496/529] Remove unused names from scoped names --- .../src/Unison/Codebase/Editor/HandleInput.hs | 4 +-- unison-core/src/Unison/Names.hs | 4 --- unison-share-api/src/Unison/Server/Backend.hs | 33 ++++++++++--------- .../src/Unison/Server/Endpoints/FuzzyFind.hs | 2 +- .../Server/Endpoints/NamespaceDetails.hs | 2 +- 5 files changed, 22 insertions(+), 23 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 475c7d2d92..4cae9cd408 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -3378,7 +3378,7 @@ basicNames' :: (Functor m) => (Path -> Backend.NameScoping) -> Action m i v (Nam basicNames' nameScoping = do root' <- use LoopState.root currentPath' <- use LoopState.currentPath - let (parse, pretty, _local) = Backend.prettyAndParseNamesForBranch root' (nameScoping $ Path.unabsolute currentPath') + let (parse, pretty, _local) = Backend.namesForBranch root' (nameScoping $ Path.unabsolute currentPath') pure (parse, pretty) data AddRunMainResult v @@ -3499,7 +3499,7 @@ diffHelperCmd :: diffHelperCmd currentRoot currentPath before after = do hqLength <- eval CodebaseHashLength diff <- eval . Eval $ BranchDiff.diff0 before after - let (_parseNames, prettyNames0, _local) = Backend.prettyAndParseNamesForBranch currentRoot (Backend.AllNames $ Path.unabsolute currentPath) + let (_parseNames, prettyNames0, _local) = Backend.namesForBranch currentRoot (Backend.AllNames $ Path.unabsolute currentPath) ppe <- PPE.suffixifiedPPE <$> prettyPrintEnvDecl (NamesWithHistory prettyNames0 mempty) (ppe,) <$> OBranchDiff.toOutput diff --git a/unison-core/src/Unison/Names.hs b/unison-core/src/Unison/Names.hs index 2e7ad5450a..e862b5174e 100644 --- a/unison-core/src/Unison/Names.hs +++ b/unison-core/src/Unison/Names.hs @@ -52,8 +52,6 @@ module Unison.Names ) where -import Control.Lens.Cons (snoc, unsnoc) -import Data.Bifunctor (first) import qualified Data.Map as Map import qualified Data.Set as Set import qualified Data.Text as Text @@ -66,7 +64,6 @@ import Unison.LabeledDependency (LabeledDependency) import qualified Unison.LabeledDependency as LD import Unison.Name (Name) import qualified Unison.Name as Name -import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Reference (Reference) import qualified Unison.Reference as Reference @@ -74,7 +71,6 @@ import Unison.Referent (Referent) import qualified Unison.Referent as Referent import Unison.ShortHash (ShortHash) import qualified Unison.ShortHash as SH -import qualified Unison.Util.List as List import Unison.Util.Relation (Relation) import qualified Unison.Util.Relation as R import qualified Unison.Util.Relation as Relation diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index cef6252842..49f8c09b4e 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -160,8 +160,9 @@ suffixifyNames hashLength names = PPE.suffixifiedPPE . PPE.fromNamesDecl hashLength $ NamesWithHistory.fromCurrentNames names -- implementation detail of parseNamesForBranch and prettyNamesForBranch -prettyAndParseNamesForBranch :: Branch m -> NameScoping -> (Names, Names, Names) -prettyAndParseNamesForBranch root scope = +-- Returns (parseNames, prettyNames, localNames) +namesForBranch :: Branch m -> NameScoping -> (Names, Names, Names) +namesForBranch root scope = (parseNames0, prettyPrintNames0, currentPathNames) where path :: Path @@ -199,10 +200,10 @@ basicSuffixifiedNames hashLength root nameScope = in suffixifyNames hashLength names0 parseNamesForBranch :: Branch m -> NameScoping -> Names -parseNamesForBranch root = prettyAndParseNamesForBranch root <&> \(n, _, _) -> n +parseNamesForBranch root = namesForBranch root <&> \(n, _, _) -> n prettyNamesForBranch :: Branch m -> NameScoping -> Names -prettyNamesForBranch root = prettyAndParseNamesForBranch root <&> \(_, n, _) -> n +prettyNamesForBranch root = namesForBranch root <&> \(_, n, _) -> n shallowPPE :: Monad m => Codebase m v a -> V2Branch.Branch m -> m PPE.PrettyPrintEnv shallowPPE codebase b = do @@ -818,7 +819,7 @@ prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase -- We might like to make sure that the user search terms get used as -- the names in the pretty-printer, but the current implementation -- doesn't. - (_parseNames, _printNames, localNamesOnly, ppe) <- scopedNamesForBranchHash codebase root path + (localNamesOnly, ppe) <- scopedNamesForBranchHash codebase root path let nameSearch :: NameSearch nameSearch = makeNameSearch hqLength (NamesWithHistory.fromCurrentNames localNamesOnly) DefinitionResults terms types misses <- restrictDefinitionsToScope localNamesOnly <$> lift (definitionsBySuffixes codebase nameSearch DontIncludeCycles query) @@ -1076,36 +1077,38 @@ bestNameForType ppe width = -- - 'local' includes ONLY the names within the provided path -- - 'ppe' is a ppe which searches for a name within the path first, but falls back to a global name search. -- The 'suffixified' component of this ppe will search for the shortest unambiguous suffix within the scope in which the name is found (local, falling back to global) -scopedNamesForBranchHash :: forall m v a. Monad m => Codebase m v a -> Maybe (Branch.CausalHash) -> Path -> Backend m (Names, Names, Names, PPE.PrettyPrintEnvDecl) +scopedNamesForBranchHash :: forall m v a. Monad m => Codebase m v a -> Maybe (Branch.CausalHash) -> Path -> Backend m (Names, PPE.PrettyPrintEnvDecl) scopedNamesForBranchHash codebase mbh path = do shouldUseNamesIndex <- asks useNamesIndex hashLen <- lift $ Codebase.hashLength codebase - (parseNames, prettyNames, localNames) <- case mbh of + (parseNames, localNames) <- case mbh of Nothing - | shouldUseNamesIndex -> indexPrettyAndParseNames + | shouldUseNamesIndex -> indexNames | otherwise -> do rootBranch <- lift $ Codebase.getRootBranch codebase - pure $ prettyAndParseNamesForBranch rootBranch (AllNames path) + let (parseNames, _prettyNames, localNames) = namesForBranch rootBranch (AllNames path) + pure (parseNames, localNames) Just bh -> do rootHash <- lift $ Codebase.getRootBranchHash codebase if (Causal.unCausalHash bh == V2.Hash.unCausalHash rootHash) && shouldUseNamesIndex - then indexPrettyAndParseNames + then indexNames else do - flip prettyAndParseNamesForBranch (AllNames path) <$> resolveCausalHash (Just bh) codebase + (parseNames, _pretty, localNames) <- flip namesForBranch (AllNames path) <$> resolveCausalHash (Just bh) codebase + pure (parseNames, localNames) let localPPE = PPE.fromNamesDecl hashLen (NamesWithHistory.fromCurrentNames localNames) let globalPPE = PPE.fromNamesDecl hashLen (NamesWithHistory.fromCurrentNames parseNames) - pure (parseNames, prettyNames, localNames, mkPPE localPPE globalPPE) + pure (localNames, mkPPE localPPE globalPPE) where mkPPE :: PPE.PrettyPrintEnvDecl -> PPE.PrettyPrintEnvDecl -> PPE.PrettyPrintEnvDecl mkPPE primary fallback = PPE.PrettyPrintEnvDecl (PPE.unsuffixifiedPPE primary <> PPE.unsuffixifiedPPE fallback) (PPE.suffixifiedPPE primary <> PPE.suffixifiedPPE fallback) - indexPrettyAndParseNames :: Backend m (Names, Names, Names) - indexPrettyAndParseNames = do + indexNames :: Backend m (Names, Names) + indexNames = do scopedNames <- lift $ Codebase.namesAtPath codebase path - pure (ScopedNames.parseNames scopedNames, ScopedNames.prettyNames scopedNames, ScopedNames.namesAtPath scopedNames) + pure (ScopedNames.parseNames scopedNames, ScopedNames.namesAtPath scopedNames) resolveCausalHash :: Monad m => Maybe (Branch.CausalHash) -> Codebase m v a -> Backend m (Branch m) diff --git a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs index 420acbdee8..b092bff799 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs @@ -141,7 +141,7 @@ serveFuzzyFind codebase mayRoot relativePath limit typeWidth query = maybe mempty Path.fromPath' <$> traverse (parsePath . Text.unpack) relativePath rootHash <- traverse (Backend.expandShortBranchHash codebase) mayRoot - (_parseNames, _prettyNames, localNamesOnly, ppe) <- Backend.scopedNamesForBranchHash codebase rootHash rel + (localNamesOnly, ppe) <- Backend.scopedNamesForBranchHash codebase rootHash rel let alignments :: ( [ ( FZF.Alignment, UnisonName, diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs index 5459b4b601..36e6376762 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs @@ -95,7 +95,7 @@ namespaceDetails runtime codebase namespaceName maySBH mayWidth = namespaceCausal <- Backend.getShallowCausalAtPathFromRootHash codebase mayRootHash namespacePath shallowBranch <- lift $ V2Causal.value namespaceCausal namespaceDetails <- do - (_parseNames, _printNames, _localNamesOnly, ppe) <- Backend.scopedNamesForBranchHash codebase mayRootHash namespacePath + (_localNamesOnly, ppe) <- Backend.scopedNamesForBranchHash codebase mayRootHash namespacePath readme <- Backend.findShallowReadmeInBranchAndRender width From 9778328f125b9f6dce641321b16c8e9428cea571 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Mon, 11 Jul 2022 16:56:22 -0400 Subject: [PATCH 497/529] Implement a sandboxed runtime and use it for pure evaluation - The sandboxed runtime filters any Tracked foreign functions from the map storing the Haskell functions implementing foreign builtins, replacing them with a function that simply throws an exception. - Two runtimes are threaded through most operations. The sandboxed runtime is used for most evaluation, the exceptions being `run` and `io.test` - The code server seems to only need a sandboxed runtime, so that's all that's being fed to it for now. --- .../src/Unison/Runtime/Builtin.hs | 34 ++++++++++++++----- .../src/Unison/Runtime/Interface.hs | 10 +++--- .../src/Unison/Runtime/Machine.hs | 7 ++-- .../src/Unison/Codebase/Editor/Command.hs | 3 +- .../Unison/Codebase/Editor/HandleCommand.hs | 25 ++++++++------ .../src/Unison/Codebase/Editor/HandleInput.hs | 16 ++++----- .../src/Unison/Codebase/TranscriptParser.hs | 19 +++++++---- unison-cli/src/Unison/CommandLine/Main.hs | 5 ++- unison-cli/unison/Main.hs | 22 +++++++----- 9 files changed, 88 insertions(+), 53 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index f85eff14f6..4856b904b6 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -14,6 +14,7 @@ module Unison.Runtime.Builtin builtinTermBackref, builtinTypeBackref, builtinForeigns, + sandboxedForeigns, numberedTermLookup, Sandbox (..), baseSandboxInfo, @@ -32,6 +33,7 @@ import Control.Exception (evaluate) import qualified Control.Exception.Safe as Exception import Control.Monad.Catch (MonadCatch) import qualified Control.Monad.Primitive as PA +import Control.Monad.Reader (ReaderT(..), runReaderT, ask) import Control.Monad.State.Strict (State, execState, modify) import qualified Crypto.Hash as Hash import qualified Crypto.MAC.HMAC as HMAC @@ -1907,7 +1909,7 @@ builtinLookup = ++ foreignWrappers type FDecl v = - State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) + ReaderT Bool (State (Word64, [(Data.Text.Text, (Sandbox, SuperNormal v))], EnumMap Word64 (Data.Text.Text, ForeignFunc))) -- Data type to determine whether a builtin should be tracked for -- sandboxing. Untracked means that it can be freely used, and Tracked @@ -1916,15 +1918,25 @@ type FDecl v = data Sandbox = Tracked | Untracked deriving (Eq, Ord, Show, Read, Enum, Bounded) +bomb :: Data.Text.Text -> a -> IO r +bomb name _ = die $ "attempted to use sandboxed operation: " ++ Data.Text.unpack name + declareForeign :: Sandbox -> Data.Text.Text -> ForeignOp -> ForeignFunc -> FDecl Symbol () -declareForeign sand name op func = - modify $ \(w, cs, fs) -> - (w + 1, (name, (sand, uncurry Lambda (op w))) : cs, mapInsert w (name, func) fs) +declareForeign sand name op func0 = do + sanitize <- ask + modify $ \(w, codes, funcs) -> + let func + | sanitize, + Tracked <- sand, + FF r w _ <- func0 = FF r w (bomb name) + | otherwise = func0 + code = (name, (sand, uncurry Lambda (op w))) + in (w + 1, code : codes, mapInsert w (name, func) funcs) mkForeignIOF :: (ForeignConvention a, ForeignConvention r) => @@ -2980,11 +2992,12 @@ typeReferences = zip rs [1 ..] ++ [DerivedId i | (_, i, _) <- Ty.builtinEffectDecls] foreignDeclResults :: - (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) -foreignDeclResults = execState declareForeigns (0, [], mempty) + Bool -> (Word64, [(Data.Text.Text, (Sandbox, SuperNormal Symbol))], EnumMap Word64 (Data.Text.Text, ForeignFunc)) +foreignDeclResults sanitize = + execState (runReaderT declareForeigns sanitize) (0, [], mempty) foreignWrappers :: [(Data.Text.Text, (Sandbox, SuperNormal Symbol))] -foreignWrappers | (_, l, _) <- foreignDeclResults = reverse l +foreignWrappers | (_, l, _) <- foreignDeclResults False = reverse l numberedTermLookup :: EnumMap Word64 (SuperNormal Symbol) numberedTermLookup = @@ -3007,10 +3020,13 @@ builtinTypeBackref = mapFromList $ swap <$> typeReferences swap (x, y) = (y, x) builtinForeigns :: EnumMap Word64 ForeignFunc -builtinForeigns | (_, _, m) <- foreignDeclResults = snd <$> m +builtinForeigns | (_, _, m) <- foreignDeclResults False = snd <$> m + +sandboxedForeigns :: EnumMap Word64 ForeignFunc +sandboxedForeigns | (_, _, m) <- foreignDeclResults True = snd <$> m builtinForeignNames :: EnumMap Word64 Data.Text.Text -builtinForeignNames | (_, _, m) <- foreignDeclResults = fst <$> m +builtinForeignNames | (_, _, m) <- foreignDeclResults False = fst <$> m -- Bootstrapping for sandbox check. The eventual map will be one with -- associations `r -> s` where `s` is all the 'sensitive' base diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index b26c110a5f..6e8fbf32cb 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -126,8 +126,8 @@ cacheContext = $ Map.keys builtinTermNumbering <&> \r -> (r, Map.singleton 0 (Tm.ref () r)) -baseContext :: IO EvalCtx -baseContext = cacheContext <$> baseCCache +baseContext :: Bool -> IO EvalCtx +baseContext sandboxed = cacheContext <$> baseCCache sandboxed resolveTermRef :: CodeLookup Symbol IO () -> @@ -496,9 +496,9 @@ data RuntimeHost = OneOff | Persistent -startRuntime :: RuntimeHost -> Text -> IO (Runtime Symbol) -startRuntime runtimeHost version = do - ctxVar <- newIORef =<< baseContext +startRuntime :: Bool -> RuntimeHost -> Text -> IO (Runtime Symbol) +startRuntime sandboxed runtimeHost version = do + ctxVar <- newIORef =<< baseContext sandboxed (activeThreads, cleanupThreads) <- case runtimeHost of -- Don't bother tracking open threads when running standalone, they'll all be cleaned up -- when the process itself exits. diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index 80a2df9956..9237513bc2 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -104,9 +104,9 @@ refNumTy cc r = refNumTy' :: CCache -> Reference -> IO (Maybe Word64) refNumTy' cc r = M.lookup r <$> refNumsTy cc -baseCCache :: IO CCache -baseCCache = - CCache builtinForeigns noTrace +baseCCache :: Bool -> IO CCache +baseCCache sandboxed = do + CCache ffuncs noTrace <$> newTVarIO combs <*> newTVarIO builtinTermBackref <*> newTVarIO builtinTypeBackref @@ -117,6 +117,7 @@ baseCCache = <*> newTVarIO builtinTypeNumbering <*> newTVarIO baseSandboxInfo where + ffuncs | sandboxed = sandboxedForeigns | otherwise = builtinForeigns noTrace _ _ = pure () ftm = 1 + maximum builtinTermNumbering fty = 1 + maximum builtinTypeNumbering diff --git a/unison-cli/src/Unison/Codebase/Editor/Command.hs b/unison-cli/src/Unison/Codebase/Editor/Command.hs index 6d06413929..8f6807abe8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Command.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Command.hs @@ -179,11 +179,12 @@ data -- of the same watches instantaneous. Evaluate :: + Bool -> -- sandboxed PPE.PrettyPrintEnv -> UF.TypecheckedUnisonFile v Ann -> Command m i v (Either Runtime.Error (EvalResult v)) -- Evaluate a single closed definition - Evaluate1 :: PPE.PrettyPrintEnv -> UseCache -> Term v Ann -> Command m i v (Either Runtime.Error (Term v Ann)) + Evaluate1 :: Bool -> PPE.PrettyPrintEnv -> UseCache -> Term v Ann -> Command m i v (Either Runtime.Error (Term v Ann)) -- Add a cached watch to the codebase PutWatch :: WK.WatchKind -> Reference.Id -> Term v Ann -> Command m i v () -- Loads any cached watches of the given kind diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs index a7ea503080..f6ee105263 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs @@ -91,6 +91,7 @@ commandLine :: IO i -> (Branch IO -> IO ()) -> Runtime Symbol -> + Runtime Symbol -> (Output Symbol -> IO ()) -> (NumberedOutput Symbol -> IO NumberedArgs) -> (SourceName -> IO LoadSourceResult) -> @@ -100,7 +101,7 @@ commandLine :: (Int -> IO gen) -> Free (Command IO i Symbol) a -> IO a -commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSource codebase serverBaseUrl ucmVersion rngGen free = do +commandLine config awaitInput setBranchRef rt sdbxRt notifyUser notifyNumbered loadSource codebase serverBaseUrl ucmVersion rngGen free = do rndSeed <- STM.newTVarIO 0 flip runReaderT rndSeed . Free.fold go $ free where @@ -124,7 +125,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour Just url -> lift . void $ openBrowser (Server.urlFor Server.UI url) Nothing -> lift (return ()) DocsToHtml root sourcePath destination -> - liftIO $ Backend.docsInBranchToHtmlFiles rt codebase root sourcePath destination + liftIO $ Backend.docsInBranchToHtmlFiles sdbxRt codebase root sourcePath destination Input -> lift awaitInput Notify output -> lift $ notifyUser output NotifyNumbered output -> lift $ notifyNumbered output @@ -144,8 +145,8 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour env = Parser.ParsingEnv namegen names lift $ typecheck ambient codebase env sourceName source TypecheckFile file ambient -> lift $ typecheck' ambient codebase file - Evaluate ppe unisonFile -> lift $ evalUnisonFile ppe unisonFile [] - Evaluate1 ppe useCache term -> lift $ eval1 ppe useCache term + Evaluate sdbx ppe unisonFile -> lift $ evalUnisonFile sdbx ppe unisonFile [] + Evaluate1 sdbx ppe useCache term -> lift $ eval1 sdbx ppe useCache term LoadLocalRootBranch -> lift $ Codebase.getRootBranch codebase LoadLocalBranch h -> lift $ fromMaybe Branch.empty <$> Codebase.getBranchForHash codebase h Merge mode b1 b2 -> @@ -207,7 +208,7 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour -- pure $ Branch.append b0 b Execute ppe uf args -> - lift $ evalUnisonFile ppe uf args + lift $ evalUnisonFile False ppe uf args AppendToReflog reason old new -> lift $ Codebase.appendReflog codebase reason old new LoadReflog -> lift $ Codebase.getReflog codebase CreateAuthorInfo t -> AuthorInfo.createAuthorInfo Ann.External t @@ -249,11 +250,12 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour maybeTerm <- Codebase.lookupWatchCache codebase h pure (Term.amap (const ()) <$> maybeTerm) - eval1 :: PPE.PrettyPrintEnv -> UseCache -> Term Symbol Ann -> _ - eval1 ppe useCache tm = do + eval1 :: Bool -> PPE.PrettyPrintEnv -> UseCache -> Term Symbol Ann -> _ + eval1 sandbox ppe useCache tm = do let codeLookup = Codebase.toCodeLookup codebase cache = if useCache then watchCache else Runtime.noCache - r <- Runtime.evaluateTerm' codeLookup cache ppe rt tm + rt' | sandbox = sdbxRt | otherwise = rt + r <- Runtime.evaluateTerm' codeLookup cache ppe rt' tm when useCache $ case r of Right tmr -> Codebase.putWatch @@ -264,10 +266,11 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour Left _ -> pure () pure $ r <&> Term.amap (const Ann.External) - evalUnisonFile :: PPE.PrettyPrintEnv -> UF.TypecheckedUnisonFile Symbol Ann -> [String] -> _ - evalUnisonFile ppe unisonFile args = withArgs args do + evalUnisonFile :: Bool -> PPE.PrettyPrintEnv -> UF.TypecheckedUnisonFile Symbol Ann -> [String] -> _ + evalUnisonFile sandbox ppe unisonFile args = withArgs args do let codeLookup = Codebase.toCodeLookup codebase - r <- Runtime.evaluateWatches codeLookup ppe watchCache rt unisonFile + rt' | sandbox = sdbxRt | otherwise = rt + r <- Runtime.evaluateWatches codeLookup ppe watchCache rt' unisonFile case r of Left e -> pure (Left e) Right rs@(_, map) -> do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 02d2218357..fc4ac99e11 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -289,7 +289,7 @@ loop = do let ppe = PPE.suffixifiedPPE pped unsafeTime "typechecked.respond" $ respond $ Typechecked sourceName ppe sr unisonFile unlessError' EvaluationFailure do - (bindings, e) <- unsafeTime "evaluate" $ ExceptT . eval . Evaluate ppe $ unisonFile + (bindings, e) <- unsafeTime "evaluate" $ ExceptT . eval . Evaluate True ppe $ unisonFile lift do let e' = Map.map go e go (ann, kind, _hash, _uneval, eval, isHit) = (ann, kind, eval, isHit) @@ -1364,7 +1364,7 @@ loop = do Just tm -> do respond $ TestIncrementalOutputStart ppe (n, total) r tm -- v don't cache; test cache populated below - tm' <- eval $ Evaluate1 ppe False tm + tm' <- eval $ Evaluate1 True ppe False tm case tm' of Left e -> respond (EvaluationFailure e) $> [] Right tm' -> do @@ -1444,8 +1444,8 @@ loop = do let a = ABT.annotation tm tm = DD.forceTerm a a (Term.ref a ref) in do - -- v Don't cache IO tests - tm' <- eval $ Evaluate1 ppe False tm + -- Don't cache IO tests v + tm' <- eval $ Evaluate1 False ppe False tm case tm' of Left e -> respond (EvaluationFailure e) Right tm' -> @@ -2406,7 +2406,7 @@ doDisplay outputLoc names tm = do useCache = True evalTerm tm = fmap ErrorUtil.hush . fmap (fmap Term.unannotate) . eval $ - Evaluate1 (PPE.suffixifiedPPE ppe) useCache (Term.amap (const External) tm) + Evaluate1 True (PPE.suffixifiedPPE ppe) useCache (Term.amap (const External) tm) loadTerm (Reference.DerivedId r) = case Map.lookup r tms of Nothing -> fmap (fmap Term.unannotate) . eval $ LoadTerm r Just (tm, _) -> pure (Just $ Term.unannotate tm) @@ -2997,14 +2997,14 @@ displayI prettyPrintNames outputLoc hq = do do let tm = Term.fromReferent External $ Set.findMin results pped <- prettyPrintEnvDecl parseNames - tm <- eval $ Evaluate1 (PPE.suffixifiedPPE pped) True tm + tm <- eval $ Evaluate1 True (PPE.suffixifiedPPE pped) True tm case tm of Left e -> respond (EvaluationFailure e) Right tm -> doDisplay outputLoc parseNames (Term.unannotate tm) Just (toDisplay, unisonFile) -> do ppe <- executePPE unisonFile unlessError' EvaluationFailure do - evalResult <- ExceptT . eval . Evaluate ppe $ unisonFile + evalResult <- ExceptT . eval . Evaluate True ppe $ unisonFile case Command.lookupEvalResult toDisplay evalResult of Nothing -> error $ "Evaluation dropped a watch expression: " <> HQ.toString hq Just tm -> lift do @@ -3053,7 +3053,7 @@ docsI srcLoc prettyPrintNames src = do len <- eval BranchHashLength let names = NamesWithHistory.NamesWithHistory prettyPrintNames mempty let tm = Term.ref External ref - tm <- eval $ Evaluate1 (PPE.fromNames len names) True tm + tm <- eval $ Evaluate1 True (PPE.fromNames len names) True tm case tm of Left e -> respond (EvaluationFailure e) Right tm -> doDisplay ConsoleLocation names (Term.unannotate tm) diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index cc59064c41..1f83108cac 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -182,20 +182,23 @@ withTranscriptRunner :: (TranscriptRunner -> m r) -> m r withTranscriptRunner ucmVersion configFile action = do - withRuntime $ \runtime -> withConfig $ \config -> do + withRuntime $ \runtime sbRuntime -> withConfig $ \config -> do action $ \transcriptName transcriptSrc (codebaseDir, codebase) -> do Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) Server.defaultCodebaseServerOpts runtime codebase $ \baseUrl -> do let parsed = parse transcriptName transcriptSrc result <- for parsed $ \stanzas -> do - liftIO $ run codebaseDir stanzas codebase runtime config ucmVersion (tShow baseUrl) + liftIO $ run codebaseDir stanzas codebase runtime sbRuntime config ucmVersion (tShow baseUrl) pure $ join @(Either TranscriptError) result where - withRuntime :: ((Runtime.Runtime Symbol -> m a) -> m a) + withRuntime :: ((Runtime.Runtime Symbol -> Runtime.Runtime Symbol -> m a) -> m a) withRuntime action = UnliftIO.bracket - (liftIO $ RTI.startRuntime RTI.Persistent ucmVersion) - (liftIO . Runtime.terminate) - action + (liftIO $ RTI.startRuntime False RTI.Persistent ucmVersion) + (liftIO . Runtime.terminate) $ \runtime -> + UnliftIO.bracket + (liftIO $ RTI.startRuntime True RTI.Persistent ucmVersion) + (liftIO . Runtime.terminate) + (action runtime) withConfig :: forall a. ((Maybe Config -> m a) -> m a) withConfig action = do case configFile of @@ -214,11 +217,12 @@ run :: [Stanza] -> Codebase IO Symbol Ann -> Runtime.Runtime Symbol -> + Runtime.Runtime Symbol -> Maybe Config -> UCMVersion -> Text -> IO (Either TranscriptError Text) -run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do +run dir stanzas codebase runtime sbRuntime config ucmVersion baseURL = UnliftIO.try $ do httpManager <- HTTP.newManager HTTP.defaultManagerSettings let initialPath = Path.absoluteEmpty putPrettyLn $ @@ -459,6 +463,7 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do awaitInput (const $ pure ()) runtime + sbRuntime print printNumbered loadPreviousUnisonBlock diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 8689fb73e8..809d527837 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -113,11 +113,12 @@ main :: (Config, IO ()) -> [Either Event Input] -> Runtime.Runtime Symbol -> + Runtime.Runtime Symbol -> Codebase IO Symbol Ann -> Maybe Server.BaseUrl -> UCMVersion -> IO () -main dir welcome initialPath (config, cancelConfig) initialInputs runtime codebase serverBaseUrl ucmVersion = do +main dir welcome initialPath (config, cancelConfig) initialInputs runtime sbRuntime codebase serverBaseUrl ucmVersion = do root <- Codebase.getRootBranch codebase eventQueue <- Q.newIO welcomeEvents <- Welcome.run codebase welcome @@ -171,6 +172,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba let cleanup = do Runtime.terminate runtime + Runtime.terminate sbRuntime cancelConfig cancelFileSystemWatch cancelWatchBranchUpdates @@ -210,6 +212,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba awaitInput (writeIORef rootRef) runtime + sbRuntime notify ( \o -> let (p, args) = notifyNumbered o diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index bfb92dd584..e5142814c4 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -115,7 +115,7 @@ main = withCP65001 do ) Run (RunFromSymbol mainName) args -> do getCodebaseOrExit mCodePathOption \(_, _, theCodebase) -> do - runtime <- RTI.startRuntime RTI.OneOff Version.gitDescribeWithDate + runtime <- RTI.startRuntime False RTI.OneOff Version.gitDescribeWithDate withArgs args $ execute theCodebase runtime mainName Run (RunFromFile file mainName) args | not (isDotU file) -> PT.putPrettyLn $ P.callout "โš ๏ธ" "Files must have a .u extension." @@ -125,21 +125,24 @@ main = withCP65001 do Left _ -> PT.putPrettyLn $ P.callout "โš ๏ธ" "I couldn't find that file or it is for some reason unreadable." Right contents -> do getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do - rt <- RTI.startRuntime RTI.OneOff Version.gitDescribeWithDate + rt <- RTI.startRuntime False RTI.OneOff Version.gitDescribeWithDate + sbrt <- RTI.startRuntime True RTI.OneOff Version.gitDescribeWithDate let fileEvent = Input.UnisonFileChanged (Text.pack file) contents - launch currentDir config rt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes + launch currentDir config rt sbrt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes Run (RunFromPipe mainName) args -> do e <- safeReadUtf8StdIn case e of Left _ -> PT.putPrettyLn $ P.callout "โš ๏ธ" "I had trouble reading this input." Right contents -> do getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do - rt <- RTI.startRuntime RTI.OneOff Version.gitDescribeWithDate + rt <- RTI.startRuntime False RTI.OneOff Version.gitDescribeWithDate + sbrt <- RTI.startRuntime True RTI.OneOff Version.gitDescribeWithDate let fileEvent = Input.UnisonFileChanged (Text.pack "") contents launch currentDir config rt + sbrt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing @@ -210,8 +213,9 @@ main = withCP65001 do runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles Launch isHeadless codebaseServerOpts downloadBase -> do getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do - runtime <- RTI.startRuntime RTI.Persistent Version.gitDescribeWithDate - Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts runtime theCodebase $ \baseUrl -> do + runtime <- RTI.startRuntime False RTI.Persistent Version.gitDescribeWithDate + sbRuntime <- RTI.startRuntime True RTI.Persistent Version.gitDescribeWithDate + Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do case exitOption of DoNotExit -> do case isHeadless of @@ -234,7 +238,7 @@ main = withCP65001 do takeMVar mvar WithCLI -> do PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..." - launch currentDir config runtime theCodebase [] (Just baseUrl) downloadBase initRes + launch currentDir config runtime sbRuntime theCodebase [] (Just baseUrl) downloadBase initRes Exit -> do Exit.exitSuccess -- | Set user agent and configure TLS on global http client. @@ -376,13 +380,14 @@ launch :: FilePath -> (Config, IO ()) -> Rt.Runtime Symbol -> + Rt.Runtime Symbol -> Codebase.Codebase IO Symbol Ann -> [Either Input.Event Input.Input] -> Maybe Server.BaseUrl -> ShouldDownloadBase -> InitResult -> IO () -launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase initResult = +launch dir config runtime sbRuntime codebase inputs serverBaseUrl shouldDownloadBase initResult = let downloadBase = case defaultBaseLib of Just remoteNS | shouldDownloadBase == ShouldDownloadBase -> Welcome.DownloadBase remoteNS _ -> Welcome.DontDownloadBase @@ -399,6 +404,7 @@ launch dir config runtime codebase inputs serverBaseUrl shouldDownloadBase initR config inputs runtime + sbRuntime codebase serverBaseUrl ucmVersion From 81c2053fc5e7d7a3dd17b63526d825d2a25abacd Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Mon, 11 Jul 2022 18:44:11 -0400 Subject: [PATCH 498/529] Add sandboxing for some instruction primops --- .../src/Unison/Runtime/Interface.hs | 2 +- .../src/Unison/Runtime/Machine.hs | 179 ++++++++++-------- 2 files changed, 100 insertions(+), 81 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index 6e8fbf32cb..a5e07742dc 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -587,7 +587,7 @@ getStoredCache = restoreCache :: StoredCache -> IO CCache restoreCache (SCache cs crs trs ftm fty int rtm rty sbs) = - CCache builtinForeigns uglyTrace + CCache builtinForeigns False uglyTrace <$> newTVarIO (cs <> combs) <*> newTVarIO (crs <> builtinTermBackref) <*> newTVarIO (trs <> builtinTypeBackref) diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index 9237513bc2..c21b714d55 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -71,6 +71,7 @@ type DEnv = EnumMap Word64 Closure -- code caching environment data CCache = CCache { foreignFuncs :: EnumMap Word64 ForeignFunc, + sandboxed :: Bool, tracer :: Unison.Util.Text.Text -> Closure -> IO (), combs :: TVar (EnumMap Word64 Combs), combRefs :: TVar (EnumMap Word64 Reference), @@ -106,7 +107,7 @@ refNumTy' cc r = M.lookup r <$> refNumsTy cc baseCCache :: Bool -> IO CCache baseCCache sandboxed = do - CCache ffuncs noTrace + CCache ffuncs sandboxed noTrace <$> newTVarIO combs <*> newTVarIO builtinTermBackref <*> newTVarIO builtinTypeBackref @@ -252,56 +253,64 @@ exec !_ !denv !_activeThreads !ustk !bstk !k (UPrim1 op i) = do exec !_ !denv !_activeThreads !ustk !bstk !k (UPrim2 op i j) = do ustk <- uprim2 ustk op i j pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 MISS i) = do - clink <- peekOff bstk i - let Ref link = unwrapForeign $ marshalToForeign clink - m <- readTVarIO (intermed env) - ustk <- bump ustk - if (link `M.member` m) then poke ustk 1 else poke ustk 0 - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CACH i) = do - arg <- peekOffS bstk i - news <- decodeCacheArgument arg - unknown <- cacheAdd news env - bstk <- bump bstk - pokeS - bstk - (Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> unknown) - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CVLD i) = do - arg <- peekOffS bstk i - news <- decodeCacheArgument arg - codeValidate news env >>= \case - Nothing -> do +exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 MISS i) + | sandboxed env = die "attempted to use sandboxed operation: isMissing" + | otherwise = do + clink <- peekOff bstk i + let Ref link = unwrapForeign $ marshalToForeign clink + m <- readTVarIO (intermed env) ustk <- bump ustk - poke ustk 0 + if (link `M.member` m) then poke ustk 1 else poke ustk 0 pure (denv, ustk, bstk, k) - Just (Failure ref msg clo) -> do - ustk <- bump ustk - bstk <- bumpn bstk 3 - poke ustk 1 - poke bstk (Foreign $ Wrap Rf.typeLinkRef ref) - pokeOffBi bstk 1 msg - pokeOff bstk 2 clo +exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CACH i) + | sandboxed env = die "attempted to use sandboxed operation: cache" + | otherwise = do + arg <- peekOffS bstk i + news <- decodeCacheArgument arg + unknown <- cacheAdd news env + bstk <- bump bstk + pokeS + bstk + (Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> unknown) pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LKUP i) = do - clink <- peekOff bstk i - let Ref link = unwrapForeign $ marshalToForeign clink - m <- readTVarIO (intermed env) - ustk <- bump ustk - bstk <- case M.lookup link m of - Nothing - | Just w <- M.lookup link builtinTermNumbering, - Just sn <- EC.lookup w numberedTermLookup -> do +exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CVLD i) + | sandboxed env = die "attempted to use sandboxed operation: validate" + | otherwise = do + arg <- peekOffS bstk i + news <- decodeCacheArgument arg + codeValidate news env >>= \case + Nothing -> do + ustk <- bump ustk + poke ustk 0 + pure (denv, ustk, bstk, k) + Just (Failure ref msg clo) -> do + ustk <- bump ustk + bstk <- bumpn bstk 3 + poke ustk 1 + poke bstk (Foreign $ Wrap Rf.typeLinkRef ref) + pokeOffBi bstk 1 msg + pokeOff bstk 2 clo + pure (denv, ustk, bstk, k) +exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LKUP i) + | sandboxed env = die "attempted to use sandboxed operation: lookup" + | otherwise = do + clink <- peekOff bstk i + let Ref link = unwrapForeign $ marshalToForeign clink + m <- readTVarIO (intermed env) + ustk <- bump ustk + bstk <- case M.lookup link m of + Nothing + | Just w <- M.lookup link builtinTermNumbering, + Just sn <- EC.lookup w numberedTermLookup -> do + poke ustk 1 + bstk <- bump bstk + bstk <$ pokeBi bstk (ANF.Rec [] sn) + | otherwise -> bstk <$ poke ustk 0 + Just sg -> do poke ustk 1 bstk <- bump bstk - bstk <$ pokeBi bstk (ANF.Rec [] sn) - | otherwise -> bstk <$ poke ustk 0 - Just sg -> do - poke ustk 1 - bstk <- bump bstk - bstk <$ pokeBi bstk sg - pure (denv, ustk, bstk, k) + bstk <$ pokeBi bstk sg + pure (denv, ustk, bstk, k) exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim1 TLTT i) = do clink <- peekOff bstk i let Ref link = unwrapForeign $ marshalToForeign clink @@ -309,25 +318,29 @@ exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim1 TLTT i) = do bstk <- bump bstk pokeBi bstk sh pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LOAD i) = do - v <- peekOffBi bstk i - ustk <- bump ustk - bstk <- bump bstk - reifyValue env v >>= \case - Left miss -> do - poke ustk 0 - pokeS bstk $ - Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> miss - Right x -> do - poke ustk 1 - poke bstk x - pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 VALU i) = do - m <- readTVarIO (tagRefs env) - c <- peekOff bstk i - bstk <- bump bstk - pokeBi bstk =<< reflectValue m c - pure (denv, ustk, bstk, k) +exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LOAD i) + | sandboxed env = die "attempted to use sandboxed operation: load" + | otherwise = do + v <- peekOffBi bstk i + ustk <- bump ustk + bstk <- bump bstk + reifyValue env v >>= \case + Left miss -> do + poke ustk 0 + pokeS bstk $ + Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> miss + Right x -> do + poke ustk 1 + poke bstk x + pure (denv, ustk, bstk, k) +exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 VALU i) + | sandboxed env = die "attempted to use sandboxed operation: value" + | otherwise = do + m <- readTVarIO (tagRefs env) + c <- peekOff bstk i + bstk <- bump bstk + pokeBi bstk =<< reflectValue m c + pure (denv, ustk, bstk, k) exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim1 op i) = do (ustk, bstk) <- bprim1 ustk bstk op i pure (denv, ustk, bstk, k) @@ -351,11 +364,13 @@ exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim2 CMPU i j) = do ustk <- bump ustk poke ustk . fromEnum $ universalCompare compare x y pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k (BPrim2 TRCE i j) = do - tx <- peekOffBi bstk i - clo <- peekOff bstk j - tracer env tx clo - pure (denv, ustk, bstk, k) +exec !env !denv !_activeThreads !ustk !bstk !k (BPrim2 TRCE i j) + | sandboxed env = die "attempted to use sandboxed operation: trace" + | otherwise = do + tx <- peekOffBi bstk i + clo <- peekOff bstk j + tracer env tx clo + pure (denv, ustk, bstk, k) exec !_ !denv !_trackThreads !ustk !bstk !k (BPrim2 op i j) = do (ustk, bstk) <- bprim2 ustk bstk op i j pure (denv, ustk, bstk, k) @@ -406,16 +421,20 @@ exec !env !denv !_activeThreads !ustk !bstk !k (ForeignCall _ w args) <$> (arg ustk bstk args >>= ev >>= res ustk bstk) | otherwise = die $ "reference to unknown foreign function: " ++ show w -exec !env !denv !activeThreads !ustk !bstk !k (Fork i) = do - tid <- forkEval env activeThreads =<< peekOff bstk i - bstk <- bump bstk - poke bstk . Foreign . Wrap Rf.threadIdRef $ tid - pure (denv, ustk, bstk, k) -exec !env !denv !activeThreads !ustk !bstk !k (Atomically i) = do - c <- peekOff bstk i - bstk <- bump bstk - atomicEval env activeThreads (poke bstk) c - pure (denv, ustk, bstk, k) +exec !env !denv !activeThreads !ustk !bstk !k (Fork i) + | sandboxed env = die "attempted to use sandboxed operation: fork" + | otherwise = do + tid <- forkEval env activeThreads =<< peekOff bstk i + bstk <- bump bstk + poke bstk . Foreign . Wrap Rf.threadIdRef $ tid + pure (denv, ustk, bstk, k) +exec !env !denv !activeThreads !ustk !bstk !k (Atomically i) + | sandboxed env = die $ "attempted to use sandboxed operation: atomically" + | otherwise = do + c <- peekOff bstk i + bstk <- bump bstk + atomicEval env activeThreads (poke bstk) c + pure (denv, ustk, bstk, k) {-# INLINE exec #-} eval :: From c4f3c293b7983c86a07145997d3f4eb2f4714889 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Mon, 11 Jul 2022 19:00:24 -0400 Subject: [PATCH 499/529] Formatting --- .../src/Unison/Runtime/Builtin.hs | 5 +- .../src/Unison/Runtime/Interface.hs | 84 +++++++++---------- unison-cli/unison/Main.hs | 22 ++--- 3 files changed, 56 insertions(+), 55 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index 4856b904b6..de668b3b78 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -33,7 +33,7 @@ import Control.Exception (evaluate) import qualified Control.Exception.Safe as Exception import Control.Monad.Catch (MonadCatch) import qualified Control.Monad.Primitive as PA -import Control.Monad.Reader (ReaderT(..), runReaderT, ask) +import Control.Monad.Reader (ReaderT (..), ask, runReaderT) import Control.Monad.State.Strict (State, execState, modify) import qualified Crypto.Hash as Hash import qualified Crypto.MAC.HMAC as HMAC @@ -1933,7 +1933,8 @@ declareForeign sand name op func0 = do let func | sanitize, Tracked <- sand, - FF r w _ <- func0 = FF r w (bomb name) + FF r w _ <- func0 = + FF r w (bomb name) | otherwise = func0 code = (name, (sand, uncurry Lambda (op w))) in (w + 1, code : codes, mapInsert w (name, func) funcs) diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index a5e07742dc..315fd6179e 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -337,9 +337,9 @@ prepareEvaluation ppe tm ctx = do $ Map.fromList bs, mn <- Tm.substs (Map.toList $ Tm.ref () . fst <$> hcs) mn0, rmn <- RF.DerivedId $ Hashing.hashClosedTerm mn = - (rmn, (rmn, mn) : Map.elems hcs) + (rmn, (rmn, mn) : Map.elems hcs) | rmn <- RF.DerivedId $ Hashing.hashClosedTerm tm = - (rmn, [(rmn, tm)]) + (rmn, [(rmn, tm)]) (rgrp, rbkr) = intermediateTerms ppe ctx rtms @@ -407,50 +407,50 @@ executeMainComb init cc = bugMsg :: PrettyPrintEnv -> Text -> Term Symbol -> Pretty ColorText bugMsg ppe name tm | name == "blank expression" = - P.callout icon . P.lines $ - [ P.wrap - ( "I encountered a" <> P.red (P.text name) - <> "with the following name/message:" - ), - "", - P.indentN 2 $ pretty ppe tm, - "", - sorryMsg - ] + P.callout icon . P.lines $ + [ P.wrap + ( "I encountered a" <> P.red (P.text name) + <> "with the following name/message:" + ), + "", + P.indentN 2 $ pretty ppe tm, + "", + sorryMsg + ] | "pattern match failure" `isPrefixOf` name = - P.callout icon . P.lines $ - [ P.wrap - ( "I've encountered a" <> P.red (P.text name) - <> "while scrutinizing:" - ), - "", - P.indentN 2 $ pretty ppe tm, - "", - "This happens when calling a function that doesn't handle all \ - \possible inputs", - sorryMsg - ] + P.callout icon . P.lines $ + [ P.wrap + ( "I've encountered a" <> P.red (P.text name) + <> "while scrutinizing:" + ), + "", + P.indentN 2 $ pretty ppe tm, + "", + "This happens when calling a function that doesn't handle all \ + \possible inputs", + sorryMsg + ] | name == "builtin.raise" = - P.callout icon . P.lines $ - [ P.wrap ("The program halted with an unhandled exception:"), - "", - P.indentN 2 $ pretty ppe tm - ] + P.callout icon . P.lines $ + [ P.wrap ("The program halted with an unhandled exception:"), + "", + P.indentN 2 $ pretty ppe tm + ] | name == "builtin.bug", RF.TupleTerm' [Tm.Text' msg, x] <- tm, "pattern match failure" `isPrefixOf` msg = - P.callout icon . P.lines $ - [ P.wrap - ( "I've encountered a" <> P.red (P.text msg) - <> "while scrutinizing:" - ), - "", - P.indentN 2 $ pretty ppe x, - "", - "This happens when calling a function that doesn't handle all \ - \possible inputs", - sorryMsg - ] + P.callout icon . P.lines $ + [ P.wrap + ( "I've encountered a" <> P.red (P.text msg) + <> "while scrutinizing:" + ), + "", + P.indentN 2 $ pretty ppe x, + "", + "This happens when calling a function that doesn't handle all \ + \possible inputs", + sorryMsg + ] bugMsg ppe name tm = P.callout icon . P.lines $ [ P.wrap @@ -617,7 +617,7 @@ traceNeeded init src = fmap (`withoutKeys` ks) $ go mempty init go acc w | hasKey w acc = pure acc | Just co <- EC.lookup w src = - foldlM go (mapInsert w co acc) (foldMap combDeps co) + foldlM go (mapInsert w co acc) (foldMap combDeps co) | otherwise = die $ "traceNeeded: unknown combinator: " ++ show w buildSCache :: diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index e5142814c4..1898109d17 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -13,9 +13,9 @@ import ArgParse Command (Init, Launch, PrintVersion, Run, Transcript), GlobalOptions (GlobalOptions, codebasePathOption, exitOption), IsHeadless (Headless, WithCLI), - ShouldExit(Exit, DoNotExit), RunSource (..), ShouldDownloadBase (..), + ShouldExit (DoNotExit, Exit), ShouldForkCodebase (..), ShouldSaveCodebase (..), UsageRenderer, @@ -120,15 +120,15 @@ main = withCP65001 do Run (RunFromFile file mainName) args | not (isDotU file) -> PT.putPrettyLn $ P.callout "โš ๏ธ" "Files must have a .u extension." | otherwise -> do - e <- safeReadUtf8 file - case e of - Left _ -> PT.putPrettyLn $ P.callout "โš ๏ธ" "I couldn't find that file or it is for some reason unreadable." - Right contents -> do - getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do - rt <- RTI.startRuntime False RTI.OneOff Version.gitDescribeWithDate - sbrt <- RTI.startRuntime True RTI.OneOff Version.gitDescribeWithDate - let fileEvent = Input.UnisonFileChanged (Text.pack file) contents - launch currentDir config rt sbrt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes + e <- safeReadUtf8 file + case e of + Left _ -> PT.putPrettyLn $ P.callout "โš ๏ธ" "I couldn't find that file or it is for some reason unreadable." + Right contents -> do + getCodebaseOrExit mCodePathOption \(initRes, _, theCodebase) -> do + rt <- RTI.startRuntime False RTI.OneOff Version.gitDescribeWithDate + sbrt <- RTI.startRuntime True RTI.OneOff Version.gitDescribeWithDate + let fileEvent = Input.UnisonFileChanged (Text.pack file) contents + launch currentDir config rt sbrt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] Nothing ShouldNotDownloadBase initRes Run (RunFromPipe mainName) args -> do e <- safeReadUtf8StdIn case e of @@ -216,7 +216,7 @@ main = withCP65001 do runtime <- RTI.startRuntime False RTI.Persistent Version.gitDescribeWithDate sbRuntime <- RTI.startRuntime True RTI.Persistent Version.gitDescribeWithDate Server.startServer (Backend.BackendEnv {Backend.useNamesIndex = False}) codebaseServerOpts sbRuntime theCodebase $ \baseUrl -> do - case exitOption of + case exitOption of DoNotExit -> do case isHeadless of Headless -> do From 51bce652b86255555f6e923acec09333dcadd243 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 11 Jul 2022 20:51:40 -0400 Subject: [PATCH 500/529] add another case to test-command transcript --- unison-src/transcripts/test-command.md | 16 +++++++ unison-src/transcripts/test-command.output.md | 43 +++++++++++++++++++ 2 files changed, 59 insertions(+) diff --git a/unison-src/transcripts/test-command.md b/unison-src/transcripts/test-command.md index 3b46a4e9c3..3d8bde394a 100644 --- a/unison-src/transcripts/test-command.md +++ b/unison-src/transcripts/test-command.md @@ -39,3 +39,19 @@ test2 = [Ok "test2"] .> test .> test.all ``` + +`test` will descend into namespaces named `lib` if they aren't at the top-level, though. + +```unison +test3 : [Result] +test3 = [Ok "test3"] +``` + +```ucm:hide +.hello.lib> add +.hello.lib> link .builtin.metadata.isTest test3 +``` + +```ucm +.> test +``` diff --git a/unison-src/transcripts/test-command.output.md b/unison-src/transcripts/test-command.output.md index 1b5f6abca0..0dbc2e8391 100644 --- a/unison-src/transcripts/test-command.output.md +++ b/unison-src/transcripts/test-command.output.md @@ -92,3 +92,46 @@ test2 = [Ok "test2"] Tip: Use view lib.test2 to view the source of a test. ``` +`test` will descend into namespaces named `lib` if they aren't at the top-level, though. + +```unison +test3 : [Result] +test3 = [Ok "test3"] +``` + +```ucm + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + โŸ These new definitions are ok to `add`: + + test3 : [Result] + +``` +```ucm +.> test + + + Cached test results (`help testcache` to learn more) + + โ—‰ test1 test1 + + โœ… 1 test(s) passing + + โœ… + + + + + + New test results: + + โ—‰ hello.lib.test3 test3 + + โœ… 1 test(s) passing + + Tip: Use view hello.lib.test3 to view the source of a test. + +``` From cf5db9d8b38a7f66cbc6c7b126594a3011993944 Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 12 Jul 2022 11:53:09 -0400 Subject: [PATCH 501/529] Assorted test/transcript fixes - Some test runners weren't adapted to the new startRuntime - Some transcripts were using Tracked operations in pure tests. Technically these are pure operations, but since they're tracked, I changed them to io tests. - Some operations were made untracked that were previously tracked. We had already decided that `Scope` related operations were fine to be untracked, and there were existing test cases failing due to them not being so. I've also made `value` untracked. It's used internally by the crypto operations, which were untracked, and I don't think there's any problem with obtaining a `Value`, when other operations on that type are tracked. --- .../src/Unison/Runtime/Builtin.hs | 54 +++++++++---------- .../src/Unison/Runtime/Machine.hs | 14 +++-- parser-typechecker/tests/Unison/Test/MCode.hs | 2 +- .../tests/Unison/Test/UnisonSources.hs | 2 +- unison-src/transcripts-using-base/codeops.md | 1 - .../transcripts-using-base/codeops.output.md | 4 -- unison-src/transcripts-using-base/tls.md | 10 +++- .../transcripts-using-base/tls.output.md | 32 +++++++---- 8 files changed, 65 insertions(+), 54 deletions(-) diff --git a/parser-typechecker/src/Unison/Runtime/Builtin.hs b/parser-typechecker/src/Unison/Runtime/Builtin.hs index de668b3b78..4e0139210e 100644 --- a/parser-typechecker/src/Unison/Runtime/Builtin.hs +++ b/parser-typechecker/src/Unison/Runtime/Builtin.hs @@ -2291,7 +2291,7 @@ declareForeigns = do \() -> unsafeSTMToIO STM.retry :: IO Closure -- Scope and Ref stuff - declareForeign Tracked "Scope.ref" boxDirect + declareForeign Untracked "Scope.ref" boxDirect . mkForeign $ \(c :: Closure) -> newIORef c @@ -2299,10 +2299,10 @@ declareForeigns = do . mkForeign $ \(c :: Closure) -> newIORef c - declareForeign Tracked "Ref.read" boxDirect . mkForeign $ + declareForeign Untracked "Ref.read" boxDirect . mkForeign $ \(r :: IORef Closure) -> readIORef r - declareForeign Tracked "Ref.write" boxBoxTo0 . mkForeign $ + declareForeign Untracked "Ref.write" boxBoxTo0 . mkForeign $ \(r :: IORef Closure, c :: Closure) -> writeIORef r c declareForeign Tracked "Tls.newClient.impl.v3" boxBoxToEFBox . mkForeignTls $ @@ -2465,7 +2465,7 @@ declareForeigns = do declareForeign Untracked "Bytes.encodeNat16be" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat16be declareForeign Untracked "Bytes.encodeNat16le" (wordDirect Ty.natRef) . mkForeign $ pure . Bytes.encodeNat16le - declareForeign Tracked "MutableArray.copyTo!" boxNatBoxNatNatToExnUnit + declareForeign Untracked "MutableArray.copyTo!" boxNatBoxNatNatToExnUnit . mkForeign $ \(dst, doff, src, soff, l) -> let name = "MutableArray.copyTo!" @@ -2482,7 +2482,7 @@ declareForeigns = do (fromIntegral soff) (fromIntegral l) - declareForeign Tracked "MutableByteArray.copyTo!" boxNatBoxNatNatToExnUnit + declareForeign Untracked "MutableByteArray.copyTo!" boxNatBoxNatNatToExnUnit . mkForeign $ \(dst, doff, src, soff, l) -> let name = "MutableByteArray.copyTo!" @@ -2499,7 +2499,7 @@ declareForeigns = do (fromIntegral soff) (fromIntegral l) - declareForeign Tracked "ImmutableArray.copyTo!" boxNatBoxNatNatToExnUnit + declareForeign Untracked "ImmutableArray.copyTo!" boxNatBoxNatNatToExnUnit . mkForeign $ \(dst, doff, src, soff, l) -> let name = "ImmutableArray.copyTo!" @@ -2525,7 +2525,7 @@ declareForeigns = do declareForeign Untracked "MutableByteArray.size" boxToNat . mkForeign $ pure . fromIntegral @Int @Word64 . PA.sizeofMutableByteArray @PA.RealWorld - declareForeign Tracked "ImmutableByteArray.copyTo!" boxNatBoxNatNatToExnUnit + declareForeign Untracked "ImmutableByteArray.copyTo!" boxNatBoxNatNatToExnUnit . mkForeign $ \(dst, doff, src, soff, l) -> let name = "ImmutableByteArray.copyTo!" @@ -2542,41 +2542,41 @@ declareForeigns = do (fromIntegral soff) (fromIntegral l) - declareForeign Tracked "MutableArray.read" boxNatToExnBox + declareForeign Untracked "MutableArray.read" boxNatToExnBox . mkForeign $ checkedRead "MutableArray.read" - declareForeign Tracked "MutableByteArray.read8" boxNatToExnNat + declareForeign Untracked "MutableByteArray.read8" boxNatToExnNat . mkForeign $ checkedRead8 "MutableByteArray.read8" - declareForeign Tracked "MutableByteArray.read16be" boxNatToExnNat + declareForeign Untracked "MutableByteArray.read16be" boxNatToExnNat . mkForeign $ checkedRead16 "MutableByteArray.read16be" - declareForeign Tracked "MutableByteArray.read24be" boxNatToExnNat + declareForeign Untracked "MutableByteArray.read24be" boxNatToExnNat . mkForeign $ checkedRead24 "MutableByteArray.read24be" - declareForeign Tracked "MutableByteArray.read32be" boxNatToExnNat + declareForeign Untracked "MutableByteArray.read32be" boxNatToExnNat . mkForeign $ checkedRead32 "MutableByteArray.read32be" - declareForeign Tracked "MutableByteArray.read40be" boxNatToExnNat + declareForeign Untracked "MutableByteArray.read40be" boxNatToExnNat . mkForeign $ checkedRead40 "MutableByteArray.read40be" - declareForeign Tracked "MutableByteArray.read64be" boxNatToExnNat + declareForeign Untracked "MutableByteArray.read64be" boxNatToExnNat . mkForeign $ checkedRead64 "MutableByteArray.read64be" - declareForeign Tracked "MutableArray.write" boxNatBoxToExnUnit + declareForeign Untracked "MutableArray.write" boxNatBoxToExnUnit . mkForeign $ checkedWrite "MutableArray.write" - declareForeign Tracked "MutableByteArray.write8" boxNatNatToExnUnit + declareForeign Untracked "MutableByteArray.write8" boxNatNatToExnUnit . mkForeign $ checkedWrite8 "MutableByteArray.write8" - declareForeign Tracked "MutableByteArray.write16be" boxNatNatToExnUnit + declareForeign Untracked "MutableByteArray.write16be" boxNatNatToExnUnit . mkForeign $ checkedWrite16 "MutableByteArray.write16be" - declareForeign Tracked "MutableByteArray.write32be" boxNatNatToExnUnit + declareForeign Untracked "MutableByteArray.write32be" boxNatNatToExnUnit . mkForeign $ checkedWrite32 "MutableByteArray.write32be" - declareForeign Tracked "MutableByteArray.write64be" boxNatNatToExnUnit + declareForeign Untracked "MutableByteArray.write64be" boxNatNatToExnUnit . mkForeign $ checkedWrite64 "MutableByteArray.write64be" @@ -2602,12 +2602,12 @@ declareForeigns = do . mkForeign $ checkedIndex64 "ImmutableByteArray.read64be" - declareForeign Tracked "MutableByteArray.freeze!" boxDirect . mkForeign $ + declareForeign Untracked "MutableByteArray.freeze!" boxDirect . mkForeign $ PA.unsafeFreezeByteArray - declareForeign Tracked "MutableArray.freeze!" boxDirect . mkForeign $ + declareForeign Untracked "MutableArray.freeze!" boxDirect . mkForeign $ PA.unsafeFreezeArray @IO @Closure - declareForeign Tracked "MutableByteArray.freeze" boxNatNatToExnBox . mkForeign $ + declareForeign Untracked "MutableByteArray.freeze" boxNatNatToExnBox . mkForeign $ \(src, off, len) -> if len == 0 then fmap Right . PA.unsafeFreezeByteArray =<< PA.newByteArray 0 @@ -2619,7 +2619,7 @@ declareForeigns = do 0 $ Right <$> PA.freezeByteArray src (fromIntegral off) (fromIntegral len) - declareForeign Tracked "MutableArray.freeze" boxNatNatToExnBox . mkForeign $ + declareForeign Untracked "MutableArray.freeze" boxNatNatToExnBox . mkForeign $ \(src, off, len) -> if len == 0 then fmap Right . PA.unsafeFreezeArray =<< PA.newArray 0 Closure.BlackHole @@ -2648,12 +2648,12 @@ declareForeigns = do PA.fillByteArray arr 0 sz init pure arr - declareForeign Tracked "Scope.array" natToBox . mkForeign $ + declareForeign Untracked "Scope.array" natToBox . mkForeign $ \n -> PA.newArray n Closure.BlackHole - declareForeign Tracked "Scope.arrayOf" boxNatToBox . mkForeign $ + declareForeign Untracked "Scope.arrayOf" boxNatToBox . mkForeign $ \(v :: Closure, n) -> PA.newArray n v - declareForeign Tracked "Scope.bytearray" natToBox . mkForeign $ PA.newByteArray - declareForeign Tracked "Scope.bytearrayOf" natNatToBox + declareForeign Untracked "Scope.bytearray" natToBox . mkForeign $ PA.newByteArray + declareForeign Untracked "Scope.bytearrayOf" natNatToBox . mkForeign $ \(sz, init) -> do arr <- PA.newByteArray sz diff --git a/parser-typechecker/src/Unison/Runtime/Machine.hs b/parser-typechecker/src/Unison/Runtime/Machine.hs index c21b714d55..99873ce5bb 100644 --- a/parser-typechecker/src/Unison/Runtime/Machine.hs +++ b/parser-typechecker/src/Unison/Runtime/Machine.hs @@ -333,14 +333,12 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LOAD i) poke ustk 1 poke bstk x pure (denv, ustk, bstk, k) -exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 VALU i) - | sandboxed env = die "attempted to use sandboxed operation: value" - | otherwise = do - m <- readTVarIO (tagRefs env) - c <- peekOff bstk i - bstk <- bump bstk - pokeBi bstk =<< reflectValue m c - pure (denv, ustk, bstk, k) +exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 VALU i) = do + m <- readTVarIO (tagRefs env) + c <- peekOff bstk i + bstk <- bump bstk + pokeBi bstk =<< reflectValue m c + pure (denv, ustk, bstk, k) exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim1 op i) = do (ustk, bstk) <- bprim1 ustk bstk op i pure (denv, ustk, bstk, k) diff --git a/parser-typechecker/tests/Unison/Test/MCode.hs b/parser-typechecker/tests/Unison/Test/MCode.hs index 89e453ffc8..8c62668c00 100644 --- a/parser-typechecker/tests/Unison/Test/MCode.hs +++ b/parser-typechecker/tests/Unison/Test/MCode.hs @@ -44,7 +44,7 @@ modifyTVarTest v f = io . atomically $ modifyTVar v f testEval0 :: EnumMap Word64 Combs -> Section -> Test () testEval0 env sect = do - cc <- io baseCCache + cc <- io (baseCCache False) modifyTVarTest (combs cc) (env <>) modifyTVarTest (combRefs cc) ((dummyRef <$ env) <>) io $ eval0 cc Nothing sect diff --git a/parser-typechecker/tests/Unison/Test/UnisonSources.hs b/parser-typechecker/tests/Unison/Test/UnisonSources.hs index 1e4d130e14..6e37705b6a 100644 --- a/parser-typechecker/tests/Unison/Test/UnisonSources.hs +++ b/parser-typechecker/tests/Unison/Test/UnisonSources.hs @@ -59,7 +59,7 @@ bad r = EasyTest.expectLeft r >> done test :: Test () test = do - rt <- io (RTI.startRuntime RTI.OneOff "") + rt <- io (RTI.startRuntime False RTI.OneOff "") scope "unison-src" . tests $ [ go rt shouldPassNow good, diff --git a/unison-src/transcripts-using-base/codeops.md b/unison-src/transcripts-using-base/codeops.md index a7e7d524f8..2aa7584077 100644 --- a/unison-src/transcripts-using-base/codeops.md +++ b/unison-src/transcripts-using-base/codeops.md @@ -191,7 +191,6 @@ to actual show that the serialization works. ```ucm .> add -.> display fDeps .> io.test tests .> io.test badLoad ``` diff --git a/unison-src/transcripts-using-base/codeops.output.md b/unison-src/transcripts-using-base/codeops.output.md index 8f96a96682..f529d3ee74 100644 --- a/unison-src/transcripts-using-base/codeops.output.md +++ b/unison-src/transcripts-using-base/codeops.output.md @@ -284,10 +284,6 @@ to actual show that the serialization works. tests : '{IO} [Result] zapper : Three Nat Nat Nat -> Request {Zap} r -> r -.> display fDeps - - [termLink f] - .> io.test tests New test results: diff --git a/unison-src/transcripts-using-base/tls.md b/unison-src/transcripts-using-base/tls.md index 2258bcf46e..2acc73ae4a 100644 --- a/unison-src/transcripts-using-base/tls.md +++ b/unison-src/transcripts-using-base/tls.md @@ -28,14 +28,20 @@ not_a_cert = "-----BEGIN SCHERMIFICATE-----\n-----END SCHERMIFICATE-----" First lets make sure we can load our cert and private key ```unison -test> this_should_work=match (decodeCert.impl (toUtf8 self_signed_cert_pem2) with +this_should_work=match (decodeCert.impl (toUtf8 self_signed_cert_pem2) with Left (Failure _ t _) -> [Fail t] Right _ -> [Ok "succesfully decoded self_signed_pem"] -test> this_should_not_work=match (decodeCert.impl (toUtf8 not_a_cert) with +this_should_not_work=match (decodeCert.impl (toUtf8 not_a_cert) with Left _ -> [Ok "failed"] Right _ -> [Fail "um, that was a schmificate"] +what_should_work _ = this_should_work ++ this_should_not_work +``` + +```ucm +.> add +.> io.test what_should_work ``` Test handshaking a client/server a local TCP connection using our diff --git a/unison-src/transcripts-using-base/tls.output.md b/unison-src/transcripts-using-base/tls.output.md index 7a6a2337de..dc298fbe55 100644 --- a/unison-src/transcripts-using-base/tls.output.md +++ b/unison-src/transcripts-using-base/tls.output.md @@ -16,14 +16,15 @@ not_a_cert = "-----BEGIN SCHERMIFICATE-----\n-----END SCHERMIFICATE-----" First lets make sure we can load our cert and private key ```unison -test> this_should_work=match (decodeCert.impl (toUtf8 self_signed_cert_pem2) with +this_should_work=match (decodeCert.impl (toUtf8 self_signed_cert_pem2) with Left (Failure _ t _) -> [Fail t] Right _ -> [Ok "succesfully decoded self_signed_pem"] -test> this_should_not_work=match (decodeCert.impl (toUtf8 not_a_cert) with +this_should_not_work=match (decodeCert.impl (toUtf8 not_a_cert) with Left _ -> [Ok "failed"] Right _ -> [Fail "um, that was a schmificate"] +what_should_work _ = this_should_work ++ this_should_not_work ``` ```ucm @@ -36,17 +37,28 @@ test> this_should_not_work=match (decodeCert.impl (toUtf8 not_a_cert) with this_should_not_work : [Result] this_should_work : [Result] + what_should_work : โˆ€ _. _ -> [Result] + +``` +```ucm +.> add + + โŸ I've added these definitions: - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. + this_should_not_work : [Result] + this_should_work : [Result] + what_should_work : โˆ€ _. _ -> [Result] - 1 | test> this_should_work=match (decodeCert.impl (toUtf8 self_signed_cert_pem2) with - - โœ… Passed succesfully decoded self_signed_pem +.> io.test what_should_work + + New test results: - 5 | test> this_should_not_work=match (decodeCert.impl (toUtf8 not_a_cert) with - - โœ… Passed failed + โ—‰ what_should_work succesfully decoded self_signed_pem + โ—‰ what_should_work failed + + โœ… 2 test(s) passing + + Tip: Use view what_should_work to view the source of a test. ``` Test handshaking a client/server a local TCP connection using our From 0ac436f671f66591285d32b452c2a5aead2ee690 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 12 Jul 2022 12:24:15 -0400 Subject: [PATCH 502/529] update the examples for push and pulls to show new share / git() syntax --- .../src/Unison/Codebase/Editor/HandleInput.hs | 23 ++++---- .../src/Unison/Codebase/Editor/Output.hs | 10 +--- .../Unison/Codebase/Editor/Output/PushPull.hs | 8 +++ .../src/Unison/CommandLine/InputPatterns.hs | 57 +++++++++++-------- .../src/Unison/CommandLine/OutputMessages.hs | 17 +++--- unison-cli/unison-cli.cabal | 1 + 6 files changed, 64 insertions(+), 52 deletions(-) create mode 100644 unison-cli/src/Unison/Codebase/Editor/Output/PushPull.hs diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 02d2218357..57d9651651 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -60,6 +60,7 @@ import Unison.Codebase.Editor.Output import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN +import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push)) import qualified Unison.Codebase.Editor.Propagate as Propagate import Unison.Codebase.Editor.RemoteRepo ( ReadGitRemoteNamespace (..), @@ -721,8 +722,8 @@ loop = do case getAtSplit' dest of Just existingDest | not (Branch.isEmpty0 (Branch.head existingDest)) -> do - -- Branch exists and isn't empty, print an error - throwError (BranchAlreadyExists (Path.unsplit' dest)) + -- Branch exists and isn't empty, print an error + throwError (BranchAlreadyExists (Path.unsplit' dest)) _ -> pure () -- allow rewriting history to ensure we move the branch's history too. lift $ @@ -1410,11 +1411,11 @@ loop = do case filtered of [(Referent.Ref ref, ty)] | Typechecker.isSubtype ty mainType -> - eval (MakeStandalone ppe ref output) >>= \case - Just err -> respond $ EvaluationFailure err - Nothing -> pure () + eval (MakeStandalone ppe ref output) >>= \case + Just err -> respond $ EvaluationFailure err + Nothing -> pure () | otherwise -> - respond $ BadMainFunction smain ty ppe [mainType] + respond $ BadMainFunction smain ty ppe [mainType] _ -> respond $ NoMainFunction smain ppe [mainType] IOTestI main -> do -- todo - allow this to run tests from scratch file, using addRunMain @@ -2652,10 +2653,10 @@ searchBranchScored names0 score queries = pair qn HQ.HashQualified qn h | h `SH.isPrefixOf` Referent.toShortHash ref -> - pair qn + pair qn HQ.HashOnly h | h `SH.isPrefixOf` Referent.toShortHash ref -> - Set.singleton (Nothing, result) + Set.singleton (Nothing, result) _ -> mempty where result = SR.termSearchResult names0 name ref @@ -2672,10 +2673,10 @@ searchBranchScored names0 score queries = pair qn HQ.HashQualified qn h | h `SH.isPrefixOf` Reference.toShortHash ref -> - pair qn + pair qn HQ.HashOnly h | h `SH.isPrefixOf` Reference.toShortHash ref -> - Set.singleton (Nothing, result) + Set.singleton (Nothing, result) _ -> mempty where result = SR.typeSearchResult names0 name ref @@ -3068,7 +3069,7 @@ docsI srcLoc prettyPrintNames src = do | Set.size s == 1 -> displayI prettyPrintNames ConsoleLocation dotDoc | Set.size s == 0 -> respond $ ListOfLinks mempty [] | otherwise -> -- todo: return a list of links here too - respond $ ListOfLinks mempty [] + respond $ ListOfLinks mempty [] filterBySlurpResult :: Ord v => diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index edaebc887d..10d4d6f893 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -8,10 +8,8 @@ module Unison.Codebase.Editor.Output HistoryTail (..), TestReportStats (..), UndoFailureReason (..), - PushPull (..), ReflogEntry (..), ShareError (..), - pushPull, isFailure, isNumberedFailure, ) @@ -26,6 +24,7 @@ import qualified Unison.Codebase.Branch as Branch import Unison.Codebase.Editor.DisplayObject (DisplayObject) import Unison.Codebase.Editor.Input import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) +import Unison.Codebase.Editor.Output.PushPull (PushPull) import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.SlurpResult (SlurpResult (..)) import qualified Unison.Codebase.Editor.SlurpResult as SR @@ -76,13 +75,6 @@ type NumberedArgs = [String] type HashLength = Int -data PushPull = Push | Pull deriving (Eq, Ord, Show) - -pushPull :: a -> a -> PushPull -> a -pushPull push pull p = case p of - Push -> push - Pull -> pull - data NumberedOutput v = ShowDiffNamespace AbsBranchId AbsBranchId PPE.PrettyPrintEnv (BranchDiffOutput v Ann) | ShowDiffAfterUndo PPE.PrettyPrintEnv (BranchDiffOutput v Ann) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output/PushPull.hs b/unison-cli/src/Unison/Codebase/Editor/Output/PushPull.hs new file mode 100644 index 0000000000..1b753f0591 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/Output/PushPull.hs @@ -0,0 +1,8 @@ +module Unison.Codebase.Editor.Output.PushPull where + +data PushPull = Push | Pull deriving (Eq, Ord, Show) + +fold :: a -> a -> PushPull -> a +fold push pull p = case p of + Push -> push + Pull -> pull diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index d4d53c4a62..97843ffa83 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -22,6 +22,8 @@ import qualified Unison.Codebase.Branch.Merge as Branch import qualified Unison.Codebase.Branch.Names as Branch import Unison.Codebase.Editor.Input (Input) import qualified Unison.Codebase.Editor.Input as Input +import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push)) +import qualified Unison.Codebase.Editor.Output.PushPull as PushPull import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemotePath) import qualified Unison.Codebase.Editor.SlurpResult as SR import qualified Unison.Codebase.Editor.UriParser as UriParser @@ -1021,7 +1023,7 @@ pullImpl name verbosity pullMode addendum = do ) ], "", - explainRemote + explainRemote Pull ] ) ( \case @@ -1042,7 +1044,7 @@ pullExhaustive = InputPattern "debug.pull-exhaustive" [] - I.Visible + I.Hidden [(Required, remoteNamespaceArg), (Optional, namespaceArg)] ( P.lines [ P.wrap $ @@ -1091,7 +1093,7 @@ push = ) ], "", - explainRemote + explainRemote Push ] ) ( \case @@ -1132,7 +1134,7 @@ pushCreate = ) ], "", - explainRemote + explainRemote Push ] ) ( \case @@ -1152,7 +1154,7 @@ pushExhaustive = InputPattern "debug.push-exhaustive" [] - I.Visible + I.Hidden [(Required, remoteNamespaceArg), (Optional, namespaceArg)] ( P.lines [ P.wrap $ @@ -1192,8 +1194,8 @@ createPullRequest = "example: " <> makeExampleNoBackticks createPullRequest - [ "https://github.com/unisonweb/base:.trunk", - "https://github.com/me/unison:.prs.base._myFeature" + [ "unison.base.main", + "myself.prs.base._myFeature" ] ] ) @@ -2022,15 +2024,19 @@ gist = [ "Publish the current namespace.", "", P.wrapColumn2 - [ ( "`gist remote`", - "publishes the contents of the current namespace into the repo `remote`." + [ ( "`gist git(git@github.com:user/repo)`", + "publishes the contents of the current namespace into the specified git repo." ) - ] + ], + "", + P.indentN 2 . P.wrap $ + "Note: Gists are not yet supported on Unison Share, though you can just do a normal" + <> "`push.create` of the current namespace to your Unison Share codebase wherever you like!" ] ) ( \case [repoString] -> do - repo <- parseWriteGitRepo "repo" repoString + repo <- parseWriteGitRepo "gist git repo" repoString pure (Input.GistI (Input.GistInput repo)) _ -> Left (showPatternHelp gist) ) @@ -2335,7 +2341,7 @@ noCompletions = globTargets = mempty } --- Arya: I could imagine completions coming from previous git pulls +-- Arya: I could imagine completions coming from previous pulls gitUrlArg :: ArgumentType gitUrlArg = ArgumentType @@ -2374,18 +2380,21 @@ remoteNamespaceArg = collectNothings :: (a -> Maybe b) -> [a] -> [a] collectNothings f as = [a | (Nothing, a) <- map f as `zip` as] -explainRemote :: P.Pretty CT.ColorText -explainRemote = - P.lines - [ P.wrap "where `remote` is a git repository, optionally followed by `:`" - <> "and an absolute remote path, a branch, or both, such as:", - P.indentN 2 . P.lines $ - [ P.backticked "https://github.com/org/repo", - P.backticked "https://github.com/org/repo:.some.remote.path", - P.backticked "https://github.com/org/repo:some-branch:.some.remote.path", - P.backticked "https://github.com/org/repo:some-branch" - ] - ] +explainRemote :: PushPull -> P.Pretty CT.ColorText +explainRemote pushPull = + P.group $ + P.lines + [ P.wrap $ "where `remote` is a hosted codebase, such as:", + P.indentN 2 . P.column2 $ + [ ("Unison Share", P.backticked "user.public.some.remote.path"), + ("Git + root", P.backticked $ "git(" <> gitRepo <> "user/repo)"), + ("Git + path", P.backticked $ "git(" <> gitRepo <> "user/repo).some.remote.path"), + ("Git + branch", P.backticked $ "git(" <> gitRepo <> "user/repo:some-branch)"), + ("Git + branch + path", P.backticked $ "git(" <> gitRepo <> "user/repo:some-branch).some.remote.path") + ] + ] + where + gitRepo = PushPull.fold @(P.Pretty P.ColorText) "git@github.com:" "https://github.com/" pushPull showErrorFancy :: P.ShowErrorComponent e => P.ErrorFancy e -> String showErrorFancy (P.ErrorFail msg) = msg diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 9187a225c1..b2a39ebdd5 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -47,6 +47,7 @@ import Unison.Codebase.Editor.Output import qualified Unison.Codebase.Editor.Output as E import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBD +import qualified Unison.Codebase.Editor.Output.PushPull as PushPull import Unison.Codebase.Editor.RemoteRepo ( ReadGitRepo, ReadRemoteNamespace, @@ -1235,7 +1236,7 @@ notifyUser dir o = case o of NoConfiguredRemoteMapping pp p -> pure . P.fatalCallout . P.wrap $ "I don't know where to " - <> pushPull "push to!" "pull from!" pp + <> PushPull.fold "push to!" "pull from!" pp <> ( if Path.isRoot p then "" else @@ -1243,7 +1244,7 @@ notifyUser dir o = case o of <> " = namespace.path' to .unisonConfig. " ) <> "Type `help " - <> pushPull "push" "pull" pp + <> PushPull.fold "push" "pull" pp <> "` for more information." -- | ConfiguredGitUrlParseError PushPull Path' Text String ConfiguredRemoteMappingParseError pp p url err -> @@ -1259,7 +1260,7 @@ notifyUser dir o = case o of P.string err, "", P.wrap $ - "Type" <> P.backticked ("help " <> pushPull "push" "pull" pp) + "Type" <> P.backticked ("help " <> PushPull.fold "push" "pull" pp) <> "for more information." ] NoBranchWithHash _h -> @@ -1675,11 +1676,11 @@ notifyUser dir o = case o of where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" expectedEmptyPushDest writeRemotePath = - P.lines - [ "The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is not empty.", - "", - "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" - ] + P.lines + [ "The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is not empty.", + "", + "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" + ] expectedNonEmptyPushDest writeRemotePath = P.lines [ P.wrap ("The remote namespace " <> prettyWriteRemotePath writeRemotePath <> " is empty."), diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 0de7f7d521..f087313f75 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -42,6 +42,7 @@ library Unison.Codebase.Editor.Output Unison.Codebase.Editor.Output.BranchDiff Unison.Codebase.Editor.Output.DumpNamespace + Unison.Codebase.Editor.Output.PushPull Unison.Codebase.Editor.Propagate Unison.Codebase.Editor.Slurp Unison.Codebase.Editor.SlurpComponent From 5d4fe82a3c23ee68ebcfda24fe6151a3c127b159 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 12 Jul 2022 15:27:26 -0400 Subject: [PATCH 503/529] finish implementing force push --- .../src/Unison/Codebase/SqliteCodebase.hs | 57 +++++++------- .../src/Unison/Codebase/Type.hs | 9 +-- .../src/Unison/Codebase/Editor/HandleInput.hs | 75 ++++++++++++------- .../src/Unison/CommandLine/InputPatterns.hs | 35 +++++++++ .../src/Unison/CommandLine/OutputMessages.hs | 1 + 5 files changed, 110 insertions(+), 67 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 2a78587984..8899d72066 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -761,7 +761,7 @@ pushGitBranch :: -- An action which accepts the current root branch on the remote and computes a new branch. (Branch m -> m (Either e (Branch m))) -> m (Either C.GitError (Either e (Branch m))) -pushGitBranch srcConn repo (PushGitBranchOpts forcePush setRoot _syncMode) action = UnliftIO.try do +pushGitBranch srcConn repo (PushGitBranchOpts behavior _syncMode) action = UnliftIO.try do -- Pull the latest remote into our git cache -- Use a local git clone to copy this git repo into a temp-dir -- Delete the codebase in our temp-dir @@ -801,35 +801,32 @@ pushGitBranch srcConn repo (PushGitBranchOpts forcePush setRoot _syncMode) actio Sqlite.runReadOnlyTransaction srcConn \runSrc -> do Sqlite.runWriteTransaction destConn \runDest -> do _ <- syncInternal (syncProgress progressStateRef) runSrc runDest newBranch - when setRoot (overwriteRoot runDest codebaseStatus remotePath newBranch) - overwriteRoot :: - (forall a. Sqlite.Transaction a -> m a) -> - CodebaseStatus -> - FilePath -> - Branch m -> - m () - overwriteRoot run codebaseStatus remotePath newBranch = do - let newBranchHash = Branch.headHash newBranch - case codebaseStatus of - ExistingCodebase -> do - when (not forcePush) do - -- the call to runDB "handles" the possible DB error by bombing - run Ops.loadRootCausalHash >>= \case - Nothing -> pure () - Just oldRootHash -> do - run (CodebaseOps.before (Cv.causalHash2to1 oldRootHash) newBranchHash) >>= \case - Nothing -> - error $ - "I couldn't find the hash " ++ show newBranchHash - ++ " that I just synced to the cached copy of " - ++ repoString - ++ " in " - ++ show remotePath - ++ "." - Just False -> throwIO . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo - Just True -> pure () - CreatedCodebase -> pure () - run (setRepoRoot newBranchHash) + let overwriteRoot forcePush = do + let newBranchHash = Branch.headHash newBranch + case codebaseStatus of + ExistingCodebase -> do + when (not forcePush) do + -- the call to runDB "handles" the possible DB error by bombing + runDest Ops.loadRootCausalHash >>= \case + Nothing -> pure () + Just oldRootHash -> do + runDest (CodebaseOps.before (Cv.causalHash2to1 oldRootHash) newBranchHash) >>= \case + Nothing -> + error $ + "I couldn't find the hash " ++ show newBranchHash + ++ " that I just synced to the cached copy of " + ++ repoString + ++ " in " + ++ show remotePath + ++ "." + Just False -> throwIO . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo + Just True -> pure () + CreatedCodebase -> pure () + runDest (setRepoRoot newBranchHash) + case behavior of + C.GitPushBehaviorGist -> pure () + C.GitPushBehaviorFf -> overwriteRoot False + C.GitPushBehaviorForce -> overwriteRoot True repoString = Text.unpack $ printWriteGitRepo repo setRepoRoot :: Branch.CausalHash -> Sqlite.Transaction () setRepoRoot h = do diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index f52b966df6..d15d84786b 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -190,10 +190,7 @@ data LocalOrRemote deriving (Show, Eq, Ord) data PushGitBranchOpts = PushGitBranchOpts - { -- | Should we perform a local `before` check, or just force-push? - forcePush :: Bool, - -- | Set the branch as root? - setRoot :: Bool, + { behavior :: GitPushBehavior, syncMode :: SyncMode } @@ -205,10 +202,6 @@ data GitPushBehavior | -- | After syncing entities, just set the root (force-pushy). GitPushBehaviorForce --- valid: dont set root, --- set root, fast-forward --- set root, force push - data GitError = GitProtocolError GitProtocolError | GitCodebaseError (GitCodebaseError Branch.CausalHash) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 26e7616427..5638052f4c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -30,8 +30,10 @@ import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) import qualified System.Console.Regions as Console.Regions import qualified Text.Megaparsec as P -import U.Codebase.HashTags (CausalHash) +import U.Codebase.HashTags (CausalHash (unCausalHash)) import qualified U.Codebase.Sqlite.Operations as Ops +import U.Util.Hash32 (Hash32) +import qualified U.Util.Hash32 as Hash32 import U.Util.Timing (time, unsafeTime) import qualified Unison.ABT as ABT import qualified Unison.Builtin as Builtin @@ -99,7 +101,7 @@ import qualified Unison.Codebase.SyncMode as SyncMode import Unison.Codebase.TermEdit (TermEdit (..)) import qualified Unison.Codebase.TermEdit as TermEdit import qualified Unison.Codebase.TermEdit.Typing as TermEdit -import Unison.Codebase.Type (GitError) +import Unison.Codebase.Type (GitError, GitPushBehavior (..)) import qualified Unison.Codebase.TypeEdit as TypeEdit import qualified Unison.Codebase.Verbosity as Verbosity import qualified Unison.CommandLine.DisplayValues as DisplayValues @@ -146,11 +148,11 @@ import qualified Unison.Server.SearchResult as SR import qualified Unison.Server.SearchResult' as SR' import qualified Unison.Share.Codeserver as Codeserver import qualified Unison.Share.Sync as Share -import qualified Unison.Share.Sync.Types as Sync +import qualified Unison.Share.Sync.Types as Share import Unison.Share.Types (codeserverBaseURL) import qualified Unison.ShortHash as SH import Unison.Symbol (Symbol) -import qualified Unison.Sync.Types as Share (Path (..)) +import qualified Unison.Sync.Types as Share (Path (..), hashJWTHash) import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) @@ -1813,23 +1815,25 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do Just newRemoteRoot -> pure (Right newRemoteRoot) let opts = PushGitBranchOpts - { forcePush = + { behavior = case pushBehavior of - PushBehavior.ForcePush -> True - PushBehavior.RequireEmpty -> False - PushBehavior.RequireNonEmpty -> False, - setRoot = True, + PushBehavior.ForcePush -> GitPushBehaviorForce + PushBehavior.RequireEmpty -> GitPushBehaviorFf + PushBehavior.RequireNonEmpty -> GitPushBehaviorFf, syncMode } runExceptT (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case Left gitErr -> respond (Output.GitError gitErr) Right (Left errOutput) -> respond errOutput Right (Right _branch) -> respond Success - NormalPush (WriteRemotePathShare sharePath) pushBehavior -> - handlePushToUnisonShare sharePath localPath pushBehavior + NormalPush (WriteRemotePathShare sharePath) pushBehavior -> handlePushToUnisonShare sharePath localPath pushBehavior GistyPush repo -> do sourceBranch <- getAt localPath - let opts = PushGitBranchOpts {forcePush = False, setRoot = False, syncMode} + let opts = + PushGitBranchOpts + { behavior = GitPushBehaviorGist, + syncMode + } runExceptT (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))) >>= \case Left gitErr -> respond (Output.GitError gitErr) Right (Left errOutput) -> respond errOutput @@ -1857,7 +1861,7 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch) PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) -handlePushToUnisonShare :: (MonadUnliftIO m) => WriteShareRemotePath -> Path.Absolute -> PushBehavior -> Action' m v () +handlePushToUnisonShare :: MonadUnliftIO m => WriteShareRemotePath -> Path.Absolute -> PushBehavior -> Action' m v () handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} localPath behavior = do let codeserver = Codeserver.resolveCodeserver server let baseURL = codeserverBaseURL codeserver @@ -1869,26 +1873,40 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l -- doesn't handle the case where a non-existent path is supplied eval (Eval (Codebase.runTransaction codebase (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath))))) >>= \case Nothing -> respond (BranchNotFound . Path.absoluteToPath' $ localPath) - Just localCausalHash -> - case behavior of - PushBehavior.RequireEmpty -> do - let push :: IO (Either (Sync.SyncError Share.CheckAndSetPushError) ()) - push = - withEntitiesUploadedProgressCallbacks \callbacks -> + Just localCausalHash -> do + let checkAndSetPush :: Maybe Hash32 -> IO (Either (Share.SyncError Share.CheckAndSetPushError) ()) + checkAndSetPush remoteHash = + withEntitiesUploadedProgressCallbacks \callbacks -> + if Just (Hash32.fromHash (unCausalHash localCausalHash)) == remoteHash + then pure (Right ()) + else Share.checkAndSetPush authHTTPClient baseURL (Codebase.withConnectionIO codebase) sharePath - Nothing + remoteHash localCausalHash callbacks - liftIO push >>= \case - Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorCheckAndSetPush err)) - Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err)) + let respondPushError :: (a -> Output.ShareError) -> Share.SyncError a -> Action' m v () + respondPushError f = + respond . \case + Share.SyncError err -> Output.ShareError (f err) + Share.TransportError err -> Output.ShareError (ShareErrorTransport err) + case behavior of + PushBehavior.ForcePush -> + liftIO (Share.getCausalHashByPath authHTTPClient baseURL sharePath) >>= \case + Left err -> respond (Output.ShareError (ShareErrorGetCausalHashByPath err)) + Right maybeHashJwt -> + liftIO (checkAndSetPush (Share.hashJWTHash <$> maybeHashJwt)) >>= \case + Left err -> respondPushError ShareErrorCheckAndSetPush err + Right () -> pure () + PushBehavior.RequireEmpty -> do + liftIO (checkAndSetPush Nothing) >>= \case + Left err -> respondPushError ShareErrorCheckAndSetPush err Right () -> pure () PushBehavior.RequireNonEmpty -> do - let push :: IO (Either (Sync.SyncError Share.FastForwardPushError) ()) + let push :: IO (Either (Share.SyncError Share.FastForwardPushError) ()) push = do withEntitiesUploadedProgressCallbacks \callbacks -> Share.fastForwardPush @@ -1899,8 +1917,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l localCausalHash callbacks liftIO push >>= \case - Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorFastForwardPush err)) - Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err)) + Left err -> respondPushError ShareErrorFastForwardPush err Right () -> pure () where pathToSegments :: Path -> [Text] @@ -2320,7 +2337,7 @@ importRemoteShareBranch rrn@(ReadShareRemoteNamespace {server, repo, path}) = do mapLeft Output.ShareError <$> do let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) LoopState.Env {authHTTPClient, codebase} <- ask - let pull :: IO (Either (Sync.SyncError Share.PullError) CausalHash) + let pull :: IO (Either (Share.SyncError Share.PullError) CausalHash) pull = withEntitiesDownloadedProgressCallbacks \callbacks -> Share.pull @@ -2330,8 +2347,8 @@ importRemoteShareBranch rrn@(ReadShareRemoteNamespace {server, repo, path}) = do shareFlavoredPath callbacks liftIO pull >>= \case - Left (Sync.SyncError err) -> pure (Left (Output.ShareErrorPull err)) - Left (Sync.TransportError err) -> pure (Left (Output.ShareErrorTransport err)) + Left (Share.SyncError err) -> pure (Left (Output.ShareErrorPull err)) + Left (Share.TransportError err) -> pure (Left (Output.ShareErrorTransport err)) Right causalHash -> do (eval . Eval) (Codebase.getBranchForHash codebase (Cv.causalHash2to1 causalHash)) >>= \case Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 25ba78224a..9f70199ff7 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1175,6 +1175,40 @@ pushCreate = } ) +pushForce :: InputPattern +pushForce = + InputPattern + "push.force" + [] + I.Visible + [(Required, remoteNamespaceArg), (Optional, namespaceArg)] + (P.wrap "Like `push`, but overwrites any remote namespace.") + ( \case + [] -> + Right $ + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { localPath = Path.relativeEmpty', + maybeRemoteRepo = Nothing, + pushBehavior = PushBehavior.ForcePush, + syncMode = SyncMode.ShortCircuit + } + url : rest -> do + pushPath <- parseWriteRemotePath "remote-path" url + p <- case rest of + [] -> Right Path.relativeEmpty' + [path] -> first fromString $ Path.parsePath' path + _ -> Left (I.help push) + Right $ + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { localPath = p, + maybeRemoteRepo = Just pushPath, + pushBehavior = PushBehavior.ForcePush, + syncMode = SyncMode.ShortCircuit + } + ) + pushExhaustive :: InputPattern pushExhaustive = InputPattern @@ -2131,6 +2165,7 @@ validInputs = names False, -- names push, pushCreate, + pushForce, pull, pullWithoutHistory, pullSilent, diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 9187a225c1..607f81a82d 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1531,6 +1531,7 @@ notifyUser dir o = case o of ) RefusedToPush pushBehavior path -> (pure . P.warnCallout) case pushBehavior of + PushBehavior.ForcePush -> error "impossible: refused to push due to ForcePush?" PushBehavior.RequireEmpty -> expectedEmptyPushDest path PushBehavior.RequireNonEmpty -> expectedNonEmptyPushDest path GistCreated remoteNamespace -> From 752145c2eb7e7b1e5aab4d77394f82a14e47c1f0 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Tue, 12 Jul 2022 17:16:42 -0400 Subject: [PATCH 504/529] Add transcript for nested lib --- unison-src/transcripts/find-command.md | 5 ++++ unison-src/transcripts/find-command.output.md | 23 ++++++++++++++----- 2 files changed, 22 insertions(+), 6 deletions(-) diff --git a/unison-src/transcripts/find-command.md b/unison-src/transcripts/find-command.md index 61826c8cc2..ac35dec7dc 100644 --- a/unison-src/transcripts/find-command.md +++ b/unison-src/transcripts/find-command.md @@ -2,6 +2,7 @@ foo = 1 lib.foo = 2 lib.bar = 3 +foo.lib.qux = 4 ``` ```ucm @@ -19,3 +20,7 @@ lib.bar = 3 ```ucm:error .> find baz ``` + +```ucm +.> find qux +``` diff --git a/unison-src/transcripts/find-command.output.md b/unison-src/transcripts/find-command.output.md index bf524a96aa..1d8327e1a3 100644 --- a/unison-src/transcripts/find-command.output.md +++ b/unison-src/transcripts/find-command.output.md @@ -2,6 +2,7 @@ foo = 1 lib.foo = 2 lib.bar = 3 +foo.lib.qux = 4 ``` ```ucm @@ -12,9 +13,10 @@ lib.bar = 3 โŸ These new definitions are ok to `add`: - foo : ##Nat - lib.bar : ##Nat - lib.foo : ##Nat + foo : ##Nat + foo.lib.qux : ##Nat + lib.bar : ##Nat + lib.foo : ##Nat ``` ```ucm @@ -22,15 +24,17 @@ lib.bar = 3 โŸ I've added these definitions: - foo : ##Nat - lib.bar : ##Nat - lib.foo : ##Nat + foo : ##Nat + foo.lib.qux : ##Nat + lib.bar : ##Nat + lib.foo : ##Nat ``` ```ucm .> find foo 1. foo : ##Nat + 2. foo.lib.qux : ##Nat ``` @@ -63,3 +67,10 @@ lib.bar = 3 namespace. ``` +```ucm +.> find qux + + 1. foo.lib.qux : ##Nat + + +``` From 57c2f341a8ac32b9d6bb2c33625589592a6e0452 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 12 Jul 2022 15:26:42 -0600 Subject: [PATCH 505/529] Hash filtering fix --- unison-core/src/Unison/Names.hs | 14 +++++++++---- unison-share-api/src/Unison/Server/Backend.hs | 20 ++++++++----------- .../src/Unison/Server/Endpoints/FuzzyFind.hs | 2 +- .../Server/Endpoints/NamespaceDetails.hs | 2 +- 4 files changed, 20 insertions(+), 18 deletions(-) diff --git a/unison-core/src/Unison/Names.hs b/unison-core/src/Unison/Names.hs index e862b5174e..8949011317 100644 --- a/unison-core/src/Unison/Names.hs +++ b/unison-core/src/Unison/Names.hs @@ -40,6 +40,7 @@ module Unison.Names typesNamed, unionLeft, unionLeftName, + unionLeftRef, namesForReference, namesForReferent, shadowTerms, @@ -221,8 +222,13 @@ unionLeftName = unionLeft' $ const . R.memberDom -- e.g. unionLeftRef [foo -> #a, bar -> #a, cat -> #c] -- [foo -> #b, baz -> #c] -- = [foo -> #a, bar -> #a, foo -> #b, cat -> #c] -_unionLeftRef :: Names -> Names -> Names -_unionLeftRef = unionLeft' $ const R.memberRan +unionLeftRef :: Names -> Names -> Names +unionLeftRef (Names priorityTerms priorityTypes) (Names fallbackTerms fallbackTypes) = + Names (restricter priorityTerms fallbackTerms) (restricter priorityTypes fallbackTypes) + where + restricter priorityRel fallbackRel = + let refsExclusiveToFallback = (Relation.ran fallbackRel) `Set.difference` (Relation.ran priorityRel) + in priorityRel <> Relation.restrictRan fallbackRel refsExclusiveToFallback -- unionLeft two Names, but don't create new aliases or new name conflicts. -- e.g. unionLeft [foo -> #a, bar -> #a, cat -> #c] @@ -239,12 +245,12 @@ unionLeft' :: Names -> Names -> Names -unionLeft' p a b = Names terms' types' +unionLeft' shouldOmit a b = Names terms' types' where terms' = foldl' go (terms a) (R.toList $ terms b) types' = foldl' go (types a) (R.toList $ types b) go :: (Ord a, Ord b) => Relation a b -> (a, b) -> Relation a b - go acc (n, r) = if p n r acc then acc else R.insert n r acc + go acc (n, r) = if shouldOmit n r acc then acc else R.insert n r acc -- | TODO: get this from database. For now it's a constant. numHashChars :: Int diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index e1077e0129..e115b0e66d 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -823,17 +823,19 @@ prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase -- We might like to make sure that the user search terms get used as -- the names in the pretty-printer, but the current implementation -- doesn't. - (localNamesOnly, ppe) <- scopedNamesForBranchHash codebase root path + (parseNames, localNamesOnly, ppe) <- scopedNamesForBranchHash codebase root path let nameSearch :: NameSearch nameSearch = makeNameSearch hqLength (NamesWithHistory.fromCurrentNames localNamesOnly) - DefinitionResults terms types misses <- restrictDefinitionsToScope localNamesOnly <$> lift (definitionsBySuffixes codebase nameSearch DontIncludeCycles query) + DefinitionResults terms types misses <- lift (definitionsBySuffixes codebase nameSearch DontIncludeCycles query) let width = mayDefaultWidth renderWidth + namesWithFallback = localNamesOnly `Names.unionLeftRef` parseNames + termFqns :: Map Reference (Set Text) termFqns = Map.mapWithKey f terms where - rel = Names.terms localNamesOnly + rel = Names.terms namesWithFallback f k _ = Set.fromList . fmap Name.toText . toList $ R.lookupRan (Referent.Ref k) rel @@ -841,7 +843,7 @@ prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase typeFqns :: Map Reference (Set Text) typeFqns = Map.mapWithKey f types where - rel = Names.types localNamesOnly + rel = Names.types namesWithFallback f k _ = Set.fromList . fmap Name.toText . toList $ R.lookupRan k rel @@ -935,12 +937,6 @@ prettyDefinitionsBySuffixes path root renderWidth suffixifyBindings rt codebase renderedDisplayTerms renderedDisplayTypes renderedMisses - where - restrictDefinitionsToScope :: Names -> DefinitionResults Symbol -> DefinitionResults Symbol - restrictDefinitionsToScope localNames (DefinitionResults terms types misses) = - let filteredTerms = Map.restrictKeys terms (Names.termReferences localNames) - filteredTypes = Map.restrictKeys types (Names.typeReferences localNames) - in DefinitionResults filteredTerms filteredTypes misses renderDoc :: PPE.PrettyPrintEnvDecl -> @@ -1081,7 +1077,7 @@ bestNameForType ppe width = -- - 'local' includes ONLY the names within the provided path -- - 'ppe' is a ppe which searches for a name within the path first, but falls back to a global name search. -- The 'suffixified' component of this ppe will search for the shortest unambiguous suffix within the scope in which the name is found (local, falling back to global) -scopedNamesForBranchHash :: forall m v a. Monad m => Codebase m v a -> Maybe (Branch.CausalHash) -> Path -> Backend m (Names, PPE.PrettyPrintEnvDecl) +scopedNamesForBranchHash :: forall m v a. Monad m => Codebase m v a -> Maybe (Branch.CausalHash) -> Path -> Backend m (Names, Names, PPE.PrettyPrintEnvDecl) scopedNamesForBranchHash codebase mbh path = do shouldUseNamesIndex <- asks useNamesIndex hashLen <- lift $ Codebase.hashLength codebase @@ -1102,7 +1098,7 @@ scopedNamesForBranchHash codebase mbh path = do let localPPE = PPE.fromNamesDecl hashLen (NamesWithHistory.fromCurrentNames localNames) let globalPPE = PPE.fromNamesDecl hashLen (NamesWithHistory.fromCurrentNames parseNames) - pure (localNames, mkPPE localPPE globalPPE) + pure (parseNames, localNames, mkPPE localPPE globalPPE) where mkPPE :: PPE.PrettyPrintEnvDecl -> PPE.PrettyPrintEnvDecl -> PPE.PrettyPrintEnvDecl mkPPE primary fallback = diff --git a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs index b092bff799..d5809359e0 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/FuzzyFind.hs @@ -141,7 +141,7 @@ serveFuzzyFind codebase mayRoot relativePath limit typeWidth query = maybe mempty Path.fromPath' <$> traverse (parsePath . Text.unpack) relativePath rootHash <- traverse (Backend.expandShortBranchHash codebase) mayRoot - (localNamesOnly, ppe) <- Backend.scopedNamesForBranchHash codebase rootHash rel + (_parseNames, localNamesOnly, ppe) <- Backend.scopedNamesForBranchHash codebase rootHash rel let alignments :: ( [ ( FZF.Alignment, UnisonName, diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs index 36e6376762..14b8509c22 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceDetails.hs @@ -95,7 +95,7 @@ namespaceDetails runtime codebase namespaceName maySBH mayWidth = namespaceCausal <- Backend.getShallowCausalAtPathFromRootHash codebase mayRootHash namespacePath shallowBranch <- lift $ V2Causal.value namespaceCausal namespaceDetails <- do - (_localNamesOnly, ppe) <- Backend.scopedNamesForBranchHash codebase mayRootHash namespacePath + (_parseNames, _localNamesOnly, ppe) <- Backend.scopedNamesForBranchHash codebase mayRootHash namespacePath readme <- Backend.findShallowReadmeInBranchAndRender width From 0aede7ef303045d33d84e9d13924607e440c7eca Mon Sep 17 00:00:00 2001 From: Dan Doel Date: Tue, 12 Jul 2022 17:50:43 -0400 Subject: [PATCH 506/529] Don't sandbox watch expressions --- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 33291881a0..3fc0595519 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -290,7 +290,7 @@ loop = do let ppe = PPE.suffixifiedPPE pped unsafeTime "typechecked.respond" $ respond $ Typechecked sourceName ppe sr unisonFile unlessError' EvaluationFailure do - (bindings, e) <- unsafeTime "evaluate" $ ExceptT . eval . Evaluate True ppe $ unisonFile + (bindings, e) <- unsafeTime "evaluate" $ ExceptT . eval . Evaluate False ppe $ unisonFile lift do let e' = Map.map go e go (ann, kind, _hash, _uneval, eval, isHit) = (ann, kind, eval, isHit) From e30f1c8c2a6c769bb0d2c7b971832b1ffee7231b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 12 Jul 2022 20:14:11 -0600 Subject: [PATCH 507/529] Update transcripts --- .../transcripts/api-getDefinition.output.md | 76 ++++++++++++++++++- 1 file changed, 75 insertions(+), 1 deletion(-) diff --git a/unison-src/transcripts/api-getDefinition.output.md b/unison-src/transcripts/api-getDefinition.output.md index ef167c5264..c6ba4f5c3d 100644 --- a/unison-src/transcripts/api-getDefinition.output.md +++ b/unison-src/transcripts/api-getDefinition.output.md @@ -316,7 +316,81 @@ GET /api/getDefinition?names=%23qkhkl0n238&relativeTo=nested GET /api/getDefinition?names=%23qkhkl0n238&relativeTo=emptypath { "missingDefinitions": [], - "termDefinitions": {}, + "termDefinitions": { + "#qkhkl0n238s1eqibd1ecb8605sqj1m4hpoaag177cu572otqlaf1u28c8suuuqgljdtthsjtr07rv04np05o6oa27ml9105k7uas0t8": { + "bestTermName": "x", + "defnTermTag": null, + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "x", + "tag": "HashQualifier" + }, + "segment": "x" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "42" + } + ], + "tag": "UserObject" + }, + "termDocs": [], + "termNames": [ + ".nested.names.x" + ] + } + }, "typeDefinitions": {} } ``` \ No newline at end of file From fb15135f771a3731a108da5e366d8c8a93708c03 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 12 Jul 2022 20:08:33 -0600 Subject: [PATCH 508/529] Improve error message on missing names --- parser-typechecker/src/Unison/PrintError.hs | 147 ++++++++++-------- .../src/Unison/Codebase/Editor/HandleInput.hs | 2 +- .../src/Unison/Codebase/Editor/Output.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 4 +- .../transcripts/destructuring-binds.output.md | 13 +- unison-src/transcripts/fix845.output.md | 13 +- .../transcripts/resolution-failures.output.md | 14 +- 7 files changed, 123 insertions(+), 72 deletions(-) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index b72c41b7d4..d2360992a2 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -20,6 +20,7 @@ import qualified Data.Text as Text import qualified Text.Megaparsec as P import qualified Unison.ABT as ABT import Unison.Builtin.Decls (pattern TupleType') +import qualified Unison.Codebase.Path as Path import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) import Unison.HashQualified (HashQualified) import qualified Unison.HashQualified as HQ @@ -160,8 +161,9 @@ renderTypeError :: TypeError v loc -> Env -> String -> + Path.Absolute -> Pretty ColorText -renderTypeError e env src = case e of +renderTypeError e env src curPath = case e of BooleanMismatch {..} -> mconcat [ Pr.wrap $ @@ -394,49 +396,49 @@ renderTypeError e env src = case e of AbilityCheckFailure {..} | [tv@(Type.Var' ev)] <- ambient, ev `Set.member` foldMap Type.freeVars requested -> - mconcat - [ "I tried to infer a cyclic ability.", - "\n\n", - "The expression ", - describeStyle ErrorSite, - " was inferred to require the ", - case length requested of - 1 -> "ability: " - _ -> "abilities: ", - "\n\n {", - commas (renderType' env) requested, - "}", - "\n\n", - "where `", - renderType' env tv, - "` is its overall abilities.", - "\n\n", - "I need a type signature to help figure this out.", - "\n\n", - annotatedAsErrorSite src abilityCheckFailureSite, - debugSummary note - ] + mconcat + [ "I tried to infer a cyclic ability.", + "\n\n", + "The expression ", + describeStyle ErrorSite, + " was inferred to require the ", + case length requested of + 1 -> "ability: " + _ -> "abilities: ", + "\n\n {", + commas (renderType' env) requested, + "}", + "\n\n", + "where `", + renderType' env tv, + "` is its overall abilities.", + "\n\n", + "I need a type signature to help figure this out.", + "\n\n", + annotatedAsErrorSite src abilityCheckFailureSite, + debugSummary note + ] AbilityCheckFailure {..} | C.InSubtype {} :<| _ <- C.path note -> - mconcat - [ "The expression ", - describeStyle ErrorSite, - "\n\n", - " needs the abilities: {", - commas (renderType' env) requested, - "}\n", - " but was assumed to only require: {", - commas (renderType' env) ambient, - "}", - "\n\n", - "This is likely a result of using an un-annotated ", - "function as an argument with concrete abilities. ", - "Try adding an annotation to the function definition whose ", - "body is red.", - "\n\n", - annotatedAsErrorSite src abilityCheckFailureSite, - debugSummary note - ] + mconcat + [ "The expression ", + describeStyle ErrorSite, + "\n\n", + " needs the abilities: {", + commas (renderType' env) requested, + "}\n", + " but was assumed to only require: {", + commas (renderType' env) ambient, + "}", + "\n\n", + "This is likely a result of using an un-annotated ", + "function as an argument with concrete abilities. ", + "Try adding an annotation to the function definition whose ", + "body is red.", + "\n\n", + annotatedAsErrorSite src abilityCheckFailureSite, + debugSummary note + ] AbilityCheckFailure {..} -> mconcat [ "The expression ", @@ -492,19 +494,33 @@ renderTypeError e env src = case e of C.Exact -> (_1 %~ ((name, typ) :)) . r C.WrongType -> (_2 %~ ((name, typ) :)) . r C.WrongName -> (_3 %~ ((name, typ) :)) . r + libPath = Path.absoluteToPath' curPath Path.:> "lib" in mconcat - [ "I'm not sure what ", + [ "I couldn't find any definitions matching the name ", style ErrorSite (Var.nameStr unknownTermV), - " means at ", - annotatedToEnglish termSite, + " inside the namespace ", + prettyPath' (Path.absoluteToPath' curPath), "\n\n", annotatedAsErrorSite src termSite, + "\n", + Pr.hang + "Some common causes of this error include:" + ( Pr.bulleted + [ Pr.wrap "Your current perspective is too deep to contain the definition in its subtree", + Pr.wrap "The definition is part of a library which hasn't been added to this project" + ] + ) + <> "\n\n" + <> "To add a library to this project use the command: " + <> Pr.backticked ("fork <.path.to.lib> " <> prettyPath' (libPath Path.:> "")), + "\n\n", case expectedType of - Type.Var' (TypeVar.Existential {}) -> "\nThere are no constraints on its type. " + Type.Var' (TypeVar.Existential {}) -> "There are no constraints on its type." _ -> - "\nWhatever it is, it has a type that conforms to " + "Whatever it is, its type should conform to " <> style Type1 (renderType' env expectedType) - <> ".\n", + <> ".", + "\n\n", -- ++ showTypeWithProvenance env src Type1 expectedType case correct of [] -> case wrongTypes of @@ -1046,9 +1062,10 @@ renderNoteAsANSI :: Pr.Width -> Env -> String -> + Path.Absolute -> Note v a -> String -renderNoteAsANSI w e s n = Pr.toANSI w $ printNoteWithSource e s n +renderNoteAsANSI w e s curPath n = Pr.toANSI w $ printNoteWithSource e s curPath n renderParseErrorAsANSI :: Var v => Pr.Width -> String -> Parser.Err v -> String renderParseErrorAsANSI w src = Pr.toANSI w . prettyParseError src @@ -1057,18 +1074,19 @@ printNoteWithSource :: (Var v, Annotated a, Show a, Ord a) => Env -> String -> + Path.Absolute -> Note v a -> Pretty ColorText -printNoteWithSource env _s (TypeInfo n) = prettyTypeInfo n env -printNoteWithSource _env s (Parsing e) = prettyParseError s e -printNoteWithSource env s (TypeError e) = prettyTypecheckError e env s -printNoteWithSource _env _s (NameResolutionFailures _es) = undefined -printNoteWithSource _env s (UnknownSymbol v a) = +printNoteWithSource env _s _curPath (TypeInfo n) = prettyTypeInfo n env +printNoteWithSource _env s _curPath (Parsing e) = prettyParseError s e +printNoteWithSource env s curPath (TypeError e) = prettyTypecheckError e env s curPath +printNoteWithSource _env _s _curPath (NameResolutionFailures _es) = undefined +printNoteWithSource _env s _curPath (UnknownSymbol v a) = fromString ("Unknown symbol `" ++ Text.unpack (Var.name v) ++ "`\n\n") <> annotatedAsErrorSite s a -printNoteWithSource env s (CompilerBug (Result.TypecheckerBug c)) = +printNoteWithSource env s _curPath (CompilerBug (Result.TypecheckerBug c)) = renderCompilerBug env s c -printNoteWithSource _env _s (CompilerBug c) = +printNoteWithSource _env _s _curPath (CompilerBug c) = fromString $ "Compiler bug: " <> show c _printPosRange :: String -> L.Pos -> L.Pos -> String @@ -1607,8 +1625,10 @@ prettyTypecheckError :: C.ErrorNote v loc -> Env -> String -> + Path.Absolute -> Pretty ColorText -prettyTypecheckError = renderTypeError . typeErrorFromNote +prettyTypecheckError note env src curPath = + renderTypeError (typeErrorFromNote note) env src curPath prettyTypeInfo :: (Var v, Ord loc, Show loc, Parser.Annotated loc) => @@ -1623,11 +1643,11 @@ intLiteralSyntaxTip :: intLiteralSyntaxTip term expectedType = case (term, expectedType) of (Term.Nat' n, Type.Ref' r) | r == Type.intRef -> - "\nTip: Use the syntax " - <> style Type2 ("+" <> show n) - <> " to produce an " - <> style Type2 "Int" - <> "." + "\nTip: Use the syntax " + <> style Type2 ("+" <> show n) + <> " to produce an " + <> style Type2 "Int" + <> "." _ -> "" -- | Pretty prints resolution failure annotations, including a table of disambiguation @@ -1690,3 +1710,6 @@ useExamples = (Pr.blue "use .foo bar.baz", Pr.wrap "Introduces `bar.baz` as a local alias for the absolute name `.foo.bar.baz`") ] ] + +prettyPath' :: Path.Path' -> Pretty ColorText +prettyPath' p' = Pr.blue (Pr.shown p') diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 6ba0cc620e..4668f62f60 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -278,7 +278,7 @@ loop = do | Result.CompilerBug (Result.TypecheckerBug bug) <- toList notes ] - when (not $ null tes) . respond $ TypeErrors text ppe tes + when (not $ null tes) . respond $ TypeErrors currentPath' text ppe tes when (not $ null cbs) . respond $ CompilerBugs text ppe cbs Just (Right uf) -> k uf loadUnisonFile sourceName text = do diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 51e6ebe241..891b8df746 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -170,7 +170,7 @@ data Output v SlurpOutput Input PPE.PrettyPrintEnv (SlurpResult v) | -- Original source, followed by the errors: ParseErrors Text [Parser.Err v] - | TypeErrors Text PPE.PrettyPrintEnv [Context.ErrorNote v Ann] + | TypeErrors Path.Absolute Text PPE.PrettyPrintEnv [Context.ErrorNote v Ann] | CompilerBugs Text PPE.PrettyPrintEnv [Context.CompilerBug v Ann] | DisplayConflicts (Relation Name Referent) (Relation Name Reference) | EvaluationFailure Runtime.Error diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 44f979649e..c984e41db1 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -953,9 +953,9 @@ notifyUser dir o = case o of ] ParseErrors src es -> pure . P.sep "\n\n" $ prettyParseError (Text.unpack src) <$> es - TypeErrors src ppenv notes -> do + TypeErrors curPath src ppenv notes -> do let showNote = - intercalateMap "\n\n" (printNoteWithSource ppenv (Text.unpack src)) + intercalateMap "\n\n" (printNoteWithSource ppenv (Text.unpack src) curPath) . map Result.TypeError pure . showNote $ notes CompilerBugs src env bugs -> pure $ intercalateMap "\n\n" bug bugs diff --git a/unison-src/transcripts/destructuring-binds.output.md b/unison-src/transcripts/destructuring-binds.output.md index 45075ce8eb..51eb76acea 100644 --- a/unison-src/transcripts/destructuring-binds.output.md +++ b/unison-src/transcripts/destructuring-binds.output.md @@ -91,11 +91,20 @@ ex4 = ```ucm - I'm not sure what a means at line 2, columns 12-13 + I couldn't find any definitions matching the name a inside the namespace . 2 | (a,b) = (a Nat.+ b, 19) - Whatever it is, it has a type that conforms to Nat. + Some common causes of this error include: + * Your current perspective is too deep to contain the + definition in its subtree + * The definition is part of a library which hasn't been + added to this project + + To add a library to this project use the command: `fork <.path.to.lib> .lib.` + + Whatever it is, its type should conform to Nat. + ``` diff --git a/unison-src/transcripts/fix845.output.md b/unison-src/transcripts/fix845.output.md index 87f2213079..78551dc74c 100644 --- a/unison-src/transcripts/fix845.output.md +++ b/unison-src/transcripts/fix845.output.md @@ -30,11 +30,20 @@ Now, typecheck a file with a reference to `Blah.zonk` (which doesn't exist in th ```ucm - I'm not sure what Blah.zonk means at line 2, columns 3-12 + I couldn't find any definitions matching the name Blah.zonk inside the namespace . 2 | > Blah.zonk [1,2,3] - Whatever it is, it has a type that conforms to [Nat] -> o. + Some common causes of this error include: + * Your current perspective is too deep to contain the + definition in its subtree + * The definition is part of a library which hasn't been + added to this project + + To add a library to this project use the command: `fork <.path.to.lib> .lib.` + + Whatever it is, its type should conform to [Nat] -> o. + ``` diff --git a/unison-src/transcripts/resolution-failures.output.md b/unison-src/transcripts/resolution-failures.output.md index 76e81657c7..6e70170d5a 100644 --- a/unison-src/transcripts/resolution-failures.output.md +++ b/unison-src/transcripts/resolution-failures.output.md @@ -106,11 +106,21 @@ useAmbiguousTerm = ambiguousTerm ```ucm - I'm not sure what ambiguousTerm means at line 1, columns 20-33 + I couldn't find any definitions matching the name ambiguousTerm inside the namespace .example.resolution_failures 1 | useAmbiguousTerm = ambiguousTerm - There are no constraints on its type. I found some terms in scope that have matching names and types. Maybe you meant one of these: + Some common causes of this error include: + * Your current perspective is too deep to contain the + definition in its subtree + * The definition is part of a library which hasn't been + added to this project + + To add a library to this project use the command: `fork <.path.to.lib> .example.resolution_failures.lib.` + + There are no constraints on its type. + + I found some terms in scope that have matching names and types. Maybe you meant one of these: - one.ambiguousTerm : ##Text - two.ambiguousTerm : ##Text From a9602069b86b194a97b0dfcf7638c0ddc91df7cc Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Wed, 13 Jul 2022 10:19:37 -0400 Subject: [PATCH 509/529] Suggest public on "no permissions" error --- .../src/Unison/CommandLine/OutputMessages.hs | 24 +++++++++++++++---- 1 file changed, 20 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 44f979649e..35d2250209 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -644,8 +644,8 @@ notifyUser dir o = case o of CachedTests 0 _ -> pure . P.callout "๐Ÿ˜ถ" $ "No tests to run." CachedTests n n' | n == n' -> - pure $ - P.lines [cache, "", displayTestResults True ppe oks fails] + pure $ + P.lines [cache, "", displayTestResults True ppe oks fails] CachedTests _n m -> pure $ if m == 0 @@ -1691,7 +1691,23 @@ notifyUser dir o = case o of noReadPermission sharePath = P.wrap $ P.text "The server said you don't have permission to read" <> P.group (prettySharePath sharePath <> ".") noWritePermission sharePath = - P.wrap $ P.text "The server said you don't have permission to write" <> P.group (prettySharePath sharePath <> ".") + case Share.pathSegments sharePath of + _ NEList.:| "public" : _ -> P.wrap $ P.text "The server said you don't have permission to write" <> P.group (prettySharePath sharePath <> ".") + uname NEList.:| ys -> + let msg = + mconcat + [ "Unison Share currently only supports sharing public code. ", + "This is done by hosting code in a public namespace under your handle.", + "It looks like you were trying to push textExtra to the " <> P.backticked (P.text uname), + " handle. Try nesting under `public` like so: " + ] + pushCommand = IP.makeExampleNoBackticks IP.push [prettySharePath exPath] + exPath = Share.Path (uname NEList.:| "public" : ys) + in P.lines + [ P.wrap msg, + "", + P.indentN 4 pushCommand + ] IntegrityCheck result -> pure $ case result of NoIntegrityErrors -> "๐ŸŽ‰ No issues detected ๐ŸŽ‰" IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns @@ -2316,7 +2332,7 @@ showDiffNamespace :: (Pretty, NumberedArgs) showDiffNamespace _ _ _ _ diffOutput | OBD.isEmpty diffOutput = - ("The namespaces are identical.", mempty) + ("The namespaces are identical.", mempty) showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = (P.sepNonEmpty "\n\n" p, toList args) where From 65e2ead7a4d8646d9d8bb32948c4e286b034921c Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Wed, 13 Jul 2022 10:33:51 -0400 Subject: [PATCH 510/529] rename force push command --- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 9f70199ff7..9ee9e98f15 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1178,7 +1178,7 @@ pushCreate = pushForce :: InputPattern pushForce = InputPattern - "push.force" + "unsafe.force-push" [] I.Visible [(Required, remoteNamespaceArg), (Optional, namespaceArg)] From b6721e00bc48a77db6b64fe4ad5c71c2410281e5 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Wed, 13 Jul 2022 10:39:59 -0400 Subject: [PATCH 511/529] mark force push as hidden --- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 3d780f3d62..ce120161c7 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1201,7 +1201,7 @@ pushForce = InputPattern "unsafe.force-push" [] - I.Visible + I.Hidden [(Required, remoteNamespaceArg), (Optional, namespaceArg)] (P.wrap "Like `push`, but overwrites any remote namespace.") ( \case From ea0dd3a7e1ccc6ddb5a5eb3919016180b0692d81 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 13 Jul 2022 08:57:35 -0600 Subject: [PATCH 512/529] Fix failing test build --- parser-typechecker/tests/Unison/Test/UnisonSources.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/parser-typechecker/tests/Unison/Test/UnisonSources.hs b/parser-typechecker/tests/Unison/Test/UnisonSources.hs index 6e37705b6a..deb9751bc5 100644 --- a/parser-typechecker/tests/Unison/Test/UnisonSources.hs +++ b/parser-typechecker/tests/Unison/Test/UnisonSources.hs @@ -13,6 +13,7 @@ import System.Directory (doesFileExist) import System.FilePath (joinPath, replaceExtension, splitPath) import System.FilePath.Find (always, extension, find, (==?)) import qualified Unison.Builtin as Builtin +import qualified Unison.Codebase.Path as Path import Unison.Codebase.Runtime (Runtime, evaluateWatches) import Unison.Names (Names) import qualified Unison.NamesWithHistory as NamesWithHistory @@ -91,7 +92,7 @@ go rt files how = do showNotes :: Foldable f => String -> PrintError.Env -> f Note -> String showNotes source env = - intercalateMap "\n\n" $ PrintError.renderNoteAsANSI 60 env source + intercalateMap "\n\n" $ PrintError.renderNoteAsANSI 60 env source Path.absoluteEmpty decodeResult :: String -> SynthResult -> EitherResult -- String (UF.TypecheckedUnisonFile Symbol Ann) From aa562b703ddd6a2a1880d82fb4d0640fe60f5fa9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 13 Jul 2022 08:56:21 -0600 Subject: [PATCH 513/529] Add link to share --- unison-cli/package.yaml | 1 + .../src/Unison/Codebase/Editor/Output.hs | 2 ++ .../src/Unison/CommandLine/OutputMessages.hs | 20 +++++++++++++++---- unison-cli/unison-cli.cabal | 5 +++++ 4 files changed, 24 insertions(+), 4 deletions(-) diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 0490f9bd42..ea139992e5 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -40,6 +40,7 @@ dependencies: - memory - mtl - network-uri + - uri-encode - nonempty-containers - open-browser - pretty-simple diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 51e6ebe241..66717366cc 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -203,6 +203,7 @@ data Output v BustedBuiltins (Set Reference) (Set Reference) | GitError GitError | ShareError ShareError + | ViewOnShare WriteShareRemotePath | ConfiguredMetadataParseError Path' String (P.Pretty P.ColorText) | NoConfiguredRemoteMapping PushPull Path.Absolute | ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String @@ -392,6 +393,7 @@ isFailure o = case o of NoIntegrityErrors -> False IntegrityErrorDetected {} -> True ShareError {} -> True + ViewOnShare {} -> False isNumberedFailure :: NumberedOutput v -> Bool isNumberedFailure = \case diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 44f979649e..807c14f4ec 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -26,6 +26,7 @@ import Data.Tuple (swap) import Data.Tuple.Extra (dupe) import qualified Network.HTTP.Types as Http import Network.URI (URI) +import qualified Network.URI.Encode as URI import qualified Servant.Client as Servant import System.Directory ( canonicalizePath, @@ -106,6 +107,7 @@ import Unison.NamePrinter styleHashQualified', ) import Unison.NameSegment (NameSegment (..)) +import qualified Unison.NameSegment as NameSegment import Unison.Names (Names (..)) import qualified Unison.Names as Names import qualified Unison.NamesWithHistory as Names @@ -644,8 +646,8 @@ notifyUser dir o = case o of CachedTests 0 _ -> pure . P.callout "๐Ÿ˜ถ" $ "No tests to run." CachedTests n n' | n == n' -> - pure $ - P.lines [cache, "", displayTestResults True ppe oks fails] + pure $ + P.lines [cache, "", displayTestResults True ppe oks fails] CachedTests _n m -> pure $ if m == 0 @@ -654,7 +656,6 @@ notifyUser dir o = case o of P.indentN 2 $ P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "โœ… "] where - NewlyComputed -> do clearCurrentLine pure $ @@ -1692,6 +1693,9 @@ notifyUser dir o = case o of P.wrap $ P.text "The server said you don't have permission to read" <> P.group (prettySharePath sharePath <> ".") noWritePermission sharePath = P.wrap $ P.text "The server said you don't have permission to write" <> P.group (prettySharePath sharePath <> ".") + ViewOnShare repoPath -> + pure $ + "View it on share: " <> prettyShareLink repoPath IntegrityCheck result -> pure $ case result of NoIntegrityErrors -> "๐ŸŽ‰ No issues detected ๐ŸŽ‰" IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns @@ -1747,6 +1751,14 @@ notifyUser dir o = case o of -- ns targets = P.oxfordCommas $ -- map (fromString . Names.renderNameTarget) (toList targets) +prettyShareLink :: WriteShareRemotePath -> Pretty +prettyShareLink WriteShareRemotePath {repo, path} = + let encodedPath = + Path.toList path + & fmap (URI.encodeText . NameSegment.toText) + & Text.intercalate "/" + in P.green . P.text $ "https://share-next.unison-lang.org/users/" <> repo <> "/code/latest/namespaces/" <> encodedPath + prettyFilePath :: FilePath -> Pretty prettyFilePath fp = P.blue (P.string fp) @@ -2316,7 +2328,7 @@ showDiffNamespace :: (Pretty, NumberedArgs) showDiffNamespace _ _ _ _ diffOutput | OBD.isEmpty diffOutput = - ("The namespaces are identical.", mempty) + ("The namespaces are identical.", mempty) showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = (P.sepNonEmpty "\n\n" p, toList args) where diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index f087313f75..75c875388c 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -150,6 +150,7 @@ library , unison-util-base32hex , unison-util-relation , unliftio + , uri-encode , vector , wai , warp @@ -255,6 +256,7 @@ executable cli-integration-tests , unison-util-base32hex , unison-util-relation , unliftio + , uri-encode , vector , wai , warp @@ -354,6 +356,7 @@ executable transcripts , unison-util-base32hex , unison-util-relation , unliftio + , uri-encode , vector , wai , warp @@ -458,6 +461,7 @@ executable unison , unison-util-base32hex , unison-util-relation , unliftio + , uri-encode , vector , wai , warp @@ -566,6 +570,7 @@ test-suite cli-tests , unison-util-base32hex , unison-util-relation , unliftio + , uri-encode , vector , wai , warp From cf0a2caa3ee3424ce60106149a184136068596ec Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 13 Jul 2022 11:07:49 -0400 Subject: [PATCH 514/529] tweak output messages to not hardcode textExtra --- .../src/Unison/CommandLine/OutputMessages.hs | 46 +++++++++++-------- 1 file changed, 27 insertions(+), 19 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 35d2250209..0b85b00195 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -644,8 +644,8 @@ notifyUser dir o = case o of CachedTests 0 _ -> pure . P.callout "๐Ÿ˜ถ" $ "No tests to run." CachedTests n n' | n == n' -> - pure $ - P.lines [cache, "", displayTestResults True ppe oks fails] + pure $ + P.lines [cache, "", displayTestResults True ppe oks fails] CachedTests _n m -> pure $ if m == 0 @@ -1603,7 +1603,8 @@ notifyUser dir o = case o of ShareErrorFastForwardPush e -> case e of (Share.FastForwardPushErrorNoHistory sharePath) -> expectedNonEmptyPushDest (sharePathToWriteRemotePathShare sharePath) - (Share.FastForwardPushErrorNoReadPermission sharePath) -> noReadPermission sharePath + (Share.FastForwardPushErrorNoReadPermission sharePath) -> + noWritePermissionFastForwardPushError sharePath (Share.FastForwardPushInvalidParentage parent child) -> P.lines [ "The server detected an error in the history being pushed, please report this as a bug in ucm.", @@ -1690,24 +1691,31 @@ notifyUser dir o = case o of Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermission sharePath noReadPermission sharePath = P.wrap $ P.text "The server said you don't have permission to read" <> P.group (prettySharePath sharePath <> ".") + noWritePermissionFastForwardPushError sharePath = + case Share.pathSegments sharePath of + _ NEList.:| "public" : _ -> + P.wrap $ + P.text "The server said you don't have permission to write" <> P.group (prettySharePath sharePath <> ".") + uname NEList.:| ys -> pushPublicNote IP.push uname ys + pushPublicNote cmd uname ys = + let msg = + mconcat + [ "Unison Share currently only supports sharing public code. ", + "This is done by hosting code in a public namespace under your handle.", + "It looks like you were trying to push directly to the" <> P.backticked (P.text uname), + "handle. Try nesting under `public` like so: " + ] + pushCommand = IP.makeExampleNoBackticks cmd [prettySharePath exPath] + exPath = Share.Path (uname NEList.:| "public" : ys) + in P.lines + [ P.wrap msg, + "", + P.indentN 4 pushCommand + ] noWritePermission sharePath = case Share.pathSegments sharePath of _ NEList.:| "public" : _ -> P.wrap $ P.text "The server said you don't have permission to write" <> P.group (prettySharePath sharePath <> ".") - uname NEList.:| ys -> - let msg = - mconcat - [ "Unison Share currently only supports sharing public code. ", - "This is done by hosting code in a public namespace under your handle.", - "It looks like you were trying to push textExtra to the " <> P.backticked (P.text uname), - " handle. Try nesting under `public` like so: " - ] - pushCommand = IP.makeExampleNoBackticks IP.push [prettySharePath exPath] - exPath = Share.Path (uname NEList.:| "public" : ys) - in P.lines - [ P.wrap msg, - "", - P.indentN 4 pushCommand - ] + uname NEList.:| ys -> pushPublicNote IP.pushCreate uname ys IntegrityCheck result -> pure $ case result of NoIntegrityErrors -> "๐ŸŽ‰ No issues detected ๐ŸŽ‰" IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns @@ -2332,7 +2340,7 @@ showDiffNamespace :: (Pretty, NumberedArgs) showDiffNamespace _ _ _ _ diffOutput | OBD.isEmpty diffOutput = - ("The namespaces are identical.", mempty) + ("The namespaces are identical.", mempty) showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = (P.sepNonEmpty "\n\n" p, toList args) where From a9398cf0231560fe9b6556e080e98ef34d2d61af Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 13 Jul 2022 09:11:55 -0600 Subject: [PATCH 515/529] Add 'View it on share' message to push --- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 6ba0cc620e..f0728cff26 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1841,7 +1841,7 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) handlePushToUnisonShare :: (MonadUnliftIO m) => WriteShareRemotePath -> Path.Absolute -> PushBehavior -> Action' m v () -handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} localPath behavior = do +handlePushToUnisonShare remote@WriteShareRemotePath {server, repo, path = remotePath} localPath behavior = do let codeserver = Codeserver.resolveCodeserver server let baseURL = codeserverBaseURL codeserver let sharePath = Share.Path (repo Nel.:| pathToSegments remotePath) @@ -1869,7 +1869,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l liftIO push >>= \case Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorCheckAndSetPush err)) Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err)) - Right () -> pure () + Right () -> respond (ViewOnShare remote) PushBehavior.RequireNonEmpty -> do let push :: IO (Either (Sync.SyncError Share.FastForwardPushError) ()) push = do @@ -1884,7 +1884,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l liftIO push >>= \case Left (Sync.SyncError err) -> respond (Output.ShareError (ShareErrorFastForwardPush err)) Left (Sync.TransportError err) -> respond (Output.ShareError (ShareErrorTransport err)) - Right () -> pure () + Right () -> respond (ViewOnShare remote) where pathToSegments :: Path -> [Text] pathToSegments = From a0fb9b45654a305faa94f88c010b612334c0dab9 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 13 Jul 2022 09:17:26 -0600 Subject: [PATCH 516/529] Adjust err message --- parser-typechecker/src/Unison/PrintError.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index d2360992a2..ad42af85e3 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -506,7 +506,7 @@ renderTypeError e env src curPath = case e of Pr.hang "Some common causes of this error include:" ( Pr.bulleted - [ Pr.wrap "Your current perspective is too deep to contain the definition in its subtree", + [ Pr.wrap "Your current namespace is too deep to contain the definition in its subtree", Pr.wrap "The definition is part of a library which hasn't been added to this project" ] ) From 740c1da84d8120f5ed20c4b1ac22d601c0e63b5d Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 13 Jul 2022 09:20:12 -0600 Subject: [PATCH 517/529] Transcript update --- parser-typechecker/src/Unison/PrintError.hs | 2 +- unison-src/transcripts/destructuring-binds.output.md | 2 +- unison-src/transcripts/fix845.output.md | 2 +- unison-src/transcripts/resolution-failures.output.md | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index ad42af85e3..460dded726 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -512,7 +512,7 @@ renderTypeError e env src curPath = case e of ) <> "\n\n" <> "To add a library to this project use the command: " - <> Pr.backticked ("fork <.path.to.lib> " <> prettyPath' (libPath Path.:> "")), + <> Pr.backticked ("fork <.path.to.lib> " <> Pr.shown (libPath Path.:> "")), "\n\n", case expectedType of Type.Var' (TypeVar.Existential {}) -> "There are no constraints on its type." diff --git a/unison-src/transcripts/destructuring-binds.output.md b/unison-src/transcripts/destructuring-binds.output.md index 51eb76acea..58a186ae0c 100644 --- a/unison-src/transcripts/destructuring-binds.output.md +++ b/unison-src/transcripts/destructuring-binds.output.md @@ -96,7 +96,7 @@ ex4 = 2 | (a,b) = (a Nat.+ b, 19) Some common causes of this error include: - * Your current perspective is too deep to contain the + * Your current namespace is too deep to contain the definition in its subtree * The definition is part of a library which hasn't been added to this project diff --git a/unison-src/transcripts/fix845.output.md b/unison-src/transcripts/fix845.output.md index 78551dc74c..14f7dedb60 100644 --- a/unison-src/transcripts/fix845.output.md +++ b/unison-src/transcripts/fix845.output.md @@ -35,7 +35,7 @@ Now, typecheck a file with a reference to `Blah.zonk` (which doesn't exist in th 2 | > Blah.zonk [1,2,3] Some common causes of this error include: - * Your current perspective is too deep to contain the + * Your current namespace is too deep to contain the definition in its subtree * The definition is part of a library which hasn't been added to this project diff --git a/unison-src/transcripts/resolution-failures.output.md b/unison-src/transcripts/resolution-failures.output.md index 6e70170d5a..046dfd01c3 100644 --- a/unison-src/transcripts/resolution-failures.output.md +++ b/unison-src/transcripts/resolution-failures.output.md @@ -111,7 +111,7 @@ useAmbiguousTerm = ambiguousTerm 1 | useAmbiguousTerm = ambiguousTerm Some common causes of this error include: - * Your current perspective is too deep to contain the + * Your current namespace is too deep to contain the definition in its subtree * The definition is part of a library which hasn't been added to this project From f73880e6dfc869dfcb0d40a18fea987e3f2883ce Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 13 Jul 2022 09:25:30 -0600 Subject: [PATCH 518/529] Pull share url into constant --- unison-cli/src/Unison/CommandLine/OutputMessages.hs | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 807c14f4ec..1d4b58abeb 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1751,13 +1751,16 @@ notifyUser dir o = case o of -- ns targets = P.oxfordCommas $ -- map (fromString . Names.renderNameTarget) (toList targets) +shareOrigin :: Text +shareOrigin = "https://share.unison-lang.org" + prettyShareLink :: WriteShareRemotePath -> Pretty prettyShareLink WriteShareRemotePath {repo, path} = let encodedPath = Path.toList path & fmap (URI.encodeText . NameSegment.toText) & Text.intercalate "/" - in P.green . P.text $ "https://share-next.unison-lang.org/users/" <> repo <> "/code/latest/namespaces/" <> encodedPath + in P.green . P.text $ shareOrigin <> "/users/" <> repo <> "/code/latest/namespaces/" <> encodedPath prettyFilePath :: FilePath -> Pretty prettyFilePath fp = From d0ca3ce5d9c257991b94db04a046de504e01577e Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 13 Jul 2022 11:40:39 -0400 Subject: [PATCH 519/529] Update unison-cli/src/Unison/CommandLine/OutputMessages.hs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Simon Hรธjberg --- unison-cli/src/Unison/CommandLine/OutputMessages.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 1d4b58abeb..2f4ce9bd10 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1695,7 +1695,7 @@ notifyUser dir o = case o of P.wrap $ P.text "The server said you don't have permission to write" <> P.group (prettySharePath sharePath <> ".") ViewOnShare repoPath -> pure $ - "View it on share: " <> prettyShareLink repoPath + "View it on Unison Share: " <> prettyShareLink repoPath IntegrityCheck result -> pure $ case result of NoIntegrityErrors -> "๐ŸŽ‰ No issues detected ๐ŸŽ‰" IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns From f287c43e2bda432b38a3a08579354e897e0c932c Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 13 Jul 2022 11:36:28 -0600 Subject: [PATCH 520/529] Split up index server and local server --- .../Server/Endpoints/NamespaceListing.hs | 155 +++++++++++------- 1 file changed, 95 insertions(+), 60 deletions(-) diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs index 1fd172a531..531db917f8 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs @@ -7,9 +7,10 @@ {-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Unison.Server.Endpoints.NamespaceListing where +module Unison.Server.Endpoints.NamespaceListing (serve, NamespaceListingAPI, NamespaceListing (..), NamespaceObject (..), NamedNamespace (..), NamedPatch (..), KindExpression (..)) where import Control.Monad.Except +import Control.Monad.Reader import Data.Aeson import Data.OpenApi (ToSchema) import qualified Data.Text as Text @@ -24,14 +25,17 @@ import Servant.Docs ToSample (..), ) import Servant.OpenApi () -import qualified U.Codebase.Branch as V2Branch import qualified U.Codebase.Causal as V2Causal import qualified U.Util.Hash as Hash import Unison.Codebase (Codebase) +import qualified Unison.Codebase as Codebase +import Unison.Codebase.Branch (Branch) +import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Causal as Causal import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Path.Parse as Path import Unison.Codebase.ShortBranchHash (ShortBranchHash) +import Unison.Codebase.SqliteCodebase.Conversions (causalHash2to1) import qualified Unison.NameSegment as NameSegment import Unison.Parser.Ann (Ann) import Unison.Prelude @@ -46,6 +50,7 @@ import Unison.Server.Types NamespaceFQN, UnisonHash, UnisonName, + branchToUnisonHash, v2CausalBranchToUnisonHash, ) import Unison.Symbol (Symbol) @@ -154,61 +159,91 @@ serve :: Maybe NamespaceFQN -> Maybe NamespaceFQN -> Backend.Backend IO NamespaceListing -serve codebase maySBH mayRelativeTo mayNamespaceName = - let -- Various helpers - errFromEither f = either (throwError . f) pure - - parsePath :: String -> Backend IO Path.Path' - parsePath p = errFromEither (`Backend.BadNamespace` p) $ Path.parsePath' p - - findShallow :: - ( V2Branch.Branch IO -> - IO [Backend.ShallowListEntry Symbol Ann] - ) - findShallow branch = Backend.lsShallowBranch codebase branch - - makeNamespaceListing :: - ( PPE.PrettyPrintEnv -> - UnisonName -> - UnisonHash -> - [Backend.ShallowListEntry Symbol a] -> - Backend IO NamespaceListing - ) - makeNamespaceListing ppe fqn hash entries = - pure . NamespaceListing fqn hash $ - fmap - (backendListEntryToNamespaceObject ppe Nothing) - entries - - -- Lookup paths, root and listing and construct response - namespaceListing :: Backend IO NamespaceListing - namespaceListing = do - -- Relative and Listing Path resolution - -- - -- The full listing path is a combination of the relativeToPath (prefix) and the namespace path - -- - -- For example: - -- "base.List" <> "Nonempty" - -- โ†‘ โ†‘ - -- relativeToPath namespacePath - -- - -- resulting in "base.List.map" which we can use via the root branch (usually the codebase hash) - -- to look up the namespace listing and present shallow name, so that the - -- definition "base.List.Nonempty.map", simple has the name "map" - -- - relativeToPath' <- (parsePath . Text.unpack) $ fromMaybe "." mayRelativeTo - namespacePath' <- (parsePath . Text.unpack) $ fromMaybe "." mayNamespaceName - - let path = Path.fromPath' relativeToPath' <> Path.fromPath' namespacePath' - let path' = Path.toPath' path - - mayRootHash <- traverse (Backend.expandShortBranchHash codebase) maySBH - listingCausal <- Backend.getShallowCausalAtPathFromRootHash codebase mayRootHash path - listingBranch <- liftIO $ V2Causal.value listingCausal - shallowPPE <- liftIO $ Backend.shallowPPE codebase listingBranch - let listingFQN = Path.toText . Path.unabsolute . either id (Path.Absolute . Path.unrelative) $ Path.unPath' path' - let listingHash = v2CausalBranchToUnisonHash listingCausal - listingEntries <- lift (findShallow listingBranch) - - makeNamespaceListing shallowPPE listingFQN listingHash listingEntries - in namespaceListing +serve codebase maySBH mayRelativeTo mayNamespaceName = do + useIndex <- asks Backend.useNamesIndex + mayRootHash <- traverse (Backend.expandShortBranchHash codebase) maySBH + codebaseRootHash <- liftIO $ Codebase.getRootBranchHash codebase + + --Relative and Listing Path resolution + -- + -- The full listing path is a combination of the relativeToPath (prefix) and the namespace path + -- + -- For example: + -- "base.List" <> "Nonempty" + -- โ†‘ โ†‘ + -- relativeToPath namespacePath + -- + -- resulting in "base.List.map" which we can use via the root branch (usually the codebase hash) + -- to look up the namespace listing and present shallow name, so that the + -- definition "base.List.Nonempty.map", simple has the name "map" + -- + relativeToPath' <- (parsePath . Text.unpack) $ fromMaybe "." mayRelativeTo + namespacePath' <- (parsePath . Text.unpack) $ fromMaybe "." mayNamespaceName + + let path = Path.fromPath' relativeToPath' <> Path.fromPath' namespacePath' + let path' = Path.toPath' path + + case (useIndex, mayRootHash) of + (True, Nothing) -> + serveFromIndex codebase mayRootHash path' + (True, Just rh) + | rh == causalHash2to1 codebaseRootHash -> + serveFromIndex codebase mayRootHash path' + (_, Just rh) -> do + mayBranch <- liftIO $ Codebase.getBranchForHash codebase rh + branch <- maybe (throwError $ Backend.NoBranchForHash rh) pure mayBranch + serveFromBranch codebase path' branch + (False, Nothing) -> do + branch <- liftIO $ Codebase.getRootBranch codebase + serveFromBranch codebase path' branch + where + parsePath :: String -> Backend IO Path.Path' + parsePath p = errFromEither (`Backend.BadNamespace` p) $ Path.parsePath' p + errFromEither f = either (throwError . f) pure + +serveFromBranch :: + Codebase IO Symbol Ann -> + Path.Path' -> + Branch IO -> + Backend.Backend IO NamespaceListing +serveFromBranch codebase path' branch = do + -- TODO: Currently the ppe is just used for rendering types which don't appear in the UI, + -- If we ever show types on hover we need to build and use a proper PPE here, but it's not + -- worth slowing down the request for this right now. + let ppe = mempty + let listingFQN = Path.toText . Path.unabsolute . either id (Path.Absolute . Path.unrelative) $ Path.unPath' path' + let listingHash = branchToUnisonHash branch + listingEntries <- liftIO $ Backend.lsBranch codebase branch + makeNamespaceListing ppe listingFQN listingHash listingEntries + +serveFromIndex :: + Codebase IO Symbol Ann -> + Maybe Branch.CausalHash -> + Path.Path' -> + Backend.Backend IO NamespaceListing +serveFromIndex codebase mayRootHash path' = do + listingCausal <- Backend.getShallowCausalAtPathFromRootHash codebase mayRootHash (Path.fromPath' path') + listingBranch <- liftIO $ V2Causal.value listingCausal + + -- TODO: Currently the ppe is just used for rendering types which don't appear in the UI, + -- If we ever show types on hover we need to build and use a proper PPE here, but it's not + -- worth slowing down the request for this right now. + -- shallowPPE <- liftIO $ Backend.shallowPPE codebase listingBranch + let shallowPPE = mempty + let listingFQN = Path.toText . Path.unabsolute . either id (Path.Absolute . Path.unrelative) $ Path.unPath' path' + let listingHash = v2CausalBranchToUnisonHash listingCausal + listingEntries <- lift (Backend.lsShallowBranch codebase listingBranch) + makeNamespaceListing shallowPPE listingFQN listingHash listingEntries + +makeNamespaceListing :: + ( PPE.PrettyPrintEnv -> + UnisonName -> + UnisonHash -> + [Backend.ShallowListEntry Symbol a] -> + Backend IO NamespaceListing + ) +makeNamespaceListing ppe fqn hash entries = + pure . NamespaceListing fqn hash $ + fmap + (backendListEntryToNamespaceObject ppe Nothing) + entries From 53b2f4944b8b44bb8ddf30acaf7ceca34f250386 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 13 Jul 2022 11:47:20 -0600 Subject: [PATCH 521/529] Include namespace definition size on local --- .../src/Unison/Server/Endpoints/NamespaceListing.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs index 531db917f8..54021be2b3 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs @@ -143,12 +143,12 @@ backendListEntryToNamespaceObject ppe typeWidth = \case Backend.ShallowTermEntry te -> TermObject $ Backend.termEntryToNamedTerm ppe typeWidth te Backend.ShallowTypeEntry te -> TypeObject $ Backend.typeEntryToNamedType te - Backend.ShallowBranchEntry name hash _size -> + Backend.ShallowBranchEntry name hash size -> Subnamespace $ NamedNamespace { namespaceName = NameSegment.toText name, namespaceHash = "#" <> Hash.toBase32HexText (Causal.unCausalHash hash), - namespaceSize = Nothing + namespaceSize = size } Backend.ShallowPatchEntry name -> PatchObject . NamedPatch $ NameSegment.toText name @@ -207,13 +207,14 @@ serveFromBranch :: Branch IO -> Backend.Backend IO NamespaceListing serveFromBranch codebase path' branch = do + let branchAtPath = Branch.getAt' (Path.fromPath' path') branch -- TODO: Currently the ppe is just used for rendering types which don't appear in the UI, -- If we ever show types on hover we need to build and use a proper PPE here, but it's not -- worth slowing down the request for this right now. let ppe = mempty let listingFQN = Path.toText . Path.unabsolute . either id (Path.Absolute . Path.unrelative) $ Path.unPath' path' - let listingHash = branchToUnisonHash branch - listingEntries <- liftIO $ Backend.lsBranch codebase branch + let listingHash = branchToUnisonHash branchAtPath + listingEntries <- liftIO $ Backend.lsBranch codebase branchAtPath makeNamespaceListing ppe listingFQN listingHash listingEntries serveFromIndex :: From 405a39e15491c1621498303c1905311eb1bb2fad Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Simon=20H=C3=B8jberg?= Date: Wed, 13 Jul 2022 13:53:20 -0400 Subject: [PATCH 522/529] Switch to use @ symbol in links to Share users --- unison-cli/src/Unison/CommandLine/OutputMessages.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index ca92bd2d3b..4b8899c408 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1785,7 +1785,7 @@ prettyShareLink WriteShareRemotePath {repo, path} = Path.toList path & fmap (URI.encodeText . NameSegment.toText) & Text.intercalate "/" - in P.green . P.text $ shareOrigin <> "/users/" <> repo <> "/code/latest/namespaces/" <> encodedPath + in P.green . P.text $ shareOrigin <> "/@" <> repo <> "/code/latest/namespaces/" <> encodedPath prettyFilePath :: FilePath -> Pretty prettyFilePath fp = From f32945d92b5ce486e8396729890fefa63ae75442 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 13 Jul 2022 13:01:53 -0600 Subject: [PATCH 523/529] Transcript update --- unison-src/transcripts/api-namespace-list.output.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-src/transcripts/api-namespace-list.output.md b/unison-src/transcripts/api-namespace-list.output.md index b62c949fa5..904d73e023 100644 --- a/unison-src/transcripts/api-namespace-list.output.md +++ b/unison-src/transcripts/api-namespace-list.output.md @@ -72,7 +72,7 @@ GET /api/list?namespace=nested.names "contents": { "namespaceHash": "#n1egracfeljprftoktbjcase2hs4f4p8idbhs5ujipl42agld1810hrq9t7p7ped16aagni2cm1fjcjhho770jh80ipthhmg0cnsur0", "namespaceName": "x", - "namespaceSize": null + "namespaceSize": 1 }, "tag": "Subnamespace" } @@ -121,7 +121,7 @@ GET /api/list?namespace=names&relativeTo=nested "contents": { "namespaceHash": "#n1egracfeljprftoktbjcase2hs4f4p8idbhs5ujipl42agld1810hrq9t7p7ped16aagni2cm1fjcjhho770jh80ipthhmg0cnsur0", "namespaceName": "x", - "namespaceSize": null + "namespaceSize": 1 }, "tag": "Subnamespace" } From 6273aa2bf8169d2b4dba6d99da0af155657cfa11 Mon Sep 17 00:00:00 2001 From: Travis Staton Date: Wed, 13 Jul 2022 16:14:26 -0400 Subject: [PATCH 524/529] Produce a better error message when pushing an empty namespace --- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 2 +- unison-cli/src/Unison/Codebase/Editor/Output.hs | 2 ++ unison-cli/src/Unison/CommandLine/OutputMessages.hs | 2 ++ 3 files changed, 5 insertions(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index cc5c5c0eb2..65a09d6a32 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1854,7 +1854,7 @@ handlePushToUnisonShare remote@WriteShareRemotePath {server, repo, path = remote -- doesn't handle the case where a non-existent path is supplied eval (Eval (Codebase.runTransaction codebase (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath))))) >>= \case - Nothing -> respond (BranchNotFound . Path.absoluteToPath' $ localPath) + Nothing -> respond (EmptyPush . Path.absoluteToPath' $ localPath) Just localCausalHash -> do let checkAndSetPush :: Maybe Hash32 -> IO (Either (Share.SyncError Share.CheckAndSetPushError) ()) checkAndSetPush remoteHash = diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 27a1d4a650..926f5e1020 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -140,6 +140,7 @@ data Output v | BranchHashAmbiguous ShortBranchHash (Set ShortBranchHash) | BadNamespace String String | BranchNotFound Path' + | EmptyPush Path' | NameNotFound Path.HQSplit' | PatchNotFound Path.Split' | TypeNotFound Path.HQSplit' @@ -304,6 +305,7 @@ isFailure o = case o of PatchAlreadyExists {} -> True NoExactTypeMatches -> True BranchEmpty {} -> True + EmptyPush {} -> True BranchNotEmpty {} -> True TypeAlreadyExists {} -> True TypeParseError {} -> True diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 4b8899c408..b9f08e849d 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -809,6 +809,8 @@ notifyUser dir o = case o of pure . P.warnCallout $ "Invalid namespace " <> P.blue (P.string path) <> ", " <> P.string msg BranchNotFound b -> pure . P.warnCallout $ "The namespace " <> P.blue (P.shown b) <> " doesn't exist." + EmptyPush b -> + pure . P.warnCallout $ "The namespace " <> P.blue (P.shown b) <> " is empty. There is nothing to push." CreatedNewBranch path -> pure $ "โ˜๏ธ The namespace " <> P.blue (P.shown path) <> " is empty." From c1f2740f86765b68911ed1862f934d7408fd8d0b Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 13 Jul 2022 14:31:42 -0600 Subject: [PATCH 525/529] PR feedback --- .../Unison/Server/Endpoints/NamespaceListing.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs index 54021be2b3..485d8d86d4 100644 --- a/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Endpoints/NamespaceListing.hs @@ -189,7 +189,11 @@ serve codebase maySBH mayRelativeTo mayNamespaceName = do (True, Just rh) | rh == causalHash2to1 codebaseRootHash -> serveFromIndex codebase mayRootHash path' - (_, Just rh) -> do + | otherwise -> do + mayBranch <- liftIO $ Codebase.getBranchForHash codebase rh + branch <- maybe (throwError $ Backend.NoBranchForHash rh) pure mayBranch + serveFromBranch codebase path' branch + (False, Just rh) -> do mayBranch <- liftIO $ Codebase.getBranchForHash codebase rh branch <- maybe (throwError $ Backend.NoBranchForHash rh) pure mayBranch serveFromBranch codebase path' branch @@ -208,7 +212,8 @@ serveFromBranch :: Backend.Backend IO NamespaceListing serveFromBranch codebase path' branch = do let branchAtPath = Branch.getAt' (Path.fromPath' path') branch - -- TODO: Currently the ppe is just used for rendering types which don't appear in the UI, + -- TODO: Currently the ppe is just used to render the types returned from the namespace + -- listing, which are currently unused because we don't show types in the side-bar. -- If we ever show types on hover we need to build and use a proper PPE here, but it's not -- worth slowing down the request for this right now. let ppe = mempty @@ -225,10 +230,9 @@ serveFromIndex :: serveFromIndex codebase mayRootHash path' = do listingCausal <- Backend.getShallowCausalAtPathFromRootHash codebase mayRootHash (Path.fromPath' path') listingBranch <- liftIO $ V2Causal.value listingCausal - - -- TODO: Currently the ppe is just used for rendering types which don't appear in the UI, + -- TODO: Currently the ppe is just used to render the types returned from the namespace + -- listing, which are currently unused because we don't show types in the side-bar. -- If we ever show types on hover we need to build and use a proper PPE here, but it's not - -- worth slowing down the request for this right now. -- shallowPPE <- liftIO $ Backend.shallowPPE codebase listingBranch let shallowPPE = mempty let listingFQN = Path.toText . Path.unabsolute . either id (Path.Absolute . Path.unrelative) $ Path.unPath' path' From d8e13e84931bf6bf4c4f4a72b958a8caf8120158 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Wed, 13 Jul 2022 18:21:10 -0400 Subject: [PATCH 526/529] don't assume ucm trunk versions start with `latest-` closes #3233 --- unison-cli/src/Unison/Codebase/Editor/VersionParser.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index 74e756858a..7b24f18246 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -2,7 +2,6 @@ module Unison.Codebase.Editor.VersionParser where -import Data.Functor (($>)) import Data.Text (Text) import qualified Data.Text as Text import Data.Void (Void) @@ -26,10 +25,10 @@ import qualified Unison.Codebase.Path as Path -- >>> parseMaybe defaultBaseLib "release/M3-409-gbcdf68db3'" -- Nothing defaultBaseLib :: Parsec Void Text ReadShareRemoteNamespace -defaultBaseLib = fmap makeNS $ latest <|> release +defaultBaseLib = fmap makeNS $ release <|> unknown where - latest, release, version :: Parsec Void Text Text - latest = "latest-" *> many anySingle *> eof $> "main" + unknown, release, version :: Parsec Void Text Text + unknown = pure "main" release = fmap ("releases._" <>) $ "release/" *> version <* eof version = do v <- Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) From 5a92d9fb9ea16f6b0a6a063bf2f5d201dadfd1ba Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Wed, 13 Jul 2022 21:29:56 -0400 Subject: [PATCH 527/529] ignore things with lib in their name in docs.to-html --- unison-share-api/src/Unison/Server/Backend.hs | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index e115b0e66d..11a3262530 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -985,7 +985,9 @@ docsInBranchToHtmlFiles :: docsInBranchToHtmlFiles runtime codebase root currentPath directory = do let currentBranch = Branch.getAt' currentPath root let allTerms = (R.toList . Branch.deepTerms . Branch.head) currentBranch - docTermsWithNames <- filterM (isDoc codebase . fst) allTerms + -- ignores docs inside lib namespace, recursively + let notLib (_, name) = all (/= "lib") (Name.segments name) + docTermsWithNames <- filterM (isDoc codebase . fst) (filter notLib allTerms) let docNamesByRef = Map.fromList docTermsWithNames hqLength <- Codebase.hashLength codebase let printNames = prettyNamesForBranch root (AllNames currentPath) From ec17548a2869839cda8e62487e9385a58b9f542f Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 14 Jul 2022 10:19:47 -0400 Subject: [PATCH 528/529] add PRAGMA busy_timeout = 1000 to sqlite connections --- lib/unison-sqlite/src/Unison/Sqlite/Connection.hs | 1 + 1 file changed, 1 insertion(+) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index b4fbcaac29..600f1244de 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -119,6 +119,7 @@ openConnection name file = do conn0 <- Sqlite.open file `catch` rethrowAsSqliteConnectException name file let conn = Connection {conn = conn0, file, name} execute_ conn "PRAGMA foreign_keys = ON" + execute_ conn "PRAGMA busy_timeout = 1000" pure conn -- Close a connection opened with 'openConnection'. From 8d04b73567e8bbedc28667c3883e37e6c5a10b21 Mon Sep 17 00:00:00 2001 From: Paul Chiusano Date: Thu, 14 Jul 2022 11:33:09 -0400 Subject: [PATCH 529/529] fix #2628 --- parser-typechecker/src/Unison/FileParser.hs | 3 ++- unison-src/transcripts/fix2628.md | 15 ++++++++++++ unison-src/transcripts/fix2628.output.md | 26 +++++++++++++++++++++ 3 files changed, 43 insertions(+), 1 deletion(-) create mode 100644 unison-src/transcripts/fix2628.md create mode 100644 unison-src/transcripts/fix2628.output.md diff --git a/parser-typechecker/src/Unison/FileParser.hs b/parser-typechecker/src/Unison/FileParser.hs index 9514175bb3..aa00d7206a 100644 --- a/parser-typechecker/src/Unison/FileParser.hs +++ b/parser-typechecker/src/Unison/FileParser.hs @@ -346,7 +346,8 @@ dataDeclaration mod = do sepBy1 (reserved "," <* optional semi) $ liftA2 (,) (prefixVar <* reserved ":") TypeParser.valueType _ <- closeBlock - pure ([go name (snd <$> fields)], [(name, fields)]) + let lastSegment = name <&> (\v -> Var.named (Name.toText $ Name.unqualified (Name.unsafeFromVar v))) + pure ([go lastSegment (snd <$> fields)], [(name, fields)]) (constructors, accessors) <- msum [record, (,[]) <$> sepBy (reserved "|") dataConstructor] _ <- closeBlock diff --git a/unison-src/transcripts/fix2628.md b/unison-src/transcripts/fix2628.md new file mode 100644 index 0000000000..5c3ec8df50 --- /dev/null +++ b/unison-src/transcripts/fix2628.md @@ -0,0 +1,15 @@ +```ucm:hide +.> alias.type ##Nat .base.Nat +``` + +```unison:hide +unique type foo.bar.baz.MyRecord = { + value : Nat +} +``` + +```ucm +.> add + +.> find : Nat -> MyRecord +``` diff --git a/unison-src/transcripts/fix2628.output.md b/unison-src/transcripts/fix2628.output.md new file mode 100644 index 0000000000..8faf5b36cb --- /dev/null +++ b/unison-src/transcripts/fix2628.output.md @@ -0,0 +1,26 @@ +```unison +unique type foo.bar.baz.MyRecord = { + value : Nat +} +``` + +```ucm +.> add + + โŸ I've added these definitions: + + unique type foo.bar.baz.MyRecord + foo.bar.baz.MyRecord.value : MyRecord -> Nat + foo.bar.baz.MyRecord.value.modify : (Nat ->{g} Nat) + -> MyRecord + ->{g} MyRecord + foo.bar.baz.MyRecord.value.set : Nat + -> MyRecord + -> MyRecord + +.> find : Nat -> MyRecord + + 1. foo.bar.baz.MyRecord.MyRecord : Nat -> MyRecord + + +```