diff --git a/codebase2/codebase-sqlite/U/Codebase/Causal/Squash.hs b/codebase2/codebase-sqlite/U/Codebase/Causal/Squash.hs deleted file mode 100644 index b00e0ef59a..0000000000 --- a/codebase2/codebase-sqlite/U/Codebase/Causal/Squash.hs +++ /dev/null @@ -1,31 +0,0 @@ -module U.Codebase.Causal.Squash (squashCausal) where - -import U.Codebase.Branch.Type -import U.Codebase.Causal (Causal (..)) -import U.Codebase.Sqlite.HashHandle qualified as HH -import U.Codebase.Sqlite.Operations qualified as SqliteOps -import Unison.Prelude -import Unison.Sqlite qualified as Sqlite - --- Recursively discards history, resulting in a namespace tree with only single a single --- Causal node at every level. -squashCausal :: HH.HashHandle -> CausalBranch Sqlite.Transaction -> Sqlite.Transaction (CausalBranch Sqlite.Transaction) -squashCausal hashHandle@HH.HashHandle {hashCausal, hashBranch} Causal {valueHash = unsquashedBranchHash, value} = do - runMaybeT (MaybeT (SqliteOps.tryGetSquashResult unsquashedBranchHash) >>= MaybeT . SqliteOps.loadCausalBranchByCausalHash) >>= \case - Just cb -> pure cb - Nothing -> do - branch@Branch {children} <- value - squashedChildren <- traverse (squashCausal hashHandle) children - let squashedBranchHead = branch {children = squashedChildren} - squashedBranchHash <- hashBranch squashedBranchHead - let squashedCausalHash = hashCausal squashedBranchHash mempty - let squashedCausalBranch = - Causal - { causalHash = squashedCausalHash, - valueHash = squashedBranchHash, - parents = mempty, - value = pure squashedBranchHead - } - SqliteOps.saveBranch hashHandle squashedCausalBranch - SqliteOps.saveSquashResult unsquashedBranchHash squashedCausalHash - pure squashedCausalBranch diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs index ce07a487fb..f8693b6694 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs @@ -1,7 +1,6 @@ module U.Codebase.Sqlite.Branch.Format ( BranchFormat' (..), BranchFormat, - HashBranchFormat, BranchLocalIds, BranchLocalIds' (..), HashBranchLocalIds, @@ -49,13 +48,6 @@ data -- | The 'BranchFormat'' used to store a branch in Sqlite type BranchFormat = BranchFormat' TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId) BranchObjectId --- | A BranchFormat which uses Hashes and Text for all its references, no --- Ids which are specific to a particular codebase. -type HashBranchFormat = BranchFormat' Text ComponentHash PatchHash (BranchHash, CausalHash) - --- = Full BranchLocalIds LocalBranch --- \| Diff BranchObjectId BranchLocalIds LocalDiff - -- | A 'BranchLocalIds' is a mapping between local ids (local to this object) encoded as offsets, and actual database ids. -- -- For example, a @branchTextLookup@ vector of @[50, 74]@ means "local id 0 corresponds to database text id 50, and diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Full.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Full.hs index 7fbd2b77da..34c42f9fb1 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Full.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Full.hs @@ -74,10 +74,6 @@ patches_ f Branch {..} = (\newPatches -> Branch terms types newPatches children) childrenHashes_ :: Traversal (Branch' t h p c) (Branch' t h p c') c c' childrenHashes_ f Branch {..} = Branch terms types patches <$> traverse f children -branchCausalHashes_ :: Traversal (Branch' t h p c) (Branch' t h p c') c c' -branchCausalHashes_ f Branch {..} = - Branch terms types patches <$> traverse f children - type LocalMetadataSet = MetadataSetFormat' LocalTextId LocalDefnId type DbMetadataSet = MetadataSetFormat' TextId ObjectId @@ -105,19 +101,3 @@ quadmapM ft fh fp fc (Branch terms types patches children) = doTerms = Map.bitraverse (bitraverse (bitraverse ft fh) (bitraverse ft fh)) doMetadata doTypes = Map.bitraverse (bitraverse ft fh) doMetadata doMetadata (Inline s) = Inline <$> Set.traverse (bitraverse ft fh) s - --- | Traversal over text references in a branch -t_ :: (Ord t', Ord h) => Traversal (Branch' t h p c) (Branch' t' h p c) t t' -t_ f = quadmapM f pure pure pure - --- | Traversal over hash references in a branch -h_ :: (Ord t, Ord h') => Traversal (Branch' t h p c) (Branch' t h' p c) h h' -h_ f = quadmapM pure f pure pure - --- | Traversal over patch references in a branch -p_ :: (Ord t, Ord h) => Traversal (Branch' t h p c) (Branch' t h p' c) p p' -p_ f = quadmapM pure pure f pure - --- | Traversal over child references in a branch -c_ :: (Ord t, Ord h) => Traversal (Branch' t h p c) (Branch' t h p c') c c' -c_ f = quadmapM pure pure pure f diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs index 582bfc65a3..d017e8456b 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs @@ -1,6 +1,5 @@ module U.Codebase.Sqlite.Causal - ( DbCausal, - GDbCausal (..), + ( GDbCausal (..), SyncCausalFormat, SyncCausalFormat' (..), ) @@ -16,8 +15,6 @@ data GDbCausal causalHash valueHash = DbCausal parents :: Set causalHash } -type DbCausal = GDbCausal CausalHashId BranchHashId - data SyncCausalFormat' causalHash valueHash = SyncCausalFormat { valueHash :: valueHash, parents :: Vector causalHash diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs index 8dedcfbe25..87773376e3 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/DbId.hs @@ -9,7 +9,7 @@ import Unison.Sqlite (FromField, ToField) newtype HashVersion = HashVersion Word64 deriving stock (Eq, Ord, Show) - deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via Word64 + deriving (Num, ToField) via Word64 newtype ObjectId = ObjectId Word64 deriving (Eq, Ord, Show) @@ -25,7 +25,7 @@ newtype HashId = HashId Word64 newtype PatchObjectId = PatchObjectId {unPatchObjectId :: ObjectId} deriving (Eq, Ord) - deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via ObjectId + deriving (Num, Real, Enum, Integral, Bits) via ObjectId newtype BranchObjectId = BranchObjectId {unBranchObjectId :: ObjectId} deriving (Eq, Ord) @@ -33,7 +33,7 @@ newtype BranchObjectId = BranchObjectId {unBranchObjectId :: ObjectId} newtype BranchHashId = BranchHashId {unBranchHashId :: HashId} deriving (Eq, Ord) - deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via HashId + deriving (FromField, ToField) via HashId newtype CausalHashId = CausalHashId {unCausalHashId :: HashId} deriving (Eq, Ord) @@ -53,7 +53,7 @@ newtype RemoteProjectId = RemoteProjectId {unRemoteProjectId :: Text} newtype SchemaVersion = SchemaVersion Word64 deriving (Eq, Ord, Show) - deriving (Num, Real, Enum, Integral, Bits, FromField, ToField) via Word64 + deriving (Num, Real, Enum, Integral, FromField, ToField) via Word64 instance Show PatchObjectId where show h = "PatchObjectId (" ++ show (unPatchObjectId h) ++ ")" diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs index c2df6ef2f6..9d825305ca 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decode.hs @@ -16,7 +16,6 @@ module U.Codebase.Sqlite.Decode decodeSyncTermAndType, decodeTermElementDiscardingTerm, decodeTermElementDiscardingType, - decodeTermElementWithType, decodeTermFormat, -- * @temp_entity.blob@ @@ -133,13 +132,6 @@ decodeTermElementDiscardingType :: C.Reference.Pos -> ByteString -> Either Decod 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 diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs index d8645b81ae..0976387302 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs @@ -37,9 +37,6 @@ newtype LocalPatchObjectId = LocalPatchObjectId Word64 deriving (Eq, Ord, Show, newtype LocalBranchChildId = LocalBranchChildId Word64 deriving (Eq, Ord, Show, Num, Real, Enum, Integral, Bits) via Word64 --- | causal hashes are treated differently from HashIds, which don't have dependencies -newtype LocalCausalHashId = LocalCausalHashId Word64 deriving (Eq, Ord, Show, Num, Real, Enum, Integral, Bits) via Word64 - instance Bitraversable LocalIds' where bitraverse f g (LocalIds t d) = LocalIds <$> traverse f t <*> traverse g d @@ -48,9 +45,3 @@ instance Bifoldable LocalIds' where instance Bifunctor LocalIds' where bimap f g (LocalIds t d) = LocalIds (f <$> t) (g <$> d) - -t_ :: Traversal (LocalIds' t h) (LocalIds' t' h) t t' -t_ f (LocalIds t d) = LocalIds <$> traverse f t <*> pure d - -h_ :: Traversal (LocalIds' t h) (LocalIds' t h') h h' -h_ f (LocalIds t d) = LocalIds <$> pure t <*> traverse f d diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/NameLookups.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/NameLookups.hs index 33a6793a41..692dc346ca 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/NameLookups.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/NameLookups.hs @@ -3,11 +3,7 @@ -- access to those domain types given the package dependency tree. module U.Codebase.Sqlite.NameLookups ( ReversedName (..), - ReversedPath (..), PathSegments (..), - NamespaceText, - reversedNameToNamespaceText, - reversedNameToPathSegments, pathSegmentsToText, textToPathSegments, ) @@ -20,20 +16,11 @@ import Unison.Prelude newtype ReversedName = ReversedName (NonEmpty Text) deriving stock (Eq, Ord, Show) -instance From ReversedName (NonEmpty Text) - instance From (NonEmpty Text) ReversedName instance From ReversedName [Text] where from (ReversedName n) = toList n -newtype ReversedPath = ReversedPath [Text] - deriving (Eq, Ord, Show) - -instance From ReversedPath [Text] - -instance From [Text] ReversedPath - newtype PathSegments = PathSegments [Text] deriving stock (Eq, Ord, Show) deriving newtype (Semigroup, Monoid) @@ -42,10 +29,6 @@ instance From PathSegments [Text] instance From [Text] PathSegments --- | A namespace rendered as a path, no leading '.' --- E.g. "base.data" -type NamespaceText = Text - -- | -- >>> pathSegmentsToText (PathSegments ["base", "data", "List"]) -- "base.data.List" @@ -57,12 +40,3 @@ pathSegmentsToText (PathSegments txt) = Text.intercalate "." txt -- PathSegments ["base","data","List"] textToPathSegments :: Text -> PathSegments textToPathSegments txt = PathSegments $ Text.splitOn "." txt - --- | --- >>> reversedSegmentsToNamespaceText (["List", "data", "base"]) --- "base.data.List" -reversedNameToNamespaceText :: ReversedName -> NamespaceText -reversedNameToNamespaceText (ReversedName txt) = Text.intercalate "." . reverse . toList $ txt - -reversedNameToPathSegments :: ReversedName -> PathSegments -reversedNameToPathSegments (ReversedName revName) = PathSegments . reverse . toList $ revName diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs index 1f91746219..3bc5d8dbdb 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/NamedRef.hs @@ -1,6 +1,5 @@ module U.Codebase.Sqlite.NamedRef where -import Data.List.NonEmpty qualified as NEL import Data.List.NonEmpty qualified as NonEmpty import Data.Text qualified as Text import U.Codebase.Sqlite.NameLookups (ReversedName) @@ -11,11 +10,6 @@ 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 @@ -26,16 +20,6 @@ instance FromField (ConstructorType) where data NamedRef ref = NamedRef {reversedSegments :: ReversedName, ref :: ref} deriving stock (Show, Functor, Foldable, Traversable) -instance (ToRow ref) => ToRow (NamedRef ref) where - toRow (NamedRef {reversedSegments = segments, ref}) = - [toField reversedName] <> toRow ref - where - reversedName = - segments - & into @[Text] - & Text.intercalate "." - & (<> ".") -- Add trailing dot, see notes on scoped_term_name_lookup schema - instance (FromRow ref) => FromRow (NamedRef ref) where fromRow = do reversedSegments <- @@ -47,21 +31,3 @@ instance (FromRow ref) => FromRow (NamedRef ref) where & into @ReversedName ref <- fromRow pure (NamedRef {reversedSegments, ref}) - --- | The new 'scoped' name lookup format is different from the old version. --- --- Specifically, the scoped format adds the 'lastNameSegment' as well as adding a trailing '.' to the db format --- of both the namespace and reversed_name. --- --- This type has a ToRow instance of the form: --- [reversedName, namespace, lastNameSegment] <> ref fields... -newtype ScopedRow ref - = ScopedRow (NamedRef ref) - -instance (ToRow ref) => ToRow (ScopedRow ref) where - toRow (ScopedRow (NamedRef {reversedSegments = revSegments, ref})) = - SQLText reversedName : SQLText namespace : SQLText lastNameSegment : toRow ref - where - reversedName = (Text.intercalate "." . into @[Text] $ revSegments) <> "." - namespace = (Text.intercalate "." . reverse . NEL.tail . from $ revSegments) <> "." - lastNameSegment = NEL.head . from $ revSegments diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 5c4e083616..8a644ad398 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -1,9 +1,5 @@ module U.Codebase.Sqlite.Operations ( -- * branches - loadCausalHashAtPath, - expectCausalHashAtPath, - loadCausalBranchAtPath, - loadBranchAtPath, saveBranch, saveBranchV3, loadCausalBranchByCausalHash, @@ -13,8 +9,6 @@ module U.Codebase.Sqlite.Operations expectBranchByBranchHashId, expectNamespaceStatsByHash, expectNamespaceStatsByHashId, - tryGetSquashResult, - saveSquashResult, -- * terms Q.saveTermComponent, @@ -49,7 +43,6 @@ module U.Codebase.Sqlite.Operations -- * indexes -- ** nearest common ancestor - before, lca, -- ** prefix index @@ -81,23 +74,12 @@ module U.Codebase.Sqlite.Operations NamesPerspective (..), termNamesForRefWithinNamespace, typeNamesForRefWithinNamespace, - termNamesBySuffix, - typeNamesBySuffix, - termRefsForExactName, - typeRefsForExactName, - recursiveTermNameSearch, - recursiveTypeNameSearch, checkBranchHashNameLookupExists, - buildNameLookupForBranchHash, - associateNameLookupMounts, longestMatchingTermNameForSuffixification, longestMatchingTypeNameForSuffixification, - deleteNameLookupsExceptFor, - fuzzySearchDefinitions, namesPerspectiveForRootAndPath, -- * Projects - expectProjectAndBranchNames, expectProjectBranchHead, -- * reflog @@ -105,28 +87,19 @@ module U.Codebase.Sqlite.Operations getProjectReflog, getProjectBranchReflog, getGlobalReflog, - appendProjectReflog, -- * low-level stuff expectDbBranch, - saveDbBranch, saveDbBranchUnderHashId, expectDbPatch, saveDbPatch, - expectDbBranchByCausalHashId, namespaceStatsForDbBranch, -- * somewhat unexpectedly unused definitions c2sReferenceId, c2sReferentId, - diffPatch, - decodeTermElementWithType, - loadTermWithTypeByReference, Q.s2cTermWithType, Q.s2cDecl, - declReferencesByPrefix, - namespaceHashesByPrefix, - derivedDependencies, -- * internal stuff that probably need not be exported, but the 1->2 migration needs it BranchV (..), @@ -138,13 +111,12 @@ import Control.Lens hiding (children) import Control.Monad.Extra qualified as Monad import Data.Bitraversable (Bitraversable (bitraverse)) import Data.Foldable qualified as Foldable -import Data.List.Extra qualified as List import Data.List.NonEmpty.Extra qualified as NonEmpty import Data.Map qualified as Map import Data.Map.Merge.Lazy qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text -import Data.Tuple.Extra (uncurry3, (***)) +import Data.Tuple.Extra (uncurry3) import U.Codebase.Branch.Type (NamespaceStats (..)) import U.Codebase.Branch.Type qualified as C.Branch import U.Codebase.BranchV3 qualified as C.BranchV3 @@ -181,7 +153,7 @@ import U.Codebase.Sqlite.ObjectType qualified as ObjectType import U.Codebase.Sqlite.Patch.Diff qualified as S import U.Codebase.Sqlite.Patch.Format qualified as S import U.Codebase.Sqlite.Patch.Format qualified as S.Patch.Format -import U.Codebase.Sqlite.Patch.Full qualified as S (LocalPatch, Patch, Patch' (..)) +import U.Codebase.Sqlite.Patch.Full qualified as S (Patch, Patch' (..)) import U.Codebase.Sqlite.Patch.TermEdit qualified as S import U.Codebase.Sqlite.Patch.TermEdit qualified as S.TermEdit import U.Codebase.Sqlite.Patch.TypeEdit qualified as S @@ -206,13 +178,11 @@ import U.Codebase.TypeEdit qualified as C.TypeEdit import U.Codebase.WatchKind (WatchKind) import U.Util.Base32Hex qualified as Base32Hex import U.Util.Serialization qualified as S -import Unison.Core.Project (ProjectBranchName, ProjectName) import Unison.Hash qualified as H import Unison.Hash32 qualified as Hash32 import Unison.NameSegment (NameSegment) -import Unison.NameSegment.Internal qualified as NameSegment import Unison.Prelude -import Unison.ShortHash (ShortCausalHash (..), ShortNamespaceHash (..)) +import Unison.ShortHash (ShortCausalHash (..)) import Unison.Sqlite import Unison.Util.Defns (DefnsF) import Unison.Util.List qualified as List @@ -239,53 +209,6 @@ expectValueHashByCausalHashId = loadValueHashById <=< Q.expectCausalValueHashId loadValueHashById :: Db.BranchHashId -> Transaction BranchHash loadValueHashById = fmap BranchHash . Q.expectHash . Db.unBranchHashId --- | Load the causal hash at the given path from the provided root, if Nothing, use the --- codebase root. -loadCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe CausalHash) -loadCausalHashAtPath rootCausalHash = - let go :: Db.CausalHashId -> [NameSegment] -> MaybeT Transaction CausalHash - go hashId = \case - [] -> lift (Q.expectCausalHash hashId) - t : ts -> do - tid <- MaybeT (Q.loadTextId $ NameSegment.toUnescapedText t) - S.Branch {children} <- MaybeT (loadDbBranchByCausalHashId hashId) - (_, hashId') <- MaybeT (pure (Map.lookup tid children)) - go hashId' ts - in \path -> do - hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash - runMaybeT (go hashId path) - --- | Expect the causal hash at the given path from the provided root, if Nothing, use the --- codebase root. -expectCausalHashAtPath :: CausalHash -> [NameSegment] -> Transaction CausalHash -expectCausalHashAtPath rootCausalHash = - let go :: Db.CausalHashId -> [NameSegment] -> Transaction CausalHash - go hashId = \case - [] -> Q.expectCausalHash hashId - t : ts -> do - tid <- Q.expectTextId $ NameSegment.toUnescapedText t - S.Branch {children} <- expectDbBranchByCausalHashId hashId - let (_, hashId') = children Map.! tid - go hashId' ts - in \path -> do - hashId <- Q.expectCausalHashIdByCausalHash rootCausalHash - go hashId path - -loadCausalBranchAtPath :: - CausalHash -> - [NameSegment] -> - Transaction (Maybe (C.Branch.CausalBranch Transaction)) -loadCausalBranchAtPath rootCausalHash path = - loadCausalHashAtPath rootCausalHash path >>= \case - Nothing -> pure Nothing - Just causalHash -> Just <$> expectCausalBranchByCausalHash causalHash - -loadBranchAtPath :: CausalHash -> [NameSegment] -> Transaction (Maybe (C.Branch.Branch Transaction)) -loadBranchAtPath rootCausalHash path = - loadCausalBranchAtPath rootCausalHash path >>= \case - Nothing -> pure Nothing - Just causal -> Just <$> C.Causal.value causal - -- * Reference transformations -- ** read existing references @@ -331,11 +254,6 @@ 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 @@ -395,25 +313,6 @@ c2sPatch (C.Branch.Patch termEdits typeEdits) = C.TypeEdit.Replace r -> S.TypeEdit.Replace <$> c2sReference r C.TypeEdit.Deprecate -> pure S.TypeEdit.Deprecate --- | produces a diff --- diff = full - ref; full = diff + ref -diffPatch :: S.LocalPatch -> S.LocalPatch -> S.LocalPatchDiff -diffPatch (S.Patch fullTerms fullTypes) (S.Patch refTerms refTypes) = - (S.PatchDiff addTermEdits addTypeEdits removeTermEdits removeTypeEdits) - where - -- add: present in full. but absent in ref. - addTermEdits = Map.merge Map.preserveMissing Map.dropMissing addDiffSet fullTerms refTerms - addTypeEdits = Map.merge Map.preserveMissing Map.dropMissing addDiffSet fullTypes refTypes - -- remove: present in ref. but absent in full. - removeTermEdits = Map.merge Map.dropMissing Map.preserveMissing removeDiffSet fullTerms refTerms - removeTypeEdits = Map.merge Map.dropMissing Map.preserveMissing removeDiffSet fullTypes refTypes - -- things that are present in full but absent in ref - addDiffSet, - removeDiffSet :: - (Ord k, Ord a) => Map.WhenMatched Identity k (Set a) (Set a) (Set a) - addDiffSet = Map.zipWithMatched (const Set.difference) - removeDiffSet = Map.zipWithMatched (const (flip Set.difference)) - getCycleLen :: H.Hash -> Transaction (Maybe Word64) getCycleLen h = do when debug $ traceM $ "\ngetCycleLen " ++ (Text.unpack . Base32Hex.toText $ H.toBase32Hex h) @@ -448,13 +347,6 @@ loadTermComponent h = do S.Term.Term (S.Term.LocallyIndexedComponent elements) <- MaybeT (Q.loadTermObject oid decodeTermFormat) 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 (Q.s2cTermWithType localIds term typ) - loadTermByReference :: C.Reference.Id -> MaybeT Transaction (C.Term Symbol) loadTermByReference r@(C.Reference.Id h i) = do when debug . traceM $ "loadTermByReference " ++ show r @@ -755,13 +647,6 @@ 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 - expectBranchByBranchHashId :: Db.BranchHashId -> Transaction (C.Branch.Branch Transaction) expectBranchByBranchHashId bhId = do boId <- Q.expectBranchObjectIdByBranchHashId bhId @@ -772,12 +657,6 @@ expectBranchByBranchHash bh = do bhId <- Q.expectBranchHashId bh expectBranchByBranchHashId bhId --- | 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 @@ -884,20 +763,6 @@ 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 :: - HashHandle -> - BranchHash -> - C.Branch.NamespaceStats -> - DbBranchV -> - Transaction Db.BranchObjectId -saveDbBranch hh hash stats branch = do - hashId <- Q.saveBranchHash hash - saveDbBranchUnderHashId hh hashId stats branch - -- | Variant of 'saveDbBranch' that might be preferred by callers that already have a hash id, not a hash. saveDbBranchUnderHashId :: HashHandle -> @@ -990,13 +855,6 @@ lca h1 h2 = runMaybeT do chId3 <- MaybeT $ Q.lca chId1 chId2 lift (Q.expectCausalHash chId3) -before :: CausalHash -> CausalHash -> Transaction (Maybe Bool) -before h1 h2 = runMaybeT do - chId2 <- MaybeT $ Q.loadCausalHashIdByCausalHash h2 - lift (Q.loadCausalHashIdByCausalHash h1) >>= \case - Just chId1 -> lift (Q.before chId1 chId2) - Nothing -> pure False - -- * Searches termsHavingType :: C.Reference -> Transaction (Set C.Referent.Id) @@ -1051,11 +909,6 @@ termReferencesByPrefix 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 ObjectType.DeclComponent t w - >>= traverse (C.Reference.idH Q.expectPrimaryHashByObjectId) - termReferentsByPrefix :: Text -> Maybe Word64 -> Transaction [C.Referent.Id] termReferentsByPrefix b32prefix pos = fmap C.Referent.RefId <$> termReferencesByPrefix b32prefix pos @@ -1089,12 +942,6 @@ declReferentsByPrefix b32prefix pos cid = do (_localIds, decl) <- Q.expectDeclObject r (decodeDeclElement i) pure (C.Decl.declType decl, length (C.Decl.constructorTypes decl)) -namespaceHashesByPrefix :: ShortNamespaceHash -> Transaction (Set BranchHash) -namespaceHashesByPrefix (ShortNamespaceHash b32prefix) = do - hashIds <- Q.namespaceHashIdByBase32Prefix b32prefix - hashes <- traverse (Q.expectHash . Db.unBranchHashId) hashIds - pure $ Set.fromList . map BranchHash $ hashes - causalHashesByPrefix :: ShortCausalHash -> Transaction (Set CausalHash) causalHashesByPrefix (ShortCausalHash b32prefix) = do hashIds <- Q.causalHashIdByBase32Prefix b32prefix @@ -1178,57 +1025,6 @@ dependentsOfComponent h = do cIds <- traverse s2cReferenceId sIds pure $ Set.fromList cIds --- | returns empty set for unknown inputs; doesn't distinguish between term and decl -derivedDependencies :: C.Reference.Id -> Transaction (Set C.Reference.Id) -derivedDependencies cid = do - sid <- c2sReferenceId cid - sids <- Q.getDependencyIdsForDependent sid - cids <- traverse s2cReferenceId sids - pure $ Set.fromList cids - --- | Apply a set of name updates to an existing index. -buildNameLookupForBranchHash :: - -- The existing name lookup index to copy before applying the diff. - -- If Nothing, run the diff against an empty index. - -- If Just, the name lookup must exist or an error will be thrown. - Maybe BranchHash -> - BranchHash -> - ( ( -- (add terms, remove terms) - ([S.NamedRef (C.Referent, Maybe C.ConstructorType)], [S.NamedRef C.Referent]) -> - -- (add types, remove types) - ([S.NamedRef C.Reference], [S.NamedRef C.Reference]) -> - Transaction () - ) -> - Transaction () - ) -> - Transaction () -buildNameLookupForBranchHash mayExistingBranchIndex newBranchHash callback = do - newBranchHashId <- Q.expectBranchHashId newBranchHash - Q.trackNewBranchHashNameLookup newBranchHashId - case mayExistingBranchIndex of - Nothing -> pure () - Just existingBranchIndex -> do - unlessM (checkBranchHashNameLookupExists existingBranchIndex) $ error "buildNameLookupForBranchHash: existingBranchIndex was provided, but no index was found for that branch hash." - existingBranchHashId <- Q.expectBranchHashId existingBranchIndex - Q.copyScopedNameLookup existingBranchHashId newBranchHashId - callback \(newTermNames, removedTermNames) (newTypeNames, removedTypeNames) -> do - Q.removeScopedTermNames newBranchHashId ((fmap c2sTextReferent <$> removedTermNames)) - Q.removeScopedTypeNames newBranchHashId ((fmap c2sTextReference <$> removedTypeNames)) - Q.insertScopedTermNames newBranchHashId (fmap (c2sTextReferent *** fmap c2sConstructorType) <$> newTermNames) - Q.insertScopedTypeNames newBranchHashId (fmap c2sTextReference <$> newTypeNames) - --- | Save a list of (mount-path, branch hash) mounts for the provided name lookup index branch --- hash. --- --- E.g. associateNameLookupMounts #roothash [(["lib", "base"], #basehash)] -associateNameLookupMounts :: BranchHash -> [(PathSegments, BranchHash)] -> Transaction () -associateNameLookupMounts rootBh dependencyMounts = do - rootBhId <- Q.expectBranchHashId rootBh - depMounts <- for dependencyMounts \(path, branchHash) -> do - branchHashId <- Q.expectBranchHashId branchHash - pure (path, branchHashId) - Q.associateNameLookupMounts rootBhId depMounts - -- | Any time we need to lookup or search names we need to know what the scope of that search -- should be. This can be complicated to keep track of, so this is a helper type to make it -- easy to pass around. @@ -1348,28 +1144,6 @@ typeNamesForRefWithinNamespace NamesPerspective {nameLookupBranchHashId, pathToM Q.typeNamesForRefWithinNamespace nameLookupBranchHashId mempty (c2sTextReference ref) maySuffix <&> fmap (prefixReversedName pathToMountedNameLookup) -termNamesBySuffix :: NamesPerspective -> S.ReversedName -> Transaction [S.NamedRef (C.Referent, Maybe C.ConstructorType)] -termNamesBySuffix NamesPerspective {nameLookupBranchHashId, pathToMountedNameLookup} suffix = do - Q.termNamesBySuffix nameLookupBranchHashId mempty suffix - <&> fmap (prefixNamedRef pathToMountedNameLookup >>> fmap (bimap s2cTextReferent (fmap s2cConstructorType))) - -typeNamesBySuffix :: NamesPerspective -> S.ReversedName -> Transaction [S.NamedRef C.Reference] -typeNamesBySuffix NamesPerspective {nameLookupBranchHashId, pathToMountedNameLookup} suffix = do - Q.typeNamesBySuffix nameLookupBranchHashId mempty suffix - <&> fmap (prefixNamedRef pathToMountedNameLookup >>> fmap s2cTextReference) - --- | Helper for findings refs by name within the correct mounted indexes. -refsForExactName :: - (Db.BranchHashId -> S.ReversedName -> Transaction [S.NamedRef ref]) -> - NamesPerspective -> - S.ReversedName -> - Transaction [S.NamedRef ref] -refsForExactName query NamesPerspective {nameLookupBranchHashId, pathToMountedNameLookup} name = do - namedRefs <- query nameLookupBranchHashId name - pure $ - namedRefs - <&> prefixNamedRef pathToMountedNameLookup - -- | Requalifies a NamedRef to some namespace prefix. prefixNamedRef :: NameLookups.PathSegments -> S.NamedRef ref -> S.NamedRef ref prefixNamedRef prefix S.NamedRef {reversedSegments, ref} = @@ -1380,15 +1154,6 @@ prefixReversedName :: PathSegments -> S.ReversedName -> S.ReversedName prefixReversedName (S.PathSegments prefix) (S.ReversedName reversedSegments) = S.ReversedName $ NonEmpty.appendl reversedSegments (reverse prefix) -termRefsForExactName :: NamesPerspective -> S.ReversedName -> Transaction [S.NamedRef (C.Referent, Maybe C.ConstructorType)] -termRefsForExactName namesPerspective reversedName = do - refsForExactName Q.termRefsForExactName namesPerspective reversedName - <&> fmap (fmap (bimap s2cTextReferent (fmap s2cConstructorType))) - -typeRefsForExactName :: NamesPerspective -> S.ReversedName -> Transaction [S.NamedRef C.Reference] -typeRefsForExactName namesPerspective reversedName = do - refsForExactName Q.typeRefsForExactName namesPerspective reversedName <&> fmap (fmap s2cTextReference) - -- | Get the name within the provided namespace that has the longest matching suffix -- with the provided name, but a different ref. -- This is a bit of a hack but allows us to shortcut suffixification. @@ -1409,38 +1174,6 @@ longestMatchingTypeNameForSuffixification NamesPerspective {nameLookupBranchHash Q.longestMatchingTypeNameForSuffixification nameLookupBranchHashId mempty (c2sTextReference <$> namedRef) <&> fmap (prefixNamedRef pathToMountedNameLookup >>> fmap s2cTextReference) --- | Searches all dependencies transitively looking for the provided ref within the --- provided namespace. --- Prefer 'termNamesForRefWithinNamespace' in most cases. --- This is slower and only necessary when resolving the name of refs when you don't know which --- dependency it may exist in. --- --- Searching transitive dependencies is exponential so we want to replace this with a more --- efficient approach as soon as possible. --- --- Note: this returns the first name it finds by searching in order of: --- Names in the current namespace, then names in the current namespace's dependencies, then --- through the current namespace's dependencies' dependencies, etc. -recursiveTermNameSearch :: NamesPerspective -> C.Referent -> Transaction (Maybe S.ReversedName) -recursiveTermNameSearch NamesPerspective {nameLookupBranchHashId} r = do - Q.recursiveTermNameSearch nameLookupBranchHashId (c2sTextReferent r) - --- | Searches all dependencies transitively looking for the provided ref within the provided --- namespace. --- Prefer 'typeNamesForRefWithinNamespace' in most cases. --- This is slower and only necessary when resolving the name of references when you don't know which --- dependency it may exist in. --- --- Searching transitive dependencies is exponential so we want to replace this with a more --- efficient approach as soon as possible. --- --- Note: this returns the first name it finds by searching in order of: --- Names in the current namespace, then names in the current namespace's dependencies, then --- through the current namespace's dependencies' dependencies, etc. -recursiveTypeNameSearch :: NamesPerspective -> C.Reference -> Transaction (Maybe S.ReversedName) -recursiveTypeNameSearch NamesPerspective {nameLookupBranchHashId} r = do - Q.recursiveTypeNameSearch nameLookupBranchHashId (c2sTextReference r) - -- | Looks up statistics for a given branch, if none exist, we compute them and save them -- then return them. expectNamespaceStatsByHash :: BranchHash -> Transaction C.Branch.NamespaceStats @@ -1520,82 +1253,6 @@ hydrateProjectReflogEntry entry = do pure (proj, branch) ) -appendProjectReflog :: ProjectReflog.Entry Db.ProjectId Db.ProjectBranchId CausalHash -> Transaction () -appendProjectReflog entry = do - dbEntry <- traverse Q.saveCausalHash entry - Q.appendProjectBranchReflog dbEntry - --- | Delete any name lookup that's not in the provided list. --- --- This can be used to garbage collect unreachable name lookups. -deleteNameLookupsExceptFor :: Set BranchHash -> Transaction () -deleteNameLookupsExceptFor reachable = do - bhIds <- for (Set.toList reachable) Q.expectBranchHashId - Q.deleteNameLookupsExceptFor bhIds - --- | Get the causal hash which would be the result of squashing the provided branch hash. --- Returns Nothing if we haven't computed it before. -tryGetSquashResult :: BranchHash -> Transaction (Maybe CausalHash) -tryGetSquashResult bh = do - bhId <- Q.expectBranchHashId bh - chId <- Q.tryGetSquashResult bhId - traverse Q.expectCausalHash chId - --- | Saves the result of a squash -saveSquashResult :: BranchHash -> CausalHash -> Transaction () -saveSquashResult bh ch = do - bhId <- Q.expectBranchHashId bh - chId <- Q.saveCausalHash ch - Q.saveSquashResult bhId chId - --- | Search for term or type names which contain the provided list of segments in order. --- Search is case insensitive. -fuzzySearchDefinitions :: - Bool -> - NamesPerspective -> - -- | Will return at most n terms and n types; i.e. max number of results is 2n - Int -> - [Text] -> - Transaction ([S.NamedRef (C.Referent, Maybe C.ConstructorType)], [S.NamedRef C.Reference]) -fuzzySearchDefinitions includeDependencies NamesPerspective {nameLookupBranchHashId, relativePerspective} limit querySegments = do - termNames <- - Q.fuzzySearchTerms includeDependencies nameLookupBranchHashId limit relativePerspective querySegments - <&> fmap \termName -> - termName - & (fmap (bimap s2cTextReferent (fmap s2cConstructorType))) - & stripPrefixFromNamedRef relativePerspective - typeNames <- - Q.fuzzySearchTypes includeDependencies nameLookupBranchHashId limit relativePerspective querySegments - <&> fmap (fmap s2cTextReference) - <&> fmap \typeName -> - typeName - & stripPrefixFromNamedRef relativePerspective - pure (termNames, typeNames) - --- | Strips a prefix path from a named ref. No-op if the prefix doesn't match. --- --- >>> stripPrefixFromNamedRef (PathSegments ["foo", "bar"]) (S.NamedRef (S.ReversedName ("baz" NonEmpty.:| ["bar", "foo"])) ()) --- NamedRef {reversedSegments = ReversedName ("baz" :| []), ref = ()} --- --- >>> stripPrefixFromNamedRef (PathSegments ["no", "match"]) (S.NamedRef (S.ReversedName ("baz" NonEmpty.:| ["bar", "foo"])) ()) --- NamedRef {reversedSegments = ReversedName ("baz" :| ["bar","foo"]), ref = ()} -stripPrefixFromNamedRef :: PathSegments -> S.NamedRef r -> S.NamedRef r -stripPrefixFromNamedRef (PathSegments prefix) namedRef = - let newReversedName = - S.reversedSegments namedRef - & \case - reversedName@(S.ReversedName (name NonEmpty.:| reversedPath)) -> - case List.stripSuffix (reverse prefix) reversedPath of - Nothing -> reversedName - Just strippedReversedPath -> S.ReversedName (name NonEmpty.:| strippedReversedPath) - in namedRef {S.reversedSegments = newReversedName} - -expectProjectAndBranchNames :: Db.ProjectId -> Db.ProjectBranchId -> Transaction (ProjectName, ProjectBranchName) -expectProjectAndBranchNames projectId projectBranchId = do - Project {name = pName} <- Q.expectProject projectId - ProjectBranch {name = bName} <- Q.expectProjectBranch projectId projectBranchId - pure (pName, bName) - expectProjectBranchHead :: Db.ProjectId -> Db.ProjectBranchId -> Transaction CausalHash expectProjectBranchHead projId projectBranchId = do chId <- Q.expectProjectBranchHead projId projectBranchId diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Orphans.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Orphans.hs index fc71d102fe..e29628a2c6 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Orphans.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Orphans.hs @@ -3,55 +3,15 @@ module U.Codebase.Sqlite.Orphans where -import Control.Applicative import U.Codebase.Branch.Type (NamespaceStats (..)) -import U.Codebase.Reference qualified as C.Reference -import U.Codebase.Referent qualified as C.Referent import U.Codebase.Reflog qualified as Reflog import U.Codebase.Sqlite.DbId import U.Codebase.WatchKind (WatchKind) import U.Codebase.WatchKind qualified as WatchKind import U.Util.Base32Hex -import Unison.Hash qualified 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 @@ -61,13 +21,6 @@ instance ToField WatchKind where 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 - instance ToRow NamespaceStats where toRow (NamespaceStats {numContainedTerms, numContainedTypes, numContainedPatches}) = toRow (numContainedTerms, numContainedTypes, numContainedPatches) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs index 7defa50234..a732887c2e 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs @@ -7,7 +7,6 @@ module U.Codebase.Sqlite.Patch.Format SyncPatchFormat' (..), applyPatchDiffs, localPatchToPatch, - localPatchToPatch', localPatchDiffToPatchDiff, localPatchToHashPatch, ) @@ -75,15 +74,6 @@ localToPatch' :: (Ord t, Ord h, Ord d) => PatchLocalIds' t h d -> (Patch' LocalT localToPatch' li = Patch.Full.trimap (lookupPatchLocalText li) (lookupPatchLocalHash li) (lookupPatchLocalDefn li) --- | Generic version of `localPatchToPatch` that works with any `PatchLocalIds'`. -localPatchToPatch' :: - (Ord t, Ord h, Ord d) => - PatchLocalIds' t h d -> - Patch' LocalTextId LocalHashId LocalDefnId -> - Patch' t h d -localPatchToPatch' li = - Patch.Full.trimap (lookupPatchLocalText li) (lookupPatchLocalHash li) (lookupPatchLocalDefn li) - -- | Type specialized version of `localToPatch'`. localPatchToPatch :: PatchLocalIds -> LocalPatch -> Patch localPatchToPatch = localToPatch' diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Full.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Full.hs index 749a87290c..39cecdb6fb 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Full.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Full.hs @@ -1,7 +1,6 @@ module U.Codebase.Sqlite.Patch.Full where import Control.Lens -import Data.Bitraversable (Bitraversable, bitraverse) import Data.Map (Map) import Data.Set (Set) import Data.Set qualified as Set @@ -48,16 +47,6 @@ data Patch' t h o = Patch typeEdits :: Map (Reference' t h) (Set (TypeEdit' t o)) } -patchT_ :: (Ord t', Ord h, Ord o) => Traversal (Patch' t h o) (Patch' t' h o) t t' -patchT_ f Patch {termEdits, typeEdits} = do - newTermEdits <- - traverseOf (Map.bitraversed (Referent.refs_ . Reference.t_) (Set.traverse . traverseFirst)) f termEdits - newTypeEdits <- traverseOf (Map.bitraversed (Reference.t_) (Set.traverse . traverseFirst)) f typeEdits - pure Patch {termEdits = newTermEdits, typeEdits = newTypeEdits} - where - traverseFirst :: (Bitraversable b) => Traversal (b a c) (b a' c) a a' - traverseFirst f = bitraverse f pure - patchH_ :: (Ord t, Ord h') => Traversal (Patch' t h o) (Patch' t h' o) h h' patchH_ f Patch {termEdits, typeEdits} = do newTermEdits <- termEdits & Map.traverseKeys . Referent.refs_ . Reference.h_ %%~ f diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs index 94e90b5c00..61ca246787 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Project.hs @@ -7,7 +7,7 @@ import U.Codebase.Sqlite.DbId (ProjectId) import Unison.Core.Orphans.Sqlite () import Unison.Core.Project (ProjectName) import Unison.Prelude -import Unison.Sqlite (FromRow, ToRow) +import Unison.Sqlite (FromRow) -- | A project. data Project = Project @@ -15,4 +15,4 @@ data Project = Project name :: !ProjectName } deriving stock (Generic, Show, Eq) - deriving anyclass (ToRow, FromRow) + deriving anyclass (FromRow) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs index 05b63e7e23..085e1635c4 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectBranch.hs @@ -7,7 +7,7 @@ import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) import Unison.Core.Orphans.Sqlite () import Unison.Core.Project (ProjectBranchName) import Unison.Prelude -import Unison.Sqlite (FromRow, ToRow) +import Unison.Sqlite (FromRow) -- | A project branch. data ProjectBranch = ProjectBranch @@ -17,4 +17,4 @@ data ProjectBranch = ProjectBranch parentBranchId :: !(Maybe ProjectBranchId) } deriving stock (Eq, Generic, Show) - deriving anyclass (ToRow, FromRow) + deriving anyclass (FromRow) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs index b759df2586..18265f668f 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/ProjectReflog.hs @@ -3,8 +3,6 @@ module U.Codebase.Sqlite.ProjectReflog ( Entry (..), - project_, - branch_, projectAndBranch_, ) where @@ -25,12 +23,6 @@ data Entry project branch causal = Entry } deriving stock (Eq, Show, Functor, Foldable, Traversable) -project_ :: Lens (Entry project branch causal) (Entry project' branch causal) project project' -project_ = lens project (\e p -> e {project = p}) - -branch_ :: Lens (Entry project branch causal) (Entry project branch' causal) branch branch' -branch_ = lens branch (\e b -> e {branch = b}) - -- | Both Project and Branch Ids are required to load a branch, so this is often more useful. projectAndBranch_ :: Lens (Entry project branch causal) (Entry project' branch' causal) (project, branch) (project', branch') projectAndBranch_ = lens (\Entry {..} -> (project, branch)) (\e (project, branch) -> e {project = project, branch = branch}) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 033efb8655..3bf80499a1 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -14,7 +14,6 @@ module U.Codebase.Sqlite.Queries loadTextId, expectTextId, expectText, - expectTextCheck, -- ** name segments saveNameSegment, @@ -27,19 +26,15 @@ module U.Codebase.Sqlite.Queries loadHashId, expectHash, expectHash32, - expectBranchHash, expectBranchHashId, loadHashIdByHash, expectHashIdByHash, saveCausalHash, expectCausalHash, - expectBranchHashForCausalHash, saveBranchHash, -- * hash_object table saveHashObject, - expectHashIdsForObject, - hashIdWithVersionForObject, loadObjectIdForPrimaryHashId, expectObjectIdForPrimaryHashId, loadObjectIdForPrimaryHash, @@ -47,7 +42,6 @@ module U.Codebase.Sqlite.Queries loadPatchObjectIdForPrimaryHash, loadObjectIdForAnyHash, loadObjectIdForAnyHashId, - expectObjectIdForAnyHashId, recordObjectRehash, -- * object table @@ -56,15 +50,12 @@ module U.Codebase.Sqlite.Queries expectObject, expectPrimaryHashByObjectId, expectPrimaryHashIdForObject, - expectObjectWithHashIdAndType, expectDeclObject, loadDeclObject, expectNamespaceObject, loadNamespaceObject, expectPatchObject, - loadPatchObject, loadTermObject, - expectTermObject, -- * namespace_statistics table saveNamespaceStats, @@ -81,18 +72,13 @@ module U.Codebase.Sqlite.Queries expectCausalHashIdByCausalHash, expectCausalValueHashId, loadCausalByCausalHash, - expectCausalByCausalHash, loadBranchObjectIdByCausalHashId, loadBranchObjectIdByBranchHashId, expectBranchObjectIdByCausalHashId, expectBranchObjectIdByBranchHashId, - tryGetSquashResult, - saveSquashResult, -- ** causal_parent table - saveCausalParents, loadCausalParents, - loadCausalParentsByHash, before, lca, @@ -100,11 +86,9 @@ module U.Codebase.Sqlite.Queries saveWatch, loadWatch, loadWatchesByWatchKind, - loadWatchKindsByReference, clearWatches, -- * projects - projectExists, doProjectsExist, projectExistsByName, loadProject, @@ -123,7 +107,6 @@ module U.Codebase.Sqlite.Queries expectProjectBranch, loadAllProjectBranchesBeginningWith, loadAllProjectBranchInfo, - loadProjectAndBranchNames, loadAllProjectBranchNamePairs, loadProjectBranch, insertProjectBranch, @@ -135,18 +118,14 @@ module U.Codebase.Sqlite.Queries loadMostRecentBranch, -- ** remote projects - loadRemoteProject, ensureRemoteProject, expectRemoteProjectName, - setRemoteProjectName, loadRemoteProjectBranch, loadDefaultMergeTargetForLocalProjectBranch, -- ** remote project branches - loadRemoteBranch, ensureRemoteProjectBranch, expectRemoteProjectBranchName, - setRemoteProjectBranchName, insertBranchRemoteMapping, ensureBranchRemoteMapping, deleteBranchRemoteMapping, @@ -158,8 +137,6 @@ module U.Codebase.Sqlite.Queries DependentsSelector (..), getDependentsForDependency, getDependentsForDependencyComponent, - getDependenciesForDependent, - getDependencyIdsForDependent, getDependenciesBetweenTerms, getDirectDependenciesOfScope, getDirectDependentsWithinScope, @@ -168,47 +145,26 @@ module U.Codebase.Sqlite.Queries -- ** type index addToTypeIndex, getReferentsByType, - getTypeReferenceForReferent, - getTypeReferencesForComponent, filterTermsByReferenceHavingType, filterTermsByReferentHavingType, -- ** type mentions index addToTypeMentionsIndex, getReferentsByTypeMention, - getTypeMentionsReferencesForComponent, -- * hash prefix lookup objectIdByBase32Prefix, - namespaceHashIdByBase32Prefix, causalHashIdByBase32Prefix, -- * Name Lookup - copyScopedNameLookup, - insertScopedTermNames, - insertScopedTypeNames, - removeScopedTermNames, - removeScopedTypeNames, termNamesWithinNamespace, typeNamesWithinNamespace, termNamesForRefWithinNamespace, typeNamesForRefWithinNamespace, - recursiveTermNameSearch, - recursiveTypeNameSearch, - termRefsForExactName, - typeRefsForExactName, checkBranchHashNameLookupExists, - trackNewBranchHashNameLookup, - deleteNameLookup, - termNamesBySuffix, - typeNamesBySuffix, longestMatchingTermNameForSuffixification, longestMatchingTypeNameForSuffixification, - associateNameLookupMounts, listNameLookupMounts, - deleteNameLookupsExceptFor, - fuzzySearchTerms, - fuzzySearchTypes, -- * Reflog getDeprecatedRootReflog, @@ -284,11 +240,8 @@ module U.Codebase.Sqlite.Queries x2cTType, x2cTerm, x2cDecl, - checkBranchExistsForCausalHash, -- * Types - NamespaceText, - TextPathSegments, JsonParseFailure (..), ) where @@ -307,7 +260,6 @@ import Data.Foldable qualified as Foldable import Data.List qualified as List import Data.List.Extra qualified as List import Data.List.NonEmpty (NonEmpty) -import Data.List.NonEmpty qualified as Nel import Data.List.NonEmpty qualified as NonEmpty import Data.Map qualified as Map import Data.Map.NonEmpty (NEMap) @@ -322,6 +274,7 @@ import Data.Time qualified as Time import Data.Vector qualified as Vector import GHC.Stack (callStack) import Network.URI (URI) +import Network.URI.Orphans.Sqlite () import U.Codebase.Branch.Type (NamespaceStats (..)) import U.Codebase.Decl qualified as C import U.Codebase.Decl qualified as C.Decl @@ -376,8 +329,6 @@ import U.Codebase.Sqlite.Reference qualified as S import U.Codebase.Sqlite.Reference qualified as S.Reference import U.Codebase.Sqlite.Referent qualified as S (TextReferent) import U.Codebase.Sqlite.Referent qualified as S.Referent -import U.Codebase.Sqlite.RemoteProject (RemoteProject (..)) -import U.Codebase.Sqlite.RemoteProjectBranch (RemoteProjectBranch) import U.Codebase.Sqlite.Serialization as Serialization import U.Codebase.Sqlite.Symbol (Symbol) import U.Codebase.Sqlite.TempEntity (TempEntity) @@ -394,7 +345,6 @@ import U.Core.ABT qualified as ABT import U.Util.Serialization qualified as S import U.Util.Term qualified as TermUtil import Unison.Core.Project (ProjectAndBranch (..), ProjectBranchName (..), ProjectName (..)) -import Unison.Debug qualified as Debug import Unison.Hash (Hash) import Unison.Hash qualified as Hash import Unison.Hash32 (Hash32) @@ -415,8 +365,6 @@ import UnliftIO qualified debug :: Bool debug = False -type TextPathSegments = [Text] - -- * main squeeze currentSchemaVersion :: SchemaVersion @@ -592,12 +540,6 @@ loadCausalByCausalHash ch = runMaybeT do 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 . Hash32.fromHash @@ -613,14 +555,6 @@ expectHash32 h = WHERE id = :h |] -expectBranchHash :: BranchHashId -> Transaction BranchHash -expectBranchHash = coerce expectHash - -expectBranchHashForCausalHash :: CausalHash -> Transaction BranchHash -expectBranchHashForCausalHash ch = do - (_, bhId)<- expectCausalByCausalHash ch - expectBranchHash bhId - saveText :: Text -> Transaction TextId saveText t = do execute @@ -652,9 +586,6 @@ loadTextIdSql t = expectText :: TextId -> Transaction Text expectText h = queryOneCol (loadTextSql h) -expectTextCheck :: SqliteExceptionReason e => TextId -> (Text -> Either e a) -> Transaction a -expectTextCheck h = queryOneColCheck (loadTextSql h) - loadTextSql :: TextId -> Sql loadTextSql h = [sql| @@ -754,11 +685,6 @@ expectNamespaceObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> E expectNamespaceObject oid = expectObjectOfType oid Namespace --- | Load a patch object. -loadPatchObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction (Maybe a) -loadPatchObject oid = - loadObjectOfType oid Patch - -- | Expect a patch object. expectPatchObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a expectPatchObject oid = @@ -769,11 +695,6 @@ loadTermObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e loadTermObject oid = loadObjectOfType oid TermComponent --- | Expect a term component object. -expectTermObject :: SqliteExceptionReason e => ObjectId -> (ByteString -> Either e a) -> Transaction a -expectTermObject oid = - expectObjectOfType oid TermComponent - expectPrimaryHashIdForObject :: ObjectId -> Transaction HashId expectPrimaryHashIdForObject oId = do queryOneCol @@ -793,15 +714,6 @@ expectObjectWithType oId check = |] (\(typ, bytes) -> check typ bytes) -expectObjectWithHashIdAndType :: ObjectId -> Transaction (HashId, ObjectType, ByteString) -expectObjectWithHashIdAndType oId = - queryOneRow - [sql| - SELECT primary_hash_id, type_id, bytes - FROM object - WHERE id = :oId - |] - loadObjectIdForPrimaryHashId :: HashId -> Transaction (Maybe ObjectId) loadObjectIdForPrimaryHashId h = queryMaybeCol (loadObjectIdForPrimaryHashIdSql h) @@ -884,10 +796,6 @@ loadObjectIdForAnyHashId :: HashId -> Transaction (Maybe ObjectId) loadObjectIdForAnyHashId h = queryMaybeCol (loadObjectIdForAnyHashIdSql h) -expectObjectIdForAnyHashId :: HashId -> Transaction ObjectId -expectObjectIdForAnyHashId h = - queryOneCol (loadObjectIdForAnyHashIdSql h) - loadObjectIdForAnyHashIdSql :: HashId -> Sql loadObjectIdForAnyHashIdSql h = [sql| @@ -922,21 +830,6 @@ expectPrimaryHash32ByObjectId oId = WHERE object.id = :oId |] -expectHashIdsForObject :: ObjectId -> Transaction (NonEmpty HashId) -expectHashIdsForObject oId = do - primaryHashId <- queryOneCol [sql| SELECT primary_hash_id FROM object WHERE id = :oId |] -- sql1 (Only oId) - hashIds <- queryListCol [sql| SELECT hash_id FROM hash_object WHERE object_id = :oId |] - pure $ primaryHashId Nel.:| filter (/= primaryHashId) hashIds - -hashIdWithVersionForObject :: ObjectId -> Transaction [(HashId, HashVersion)] -hashIdWithVersionForObject oId = - queryListRow - [sql| - SELECT hash_id, hash_version - FROM hash_object - WHERE object_id = :oId - |] - -- | @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. @@ -1310,16 +1203,6 @@ loadBranchObjectIdByBranchHashIdSql id = WHERE hash_id = :id |] -saveCausalParents :: CausalHashId -> [CausalHashId] -> Transaction () -saveCausalParents child = - traverse_ \parent -> - execute - [sql| - INSERT INTO causal_parent (causal_id, parent_id) - VALUES (:child, :parent) - ON CONFLICT DO NOTHING - |] - loadCausalParents :: CausalHashId -> Transaction [CausalHashId] loadCausalParents h = queryListCol @@ -1329,18 +1212,6 @@ loadCausalParents h = WHERE causal_id = :h |] --- | Like 'loadCausalParents', but the input and outputs are hashes, not hash ids. -loadCausalParentsByHash :: Hash32 -> Transaction [Hash32] -loadCausalParentsByHash hash = - queryListCol - [sql| - 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 = :hash COLLATE NOCASE - |] - saveWatch :: WatchKind -> S.Reference.IdH -> ByteString -> Transaction () saveWatch k r blob = do execute @@ -1375,18 +1246,6 @@ loadWatch k r check = |] check -loadWatchKindsByReference :: S.Reference.IdH -> Transaction [WatchKind] -loadWatchKindsByReference r = - queryListCol - [sql| - SELECT watch_kind_id FROM watch_result - INNER JOIN watch - ON watch_result.hash_id = watch.hash_id - AND watch_result.component_index = watch.component_index - WHERE watch.hash_id = @r - AND watch.component_index = @ - |] - loadWatchesByWatchKind :: WatchKind -> Transaction [S.Reference.IdH] loadWatchesByWatchKind k = queryListRow @@ -1432,37 +1291,6 @@ getReferentsByType r = AND type_reference_component_index IS @ |] -getTypeReferenceForReferent :: S.Referent.Id -> Transaction S.ReferenceH -getTypeReferenceForReferent r = - queryOneRow - [sql| - SELECT - type_reference_builtin, - type_reference_hash_id, - type_reference_component_index - FROM find_type_index - WHERE term_referent_object_id = @r - AND term_referent_component_index = @ - AND term_referent_constructor_index IS @ - |] - --- todo: error if no results -getTypeReferencesForComponent :: ObjectId -> Transaction [(S.ReferenceH, S.Referent.Id)] -getTypeReferencesForComponent oId = - fmap (map fixupTypeIndexRow) $ - queryListRow - [sql| - SELECT - type_reference_builtin, - type_reference_hash_id, - type_reference_component_index, - term_referent_object_id, - term_referent_component_index, - term_referent_constructor_index - FROM find_type_index - WHERE term_referent_object_id = :oId - |] - filterTermsByReferentHavingType :: S.ReferenceH -> [S.Referent.Id] -> Transaction [S.Referent.Id] filterTermsByReferentHavingType typ terms = create *> for_ terms insert *> select <* drop where @@ -1562,26 +1390,6 @@ getReferentsByTypeMention r = AND type_reference_component_index IS @ |] --- todo: error if no results -getTypeMentionsReferencesForComponent :: ObjectId -> Transaction [(S.ReferenceH, S.Referent.Id)] -getTypeMentionsReferencesForComponent r = - fmap (map fixupTypeIndexRow) $ - queryListRow - [sql| - SELECT - type_reference_builtin, - type_reference_hash_id, - type_reference_component_index, - term_referent_object_id, - term_referent_component_index, - term_referent_constructor_index - FROM find_type_mentions_index - WHERE term_referent_object_id IS :r - |] - -fixupTypeIndexRow :: S.ReferenceH :. S.Referent.Id -> (S.ReferenceH, S.Referent.Id) -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. @@ -1706,40 +1514,6 @@ getDependentsForDependencyComponent dependency = isNotSelfReference = \case (C.Reference.Id oid1 _pos1) -> dependency /= oid1 --- | Get non-self dependencies of a user-defined dependent. -getDependenciesForDependent :: S.Reference.Id -> Transaction [S.Reference] -getDependenciesForDependent dependent@(C.Reference.Id oid0 _) = - fmap (filter isNotSelfReference) $ - queryListRow - [sql| - SELECT dependency_builtin, dependency_object_id, dependency_component_index - FROM dependents_index - WHERE dependent_object_id IS @dependent - AND dependent_component_index IS @ - |] - where - isNotSelfReference :: S.Reference -> Bool - isNotSelfReference = \case - ReferenceBuiltin _ -> True - ReferenceDerived (C.Reference.Id oid1 _) -> oid0 /= oid1 - --- | Get non-self, user-defined dependencies of a user-defined dependent. -getDependencyIdsForDependent :: S.Reference.Id -> Transaction [S.Reference.Id] -getDependencyIdsForDependent dependent@(C.Reference.Id oid0 _) = - fmap (filter isNotSelfReference) $ - queryListRow - [sql| - SELECT dependency_object_id, dependency_component_index - FROM dependents_index - WHERE dependency_builtin IS NULL - AND dependent_object_id = @dependent - AND dependent_component_index = @ - |] - where - isNotSelfReference :: S.Reference.Id -> Bool - isNotSelfReference (C.Reference.Id oid1 _) = - oid0 /= oid1 - -- | Given two term (components) A and B, return the set of all terms that are along any "dependency path" from A to B, -- not including A nor B; i.e., the transitive dependencies of A that are transitive dependents of B. -- @@ -2072,17 +1846,6 @@ causalHashIdByBase32Prefix prefix = where prefix2 = prefix <> "%" -namespaceHashIdByBase32Prefix :: Text -> Transaction [BranchHashId] -namespaceHashIdByBase32Prefix prefix = - queryListCol - [sql| - SELECT value_hash_id FROM causal - INNER JOIN hash ON id = value_hash_id - WHERE base32 LIKE :prefix2 ESCAPE '\' - |] - where - prefix2 = prefix <> "%" - -- | 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. @@ -2109,49 +1872,6 @@ removeHashObjectsByHashingVersion hashVersion = WHERE hash_version = :hashVersion |] --- | Copies existing name lookup rows but replaces their branch hash id; --- This is a low-level operation used as part of deriving a new name lookup index --- from an existing one as performantly as possible. -copyScopedNameLookup :: BranchHashId -> BranchHashId -> Transaction () -copyScopedNameLookup fromBHId toBHId = do - execute termsCopySql - execute typesCopySql - where - termsCopySql = - [sql| - INSERT INTO scoped_term_name_lookup(root_branch_hash_id, reversed_name, last_name_segment, namespace, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type) - SELECT :toBHId, reversed_name, last_name_segment, namespace, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type - FROM scoped_term_name_lookup - WHERE root_branch_hash_id = :fromBHId - |] - typesCopySql = - [sql| - INSERT INTO scoped_type_name_lookup(root_branch_hash_id, reversed_name, last_name_segment, namespace, reference_builtin, reference_component_hash, reference_component_index) - SELECT :toBHId, reversed_name, last_name_segment, namespace, reference_builtin, reference_component_hash, reference_component_index - FROM scoped_type_name_lookup - WHERE root_branch_hash_id = :fromBHId - |] - --- | Delete the specified name lookup. --- This should only be used if you're sure it's unused, or if you're going to re-create it in --- the same transaction. -deleteNameLookup :: BranchHashId -> Transaction () -deleteNameLookup bhId = do - execute - [sql| - DELETE FROM name_lookups - WHERE root_branch_hash_id = :bhId - |] - --- | Inserts a new record into the name_lookups table -trackNewBranchHashNameLookup :: BranchHashId -> Transaction () -trackNewBranchHashNameLookup bhId = do - execute - [sql| - INSERT INTO name_lookups (root_branch_hash_id) - VALUES (:bhId) - |] - -- | Check if we've already got an index for the desired root branch hash. checkBranchHashNameLookupExists :: BranchHashId -> Transaction Bool checkBranchHashNameLookupExists hashId = do @@ -2165,100 +1885,6 @@ checkBranchHashNameLookupExists hashId = do ) |] --- | Delete any name lookup that's not in the provided list. --- --- This can be used to garbage collect unreachable name lookups. -deleteNameLookupsExceptFor :: [BranchHashId] -> Transaction () -deleteNameLookupsExceptFor hashIds = do - case hashIds of - [] -> execute [sql| DELETE FROM name_lookups |] - (x : xs) -> do - let hashIdValues :: NonEmpty (Only BranchHashId) - hashIdValues = coerce (x NonEmpty.:| xs) - execute - [sql| - WITH RECURSIVE reachable(branch_hash_id) AS ( - VALUES :hashIdValues - -- Any name lookup that's mounted on a reachable name lookup is also reachable - UNION ALL - SELECT mounted_root_branch_hash_id FROM name_lookup_mounts JOIN reachable ON branch_hash_id = parent_root_branch_hash_id - ) - DELETE FROM name_lookups - WHERE root_branch_hash_id NOT IN (SELECT branch_hash_id FROM reachable); - |] - --- | Insert the given set of term names into the name lookup table -insertScopedTermNames :: BranchHashId -> [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)] -> Transaction () -insertScopedTermNames bhId = do - traverse_ \name0 -> do - let name = NamedRef.ScopedRow (refToRow <$> name0) - execute - [sql| - INSERT INTO scoped_term_name_lookup ( - root_branch_hash_id, - reversed_name, - namespace, - last_name_segment, - referent_builtin, - referent_component_hash, - referent_component_index, - referent_constructor_index, - referent_constructor_type - ) - VALUES (:bhId, @name, @, @, @, @, @, @, @) - |] - where - refToRow :: (S.TextReferent, Maybe NamedRef.ConstructorType) -> (S.TextReferent :. Only (Maybe NamedRef.ConstructorType)) - refToRow (ref, ct) = ref :. Only ct - --- | Insert the given set of type names into the name lookup table -insertScopedTypeNames :: BranchHashId -> [NamedRef S.TextReference] -> Transaction () -insertScopedTypeNames bhId = - traverse_ \name0 -> do - let name = NamedRef.ScopedRow name0 - execute - [sql| - INSERT INTO scoped_type_name_lookup ( - root_branch_hash_id, - reversed_name, - namespace, - last_name_segment, - reference_builtin, - reference_component_hash, - reference_component_index - ) - VALUES (:bhId, @name, @, @, @, @, @) - |] - --- | Remove the given set of term names into the name lookup table -removeScopedTermNames :: BranchHashId -> [NamedRef S.TextReferent] -> Transaction () -removeScopedTermNames bhId names = do - for_ names \name -> - execute - [sql| - DELETE FROM scoped_term_name_lookup - WHERE root_branch_hash_id IS :bhId - AND reversed_name IS @name - AND referent_builtin IS @ - AND referent_component_hash IS @ - AND referent_component_index IS @ - AND referent_constructor_index IS @ - |] - --- | Remove the given set of term names into the name lookup table -removeScopedTypeNames :: BranchHashId -> [NamedRef S.TextReference] -> Transaction () -removeScopedTypeNames bhId names = do - for_ names \name -> - execute - [sql| - DELETE FROM scoped_type_name_lookup - WHERE root_branch_hash_id IS :bhId - AND reversed_name IS @name - AND reference_builtin IS @ - AND reference_component_hash IS @ - AND reference_component_index IS @ - |] - -- | We need to escape any special characters for globbing. -- -- >>> globEscape "Nat.*.doc" @@ -2363,122 +1989,6 @@ typeNamesWithinNamespace bhId namespace = where namespaceGlob = toNamespaceGlob namespace --- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this --- is only true on Share. --- --- Get the list of term names within a given namespace which have the given suffix. -termNamesBySuffix :: BranchHashId -> PathSegments -> ReversedName -> Transaction [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)] -termNamesBySuffix bhId namespaceRoot suffix = do - Debug.debugM Debug.Server "termNamesBySuffix" (namespaceRoot, suffix) - let namespaceGlob = toNamespaceGlob namespaceRoot - let lastSegment = NonEmpty.head . into @(NonEmpty Text) $ suffix - let reversedNameGlob = toSuffixGlob suffix - results :: [NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- - -- Note: It may seem strange that we do a last_name_segment constraint AND a reversed_name - -- GLOB, but this helps improve query performance. - -- The SQLite query optimizer is smart enough to do a prefix-search on globs, but will - -- ONLY do a single prefix-search, meaning we use the index for `namespace`, but not for - -- `reversed_name`. By adding the `last_name_segment` constraint, we can cull a ton of - -- names which couldn't possibly match before we then manually filter the remaining names - -- using the `reversed_name` glob which can't be optimized with an index. - queryListRow - [sql| - SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type - FROM scoped_term_name_lookup - WHERE root_branch_hash_id = :bhId - AND last_name_segment IS :lastSegment - AND namespace GLOB :namespaceGlob - AND reversed_name GLOB :reversedNameGlob - UNION ALL - SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type - FROM name_lookup_mounts mount - INNER JOIN scoped_term_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id - WHERE mount.parent_root_branch_hash_id = :bhId - AND mount.mount_path GLOB :namespaceGlob - AND last_name_segment IS :lastSegment - AND reversed_name GLOB :reversedNameGlob - |] - pure (fmap unRow <$> results) - where - unRow (a :. Only b) = (a, b) - --- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this --- is only true on Share. --- --- Get the list of type names within a given namespace which have the given suffix. -typeNamesBySuffix :: BranchHashId -> PathSegments -> ReversedName -> Transaction [NamedRef S.TextReference] -typeNamesBySuffix bhId namespaceRoot suffix = do - Debug.debugM Debug.Server "typeNamesBySuffix" (namespaceRoot, suffix) - let namespaceGlob = toNamespaceGlob namespaceRoot - let lastNameSegment = NonEmpty.head . into @(NonEmpty Text) $ suffix - let reversedNameGlob = toSuffixGlob suffix - -- Note: It may seem strange that we do a last_name_segment constraint AND a reversed_name - -- GLOB, but this helps improve query performance. - -- The SQLite query optimizer is smart enough to do a prefix-search on globs, but will - -- ONLY do a single prefix-search, meaning we use the index for `namespace`, but not for - -- `reversed_name`. By adding the `last_name_segment` constraint, we can cull a ton of - -- names which couldn't possibly match before we then manually filter the remaining names - -- using the `reversed_name` glob which can't be optimized with an index. - queryListRow - [sql| - SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index - FROM scoped_type_name_lookup - WHERE root_branch_hash_id = :bhId - AND last_name_segment IS :lastNameSegment - AND namespace GLOB :namespaceGlob - AND reversed_name GLOB :reversedNameGlob - UNION ALL - SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, reference_builtin, reference_component_hash, reference_component_index - FROM name_lookup_mounts mount - INNER JOIN scoped_type_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id - WHERE mount.parent_root_branch_hash_id = :bhId - AND mount.mount_path GLOB :namespaceGlob - AND last_name_segment IS :lastNameSegment - AND reversed_name GLOB :reversedNameGlob - |] - --- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this --- is only true on Share. --- --- Get the set of refs for an exact name. --- This will only return results which are within the name lookup for the provided branch hash --- id. It's the caller's job to select the correct name lookup for your exact name. --- --- See termRefsForExactName in U.Codebase.Sqlite.Operations -termRefsForExactName :: BranchHashId -> ReversedName -> Transaction [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)] -termRefsForExactName bhId reversedSegments = do - let reversedName = toReversedName reversedSegments - results :: [NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <- - queryListRow - [sql| - SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type - FROM scoped_term_name_lookup - WHERE root_branch_hash_id = :bhId - AND reversed_name = :reversedName - |] - pure (fmap unRow <$> results) - where - unRow (a :. Only b) = (a, b) - --- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this --- is only true on Share. --- --- Get the set of refs for an exact name. --- This will only return results which are within the name lookup for the provided branch hash --- id. It's the caller's job to select the correct name lookup for your exact name. --- --- See termRefsForExactName in U.Codebase.Sqlite.Operations -typeRefsForExactName :: BranchHashId -> ReversedName -> Transaction [NamedRef S.TextReference] -typeRefsForExactName bhId reversedSegments = do - let reversedName = toReversedName reversedSegments - queryListRow - [sql| - SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index - FROM scoped_type_name_lookup - WHERE root_branch_hash_id = :bhId - AND reversed_name = :reversedName - |] - -- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this -- is only true on Share. -- @@ -2599,80 +2109,6 @@ transitiveDependenciesSql rootBranchHashId = ) |] --- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this --- is only true on Share. --- --- Searches all dependencies transitively looking for the provided referent. --- Prefer 'termNamesForRefWithinNamespace' in most cases. --- This is slower and only necessary when resolving the name of references when you don't know which --- dependency it may exist in. --- --- Searching transitive dependencies is exponential so we want to replace this with a more --- efficient approach as soon as possible. --- --- Note: this returns the first name it finds by searching in order of: --- Names in the current namespace, then names in the current namespace's dependencies, then --- through the current namespace's dependencies' dependencies, etc. -recursiveTermNameSearch :: BranchHashId -> S.TextReferent -> Transaction (Maybe ReversedName) -recursiveTermNameSearch bhId ref = do - queryMaybeColCheck - [sql| - -- Recursive table containing all transitive deps - WITH RECURSIVE - all_in_scope_roots(root_branch_hash_id, reversed_mount_path) AS ( - -- Include the primary root - SELECT :bhId, "" - UNION ALL - SELECT mount.mounted_root_branch_hash_id, mount.reversed_mount_path || rec.reversed_mount_path - FROM name_lookup_mounts mount - INNER JOIN all_in_scope_roots rec ON mount.parent_root_branch_hash_id = rec.root_branch_hash_id - ) - SELECT (reversed_name || reversed_mount_path) AS reversed_name - FROM all_in_scope_roots - INNER JOIN scoped_term_name_lookup - ON scoped_term_name_lookup.root_branch_hash_id = all_in_scope_roots.root_branch_hash_id - WHERE referent_builtin IS @ref AND referent_component_hash IS @ AND referent_component_index IS @ AND referent_constructor_index IS @ - LIMIT 1 - |] - (\reversedName -> reversedNameToReversedSegments reversedName) - --- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this --- is only true on Share. --- --- Searches all dependencies transitively looking for the provided referent. --- Prefer 'typeNamesForRefWithinNamespace' in most cases. --- This is slower and only necessary when resolving the name of references when you don't know which --- dependency it may exist in. --- --- Searching transitive dependencies is exponential so we want to replace this with a more --- efficient approach as soon as possible. --- --- Note: this returns the first name it finds by searching in order of: --- Names in the current namespace, then names in the current namespace's dependencies, then --- through the current namespace's dependencies' dependencies, etc. -recursiveTypeNameSearch :: BranchHashId -> S.TextReference -> Transaction (Maybe ReversedName) -recursiveTypeNameSearch bhId ref = do - queryMaybeColCheck - [sql| - -- Recursive table containing all transitive deps - WITH RECURSIVE - all_in_scope_roots(root_branch_hash_id, reversed_mount_path) AS ( - -- Include the primary root - SELECT :bhId, "" - UNION ALL - SELECT mount.mounted_root_branch_hash_id, mount.reversed_mount_path || rec.reversed_mount_path - FROM name_lookup_mounts mount - INNER JOIN all_in_scope_roots rec ON mount.parent_root_branch_hash_id = rec.root_branch_hash_id - ) - SELECT (reversed_name || reversed_mount_path) AS reversed_name - FROM all_in_scope_roots - INNER JOIN scoped_type_name_lookup - ON scoped_type_name_lookup.root_branch_hash_id = all_in_scope_roots.root_branch_hash_id - WHERE reference_builtin IS @ref AND reference_component_hash IS @ AND reference_component_index IS @ - LIMIT 1 - |] - (\reversedName -> reversedNameToReversedSegments reversedName) - -- | NOTE: requires that the codebase has an up-to-date name lookup index. As of writing, this -- is only true on Share. -- @@ -2821,19 +2257,6 @@ longestMatchingTypeNameForSuffixification bhId namespaceRoot (NamedRef.NamedRef & map (toSuffixGlob . into @ReversedName) runMaybeT $ loop suffixes --- | Associate name lookup indexes for dependencies to specific mounting points within another name lookup. -associateNameLookupMounts :: BranchHashId -> [(PathSegments, BranchHashId)] -> Transaction () -associateNameLookupMounts rootBranchHashId mounts = do - for_ mounts \(mountPath, mountedBranchHashId) -> do - let mountPathText = pathSegmentsToText mountPath <> "." - reversedMountPathText = pathSegmentsToText (PathSegments . reverse . coerce $ mountPath) <> "." - - execute - [sql| - INSERT INTO name_lookup_mounts (parent_root_branch_hash_id, mounted_root_branch_hash_id, mount_path, reversed_mount_path) - VALUES (:rootBranchHashId, :mountedBranchHashId, :mountPathText, :reversedMountPathText) - |] - -- | Fetch the name lookup mounts for a given name lookup index. listNameLookupMounts :: BranchHashId -> Transaction [(PathSegments, BranchHashId)] listNameLookupMounts rootBranchHashId = @@ -2949,21 +2372,6 @@ entityExists hash = do -- then check if is causal hash or if object exists for hash id Just hashId -> isCausalHash hashId ||^ isObjectHash hashId --- | Checks whether the codebase contains the actual branch value for a given causal hash. -checkBranchExistsForCausalHash :: CausalHash -> Transaction Bool -checkBranchExistsForCausalHash ch = do - loadCausalHashIdByCausalHash ch >>= \case - Nothing -> pure False - Just chId -> - queryOneCol - [sql| - SELECT EXISTS ( - SELECT 1 - FROM causal c JOIN object o ON c.value_hash_id = o.primary_hash_id - WHERE c.self_hash_id = :chId - ) - |] - -- | Insert a new `temp_entity` row, and its associated 1+ `temp_entity_missing_dependency` rows. -- -- Preconditions: @@ -3552,18 +2960,6 @@ getGlobalReflog numEntries = LIMIT :numEntries |] --- | Does a project exist with this id? -projectExists :: ProjectId -> Transaction Bool -projectExists projectId = - queryOneCol - [sql| - SELECT EXISTS ( - SELECT 1 - FROM project - WHERE id = :projectId - ) - |] - -- | Check if any projects exist doProjectsExist :: Transaction Bool doProjectsExist = @@ -3825,21 +3221,6 @@ loadAllProjectBranchInfo projectId = -- No need to pattern match on maybeRemoteBranches; we know it's Nothing, too _ -> Map.empty -loadProjectAndBranchNames :: ProjectId -> ProjectBranchId -> Transaction (Maybe (ProjectName, ProjectBranchName)) -loadProjectAndBranchNames projectId branchId = - queryMaybeRow - [sql| - SELECT - project.name, - project_branch.name - FROM - project - JOIN project_branch ON project.id = project_branch.project_id - WHERE - project_branch.project_id = :projectId - AND project_branch.branch_id = :branchId - |] - -- | Insert a project branch. insertProjectBranch :: (HasCallStack) => Text -> CausalHashId -> ProjectBranch -> Transaction () insertProjectBranch description causalHashId (ProjectBranch projectId branchId branchName maybeParentBranchId) = do @@ -4082,21 +3463,6 @@ loadRemoteProjectBranchGen loadRemoteBranchFlag pid remoteUri bid = IncludeSelfRemote -> [sql| TRUE |] ExcludeSelfRemote -> [sql| depth > 0 |] -loadRemoteProject :: RemoteProjectId -> URI -> Transaction (Maybe RemoteProject) -loadRemoteProject rpid host = - queryMaybeRow - [sql| - SELECT - id, - host, - name - FROM - remote_project - WHERE - id = :rpid - and host = :host - |] - ensureRemoteProject :: RemoteProjectId -> URI -> ProjectName -> Transaction () ensureRemoteProject rpid host name = execute @@ -4129,35 +3495,6 @@ expectRemoteProjectName projectId host = AND host = :host |] -setRemoteProjectName :: RemoteProjectId -> ProjectName -> Transaction () -setRemoteProjectName rpid name = - execute - [sql| - UPDATE - remote_project - SET - name = :name - WHERE - id = :rpid - |] - -loadRemoteBranch :: RemoteProjectId -> URI -> RemoteProjectBranchId -> Transaction (Maybe RemoteProjectBranch) -loadRemoteBranch rpid host rbid = - queryMaybeRow - [sql| - SELECT - project_id, - branch_id, - host, - name - FROM - remote_project_branch - WHERE - project_id = :rpid - AND branch_id = :rbid - AND host = :host - |] - ensureRemoteProjectBranch :: RemoteProjectId -> URI -> RemoteProjectBranchId -> ProjectBranchName -> Transaction () ensureRemoteProjectBranch rpid host rbid name = execute @@ -4194,20 +3531,6 @@ expectRemoteProjectBranchName host projectId branchId = AND branch_id = :branchId |] -setRemoteProjectBranchName :: RemoteProjectId -> URI -> RemoteProjectBranchId -> ProjectBranchName -> Transaction () -setRemoteProjectBranchName rpid host rbid name = - execute - [sql| - UPDATE - remote_project_branch - SET - name = :name - WHERE - project_id = :rpid - AND host = :host - AND branch_id = :rbid - |] - insertBranchRemoteMapping :: ProjectId -> ProjectBranchId -> @@ -4282,13 +3605,6 @@ deleteBranchRemoteMapping pid bid host = toSuffixGlob :: ReversedName -> Text toSuffixGlob suffix = globEscape (Text.intercalate "." (into @[Text] suffix)) <> ".*" --- | Convert reversed segments into the DB representation of a reversed_name. --- --- >>> toReversedName (NonEmpty.fromList ["foo", "bar"]) --- "foo.bar." -toReversedName :: ReversedName -> Text -toReversedName revSegs = Text.intercalate "." (into @[Text] revSegs) <> "." - -- | Convert a namespace into the appropriate glob for searching within that namespace -- -- >>> toNamespaceGlob "foo.bar" @@ -4348,105 +3664,6 @@ loadMostRecentBranch projectId = project_id = :projectId |] --- | Searches for all names within the given name lookup which contain the provided list of segments --- in order. --- Search is case insensitive. -fuzzySearchTerms :: Bool -> BranchHashId -> Int -> PathSegments -> [Text] -> Transaction [(NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType))] -fuzzySearchTerms includeDependencies bhId limit namespace querySegments = do - -- Union in the dependencies if required. - let dependenciesSql = - if includeDependencies - then - [sql| - UNION ALL - SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type - FROM name_lookup_mounts mount - INNER JOIN scoped_term_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id - WHERE - mount.parent_root_branch_hash_id = :bhId - -- We have a pre-condition that the namespace must not be within any of the mounts, - -- so this is sufficient to determine whether the entire sub-index is within the - -- required namespace prefix. - AND mount.mount_path GLOB :namespaceGlob - AND (mount.mount_path || namespace || last_name_segment) LIKE :preparedQuery ESCAPE '\' - |] - else [sql||] - fmap unRow - <$> queryListRow - [sql| - SELECT reversed_name, referent_builtin, referent_component_hash, referent_component_index, referent_constructor_index, referent_constructor_type - FROM scoped_term_name_lookup - WHERE - root_branch_hash_id = :bhId - AND namespace GLOB :namespaceGlob - AND (namespace || last_name_segment) LIKE :preparedQuery ESCAPE '\' - $dependenciesSql - LIMIT :limit - |] - where - namespaceGlob = toNamespaceGlob namespace - preparedQuery = prepareFuzzyQuery '\\' querySegments - unRow :: NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType)) -> NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType) - unRow = fmap \(a :. Only b) -> (a, b) - --- | Searches for all names within the given name lookup which contain the provided list of segments --- in order. --- --- Search is case insensitive. -fuzzySearchTypes :: Bool -> BranchHashId -> Int -> PathSegments -> [Text] -> Transaction [(NamedRef S.TextReference)] -fuzzySearchTypes includeDependencies bhId limit namespace querySegments = do - -- Union in the dependencies if required. - let dependenciesSql = - if includeDependencies - then - [sql| - UNION ALL - SELECT (names.reversed_name || mount.reversed_mount_path) AS reversed_name, reference_builtin, reference_component_hash, reference_component_index - FROM name_lookup_mounts mount - INNER JOIN scoped_type_name_lookup names ON names.root_branch_hash_id = mount.mounted_root_branch_hash_id - WHERE - mount.parent_root_branch_hash_id = :bhId - -- We have a pre-condition that the namespace must not be within any of the mounts, - -- so this is sufficient to determine whether the entire sub-index is within the - -- required namespace prefix. - AND mount.mount_path GLOB :namespaceGlob - AND (mount.mount_path || namespace || last_name_segment) LIKE :preparedQuery ESCAPE '\' - |] - else [sql||] - queryListRow - [sql| - SELECT reversed_name, reference_builtin, reference_component_hash, reference_component_index - FROM scoped_type_name_lookup - WHERE - root_branch_hash_id = :bhId - AND namespace GLOB :namespaceGlob - AND (namespace || last_name_segment) LIKE :preparedQuery ESCAPE '\' - - $dependenciesSql - - LIMIT :limit - |] - where - namespaceGlob = toNamespaceGlob namespace - preparedQuery = prepareFuzzyQuery '\\' querySegments - --- | >>> prepareFuzzyQuery ["foo", "bar"] --- "%foo%bar%" --- --- >>> prepareFuzzyQuery ["foo", "", "bar"] --- "%foo%bar%" --- --- >>> prepareFuzzyQuery ["foo%", "bar "] --- "%foo\\%%bar%" -prepareFuzzyQuery :: Char -> [Text] -> Text -prepareFuzzyQuery escapeChar query = - query - & filter (not . Text.null) - & map (likeEscape escapeChar . Text.strip) - & \q -> "%" <> Text.intercalate "%" q <> "%" - --- fuzzySearchTypes :: Text -> Transaction [NamedRef Reference.TextReference] - data JsonParseFailure = JsonParseFailure { bytes :: !Text, failure :: !Text @@ -4488,32 +3705,3 @@ setCurrentProjectPath projId branchId path = do jsonPath :: Text jsonPath = Text.Lazy.toStrict (Aeson.encodeToLazyText $ NameSegment.toUnescapedText <$> path) - --- | Get the causal hash result from squashing the provided branch hash if we've squashed it --- at some point in the past. -tryGetSquashResult :: BranchHashId -> Transaction (Maybe CausalHashId) -tryGetSquashResult bhId = do - queryMaybeCol - [sql| - SELECT - squashed_causal_hash_id - FROM - squash_results - WHERE - branch_hash_id = :bhId - |] - --- | Save the result of running a squash on the provided branch hash id. -saveSquashResult :: BranchHashId -> CausalHashId -> Transaction () -saveSquashResult bhId chId = - execute - [sql| - INSERT INTO squash_results ( - branch_hash_id, - squashed_causal_hash_id) - VALUES ( - :bhId, - :chId - ) - ON CONFLICT DO NOTHING - |] diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs index 7c45dbc97d..3b7846dba4 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs @@ -32,8 +32,6 @@ type LocalReferenceH = Reference' LocalTextId LocalHashId type LocalReference = Reference' LocalTextId LocalDefnId -type LocalId = Id' LocalDefnId - type ReferenceH = Reference' TextId HashId type IdH = Id' HashId @@ -52,9 +50,6 @@ 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) where fromRow = referenceFromRow' diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/RemoteProject.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/RemoteProject.hs deleted file mode 100644 index 0fd7610316..0000000000 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/RemoteProject.hs +++ /dev/null @@ -1,21 +0,0 @@ -module U.Codebase.Sqlite.RemoteProject - ( RemoteProject (..), - ) -where - -import Network.URI (URI) -import Network.URI.Orphans.Sqlite () -import U.Codebase.Sqlite.DbId (RemoteProjectId) -import Unison.Core.Orphans.Sqlite () -import Unison.Core.Project (ProjectName) -import Unison.Prelude -import Unison.Sqlite (FromRow, ToRow) - --- | A remote project. -data RemoteProject = RemoteProject - { projectId :: RemoteProjectId, - host :: URI, - name :: ProjectName - } - deriving stock (Generic, Show) - deriving anyclass (ToRow, FromRow) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/RemoteProjectBranch.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/RemoteProjectBranch.hs deleted file mode 100644 index 5e5638c274..0000000000 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/RemoteProjectBranch.hs +++ /dev/null @@ -1,21 +0,0 @@ -module U.Codebase.Sqlite.RemoteProjectBranch - ( RemoteProjectBranch (..), - ) -where - -import Network.URI (URI) -import Network.URI.Orphans.Sqlite () -import U.Codebase.Sqlite.DbId (RemoteProjectBranchId, RemoteProjectId) -import Unison.Core.Orphans.Sqlite () -import Unison.Core.Project (ProjectBranchName) -import Unison.Prelude -import Unison.Sqlite (FromRow, ToRow) - -data RemoteProjectBranch = RemoteProjectBranch - { projectId :: RemoteProjectId, - branchId :: RemoteProjectBranchId, - host :: URI, - name :: ProjectBranchName - } - deriving stock (Generic, Show) - deriving anyclass (ToRow, FromRow) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs index 55c3213f4a..a7d7866a49 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Serialization.hs @@ -5,7 +5,6 @@ module U.Codebase.Sqlite.Serialization decomposeDeclFormat, decomposePatchFormat, decomposeTermFormat, - decomposeWatchFormat, getBranchFormat, getLocalBranch, getDeclElement, @@ -19,12 +18,10 @@ module U.Codebase.Sqlite.Serialization getTempPatchFormat, getTempTermFormat, getTermAndType, - getTypeFromTermAndType, getTermFormat, getWatchResultFormat, lookupDeclElement, lookupDeclElementNumConstructors, - lookupTermElement, lookupTermElementDiscardingTerm, lookupTermElementDiscardingType, putBranchFormat, @@ -37,7 +34,6 @@ module U.Codebase.Sqlite.Serialization recomposeDeclFormat, recomposePatchFormat, recomposeTermFormat, - recomposeWatchFormat, -- * Exported for Share putTermAndType, @@ -326,12 +322,6 @@ getTermComponent = getTermAndType :: (MonadGet m) => m (TermFormat.Term, TermFormat.Type) getTermAndType = (,) <$> getFramed getSingleTerm <*> getTermElementType --- | Decode ONLY the type of a term-component element. --- This is useful during sync and when we need the type of a term component element but don't --- want to decode the whole term (which can be expensive). -getTypeFromTermAndType :: (MonadGet m) => m (TermFormat.Type) -getTypeFromTermAndType = skipFramed *> getTermElementType - getSingleTerm :: (MonadGet m) => m TermFormat.Term getSingleTerm = getABT getSymbol getUnit getF where @@ -408,12 +398,6 @@ getSingleTerm = getABT getSymbol getUnit getF 2 -> pure Term.PConcat tag -> unknownTag "SeqOp" tag -lookupTermElement :: (MonadGet m) => Reference.Pos -> m (LocalIds, TermFormat.Term, TermFormat.Type) -lookupTermElement i = - getWord8 >>= \case - 0 -> unsafeFramedArrayLookup (getTuple3 getLocalIds (getFramed getSingleTerm) getTermElementType) $ fromIntegral i - tag -> unknownTag "lookupTermElement" tag - lookupTermElementDiscardingType :: (MonadGet m) => Reference.Pos -> m (LocalIds, TermFormat.Term) lookupTermElementDiscardingType i = getWord8 >>= \case @@ -813,16 +797,6 @@ recomposeComponent = putFramedArray \(localIds, bytes) -> do putLocalIds localIds putByteString bytes -decomposeWatchFormat :: (MonadGet m) => m TermFormat.SyncWatchResultFormat -decomposeWatchFormat = - getWord8 >>= \case - 0 -> TermFormat.SyncWatchResult <$> getWatchLocalIds <*> getRemainingByteString - x -> unknownTag "decomposeWatchFormat" x - -recomposeWatchFormat :: (MonadPut m) => TermFormat.SyncWatchResultFormat -> m () -recomposeWatchFormat (TermFormat.SyncWatchResult wli bs) = - putWord8 0 *> putLocalIds wli *> putByteString bs - decomposePatchFormat :: (MonadGet m) => m PatchFormat.SyncPatchFormat decomposePatchFormat = getWord8 >>= \case diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs index e50d215ecf..d9aaeb89c7 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs @@ -9,7 +9,6 @@ import U.Codebase.Reference (Reference') import U.Codebase.Referent (Referent') import U.Codebase.Sqlite.DbId (ObjectId, TextId) import U.Codebase.Sqlite.LocalIds (LocalDefnId, LocalIds', LocalTextId, WatchLocalIds) -import U.Codebase.Sqlite.Reference qualified as Sqlite import U.Codebase.Sqlite.Symbol (Symbol) import U.Codebase.Term qualified as Term import U.Codebase.Type qualified as Type @@ -40,9 +39,6 @@ type TypeLink = TypeRef -- * The term's type, also with internal references to local id. type LocallyIndexedComponent = LocallyIndexedComponent' TextId ObjectId --- | A locally indexed component which uses hash references instead of database ids. -type HashLocallyIndexedComponent = LocallyIndexedComponent' Text Hash32 - newtype LocallyIndexedComponent' t d = LocallyIndexedComponent {unLocallyIndexedComponent :: Vector (LocalIds' t d, Term, Type)} deriving (Show) @@ -112,11 +108,6 @@ type Type = ABT.Term FT Symbol () -- * Type of Term --- Maybe these should have a LocalIds index too; or share one with the term? -type FTT = Type.F' Sqlite.Reference - -type TypeOfTerm = ABT.Term FTT Symbol () - type TermFormat = TermFormat' TextId ObjectId -- | A TermFormat which uses hash references instead of database ids. @@ -130,6 +121,3 @@ data SyncTermFormat' t d = SyncTerm (SyncLocallyIndexedComponent' t d) data WatchResultFormat = WatchResult WatchLocalIds Term - -data SyncWatchResultFormat - = SyncWatchResult WatchLocalIds ByteString diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 2641df87cd..92ef9bc611 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -33,7 +33,6 @@ source-repository head library exposed-modules: U.Codebase.Branch - U.Codebase.Causal.Squash U.Codebase.Sqlite.Branch.Diff U.Codebase.Sqlite.Branch.Format U.Codebase.Sqlite.Branch.Full @@ -61,8 +60,6 @@ library U.Codebase.Sqlite.Queries U.Codebase.Sqlite.Reference U.Codebase.Sqlite.Referent - U.Codebase.Sqlite.RemoteProject - U.Codebase.Sqlite.RemoteProjectBranch U.Codebase.Sqlite.Serialization U.Codebase.Sqlite.Symbol U.Codebase.Sqlite.TempEntity diff --git a/codebase2/codebase-sync/U/Codebase/Sync.hs b/codebase2/codebase-sync/U/Codebase/Sync.hs index a88b290ad8..8d0ff2a479 100644 --- a/codebase2/codebase-sync/U/Codebase/Sync.hs +++ b/codebase2/codebase-sync/U/Codebase/Sync.hs @@ -19,9 +19,6 @@ data TrySyncResult entity = Missing [entity] | Done | PreviouslyDone | NonFatalE 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) - data Progress m h = Progress { need :: h -> m (), done :: h -> m (), @@ -29,9 +26,6 @@ data Progress m h = Progress allDone :: m () } -transformProgress :: (forall a. m a -> n a) -> Progress m h -> Progress n h -transformProgress f (Progress a b c d) = Progress (f . a) (f . b) (f . c) (f d) - -- the Show constraint is just for debugging sync, sync' :: forall m h. (Monad m, Show h) => Sync m h -> Progress m h -> [h] -> m () diff --git a/codebase2/codebase/U/Codebase/Branch/Type.hs b/codebase2/codebase/U/Codebase/Branch/Type.hs index d19743a3b9..40aee5f681 100644 --- a/codebase2/codebase/U/Codebase/Branch/Type.hs +++ b/codebase2/codebase/U/Codebase/Branch/Type.hs @@ -2,21 +2,17 @@ module U.Codebase.Branch.Type ( Branch (..), CausalBranch, Patch (..), - MetadataType, MetadataValue, MdValues (..), NamespaceStats (..), hasDefinitions, childAt, - hoist, - hoistCausalBranch, U.Codebase.Branch.Type.empty, ) where import Data.Map.Strict qualified as Map import U.Codebase.Causal (Causal) -import U.Codebase.Causal qualified as Causal import U.Codebase.HashTags (BranchHash, CausalHash, PatchHash) import U.Codebase.Reference (Reference) import U.Codebase.Referent (Referent) @@ -25,8 +21,6 @@ import U.Codebase.TypeEdit (TypeEdit) import Unison.NameSegment (NameSegment) import Unison.Prelude -type MetadataType = Reference - type MetadataValue = Reference newtype MdValues = MdValues {unMdValues :: Set MetadataValue} deriving (Eq, Ord, Show) @@ -86,18 +80,3 @@ hasDefinitions (NamespaceStats numTerms numTypes _numPatches) = 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 {children, patches, terms, types} = - Branch - { terms = (fmap . fmap) f terms, - types = (fmap . fmap) f types, - patches = (fmap . fmap) f patches, - children = fmap (hoistCausalBranch f) children - } - -hoistCausalBranch :: (Functor n) => (forall x. m x -> n x) -> CausalBranch m -> CausalBranch n -hoistCausalBranch f cb = - cb - & Causal.hoist f - & Causal.emap (hoist f) (hoist f) diff --git a/codebase2/codebase/U/Codebase/Causal.hs b/codebase2/codebase/U/Codebase/Causal.hs index 74e4c1fcf0..78710c4419 100644 --- a/codebase2/codebase/U/Codebase/Causal.hs +++ b/codebase2/codebase/U/Codebase/Causal.hs @@ -2,13 +2,10 @@ module U.Codebase.Causal ( Causal (..), - emap, - hoist, ) where import Data.Function (on) -import Data.Map.Strict qualified as Map import Unison.Prelude data Causal m hc he pe e = Causal @@ -21,19 +18,3 @@ data Causal m hc he pe e = Causal instance (Eq hc) => Eq (Causal m hc he pe e) where (==) = (==) `on` causalHash - --- | @emap f g@ maps over the values and parents' values with @f@ and @g@. -emap :: (Functor m) => (e -> e') -> (pe -> pe') -> Causal m hc he pe e -> Causal m hc he pe' e' -emap f g causal@Causal {parents, value} = - causal - { parents = Map.map (fmap (emap g g)) parents, - value = f <$> value - } - -hoist :: (Functor n) => (forall x. m x -> n x) -> Causal m hc he pe e -> Causal n hc he pe e -hoist f (Causal {..}) = - Causal - { parents = parents & fmap f & (fmap . fmap) (hoist f), - value = f value, - .. - } diff --git a/codebase2/codebase/U/Codebase/Decl.hs b/codebase2/codebase/U/Codebase/Decl.hs index cf6ae66902..e32b7313d4 100644 --- a/codebase2/codebase/U/Codebase/Decl.hs +++ b/codebase2/codebase/U/Codebase/Decl.hs @@ -17,7 +17,7 @@ import Unison.Util.Recursion type ConstructorId = Word64 data DeclType = Data | Effect - deriving (Eq, Ord, Show, Enum) + deriving (Eq, Ord, Show) type Decl v = DeclR TypeRef v @@ -55,29 +55,11 @@ vmap f (DataDeclaration {declType, modifier, bound, constructorTypes}) = constructorTypes = ABT.vmap f <$> constructorTypes } -rmap :: (Ord v) => (r -> r') -> DeclR r v -> DeclR r' v -rmap f (DataDeclaration {declType, modifier, bound, constructorTypes}) = - DataDeclaration - { declType, - modifier, - bound, - constructorTypes = Type.rmap f <$> constructorTypes - } - -- * Hashing stuff dependencies :: (Ord r, Ord v) => DeclR r v -> Set r dependencies (DataDeclaration _ _ _ cts) = foldMap Type.dependencies cts -data V v = Bound v | Ctor Int - -data F a - = Type (Type.FD a) - | LetRec [a] a - | Constructors [a] - | Modified DeclType Modifier a - deriving (Functor, Foldable, Show) - -- | Given the pieces of a single decl component, -- replaces all 'Nothing' self-referential hashes with a variable reference -- to the relevant piece of the component in the component map. diff --git a/codebase2/codebase/U/Codebase/Referent.hs b/codebase2/codebase/U/Codebase/Referent.hs index 93aec093a8..5ff6ceab2d 100644 --- a/codebase2/codebase/U/Codebase/Referent.hs +++ b/codebase2/codebase/U/Codebase/Referent.hs @@ -11,8 +11,6 @@ import U.Codebase.Reference (Reference, Reference') import U.Codebase.Reference qualified as Reference import Unison.Hash (Hash) import Unison.Prelude -import Unison.ShortHash (ShortHash) -import Unison.ShortHash qualified as SH data ConstructorType = DataConstructor @@ -31,33 +29,12 @@ data Referent' termRef typeRef refs_ :: Traversal (Referent' ref ref) (Referent' ref' ref') ref ref' refs_ f r = bitraverse f f r -typeRef_ :: Traversal (Referent' termRef typeRef) (Referent' termRef typeRef') typeRef typeRef' -typeRef_ f = bitraverse pure f - -termRef_ :: Traversal (Referent' termRef typeRef) (Referent' termRef' typeRef) termRef termRef' -termRef_ f = bitraverse f pure - _Ref :: Prism (Referent' tmr tyr) (Referent' tmr' tyr) tmr tmr' _Ref = _Ctor @"Ref" _Con :: Prism (Referent' tmr tyr) (Referent' tmr tyr') (tyr, ConstructorId) (tyr', ConstructorId) _Con = _Ctor @"Con" -toReference :: Referent -> Reference -toReference = \case - Ref termRef -> termRef - Con typeRef _ -> typeRef - -toReferenceId :: Referent -> Maybe Reference.Id -toReferenceId = \case - Ref termRef -> Reference.toId termRef - Con typeRef _ -> Reference.toId typeRef - -toTermReference :: Referent' termRef typeRef -> Maybe termRef -toTermReference = \case - Ref termRef -> Just termRef - Con _ _ -> Nothing - type Id = Id' Hash Hash data Id' hTm hTp @@ -94,11 +71,3 @@ instance Bitraversable Id' where bitraverse f g = \case RefId r -> RefId <$> traverse f r ConId r c -> flip ConId c <$> traverse g r - -toShortHash :: Referent -> ShortHash -toShortHash = \case - Ref r -> Reference.toShortHash r - Con r conId -> - case Reference.toShortHash r of - SH.Builtin b -> SH.Builtin b - SH.ShortHash prefix cycle _cid -> SH.ShortHash prefix cycle (Just conId) diff --git a/codebase2/codebase/U/Codebase/Term.hs b/codebase2/codebase/U/Codebase/Term.hs index 07b938ae25..fc160b52a4 100644 --- a/codebase2/codebase/U/Codebase/Term.hs +++ b/codebase2/codebase/U/Codebase/Term.hs @@ -2,8 +2,6 @@ module U.Codebase.Term where import Control.Lens hiding (List) import Control.Monad.State -import Control.Monad.Writer qualified as Writer -import Data.Foldable qualified as Foldable import Data.Map qualified as Map import Data.Set qualified as Set import U.Codebase.Reference (Reference, Reference') @@ -205,9 +203,6 @@ extraMapM ftext ftermRef ftypeRef ftermLink ftypeLink fvt = go' goCase (MatchCase p g b) = MatchCase <$> goPat p <*> pure g <*> pure b goPat = rmapPatternM ftext ftypeRef -rmapPattern :: (t -> t') -> (r -> r') -> Pattern t r -> Pattern t' r' -rmapPattern ft fr p = runIdentity . rmapPatternM (pure . ft) (pure . fr) $ p - rmapPatternM :: (Applicative m) => (t -> m t') -> (r -> m r') -> Pattern t r -> m (Pattern t' r') rmapPatternM ft fr = go where @@ -227,35 +222,6 @@ rmapPatternM ft fr = go PSequenceLiteral ps -> PSequenceLiteral <$> traverse go ps PSequenceOp p1 op p2 -> PSequenceOp <$> go p1 <*> pure op <*> go p2 -dependencies :: - (Ord termRef, Ord typeRef, Ord termLink, Ord typeLink, Ord v) => - ABT.Term (F' text termRef typeRef termLink typeLink vt) v a -> - (Set termRef, Set typeRef, Set termLink, Set typeLink) -dependencies = - Writer.execWriter . ABT.visit_ \case - Ref r -> termRef r - Constructor r _ -> typeRef r - Request r _ -> typeRef r - Match _ cases -> Foldable.for_ cases \case - MatchCase pat _guard _body -> go pat - where - go = \case - PConstructor r _i args -> typeRef r *> Foldable.traverse_ go args - PAs pat -> go pat - PEffectPure pat -> go pat - PEffectBind r _i args k -> typeRef r *> Foldable.traverse_ go args *> go k - PSequenceLiteral pats -> Foldable.traverse_ go pats - PSequenceOp l _op r -> go l *> go r - _ -> pure () - TermLink r -> termLink r - TypeLink r -> typeLink r - _ -> pure () - where - termRef r = Writer.tell (Set.singleton r, mempty, mempty, mempty) - typeRef r = Writer.tell (mempty, Set.singleton r, mempty, mempty) - termLink r = Writer.tell (mempty, mempty, Set.singleton r, mempty) - typeLink r = Writer.tell (mempty, mempty, mempty, Set.singleton r) - -- | Given the pieces of a single term component, -- replaces all 'Nothing' self-referential hashes with a variable reference -- to the relevant piece of the component in the component map. diff --git a/codebase2/codebase/U/Codebase/Type.hs b/codebase2/codebase/U/Codebase/Type.hs index d24179b89a..beb981bee3 100644 --- a/codebase2/codebase/U/Codebase/Type.hs +++ b/codebase2/codebase/U/Codebase/Type.hs @@ -1,7 +1,6 @@ module U.Codebase.Type where import Control.Monad.Writer.Strict qualified as Writer -import Data.Maybe qualified as Maybe import Data.Set qualified as Set import U.Codebase.Kind (Kind) import U.Codebase.Reference (Reference, Reference') @@ -49,9 +48,6 @@ rmapM f = ABT.transformM \case Ref r -> Ref <$> f r x -> pure $ unsafeCoerce x -typeD2T :: (Ord v) => Hash -> TypeD v -> TypeT v -typeD2T h = rmap $ bimap id $ Maybe.fromMaybe h - dependencies :: (Ord v, Ord r) => ABT.Term (F' r) v a -> Set r dependencies = Writer.execWriter . ABT.visit' f where diff --git a/codebase2/core/U/Codebase/HashTags.hs b/codebase2/core/U/Codebase/HashTags.hs index 5470f3009f..8663fbfee1 100644 --- a/codebase2/core/U/Codebase/HashTags.hs +++ b/codebase2/core/U/Codebase/HashTags.hs @@ -1,8 +1,6 @@ module U.Codebase.HashTags where import Unison.Hash (Hash) -import Unison.Hash32 (Hash32) -import Unison.Prelude -- | Represents a hash of a type or term component newtype ComponentHash = ComponentHash {unComponentHash :: Hash} @@ -29,55 +27,3 @@ instance Show CausalHash where instance Show PatchHash where show h = "PatchHash (" ++ show (unPatchHash h) ++ ")" - -instance From ComponentHash Text where - from = from @Hash @Text . unComponentHash - -instance From BranchHash Text where - from = from @Hash @Text . unBranchHash - -instance From CausalHash Text where - from = from @Hash @Text . unCausalHash - -instance From PatchHash Text where - from = from @Hash @Text . unPatchHash - -instance From ComponentHash Hash - -instance From BranchHash Hash - -instance From CausalHash Hash - -instance From PatchHash Hash - -instance From Hash ComponentHash - -instance From Hash BranchHash - -instance From Hash CausalHash - -instance From Hash PatchHash - -instance From ComponentHash Hash32 where - from = from @Hash @Hash32 . unComponentHash - -instance From BranchHash Hash32 where - from = from @Hash @Hash32 . unBranchHash - -instance From CausalHash Hash32 where - from = from @Hash @Hash32 . unCausalHash - -instance From PatchHash Hash32 where - from = from @Hash @Hash32 . unPatchHash - -instance From Hash32 ComponentHash where - from = ComponentHash . from @Hash32 @Hash - -instance From Hash32 BranchHash where - from = BranchHash . from @Hash32 @Hash - -instance From Hash32 CausalHash where - from = CausalHash . from @Hash32 @Hash - -instance From Hash32 PatchHash where - from = PatchHash . from @Hash32 @Hash diff --git a/codebase2/core/U/Codebase/Reference.hs b/codebase2/core/U/Codebase/Reference.hs index e40ce2ac37..0eaf51a634 100644 --- a/codebase2/core/U/Codebase/Reference.hs +++ b/codebase2/core/U/Codebase/Reference.hs @@ -1,11 +1,8 @@ module U.Codebase.Reference ( Reference, - RReference, TermReference, - TermRReference, TermReferenceId, TypeReference, - TypeRReference, TypeReferenceId, Reference' (..), TermReference', @@ -16,7 +13,6 @@ module U.Codebase.Reference Id' (..), Pos, _ReferenceDerived, - _RReferenceReference, t_, h_, idH, @@ -31,7 +27,7 @@ module U.Codebase.Reference ) where -import Control.Lens (Lens, Lens', Prism, Prism', Traversal, lens, preview, prism) +import Control.Lens (Lens, Lens', Prism, Traversal, lens, preview, prism) import Data.Bifoldable (Bifoldable (..)) import Data.Bitraversable (Bitraversable (..)) import Data.Text qualified as Text @@ -45,21 +41,12 @@ import Unison.ShortHash qualified as SH -- | This is the canonical representation of Reference type Reference = Reference' Text Hash --- | A possibly-self (R = "recursive") reference. -type RReference = Reference' Text (Maybe Hash) - -- | A term reference. type TermReference = Reference --- | A possibly-self term reference. -type TermRReference = RReference - -- | A type declaration reference. type TypeReference = Reference --- | A possibly-self type declaration reference. -type TypeRReference = RReference - type Id = Id' Hash -- | A term reference id. @@ -82,19 +69,6 @@ type TermReference' t h = Reference' t h -- | A term declaration reference. type TypeReference' t h = Reference' t h -_RReferenceReference :: Prism' (Reference' t (Maybe h)) (Reference' t h) -_RReferenceReference = prism embed project - where - embed = \case - ReferenceBuiltin x -> ReferenceBuiltin x - ReferenceDerived (Id h p) -> ReferenceDerived (Id (Just h) p) - - project = \case - ReferenceBuiltin x -> Right (ReferenceBuiltin x) - ReferenceDerived (Id mh p) -> case mh of - Nothing -> Left (ReferenceDerived (Id mh p)) - Just h -> Right (ReferenceDerived (Id h p)) - _ReferenceDerived :: Prism (Reference' t h) (Reference' t h') (Id' h) (Id' h') _ReferenceDerived = prism embed project where diff --git a/codebase2/core/U/Core/ABT.hs b/codebase2/core/U/Core/ABT.hs index 2e22791fde..3f9d2e5ee2 100644 --- a/codebase2/core/U/Core/ABT.hs +++ b/codebase2/core/U/Core/ABT.hs @@ -1,5 +1,4 @@ --- Based on: http://semantic-domain.blogspot.com/2015/03/abstract-binding-trees.html - +-- | Based on: http://semantic-domain.blogspot.com/2015/03/abstract-binding-trees.html module U.Core.ABT where import Control.Lens (Lens', use, (.=)) diff --git a/codebase2/core/Unison/ShortHash.hs b/codebase2/core/Unison/ShortHash.hs index 70dce9de9e..3822f31745 100644 --- a/codebase2/core/Unison/ShortHash.hs +++ b/codebase2/core/Unison/ShortHash.hs @@ -3,7 +3,6 @@ module Unison.ShortHash ( ShortHash (..), ShortCausalHash (..), - ShortNamespaceHash (..), isPrefixOf, shortenTo, @@ -39,9 +38,6 @@ data ShortHash newtype ShortCausalHash = ShortCausalHash {shortCausalHashToText :: Text} deriving stock (Eq, Ord, Show) -newtype ShortNamespaceHash = ShortNamespaceHash {shortNamespaceHashToText :: Text} - deriving stock (Eq, Ord, Show) - -- x `isPrefixOf` y is True iff x might be a shorter version of y -- if a constructor id is provided on the right-hand side, the left-hand side -- needs to match exactly (as of this commit). diff --git a/codebase2/util-serialization/U/Util/Serialization.hs b/codebase2/util-serialization/U/Util/Serialization.hs index 2d4f1bd7ae..eb2f6dc044 100644 --- a/codebase2/util-serialization/U/Util/Serialization.hs +++ b/codebase2/util-serialization/U/Util/Serialization.hs @@ -11,10 +11,8 @@ module U.Util.Serialization where import Control.Applicative (liftA3) import Control.Monad (foldM, replicateM, replicateM_, when) import Data.Bits (Bits, clearBit, setBit, shiftL, shiftR, testBit, (.|.)) -import Data.ByteString (ByteString, readFile, writeFile) +import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import Data.ByteString.Short (ShortByteString) -import qualified Data.ByteString.Short as BSS import Data.Bytes.Get (MonadGet, getByteString, getBytes, getWord8, remaining, runGetS, skip) import Data.Bytes.Put (MonadPut, putByteString, putWord8, runPutS) import Data.Bytes.VarInt (VarInt (VarInt)) @@ -27,56 +25,23 @@ import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import Data.Text.Encoding (decodeUtf8, encodeUtf8) -import Data.Text.Short (ShortText) -import qualified Data.Text.Short as TS -import qualified Data.Text.Short.Unsafe as TSU import Data.Vector (Vector) import qualified Data.Vector as Vector import Data.Word (Word8) import Debug.Trace (traceM) import GHC.Word (Word64) -import System.FilePath (takeDirectory) -import UnliftIO (MonadIO, liftIO) -import UnliftIO.Directory (createDirectoryIfMissing, doesFileExist) import Prelude hiding (readFile, writeFile) type Get a = forall m. (MonadGet m) => m a type Put a = forall m. (MonadPut m) => a -> m () --- todo: do we use this? -data Format a = Format - { get :: Get a, - put :: Put a - } - debug :: Bool debug = False -getFromBytes :: Get a -> ByteString -> Maybe a -getFromBytes getA bytes = - case runGetS getA bytes of Left _ -> Nothing; Right a -> Just a - -getFromFile :: (MonadIO m) => Get a -> FilePath -> m (Maybe a) -getFromFile getA file = do - b <- doesFileExist file - if b then getFromBytes getA <$> liftIO (readFile file) else pure Nothing - -getFromFile' :: (MonadIO m) => Get a -> FilePath -> m (Either String a) -getFromFile' getA file = do - b <- doesFileExist file - if b - then runGetS getA <$> liftIO (readFile file) - else pure . Left $ "No such file: " ++ file - putBytes :: Put a -> a -> ByteString putBytes put a = runPutS (put a) -putWithParentDirs :: (MonadIO m) => Put a -> FilePath -> a -> m () -putWithParentDirs putA file a = do - createDirectoryIfMissing True (takeDirectory file) - liftIO . writeFile file $ putBytes putA a - putVarInt :: (MonadPut m, Integral a, Bits a) => a -> m () putVarInt n | n < 0x80 = putWord8 $ fromIntegral n @@ -112,28 +77,6 @@ getText = do skipText :: (MonadGet m) => m () skipText = skip =<< getVarInt -putShortText :: (MonadPut m) => ShortText -> m () -putShortText text = do - let sbs = TS.toShortByteString text - putVarInt $ BSS.length sbs - putShortByteString sbs - -getShortText :: (MonadGet m) => m ShortText -getShortText = do - len <- getVarInt - sbs <- getShortByteString len - pure $ TSU.fromShortByteStringUnsafe sbs - --- | the `binary` package has a native version of this, --- which may be more efficient by a constant factor -putShortByteString :: (MonadPut m) => ShortByteString -> m () -putShortByteString = putByteString . BSS.fromShort - --- | the `binary` package has a native version of this, --- which may be more efficient by a constant factor -getShortByteString :: (MonadGet m) => Int -> m ShortByteString -getShortByteString len = BSS.toShort <$> getByteString len - putFoldable :: (Foldable f, MonadPut m) => (a -> m ()) -> f a -> m () putFoldable putA as = do @@ -229,18 +172,6 @@ getFramedArray getA = do let count = length offsets - 1 Vector.replicateM count getA --- | Look up a 0-based index in a framed array, O(num array elements), --- because it reads the start indices for all elements first. --- This could be skipped if the indices had a fixed size instead of varint -lookupFramedArray :: (MonadGet m) => m a -> Int -> m (Maybe a) -lookupFramedArray getA index = do - offsets <- getVector getVarInt - if index > Vector.length offsets - 1 - then pure Nothing - else do - skip (Vector.unsafeIndex offsets index) - Just <$> getA - lengthFramedArray :: (MonadGet m) => m Word64 lengthFramedArray = (\offsetsLen -> offsetsLen - 1) <$> getVarInt diff --git a/codebase2/util-serialization/package.yaml b/codebase2/util-serialization/package.yaml index 2f836d75cc..281cd7f176 100644 --- a/codebase2/util-serialization/package.yaml +++ b/codebase2/util-serialization/package.yaml @@ -11,8 +11,5 @@ dependencies: - bytes - bytestring - containers - - filepath - text - - text-short - - unliftio - vector diff --git a/codebase2/util-serialization/unison-util-serialization.cabal b/codebase2/util-serialization/unison-util-serialization.cabal index 57ad5b4a47..2870591360 100644 --- a/codebase2/util-serialization/unison-util-serialization.cabal +++ b/codebase2/util-serialization/unison-util-serialization.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.0. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -18,9 +18,6 @@ library , bytes , bytestring , containers - , filepath , text - , text-short - , unliftio , vector default-language: Haskell2010 diff --git a/codebase2/util-term/U/Util/Term.hs b/codebase2/util-term/U/Util/Term.hs index f86f598e82..087ebe6999 100644 --- a/codebase2/util-term/U/Util/Term.hs +++ b/codebase2/util-term/U/Util/Term.hs @@ -11,12 +11,6 @@ import U.Codebase.Term (F' (..), MatchCase (..), Pattern (..)) import qualified U.Codebase.Term as Term import qualified U.Core.ABT as ABT -text :: (Ord v) => ABT.Term (Term.F' text termRef typeRef termLink typeLink vt) v a -> [text] -text = - execWriter . ABT.visit_ \case - Text t -> tell [t] - _ -> pure () - dependencies :: (Ord v) => ABT.Term (Term.F' text termRef typeRef termLink typeLink vt) v a -> diff --git a/development.markdown b/development.markdown index d63bf7c245..3712c64b09 100644 --- a/development.markdown +++ b/development.markdown @@ -224,3 +224,15 @@ cabal run --enable-profiling unison-cli-main:exe:unison -- +RTS -p ## Native compilation See the [readme](scheme-libs/racket/unison/Readme.md). + +## Weeding + +The Nix devShell includes Weeder, a tool for detecting dead code. + +Before running it, make sure your build is up-to-date (`stack build --bench --no-run-benchmarks --test --no-run-tests --haddock`). + +Not building tests will result in false reports of dead code, because Weeder won’t see call sites of things used only by tests. However, if Weeder runs clean on the entire codebase, you can `stack clean && stack build && weeder` and the complaints Weeder emits will then be things that are defined in production code, but are only used in benchmarks, tests, or Haddock. This indicates either dead code that we’re testing, or test utilities that live in the wrong place. The former should be removed, and the later should be moved. + +Removing `root-instances` and then `weeder | grep --invert-match '\(Instance\)'` can show you types that are unused (but appear used because of the instances). + +__NB__: Sometimes weeder complains about HIE files being built with the wrong GHC version. To fix this, I’ve had success with deleting my .direnv cache. You can specify multiple directories for Weeder to search with `--hie-directory`, but can’t specify a directory to exclude. diff --git a/flake.nix b/flake.nix index a266bd2e29..9f82cd2e14 100644 --- a/flake.nix +++ b/flake.nix @@ -35,6 +35,7 @@ // { hpack = "0.35.2"; ormolu = "0.7.2.0"; + weeder = "2.8.0"; }; pkgs = import nixpkgs-haskellNix { inherit system; diff --git a/lib/unison-hash/src/Unison/Hash.hs b/lib/unison-hash/src/Unison/Hash.hs index c6b4b2d67e..f311841a13 100644 --- a/lib/unison-hash/src/Unison/Hash.hs +++ b/lib/unison-hash/src/Unison/Hash.hs @@ -15,7 +15,6 @@ module Unison.Hash -- ** Base32Hex Text conversions fromBase32HexText, - unsafeFromBase32HexText, toBase32HexText, ) where @@ -37,9 +36,6 @@ instance Show Hash where newtype HashFor t = HashFor {genericHash :: Hash} deriving newtype (Show, Eq, Ord, Generic) -instance From Hash Text where - from = toBase32HexText - -- | Convert a hash to a byte string. toByteString :: Hash -> ByteString toByteString = B.Short.fromShort . toShort @@ -60,10 +56,6 @@ toBase32Hex = Base32Hex.fromByteString . toByteString fromBase32HexText :: Text -> Maybe Hash fromBase32HexText = fmap fromBase32Hex . Base32Hex.fromText --- | Convert a hash from base32 hex without any validation. -unsafeFromBase32HexText :: Text -> Hash -unsafeFromBase32HexText = fromBase32Hex . Base32Hex.UnsafeFromText - -- | Return the lowercase unpadded base32Hex encoding of this 'Hash'. -- Multibase prefix would be 'v', see https://github.com/multiformats/multibase toBase32HexText :: Hash -> Text diff --git a/lib/unison-hash/src/Unison/Hash32.hs b/lib/unison-hash/src/Unison/Hash32.hs index 97e7c201ed..9d55c82a81 100644 --- a/lib/unison-hash/src/Unison/Hash32.hs +++ b/lib/unison-hash/src/Unison/Hash32.hs @@ -32,15 +32,6 @@ import Unison.Prelude newtype Hash32 = UnsafeFromBase32Hex Base32Hex deriving (Eq, Ord, Show) via (Text) -instance From Hash32 Text where - from = toText - -instance From Hash32 Hash where - from = toHash - -instance From Hash Hash32 where - from = fromHash - fromHash :: Hash -> Hash32 fromHash = unsafeFromBase32Hex . Hash.toBase32Hex diff --git a/lib/unison-prelude/src/U/Util/Text.hs b/lib/unison-prelude/src/U/Util/Text.hs deleted file mode 100644 index 6b1d162b2c..0000000000 --- a/lib/unison-prelude/src/U/Util/Text.hs +++ /dev/null @@ -1,37 +0,0 @@ -module U.Util.Text - ( stripMargin, - ) -where - -import Data.Char qualified as Char -import Data.Maybe (fromMaybe) -import Data.Text (Text) -import Data.Text qualified as Text -import Safe.Foldable (minimumMay) - --- | remove however many spaces prefix all of the lines of the input --- e.g. --- stripMargin [here| --- def foo: --- blah blah --- |] == [here| --- def foo: --- blah blah --- |]T -stripMargin :: Text -> Text -stripMargin str = - let stripLen = - Data.Maybe.fromMaybe 0 - . minimumMay - . map (Text.length . fst . Text.span (== ' ')) - . filter (not . Text.all (Char.isSpace)) - $ Text.lines str - dropFirstIf f = \case - h : t | f h -> t - x -> x - dropLastIf f = reverse . dropFirstIf f . reverse - in Text.unlines - . dropLastIf Text.null - . dropFirstIf Text.null - . map (Text.drop stripLen) - $ Text.lines str diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index 374f4a1812..3c082d1642 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -11,8 +11,6 @@ module Unison.Prelude wundefined, -- * @Bool@ control flow - onFalse, - onFalseM, onTrue, onTrueM, @@ -113,21 +111,6 @@ altSum = foldl' (<|>) empty altMap :: (Alternative f, Foldable t) => (a -> f b) -> t a -> f b altMap f = altSum . fmap f . toList --- | --- > condition & onFalse do --- > shortCircuit -onFalse :: (Applicative m) => m () -> Bool -> m () -onFalse action = \case - False -> action - True -> pure () - --- | --- > action & onFalseM do --- > shortCircuit -onFalseM :: (Monad m) => m () -> m Bool -> m () -onFalseM x y = - y >>= onFalse x - -- | -- > condition & onTrue do -- > shortCircuit diff --git a/lib/unison-prelude/src/Unison/Util/Set.hs b/lib/unison-prelude/src/Unison/Util/Set.hs index 50d2cff56a..d60e3b1218 100644 --- a/lib/unison-prelude/src/Unison/Util/Set.hs +++ b/lib/unison-prelude/src/Unison/Util/Set.hs @@ -2,20 +2,14 @@ module Unison.Util.Set ( asSingleton, difference1, mapMaybe, - symmetricDifference, Unison.Util.Set.traverse, flatMap, - filterM, - forMaybe, ) where -import Data.Function ((&)) -import Data.Functor ((<&>)) import Data.Maybe qualified as Maybe import Data.Set (Set) import Data.Set qualified as Set -import Unison.Util.Monoid (foldMapM) -- | Get the only member of a set, iff it's a singleton. asSingleton :: Set a -> Maybe a @@ -29,28 +23,11 @@ difference1 xs ys = where zs = Set.difference xs ys -symmetricDifference :: (Ord a) => Set a -> Set a -> Set a -symmetricDifference a b = (a `Set.difference` b) `Set.union` (b `Set.difference` a) - mapMaybe :: (Ord b) => (a -> Maybe b) -> Set a -> Set b mapMaybe f = Set.fromList . Maybe.mapMaybe f . Set.toList -forMaybe :: (Ord b, Applicative f) => Set a -> (a -> f (Maybe b)) -> f (Set b) -forMaybe xs f = - Prelude.traverse f (Set.toList xs) <&> \ys -> - ys - & Maybe.catMaybes - & Set.fromList - traverse :: (Applicative f, Ord b) => (a -> f b) -> Set a -> f (Set b) 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/src/Unison/Util/Timing.hs b/lib/unison-prelude/src/Unison/Util/Timing.hs index e4ffd5b2a2..4b81f1ab72 100644 --- a/lib/unison-prelude/src/Unison/Util/Timing.hs +++ b/lib/unison-prelude/src/Unison/Util/Timing.hs @@ -1,6 +1,5 @@ module Unison.Util.Timing ( time, - unsafeTime, ) where @@ -8,7 +7,6 @@ import Data.Time.Clock (picosecondsToDiffTime) import Data.Time.Clock.System (getSystemTime, systemToTAITime) import Data.Time.Clock.TAI (diffAbsoluteTime) import System.CPUTime (getCPUTime) -import System.IO.Unsafe (unsafePerformIO) import Unison.Debug qualified as Debug import UnliftIO (MonadIO, liftIO) @@ -27,20 +25,3 @@ time label ma = liftIO $ putStrLn $ "Finished " ++ label ++ " in " ++ show cpuDiff ++ " (cpu), " ++ show systemDiff ++ " (system)" pure a else ma - --- Mitchell says: this function doesn't look like it would work at all; let's just delete it -unsafeTime :: (Monad m) => String -> m a -> m 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/lib/unison-prelude/unison-prelude.cabal b/lib/unison-prelude/unison-prelude.cabal index 3fdff06aeb..c8fb88800b 100644 --- a/lib/unison-prelude/unison-prelude.cabal +++ b/lib/unison-prelude/unison-prelude.cabal @@ -17,7 +17,6 @@ source-repository head library exposed-modules: - U.Util.Text Unison.Debug Unison.Prelude Unison.Util.Alternative diff --git a/lib/unison-pretty-printer/package.yaml b/lib/unison-pretty-printer/package.yaml index b46898a9dc..33bf320d32 100644 --- a/lib/unison-pretty-printer/package.yaml +++ b/lib/unison-pretty-printer/package.yaml @@ -81,8 +81,6 @@ tests: dependencies: - base - unison-pretty-printer - - raw-strings-qq - easytest - - containers - code-page - unison-syntax diff --git a/lib/unison-pretty-printer/src/Unison/PrettyTerminal.hs b/lib/unison-pretty-printer/src/Unison/PrettyTerminal.hs index e79e895727..2d1277fd9d 100644 --- a/lib/unison-pretty-printer/src/Unison/PrettyTerminal.hs +++ b/lib/unison-pretty-printer/src/Unison/PrettyTerminal.hs @@ -1,17 +1,10 @@ module Unison.PrettyTerminal where -import Data.Char (isSpace) -import Data.List (dropWhileEnd) import System.Console.Terminal.Size qualified as Terminal import Unison.Util.ColorText qualified as CT import Unison.Util.Less (less) import Unison.Util.Pretty qualified as P -stripSurroundingBlanks :: String -> String -stripSurroundingBlanks s = unlines (dropWhile isBlank . dropWhileEnd isBlank $ lines s) - where - isBlank line = all isSpace line - -- like putPrettyLn' but prints a blank line before and after. putPrettyLn :: P.Pretty CT.ColorText -> IO () putPrettyLn p | p == mempty = pure () diff --git a/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs b/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs index 47bb6d9ca7..4604de78fc 100644 --- a/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs +++ b/lib/unison-pretty-printer/src/Unison/Util/AnnotatedText.hs @@ -96,9 +96,6 @@ annotate' :: Maybe b -> AnnotatedText a -> AnnotatedText b annotate' a (AnnotatedText at) = AnnotatedText $ (\(Segment s _) -> Segment s a) <$> at -deannotate :: AnnotatedText a -> AnnotatedText b -deannotate = annotate' Nothing - -- Replace the annotation (whether existing or no) with the given annotation annotate :: a -> AnnotatedText a -> AnnotatedText a annotate a (AnnotatedText at) = @@ -108,14 +105,6 @@ annotateMaybe :: AnnotatedText (Maybe a) -> AnnotatedText a annotateMaybe (AnnotatedText segments) = AnnotatedText (fmap (\(Segment s a) -> Segment s (join a)) segments) -trailingNewLine :: AnnotatedText a -> Bool -trailingNewLine (AnnotatedText (init :|> (Segment s _))) = - case lastMay s of - Just '\n' -> True - Just _ -> False - _ -> trailingNewLine (AnnotatedText init) -trailingNewLine _ = False - markup :: AnnotatedExcerpt a -> Map Range a -> AnnotatedExcerpt a markup a r = a {annotations = r `Map.union` annotations a} @@ -123,14 +112,6 @@ markup a r = a {annotations = r `Map.union` annotations a} -- renderTextUnstyled (AnnotatedText chunks) = foldl' go mempty chunks -- where go r (text, _) = r <> fromString text -textLength :: AnnotatedText a -> Int -textLength (AnnotatedText chunks) = foldl' go 0 chunks - where - go len (toPair -> (text, _a)) = len + length text - -textEmpty :: AnnotatedText a -> Bool -textEmpty = (== 0) . textLength - condensedExcerptToText :: Int -> AnnotatedExcerpt a -> AnnotatedText a condensedExcerptToText margin e = intercalateMap " .\n" excerptToText $ snipWithContext margin e diff --git a/lib/unison-pretty-printer/tests/Unison/Test/ColorText.hs b/lib/unison-pretty-printer/tests/Unison/Test/ColorText.hs index 3e6b1bfe0a..5d7004c577 100644 --- a/lib/unison-pretty-printer/tests/Unison/Test/ColorText.hs +++ b/lib/unison-pretty-printer/tests/Unison/Test/ColorText.hs @@ -3,99 +3,9 @@ module Unison.Test.ColorText where --- import EasyTest -import Data.Map qualified as Map import EasyTest -import Text.RawString.QQ -import Unison.Lexer.Pos (Pos (..)) -import Unison.Util.AnnotatedText - ( AnnotatedExcerpt (..), - condensedExcerptToText, - markup, - ) -import Unison.Util.ColorText (Color (..), toANSI) -import Unison.Util.ColorText qualified as ColorText -import Unison.Util.Range (Range (..)) test :: Test () test = scope "colortext" . tests $ [] - --- commented out because they don't render exactly the same escape sequences, but they're equivalent4 as of this writing --- scope "inclusive-exclusive range" . expect . trace ("ex4e: " ++ show (rawRender ex4e) ++ "\n" ++ "ex4t: " ++ show (rawRender ex4t) ++ "\n")$ ex4e == ex4t - -ex4e :: String -ex4e = toANSI . condensedExcerptToText 1 $ markup "abc" m - where - m = Map.singleton (Range (Pos 1 2) (Pos 1 3)) Red - -ex4t :: String -ex4t = toANSI $ " 1 | " <> "a" <> ColorText.style Red "b" <> "c" <> "\n" - -ex2 :: AnnotatedExcerpt Color -ex2 = - markup - ex - ( Map.fromList - [ (Range (Pos 3 1) (Pos 3 5), Red), -- SCENE - (Range (Pos 5 9) (Pos 5 14), Blue), -- Master - (Range (Pos 5 22) (Pos 5 30), Blue), -- Boatswain - (Range (Pos 25 1) (Pos 25 6), Red), -- ALONSO - (Range (Pos 12 30) (Pos 13 27), Green) -- fall ... aground. - ] - ) - -renderEx2 :: String -renderEx2 = toANSI . condensedExcerptToText 3 $ ex2 - -ex3 :: AnnotatedExcerpt Color -ex3 = - markup "Hello, world!" $ - Map.fromList - [ (Range (Pos 1 8) (Pos 1 12), Blue), - (Range (Pos 1 1) (Pos 1 5), Green) - ] - -ex4 :: AnnotatedExcerpt Color -ex4 = - markup "Hello,\nworld!" $ - Map.fromList - [ (Range (Pos 2 1) (Pos 2 5), Blue), - (Range (Pos 1 1) (Pos 1 5), Green) - ] - -ex :: (Ord a) => AnnotatedExcerpt a -ex = - [r|The Tempest | Act 1, Scene 1 - -SCENE I. On a ship at sea: a tempestuous noise -of thunder and lightning heard. -Enter a Master and a Boatswain - -Master -Boatswain! -Boatswain -Here, master: what cheer? -Master -Good, speak to the mariners: fall to't, yarely, -or we run ourselves aground: bestir, bestir. -Exit - -Enter Mariners - -Boatswain -Heigh, my hearts! cheerly, cheerly, my hearts! -yare, yare! Take in the topsail. Tend to the -master's whistle. Blow, till thou burst thy wind, -if room enough! -Enter ALONSO, SEBASTIAN, ANTONIO, FERDINAND, GONZALO, and others - -ALONSO -Good boatswain, have care. Where's the master? -Play the men. -Boatswain -I pray now, keep below. -|] - --- test = scope "colortext.snipWithContext" . expect $ diff --git a/lib/unison-pretty-printer/unison-pretty-printer.cabal b/lib/unison-pretty-printer/unison-pretty-printer.cabal index c44cb02e5f..a57cbfec23 100644 --- a/lib/unison-pretty-printer/unison-pretty-printer.cabal +++ b/lib/unison-pretty-printer/unison-pretty-printer.cabal @@ -143,9 +143,7 @@ test-suite pretty-printer-tests build-depends: base , code-page - , containers , easytest - , raw-strings-qq , unison-pretty-printer , unison-syntax default-language: Haskell2010 diff --git a/lib/unison-sqlite/package.yaml b/lib/unison-sqlite/package.yaml index 84d0201eab..445b294e20 100644 --- a/lib/unison-sqlite/package.yaml +++ b/lib/unison-sqlite/package.yaml @@ -20,7 +20,6 @@ library: - text-builder - transformers - unison-prelude - - unison-util-cache - unliftio source-dirs: src diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index eec974d6ed..6cf4259344 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -19,9 +19,7 @@ module Unison.Sqlite Transaction, runTransaction, runTransactionWithRollback, - runReadOnlyTransaction, runWriteTransaction, - cacheTransaction, savepoint, -- ** Unsafe things @@ -38,8 +36,6 @@ module Unison.Sqlite -- ** With results -- $query-naming-convention - queryStreamRow, - queryStreamCol, queryListRow, queryListCol, queryMaybeRow, @@ -48,9 +44,7 @@ module Unison.Sqlite queryOneCol, -- *** With checks - queryListRowCheck, queryListColCheck, - queryMaybeRowCheck, queryMaybeColCheck, queryOneRowCheck, queryOneColCheck, @@ -58,10 +52,6 @@ module Unison.Sqlite -- * Rows modified rowsModified, - -- * Data version - DataVersion (..), - getDataVersion, - -- * Journal mode JournalMode (..), trySetJournalMode, @@ -72,7 +62,6 @@ module Unison.Sqlite -- * Exceptions SomeSqliteException (..), - isCantOpenException, SqliteConnectException, SqliteQueryException, SqliteExceptionReason, @@ -106,14 +95,12 @@ import Unison.Sqlite.Connection vacuumInto, withConnection, ) -import Unison.Sqlite.DataVersion (DataVersion (..), getDataVersion) import Unison.Sqlite.Exception ( SomeSqliteException (..), SomeSqliteExceptionReason (..), SqliteConnectException, SqliteExceptionReason, SqliteQueryException, - isCantOpenException, ) import Unison.Sqlite.JournalMode (JournalMode (..), SetJournalModeException (..), trySetJournalMode) import Unison.Sqlite.Sql (Sql, sql) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs index 48167980db..a74e764f20 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Connection.hs @@ -13,8 +13,6 @@ module Unison.Sqlite.Connection executeStatements, -- ** With results - queryStreamRow, - queryStreamCol, queryListRow, queryListCol, queryMaybeRow, @@ -46,7 +44,6 @@ module Unison.Sqlite.Connection rollback, -- ** Savepoint - withSavepoint, withSavepointIO, savepoint, rollbackTo, @@ -184,34 +181,6 @@ executeStatements conn@(Connection _ _ (Sqlite.Connection database _tempNameCoun -- With results, without checks -queryStreamRow :: (HasCallStack, Sqlite.FromRow a) => Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r -queryStreamRow conn@(Connection _ _ conn0) sql@(Sql s params) callback = - run `catch` \(exception :: Sqlite.SQLError) -> - throwSqliteQueryException - SqliteQueryExceptionInfo - { connection = conn, - exception = SomeSqliteExceptionReason exception, - sql - } - where - run = - bracket (Sqlite.openStatement conn0 (coerce s)) Sqlite.closeStatement \statement -> do - Sqlite.bind statement params - callback (Sqlite.nextRow statement) - -queryStreamCol :: - forall a r. - (HasCallStack, Sqlite.FromField a) => - Connection -> - Sql -> - (IO (Maybe a) -> IO r) -> - IO r -queryStreamCol = - coerce - @(Connection -> Sql -> (IO (Maybe (Sqlite.Only a)) -> IO r) -> IO r) - @(Connection -> Sql -> (IO (Maybe a) -> IO r) -> IO r) - queryStreamRow - queryListRow :: forall a. (Sqlite.FromRow a, HasCallStack) => Connection -> Sql -> IO [a] queryListRow conn@(Connection _ _ conn0) sql@(Sql s params) = do result <- @@ -389,12 +358,6 @@ rollback conn = execute conn [Sql.sql| 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 = - withRunInIO \runInIO -> - withSavepointIO conn name \rollback -> - runInIO (action (liftIO rollback)) - withSavepointIO :: Connection -> Text -> (IO () -> IO a) -> IO a withSavepointIO conn name action = do uninterruptibleMask \restore -> do diff --git a/lib/unison-sqlite/src/Unison/Sqlite/DataVersion.hs b/lib/unison-sqlite/src/Unison/Sqlite/DataVersion.hs deleted file mode 100644 index 6feb2295ad..0000000000 --- a/lib/unison-sqlite/src/Unison/Sqlite/DataVersion.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE QuasiQuotes #-} - -module Unison.Sqlite.DataVersion - ( DataVersion (..), - getDataVersion, - ) -where - -import Unison.Prelude -import Unison.Sqlite.Sql (sql) -import Unison.Sqlite.Transaction - -newtype DataVersion - = DataVersion Int64 - deriving stock (Eq) - deriving newtype (Show) - -getDataVersion :: Transaction DataVersion -getDataVersion = - coerce @(Transaction Int64) (queryOneCol [sql| PRAGMA data_version |]) diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs b/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs index e1473edfc2..93682590d9 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Exception.hs @@ -4,7 +4,6 @@ module Unison.Sqlite.Exception ( -- * @SomeSqliteException@ SomeSqliteException (..), - isCantOpenException, -- ** @SqliteConnectException@ SqliteConnectException (..), @@ -57,12 +56,6 @@ data SomeSqliteException instance Show SomeSqliteException where show (SomeSqliteException e) = show e -isCantOpenException :: SomeSqliteException -> Bool -isCantOpenException (SomeSqliteException exception) = - case cast exception of - Just SqliteConnectException {exception = Sqlite.SQLError Sqlite.ErrorCan'tOpen _ _} -> True - _ -> False - ------------------------------------------------------------------------------------------------------------------------ -- SomeSqliteException -- └── SqliteConnectException @@ -153,7 +146,6 @@ throwSqliteQueryException SqliteQueryExceptionInfo {connection, exception, sql = data SomeSqliteExceptionReason = forall e. (SqliteExceptionReason e) => SomeSqliteExceptionReason e - deriving anyclass (SqliteExceptionReason) instance Show SomeSqliteExceptionReason where show (SomeSqliteExceptionReason x) = show x diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index b44a04b0fa..da7a9da97c 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -3,9 +3,7 @@ module Unison.Sqlite.Transaction Transaction, runTransaction, runTransactionWithRollback, - runReadOnlyTransaction, runWriteTransaction, - cacheTransaction, savepoint, -- ** Unsafe things @@ -20,8 +18,6 @@ module Unison.Sqlite.Transaction executeStatements, -- ** With results - queryStreamRow, - queryStreamCol, queryListRow, queryListCol, queryMaybeRow, @@ -30,9 +26,7 @@ module Unison.Sqlite.Transaction queryOneCol, -- *** With checks - queryListRowCheck, queryListColCheck, - queryMaybeRowCheck, queryMaybeColCheck, queryOneRowCheck, queryOneColCheck, @@ -55,9 +49,7 @@ import Unison.Sqlite.Connection (Connection (..)) import Unison.Sqlite.Connection qualified as Connection import Unison.Sqlite.Exception (SqliteExceptionReason, SqliteQueryException, pattern SqliteBusyException) import Unison.Sqlite.Sql (Sql) -import Unison.Util.Cache (Cache) -import Unison.Util.Cache qualified as Cache -import UnliftIO.Exception (bracketOnError_, catchAny, trySyncOrAsync, uninterruptibleMask) +import UnliftIO.Exception (catchAny, trySyncOrAsync, uninterruptibleMask) import Unsafe.Coerce (unsafeCoerce) newtype Transaction a @@ -74,19 +66,6 @@ instance (Semigroup a) => Semigroup (Transaction a) where (<>) :: Transaction a -> Transaction a -> Transaction a (<>) = liftA2 (<>) --- Internal newtype that equips Transaction with a MonadIO instance -newtype TransactionWithMonadIO a - = TransactionWithMonadIO (Transaction a) - deriving newtype (Applicative, Functor, Monad) - -unTransactionWithMonadIO :: TransactionWithMonadIO a -> Transaction a -unTransactionWithMonadIO (TransactionWithMonadIO m) = m - -instance MonadIO TransactionWithMonadIO where - liftIO :: forall a. IO a -> TransactionWithMonadIO a - liftIO = - coerce @(IO a -> Transaction a) unsafeIO - -- | Run a transaction on the given connection. runTransaction :: (MonadIO m, HasCallStack) => Connection -> Transaction a -> m a runTransaction conn (Transaction f) = liftIO do @@ -130,30 +109,6 @@ runTransactionWithRollback conn transaction = liftIO do Right x -> pure x {-# SPECIALIZE runTransactionWithRollback :: Connection -> ((forall void. a -> Transaction void) -> Transaction a) -> IO a #-} --- | Run a transaction that is known to only perform reads. --- --- The action is provided a function that peels off the 'Transaction' newtype without sending the corresponding --- BEGIN/COMMIT statements. --- --- 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, HasCallStack) => 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 runReadOnlyTransaction :: Connection -> ((forall x. Transaction x -> IO x) -> IO a) -> IO a #-} - -runReadOnlyTransaction_ :: (HasCallStack) => 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 action is provided a function that peels off the 'Transaction' newtype without sending the corresponding @@ -193,11 +148,6 @@ ignoringExceptions :: IO () -> IO () ignoringExceptions action = action `catchAny` \_ -> pure () --- | Wrap a transaction with a cache; cache hits will not hit SQLite. -cacheTransaction :: forall k v. Cache k v -> (k -> Transaction v) -> (k -> Transaction v) -cacheTransaction cache f k = - unTransactionWithMonadIO (Cache.apply cache (TransactionWithMonadIO . f) k) - -- | 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 @@ -242,28 +192,6 @@ executeStatements s = -- With results, without checks -queryStreamRow :: - (Sqlite.FromRow a, HasCallStack) => - Sql -> - (Transaction (Maybe a) -> Transaction r) -> - Transaction r -queryStreamRow sql callback = - Transaction \conn -> - Connection.queryStreamRow conn sql \next -> - unsafeUnTransaction (callback (unsafeIO next)) conn - -queryStreamCol :: - forall a r. - (Sqlite.FromField a, HasCallStack) => - Sql -> - (Transaction (Maybe a) -> Transaction r) -> - Transaction r -queryStreamCol = - coerce - @(Sql -> (Transaction (Maybe (Sqlite.Only a)) -> Transaction r) -> Transaction r) - @(Sql -> (Transaction (Maybe a) -> Transaction r) -> Transaction r) - queryStreamRow - queryListRow :: (Sqlite.FromRow a, HasCallStack) => Sql -> Transaction [a] queryListRow s = Transaction \conn -> Connection.queryListRow conn s @@ -290,14 +218,6 @@ queryOneCol s = -- With results, with parameters, with checks -queryListRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => - Sql -> - ([a] -> Either e r) -> - Transaction r -queryListRowCheck sql check = - Transaction \conn -> Connection.queryListRowCheck conn sql check - queryListColCheck :: (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Sql -> @@ -306,14 +226,6 @@ queryListColCheck :: queryListColCheck sql check = Transaction \conn -> Connection.queryListColCheck conn sql check -queryMaybeRowCheck :: - (Sqlite.FromRow a, SqliteExceptionReason e, HasCallStack) => - Sql -> - (a -> Either e r) -> - Transaction (Maybe r) -queryMaybeRowCheck s check = - Transaction \conn -> Connection.queryMaybeRowCheck conn s check - queryMaybeColCheck :: (Sqlite.FromField a, SqliteExceptionReason e, HasCallStack) => Sql -> diff --git a/lib/unison-sqlite/unison-sqlite.cabal b/lib/unison-sqlite/unison-sqlite.cabal index 28ea0f7c4f..a4f8dccc41 100644 --- a/lib/unison-sqlite/unison-sqlite.cabal +++ b/lib/unison-sqlite/unison-sqlite.cabal @@ -23,7 +23,6 @@ library Unison.Sqlite.Transaction other-modules: Unison.Sqlite.Connection.Internal - Unison.Sqlite.DataVersion Unison.Sqlite.Exception Unison.Sqlite.JournalMode Unison.Sqlite.Sql @@ -75,7 +74,6 @@ library , text-builder , transformers , unison-prelude - , unison-util-cache , unliftio default-language: Haskell2010 diff --git a/lib/unison-util-cache/src/Unison/Util/Cache.hs b/lib/unison-util-cache/src/Unison/Util/Cache.hs index 1630d97285..f002f111ba 100644 --- a/lib/unison-util-cache/src/Unison/Util/Cache.hs +++ b/lib/unison-util-cache/src/Unison/Util/Cache.hs @@ -1,6 +1,5 @@ module Unison.Util.Cache ( Cache, - cache, nullCache, semispaceCache, lookup, @@ -29,19 +28,6 @@ lookup c k = liftIO (lookup_ c k) insert :: (MonadIO m) => Cache k v -> k -> v -> m () insert c k v = liftIO (insert_ c k v) --- Create a cache of unbounded size. -cache :: (MonadIO m, Ord k) => m (Cache k v) -cache = do - t <- newTVarIO Map.empty - let lookup k = Map.lookup k <$> readTVarIO t - insert k v = do - m <- readTVarIO t - case Map.lookup k m of - Nothing -> atomically $ modifyTVar' t (Map.insert k v) - _ -> pure () - - pure $ Cache lookup insert - nullCache :: Cache k v nullCache = Cache (const (pure Nothing)) (\_ _ -> pure ()) diff --git a/lib/unison-util-cache/test/Main.hs b/lib/unison-util-cache/test/Main.hs index 060af0270c..2df10f3340 100644 --- a/lib/unison-util-cache/test/Main.hs +++ b/lib/unison-util-cache/test/Main.hs @@ -14,8 +14,7 @@ main = test :: Test () test = tests - [ scope "ex1" $ fits Cache.cache, - scope "ex2" $ fits (Cache.semispaceCache n), + [ scope "ex2" $ fits (Cache.semispaceCache n), scope "ex3" $ doesn'tFit (Cache.semispaceCache n), scope "ex4" $ do replicateM_ 10 $ concurrent (Cache.semispaceCache n) diff --git a/nix/haskell-nix-flake.nix b/nix/haskell-nix-flake.nix index ac4764c781..5a3c33b829 100644 --- a/nix/haskell-nix-flake.nix +++ b/nix/haskell-nix-flake.nix @@ -63,6 +63,7 @@ constraints: ormolu == ${versions.ormolu} ''; }; + weeder = {version = versions.weeder;}; }; }; diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 71a031c8b6..ca0a45f8a3 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -22,32 +22,24 @@ library: dependencies: - ListLike - aeson - - async - atomic-primops - base - - bytes - - bytestring - concurrent-output - containers >= 0.6.3 - - errors - extra - filelock - filepath - free - generic-lens - - hashable - - hashtables - lens - megaparsec - mmorph - mtl - - mutable-containers - network-uri - nonempty-containers - pretty-simple - regex-tdfa - semialign - - semigroups - servant-client - stm - text diff --git a/parser-typechecker/src/U/Codebase/Branch/Diff.hs b/parser-typechecker/src/U/Codebase/Branch/Diff.hs index 430155a4cc..a2001b237b 100644 --- a/parser-typechecker/src/U/Codebase/Branch/Diff.hs +++ b/parser-typechecker/src/U/Codebase/Branch/Diff.hs @@ -1,19 +1,15 @@ module U.Codebase.Branch.Diff ( TreeDiff (..), - hoistTreeDiff, NameChanges (..), DefinitionDiffs (..), Diff (..), - NameBasedDiff (..), diffBranches, allNameChanges, - nameBasedDiff, streamNameChanges, ) where import Control.Comonad.Cofree -import Control.Comonad.Cofree qualified as Cofree import Control.Lens (ifoldMap) import Control.Lens qualified as Lens import Data.Functor.Compose (Compose (..)) @@ -27,15 +23,12 @@ import U.Codebase.Branch.Type qualified as Branch import U.Codebase.Causal qualified as Causal import U.Codebase.Reference (Reference) import U.Codebase.Referent (Referent) -import U.Codebase.Referent qualified as Referent import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Sqlite qualified as Sqlite -import Unison.Util.Monoid (foldMapM, ifoldMapM) -import Unison.Util.Relation (Relation) -import Unison.Util.Relation qualified as Relation +import Unison.Util.Monoid (ifoldMapM) data Diff a = Diff { adds :: Set a, @@ -78,10 +71,6 @@ instance (Applicative m) => Semigroup (TreeDiff m) where instance (Applicative m) => Monoid (TreeDiff m) where mempty = TreeDiff (mempty :< Compose mempty) -hoistTreeDiff :: (Functor m) => (forall x. m x -> n x) -> TreeDiff m -> TreeDiff n -hoistTreeDiff f (TreeDiff cfr) = - TreeDiff $ Cofree.hoistCofree (\(Compose m) -> Compose (fmap f m)) cfr - -- | A summary of a 'TreeDiff', containing all names added and removed. -- Note that there isn't a clear notion of a name "changing" since conflicts might muddy the notion -- by having multiple copies of both the from and to names, so we just talk about adds and @@ -101,24 +90,6 @@ instance Semigroup NameChanges where instance Monoid NameChanges where mempty = NameChanges mempty mempty mempty mempty --- | A name-based diff for namespaces `N1` and `N2` is (for both terms and types) a relation between references, where --- `a R b` if: --- --- 1. `a` has name `n` in `N1`, and `b` has the same name `n` in `N2` --- 2. `a` != `b` -data NameBasedDiff = NameBasedDiff - { terms :: Relation Reference Reference, - types :: Relation Reference Reference - } - deriving stock (Generic, Show) - -instance Monoid NameBasedDiff where - mempty = NameBasedDiff mempty mempty - -instance Semigroup NameBasedDiff where - NameBasedDiff terms0 types0 <> NameBasedDiff terms1 types1 = - NameBasedDiff (terms0 <> terms1) (types0 <> types1) - -- | Diff two Branches, returning a tree containing all of the changes diffBranches :: Branch Sqlite.Transaction -> Branch Sqlite.Transaction -> Sqlite.Transaction (TreeDiff Sqlite.Transaction) diffBranches from to = do @@ -176,28 +147,6 @@ allNameChanges :: allNameChanges mayPrefix treediff = do streamNameChanges mayPrefix treediff \_prefix changes -> pure changes --- | Get a 'NameBasedDiff' from a 'TreeDiff'. -nameBasedDiff :: (Monad m) => TreeDiff m -> m NameBasedDiff -nameBasedDiff (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< Compose childMap)) = do - children <- sequenceA childMap >>= foldMapM (nameBasedDiff . TreeDiff) - let terms = foldMap nameBasedTermDiff termDiffs - let types = foldMap nameBasedTypeDiff typeDiffs - pure $ NameBasedDiff {terms, types} <> children - where - nameBasedTermDiff :: Diff Referent -> Relation Reference Reference - nameBasedTermDiff Diff {adds, removals} = - let termAdds = mapMaybe Referent.toTermReference (Set.toList adds) - termRemovals = mapMaybe Referent.toTermReference (Set.toList removals) - in ((,) <$> termRemovals <*> termAdds) - & filter (\(r0, r1) -> r0 /= r1) - & Relation.fromList - - nameBasedTypeDiff :: Diff Reference -> Relation Reference Reference - nameBasedTypeDiff Diff {adds, removals} = - ((,) <$> Set.toList removals <*> Set.toList adds) - & filter (\(r0, r1) -> r0 /= r1) - & Relation.fromList - -- | Stream a summary of all of the name adds and removals from a tree diff. -- Callback is passed the diff from one namespace level at a time, with the name representing -- that location. diff --git a/parser-typechecker/src/U/Codebase/Projects.hs b/parser-typechecker/src/U/Codebase/Projects.hs deleted file mode 100644 index 387da9c737..0000000000 --- a/parser-typechecker/src/U/Codebase/Projects.hs +++ /dev/null @@ -1,52 +0,0 @@ -module U.Codebase.Projects - ( inferDependencyMounts, - ) -where - -import Control.Lens (ifoldMap) -import Data.Map qualified as Map -import U.Codebase.Branch -import U.Codebase.Branch qualified as Branch -import U.Codebase.Causal qualified as Causal -import U.Codebase.HashTags (BranchHash (..)) -import Unison.Codebase.Path -import Unison.Codebase.Path qualified as Path -import Unison.NameSegment (libSegment) -import Unison.Prelude -import Unison.Sqlite qualified as Sqlite -import Unison.Util.Monoid (ifoldMapM) - --- | Find all dependency mounts within a branch and the path to those mounts. --- --- For a typical project this will return something like: --- @[(lib.base, #abc), (lib.distributed, #def)]@ --- --- For the top-level name lookup of a user codebase it returns the project roots, and will return something like: --- @[(public.nested.myproject.latest, #abc), (public.other.namespace.otherproject.main, #def)]@ -inferDependencyMounts :: Branch Sqlite.Transaction -> Sqlite.Transaction [(Path, BranchHash)] -inferDependencyMounts branch = do - children <- Branch.nonEmptyChildren branch - do - children - & ifoldMapM \segment child -> do - case segment of - seg - | seg == libSegment -> do - childBranch <- Causal.value child - deps <- Branch.nonEmptyChildren childBranch - deps - & ( ifoldMap \depName depBranch -> - [(Path.fromList [seg, depName], Causal.valueHash depBranch)] - ) - & pure - | otherwise -> do - childBranch <- Causal.value child - nestedChildren <- Branch.nonEmptyChildren childBranch - -- If a given child has a lib child, then it's inferred to be a project root. - -- This allows us to detect most project roots in loose code. - -- Note, we only do this on children nested at least one level deep - -- to avoid treating project roots as their own self-referential dependency - -- mounts. Mount paths must not be empty. - case Map.member libSegment nestedChildren of - True -> pure [(Path.fromList [seg], Causal.valueHash child)] - False -> inferDependencyMounts childBranch <&> map (first (Path.cons seg)) diff --git a/parser-typechecker/src/Unison/Builtin.hs b/parser-typechecker/src/Unison/Builtin.hs index 1a9477fa63..064dc15c84 100644 --- a/parser-typechecker/src/Unison/Builtin.hs +++ b/parser-typechecker/src/Unison/Builtin.hs @@ -1,6 +1,5 @@ module Unison.Builtin ( codeLookup, - constructorType, names, builtinDataDecls, builtinEffectDecls, @@ -16,7 +15,6 @@ module Unison.Builtin typeOf, typeLookup, termRefTypes, - termRefTypeReferences, ) where @@ -90,11 +88,6 @@ typeLookup = (Map.fromList $ map (first R.DerivedId . snd) builtinDataDecls) (Map.fromList $ map (first R.DerivedId . snd) builtinEffectDecls) -constructorType :: R.Reference -> Maybe CT.ConstructorType -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] @@ -332,9 +325,6 @@ termRefTypes = foldl' go mempty builtinsSrc D r t -> Map.insert (R.Builtin r) t m _ -> m -termRefTypeReferences :: Map R.TermReference R.TypeReference -termRefTypeReferences = H.typeToReference <$> termRefTypes - typeOf :: a -> (Type -> a) -> R.Reference -> a typeOf a f r = maybe a f (Map.lookup r termRefTypes) diff --git a/parser-typechecker/src/Unison/Builtin/Decls.hs b/parser-typechecker/src/Unison/Builtin/Decls.hs index a918671d8d..db6cd6076a 100644 --- a/parser-typechecker/src/Unison/Builtin/Decls.hs +++ b/parser-typechecker/src/Unison/Builtin/Decls.hs @@ -11,7 +11,7 @@ import Unison.ConstructorType qualified as CT import Unison.DataDeclaration (DataDeclaration (..), Modifier (Structural, Unique)) import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration.ConstructorId (ConstructorId) -import Unison.Hashing.V2.Convert (hashDataDecls, typeToReference) +import Unison.Hashing.V2.Convert (hashDataDecls) import Unison.Pattern qualified as Pattern import Unison.Prelude import Unison.Reference (Reference) @@ -46,10 +46,10 @@ pairRef = lookupDeclRef "Tuple" optionalRef = lookupDeclRef "Optional" eitherRef = lookupDeclRef "Either" -testResultRef, testResultListRef, linkRef, docRef, ioErrorRef, stdHandleRef :: Reference +testResultRef, linkRef, docRef, stdHandleRef :: Reference failureRef, ioFailureRef, tlsFailureRef, arrayFailureRef :: Reference cryptoFailureRef :: Reference -exceptionRef, tlsSignedCertRef, tlsPrivateKeyRef :: Reference +exceptionRef :: Reference isPropagatedRef, isTestRef :: Reference isPropagatedRef = lookupDeclRef "IsPropagated" @@ -57,15 +57,10 @@ isTestRef = lookupDeclRef "IsTest" testResultRef = lookupDeclRef "Test.Result" --- Reference for [Test.Result] -testResultListRef = typeToReference @Symbol (testResultListType ()) - linkRef = lookupDeclRef "Link" docRef = lookupDeclRef "Doc" -ioErrorRef = lookupDeclRef "io2.IOError" - stdHandleRef = lookupDeclRef "io2.StdHandle" failureRef = lookupDeclRef "io2.Failure" @@ -80,10 +75,6 @@ arrayFailureRef = lookupDeclRef "io2.ArrayFailure" cryptoFailureRef = lookupDeclRef "crypto.CryptoFailure" -tlsSignedCertRef = lookupDeclRef "io2.Tls.SignedCert" - -tlsPrivateKeyRef = lookupDeclRef "io2.Tls.PrivateKey" - runtimeFailureRef, arithmeticFailureRef, miscFailureRef, stmFailureRef, threadKilledFailureRef :: Reference runtimeFailureRef = lookupDeclRef "io2.RuntimeFailure" arithmeticFailureRef = lookupDeclRef "io2.ArithmeticFailure" @@ -91,9 +82,8 @@ miscFailureRef = lookupDeclRef "io2.MiscFailure" stmFailureRef = lookupDeclRef "io2.STMFailure" threadKilledFailureRef = lookupDeclRef "io2.ThreadKilledFailure" -fileModeRef, filePathRef, bufferModeRef, seekModeRef, seqViewRef :: Reference +fileModeRef, bufferModeRef, seekModeRef, seqViewRef :: Reference fileModeRef = lookupDeclRef "io2.FileMode" -filePathRef = lookupDeclRef "io2.FilePath" bufferModeRef = lookupDeclRef "io2.BufferMode" seekModeRef = lookupDeclRef "io2.SeekMode" seqViewRef = lookupDeclRef "SeqView" @@ -153,10 +143,6 @@ bufferModeBlockBufferingId = Maybe.fromJust $ constructorId bufferModeRef "io2.B bufferModeSizedBlockBufferingId = Maybe.fromJust $ constructorId bufferModeRef "io2.BufferMode.SizedBlockBuffering" -okConstructorReferent, failConstructorReferent :: Referent.Referent -okConstructorReferent = Referent.Con (ConstructorReference testResultRef okConstructorId) CT.Data -failConstructorReferent = Referent.Con (ConstructorReference testResultRef failConstructorId) CT.Data - rewriteTermRef :: Reference rewriteTermRef = lookupDeclRef "RewriteTerm" @@ -728,9 +714,7 @@ unitType, optionalType, testResultListType, eitherType, - ioErrorType, fileModeType, - filePathType, bufferModeType, seekModeType, stdHandleType, @@ -745,18 +729,13 @@ pairType a = Type.ref a pairRef testResultListType a = Type.app a (Type.list a) (Type.ref a testResultRef) optionalType a = Type.ref a optionalRef eitherType a = Type.ref a eitherRef -ioErrorType a = Type.ref a ioErrorRef fileModeType a = Type.ref a fileModeRef -filePathType a = Type.ref a filePathRef bufferModeType a = Type.ref a bufferModeRef seekModeType a = Type.ref a seekModeRef stdHandleType a = Type.ref a stdHandleRef failureType a = Type.ref a failureRef exceptionType a = Type.ref a exceptionRef -tlsSignedCertType :: (Var v) => a -> Type v a -tlsSignedCertType a = Type.ref a tlsSignedCertRef - unitTerm :: (Var v) => a -> Term2 vt at ap v a unitTerm ann = Term.constructor ann (ConstructorReference unitRef 0) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index fae356d3a2..bece981009 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -25,9 +25,7 @@ module Unison.Codebase -- ** Search termsOfType, filterTermsByReferenceIdHavingType, - filterTermsByReferentHavingType, termsMentioningType, - SqliteCodebase.Operations.termReferencesByPrefix, termReferentsByPrefix, -- * Type declarations @@ -46,7 +44,6 @@ module Unison.Codebase putBranch, SqliteCodebase.Operations.causalHashesByPrefix, lca, - SqliteCodebase.Operations.before, getShallowBranchAtPath, getMaybeShallowBranchAtPath, getShallowCausalAtPath, @@ -64,11 +61,6 @@ module Unison.Codebase -- * Root branch SqliteCodebase.Operations.namesAtPath, - -- * Patches - SqliteCodebase.Operations.patchExists, - SqliteCodebase.Operations.getPatch, - SqliteCodebase.Operations.putPatch, - -- * Watches getWatch, lookupWatchCache, @@ -402,7 +394,6 @@ typeLookupForDependencies codebase s = do in depthFirstAccumTypes z (DD.typeDependencies dd) Nothing -> pure tl goType tl Reference.Builtin {} = pure tl -- codebase isn't consulted for builtins - unseen :: TL.TypeLookup Symbol a -> Reference -> Bool unseen tl r = isNothing @@ -469,28 +460,9 @@ termsOfTypeByReference c r = . Set.map (fmap Reference.DerivedId) <$> termsOfTypeImpl c r -filterTermsByReferentHavingType :: (Var v) => Codebase m v a -> Type v a -> Set Referent.Referent -> Sqlite.Transaction (Set Referent.Referent) -filterTermsByReferentHavingType c ty = filterTermsByReferentHavingTypeByReference c $ Hashing.typeToReference ty - filterTermsByReferenceIdHavingType :: (Var v) => Codebase m v a -> Type v a -> Set TermReferenceId -> Sqlite.Transaction (Set TermReferenceId) filterTermsByReferenceIdHavingType c ty = filterTermsByReferenceIdHavingTypeImpl c (Hashing.typeToReference ty) --- | Find the subset of `tms` which match the exact type `r` points to. -filterTermsByReferentHavingTypeByReference :: Codebase m v a -> TypeReference -> Set Referent.Referent -> Sqlite.Transaction (Set Referent.Referent) -filterTermsByReferentHavingTypeByReference c r tms = do - let (builtins, derived) = partitionEithers . map p $ Set.toList tms - let builtins' = - Set.intersection - (Set.fromList builtins) - (Rel.lookupDom r Builtin.builtinTermsByType) - derived' <- filterTermsByReferentIdHavingTypeImpl c r (Set.fromList derived) - pure $ builtins' <> Set.mapMonotonic Referent.fromId derived' - where - p :: Referent.Referent -> Either Referent.Referent Referent.Id - p r = case Referent.toId r of - Just rId -> Right rId - Nothing -> Left r - -- | Get the set of terms-or-constructors mention the given type anywhere in their signature. termsMentioningType :: (Var v) => Codebase m v a -> Type v a -> Sqlite.Transaction (Set Referent.Referent) termsMentioningType c ty = diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index 14629643ec..2d0f78d4fb 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -6,7 +6,6 @@ module Unison.Codebase.Branch Branch (..), UnwrappedBranch, Branch0, - Raw, Star, NamespaceHash, @@ -27,7 +26,6 @@ module Unison.Codebase.Branch isEmpty, isEmpty0, isOne, - before, lca, -- * properties @@ -38,8 +36,6 @@ module Unison.Codebase.Branch children, nonEmptyChildren, deepEdits', - toList0, - namespaceStats, -- * step step, @@ -48,7 +44,6 @@ module Unison.Codebase.Branch stepEverywhere, batchUpdates, batchUpdatesM, - UpdateStrategy (..), addTermName, addTypeName, deleteTermName, @@ -56,8 +51,6 @@ module Unison.Codebase.Branch annihilateTypeName, deleteTypeName, setChildBranch, - replacePatch, - deletePatch, getMaybePatch, getPatch, modifyPatches, @@ -68,7 +61,6 @@ module Unison.Codebase.Branch getAt0, modifyAt, modifyAtM, - children0, -- *** Libdep manipulations withoutLib, @@ -87,7 +79,6 @@ module Unison.Codebase.Branch deepTerms, deepTypes, deepDefns, - deepEdits, deepPaths, deepReferents, deepTermReferences, @@ -102,9 +93,7 @@ import Control.Lens hiding (children, cons, transform, uncons) import Data.Map qualified as Map import Data.Semialign qualified as Align import Data.These (These (..)) -import U.Codebase.Branch.Type (NamespaceStats (..)) import U.Codebase.HashTags (CausalHash, PatchHash (..)) -import Unison.Codebase.Branch.Raw (Raw) import Unison.Codebase.Branch.Type ( Branch (..), Branch0, @@ -114,7 +103,6 @@ import Unison.Codebase.Branch.Type branch0, children, deepDefns, - deepEdits, deepPaths, deepTerms, deepTypes, @@ -146,7 +134,6 @@ import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Util.List qualified as List import Unison.Util.Relation qualified as R -import Unison.Util.Relation qualified as Relation import Unison.Util.Set qualified as Set import Unison.Util.Star2 qualified as Star2 import Witherable (FilterableWithIndex (imapMaybe)) @@ -217,14 +204,6 @@ deepTypeReferenceIds :: Branch0 m -> Set TypeReferenceId deepTypeReferenceIds = Set.mapMaybe Reference.toId . deepTypeReferences -namespaceStats :: Branch0 m -> NamespaceStats -namespaceStats b = - NamespaceStats - { numContainedTerms = Relation.size $ deepTerms b, - numContainedTypes = Relation.size $ deepTypes b, - numContainedPatches = Map.size $ deepEdits b - } - -- | Update the head of the current causal. -- This re-hashes the current causal head after modifications. head_ :: Lens' (Branch m) (Branch0 m) @@ -254,22 +233,6 @@ discardHistory :: (Applicative m) => Branch m -> Branch m discardHistory b = one (discardHistory0 (head b)) --- `before b1 b2` is true if `b2` incorporates all of `b1` -before :: (Monad m) => Branch m -> Branch m -> m Bool -before (Branch b1) (Branch b2) = Causal.before b1 b2 - --- | what does this do? —AI -toList0 :: Branch0 m -> [(Path, Branch0 m)] -toList0 = go Path.empty - where - go p b = - (p, b) - : ( Map.toList (b ^. children) - >>= ( \(seg, cb) -> - go (Path.snoc p seg) (head cb) - ) - ) - -- returns `Nothing` if no Branch at `path` or if Branch is empty at `path` getAt :: Path -> @@ -354,26 +317,6 @@ stepManyAt actions startBranch = actionsIdentity :: [(Path, Branch0 m -> Identity (Branch0 m))] actionsIdentity = coerce (toList actions) -data UpdateStrategy - = -- | Compress all changes into a single causal cons. - -- The resulting branch will have at most one new causal cons at each branch. - -- - -- Note that this does NOT allow updates to add histories at children. - -- E.g. if the root.editme branch has history: A -> B -> C - -- and you use 'makeSetBranch' to update it to a new branch with history X -> Y -> Z, - -- CompressHistory will result in a history for root.editme of: A -> B -> C -> Z. - -- A 'snapshot' of the most recent state of the updated branch is appended to the existing history, - -- if the new state is equal to the existing state, no new history nodes are appended. - CompressHistory - | -- | Preserves any history changes made within the update. - -- - -- Note that this allows you to clobber the history child branches if you want. - -- E.g. if the root.editme branch has history: A -> B -> C - -- and you use 'makeSetBranch' to update it to a new branch with history X -> Y -> Z, - -- AllowRewritingHistory will result in a history for root.editme of: X -> Y -> Z. - -- The history of the updated branch is replaced entirely. - AllowRewritingHistory - -- | Run a series of updates at specific locations. -- History is managed according to the 'UpdateStrategy' stepManyAtM :: @@ -423,12 +366,6 @@ modifyPatches seg f = mapMOf edits update let h = H.hashPatch p' pure $ Map.insert seg (PatchHash h, pure p') m -replacePatch :: (Applicative m) => NameSegment -> Patch -> Branch0 m -> Branch0 m -replacePatch n p = over edits (Map.insert n (PatchHash (H.hashPatch p), pure p)) - -deletePatch :: NameSegment -> Branch0 m -> Branch0 m -deletePatch n = over edits (Map.delete n) - updateChildren :: NameSegment -> Branch m -> @@ -587,11 +524,6 @@ transform0 f b = newChildren = transform f <$> (b ^. children) newEdits = second f <$> (b ^. edits) --- | Traverse the head branch of all direct children. --- The index of the traversal is the name of that child branch according to the parent. -children0 :: IndexedTraversal' NameSegment (Branch0 m) (Branch0 m) -children0 = children .> itraversed <. (history . Causal.head_) - -- | @head `consBranchSnapshot` base@ Cons's the current state of @head@ onto @base@ as-is. -- Consider whether you really want this behaviour or the behaviour of 'Causal.squashMerge' -- That is, it does not perform any common ancestor detection, or change reconciliation, it diff --git a/parser-typechecker/src/Unison/Codebase/Branch/Raw.hs b/parser-typechecker/src/Unison/Codebase/Branch/Raw.hs deleted file mode 100644 index a93fa55f71..0000000000 --- a/parser-typechecker/src/Unison/Codebase/Branch/Raw.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Unison.Codebase.Branch.Raw where - -import Data.Map (Map) -import Unison.Codebase.Metadata qualified as Metadata -import Unison.Hash (Hash) -import Unison.Hash qualified as Hash -import Unison.NameSegment (NameSegment) -import Unison.Reference (Reference) -import Unison.Referent (Referent) - -type Star r n = Metadata.Star r n - -type EditHash = Hash.Hash - --- The raw Branch -data Raw = Raw - { _termsR :: Star Referent NameSegment, - _typesR :: Star Reference NameSegment, - _childrenR :: Map NameSegment Hash, - _editsR :: Map NameSegment EditHash - } diff --git a/parser-typechecker/src/Unison/Codebase/Branch/Type.hs b/parser-typechecker/src/Unison/Codebase/Branch/Type.hs index ebc0ae467e..d7d3c906ca 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch/Type.hs @@ -21,7 +21,6 @@ module Unison.Codebase.Branch.Type deepTypes, deepDefns, deepPaths, - deepEdits, Star, UnwrappedBranch, ) @@ -161,9 +160,6 @@ deepDefns branch = deepPaths :: Branch0 m -> Set Path deepPaths = _deepPaths -deepEdits :: Branch0 m -> Map Name PatchHash -deepEdits = _deepEdits - children :: Lens' (Branch0 m) (Map NameSegment (Branch m)) children = lens _children (\Branch0 {_terms, _types, _edits} x -> branch0 _terms _types x _edits) diff --git a/parser-typechecker/src/Unison/Codebase/BranchUtil.hs b/parser-typechecker/src/Unison/Codebase/BranchUtil.hs index e639fd41b0..06bc54d9eb 100644 --- a/parser-typechecker/src/Unison/Codebase/BranchUtil.hs +++ b/parser-typechecker/src/Unison/Codebase/BranchUtil.hs @@ -3,12 +3,10 @@ module Unison.Codebase.BranchUtil fromNames, -- * Branch queries - getBranch, getTerm, getType, -- * Branch modifications - makeSetBranch, makeAddTypeName, makeDeleteTypeName, makeAnnihilateTypeName, @@ -19,7 +17,6 @@ module Unison.Codebase.BranchUtil where import Control.Lens -import Data.Map qualified as Map import Data.Set qualified as Set import Unison.Codebase.Branch (Branch, Branch0) import Unison.Codebase.Branch qualified as Branch @@ -63,13 +60,6 @@ getType (p, hq) b = case hq of filter sh = Set.filter (SH.isPrefixOf sh . Reference.toShortHash) types = (Branch.getAt0 p b) ^. Branch.types -getBranch :: Path.Split -> Branch0 m -> Maybe (Branch m) -getBranch (p, seg) b = case Path.toList p of - [] -> Map.lookup seg (b ^. Branch.children) - h : p -> - (Branch.head <$> Map.lookup h (b ^. Branch.children)) - >>= getBranch (Path.fromList p, seg) - makeAddTermName :: (p, NameSegment) -> Referent -> (p, Branch0 m -> Branch0 m) makeAddTermName (p, name) r = (p, Branch.addTermName r name) @@ -87,6 +77,3 @@ makeAddTypeName (p, name) r = (p, Branch.addTypeName r name) makeDeleteTypeName :: (p, NameSegment) -> Reference -> (p, Branch0 m -> Branch0 m) makeDeleteTypeName (p, name) r = (p, Branch.deleteTypeName r name) - -makeSetBranch :: Path.Split -> Branch m -> (Path, Branch0 m -> Branch0 m) -makeSetBranch (p, name) b = (p, Branch.setChildBranch name b) diff --git a/parser-typechecker/src/Unison/Codebase/Causal.hs b/parser-typechecker/src/Unison/Codebase/Causal.hs index 9bdd089032..52c2396be9 100644 --- a/parser-typechecker/src/Unison/Codebase/Causal.hs +++ b/parser-typechecker/src/Unison/Codebase/Causal.hs @@ -12,23 +12,16 @@ module Unison.Codebase.Causal mergeNode, uncons, predecessors, - threeWayMerge, threeWayMerge', squashMerge', lca, - stepDistinct, stepDistinctM, transform, unsafeMapHashPreserving, - before, - beforeHash, ) where import Control.Lens qualified as Lens -import Control.Monad.Extra qualified as Monad (anyM) -import Control.Monad.Reader qualified as Reader -import Control.Monad.State qualified as State import Data.Map qualified as Map import Data.Set qualified as Set import U.Codebase.HashTags (CausalHash) @@ -43,7 +36,6 @@ import Unison.Codebase.Causal.Type tails, valueHash ), - before, lca, predecessors, pattern Cons, @@ -68,7 +60,7 @@ head_ = Lens.lens getter setter 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 +-- as a @`threeWayMerge'` `lca`, 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' :: @@ -90,15 +82,6 @@ squashMerge' lca discardHistory combine c1 c2 = do | lca == c2 -> done <$> discardHistory (head c1) | otherwise -> done <$> combine (Just $ head lca) (head c1) (head c2) -threeWayMerge :: - forall m e. - (Monad m, Hashing.ContentAddressable e) => - (Maybe e -> e -> e -> m e) -> - Causal m e -> - Causal m e -> - m (Causal m e) -threeWayMerge = threeWayMerge' lca - threeWayMerge' :: forall m e. (Monad m, Hashing.ContentAddressable e) => @@ -119,27 +102,6 @@ threeWayMerge' lca combine c1 c2 = do 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 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 - go c | h == currentHash c = pure True - go c = do - currentDepth :: Word <- Reader.ask - if currentDepth >= maxDepth - then pure False - else do - seen <- State.get - cs <- lift . lift $ toList <$> sequence (predecessors c) - let unseens = filter (\c -> c `Set.notMember` seen) cs - State.modify' (<> Set.fromList cs) - Monad.anyM (Reader.local (1 +) . go) unseens - -stepDistinct :: (Applicative m, Eq e, Hashing.ContentAddressable e) => (e -> e) -> Causal m e -> Causal m e -stepDistinct f c = f (head c) `consDistinct` c - stepDistinctM :: (Applicative m, Functor n, Eq e, Hashing.ContentAddressable e) => (e -> n e) -> @@ -205,5 +167,3 @@ unsafeMapHashPreserving f c = case c of 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/Type.hs b/parser-typechecker/src/Unison/Codebase/Causal/Type.hs index 0651ac03d2..7f30a4ad12 100644 --- a/parser-typechecker/src/Unison/Codebase/Causal/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Causal/Type.hs @@ -7,7 +7,6 @@ module Unison.Codebase.Causal.Type pattern One, pattern Cons, pattern Merge, - before, predecessors, lca, ) @@ -85,9 +84,6 @@ predecessors (UnsafeOne _ _ _) = Seq.empty predecessors (UnsafeCons _ _ _ (_, t)) = Seq.singleton t predecessors (UnsafeMerge _ _ _ ts) = Seq.fromList $ Map.elems ts -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 e -> Causal m e -> m (Maybe (Causal m e)) lca a b = diff --git a/parser-typechecker/src/Unison/Codebase/CodeLookup.hs b/parser-typechecker/src/Unison/Codebase/CodeLookup.hs index aad2794519..ca753316dd 100644 --- a/parser-typechecker/src/Unison/Codebase/CodeLookup.hs +++ b/parser-typechecker/src/Unison/Codebase/CodeLookup.hs @@ -1,16 +1,10 @@ module Unison.Codebase.CodeLookup where import Control.Monad.Morph (MFunctor (..)) -import Data.Set qualified as Set import Unison.DataDeclaration (Decl) -import Unison.DataDeclaration qualified as DD -import Unison.Prelude import Unison.Reference qualified as Reference import Unison.Term (Term) import Unison.Term qualified as Term -import Unison.Util.Defns (Defns (..)) -import Unison.Util.Set qualified as Set -import Unison.Var (Var) data CodeLookup v m a = CodeLookup { getTerm :: Reference.Id -> m (Maybe (Term v a)), @@ -40,34 +34,3 @@ instance (Monad m) => Semigroup (CodeLookup v m a) where instance (Monad m) => Monoid (CodeLookup v m a) where mempty = CodeLookup (const $ pure Nothing) (const $ pure Nothing) - --- todo: can this be implemented in terms of TransitiveClosure.transitiveClosure? --- todo: add some tests on this guy? -transitiveDependencies :: - (Monad m, Var v) => - CodeLookup v m a -> - Set Reference.Id -> - Reference.Id -> - m (Set Reference.Id) -transitiveDependencies code seen0 rid = - if Set.member rid seen0 - then pure seen0 - else - let seen = Set.insert rid seen0 - getIds = Set.mapMaybe Reference.toId - in getTerm code rid >>= \case - Just t -> - foldM (transitiveDependencies code) seen (getIds $ let deps = Term.dependencies t in deps.terms <> deps.types) - Nothing -> - getTypeDeclaration code rid >>= \case - Nothing -> pure seen - Just (Left ed) -> - foldM - (transitiveDependencies code) - seen - (getIds $ DD.typeDependencies (DD.toDataDecl ed)) - Just (Right dd) -> - foldM - (transitiveDependencies code) - seen - (getIds $ DD.typeDependencies dd) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs b/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs index cc75bc31ea..905188d40c 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs @@ -4,19 +4,8 @@ module Unison.Codebase.Editor.DisplayObject where import Data.Bifoldable import Data.Bitraversable -import Data.Set qualified as Set -import U.Codebase.Reference (TermReference, TypeReference) -import Unison.DataDeclaration qualified as DD -import Unison.DataDeclaration.Dependencies qualified as DD -import Unison.LabeledDependency qualified as LD -import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.ShortHash (ShortHash) -import Unison.Symbol (Symbol) -import Unison.Term (Term) -import Unison.Term qualified as Term -import Unison.Type (Type) -import Unison.Type qualified as Type data DisplayObject b a = BuiltinObject b | MissingObject ShortHash | UserObject a deriving (Eq, Ord, Show, Functor, Generic, Foldable, Traversable) @@ -33,19 +22,3 @@ instance Bitraversable DisplayObject where instance Bifoldable DisplayObject where bifoldMap = bifoldMapDefault - -toMaybe :: DisplayObject b a -> Maybe a -toMaybe = \case - UserObject a -> Just a - _ -> Nothing - -termDisplayObjectLabeledDependencies :: TermReference -> DisplayObject (Type Symbol Ann) (Term Symbol Ann) -> (Set LD.LabeledDependency) -termDisplayObjectLabeledDependencies termRef displayObject = do - displayObject - & bifoldMap (Type.labeledDependencies) (Term.labeledDependencies) - & Set.insert (LD.TermReference termRef) - -typeDisplayObjectLabeledDependencies :: TypeReference -> DisplayObject () (DD.Decl Symbol Ann) -> Set LD.LabeledDependency -typeDisplayObjectLabeledDependencies typeRef displayObject = do - displayObject - & foldMap (DD.labeledDeclDependenciesIncludingSelfAndFieldAccessors typeRef) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index bd352cbc26..cd6a30dfba 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -4,7 +4,6 @@ import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.NameSegment qualified as NameSegment import Unison.Prelude -import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Share.Types data ShareCodeserver @@ -38,10 +37,6 @@ printReadRemoteNamespace printProject = \case ReadShare'LooseCode ReadShareLooseCode {server, repo, path} -> displayShareCodeserver server repo path ReadShare'ProjectBranch project -> printProject project --- | Render a 'WriteRemoteNamespace' as text. -printWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Text -printWriteRemoteNamespace projectAndBranch = into @Text projectAndBranch - maybePrintPath :: Path -> Text maybePrintPath path = if path == Path.empty diff --git a/parser-typechecker/src/Unison/Codebase/Init.hs b/parser-typechecker/src/Unison/Codebase/Init.hs index 608777ab49..c43ebf1bf1 100644 --- a/parser-typechecker/src/Unison/Codebase/Init.hs +++ b/parser-typechecker/src/Unison/Codebase/Init.hs @@ -14,7 +14,6 @@ module Unison.Codebase.Init VacuumStrategy (..), Pretty, createCodebase, - initCodebaseAndExit, withOpenOrCreateCodebase, withNewUcmCodebaseOrExit, withTemporaryUcmCodebase, @@ -180,12 +179,6 @@ withNewUcmCodebaseOrExit cbInit verbosity debugName path lockOption action = do Left error -> liftIO $ PT.putPrettyLn' error >> exitFailure Right result -> pure result --- | try to init a codebase where none exists and then exit regardless (i.e. `ucm --codebase dir init`) -initCodebaseAndExit :: (MonadIO m) => Init m Symbol Ann -> Verbosity -> DebugName -> Maybe CodebasePath -> CodebaseLockOption -> m () -initCodebaseAndExit i verbosity debugName mdir lockOption = do - codebaseDir <- Codebase.getCodebaseDir mdir - withNewUcmCodebaseOrExit i verbosity debugName codebaseDir lockOption (const $ pure ()) - withTemporaryUcmCodebase :: (MonadUnliftIO m) => Init m Symbol Ann -> diff --git a/parser-typechecker/src/Unison/Codebase/Init/Type.hs b/parser-typechecker/src/Unison/Codebase/Init/Type.hs deleted file mode 100644 index 05a99f5029..0000000000 --- a/parser-typechecker/src/Unison/Codebase/Init/Type.hs +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE OverloadedStrings #-} - -module Unison.Codebase.Init.Type (Init (..)) where - -import Unison.Codebase (Codebase, CodebasePath) -import Unison.Codebase.Init.CreateCodebaseError (CreateCodebaseError, Pretty) - -type DebugName = String - -data Init m v a = Init - { -- | open an existing codebase - openCodebase :: DebugName -> CodebasePath -> m (Either Pretty (m (), Codebase m v a)), - -- | create a new codebase - createCodebase' :: DebugName -> CodebasePath -> m (Either CreateCodebaseError (m (), Codebase m v a)), - -- | given a codebase root, and given that the codebase root may have other junk in it, - -- give the path to the "actual" files; e.g. what a forked transcript should clone. - codebasePath :: CodebasePath -> CodebasePath - } diff --git a/parser-typechecker/src/Unison/Codebase/Patch.hs b/parser-typechecker/src/Unison/Codebase/Patch.hs index 7f0bd0946c..9890717430 100644 --- a/parser-typechecker/src/Unison/Codebase/Patch.hs +++ b/parser-typechecker/src/Unison/Codebase/Patch.hs @@ -10,8 +10,6 @@ import Unison.Codebase.TermEdit (TermEdit, Typing (Same)) import Unison.Codebase.TermEdit qualified as TermEdit import Unison.Codebase.TypeEdit (TypeEdit) import Unison.Codebase.TypeEdit qualified as TypeEdit -import Unison.LabeledDependency (LabeledDependency) -import Unison.LabeledDependency qualified as LD import Unison.Prelude hiding (empty) import Unison.Reference (Reference) import Unison.Util.Relation (Relation) @@ -44,33 +42,9 @@ diff new old = _removedTermEdits = R.difference (view termEdits old) (view termEdits new) } -labeledDependencies :: Patch -> Set LabeledDependency -labeledDependencies Patch {..} = - Set.map LD.termRef (R.dom _termEdits) - <> Set.fromList - (fmap LD.termRef $ TermEdit.references =<< toList (R.ran _termEdits)) - <> Set.map LD.typeRef (R.dom _typeEdits) - <> Set.fromList - (fmap LD.typeRef $ TypeEdit.references =<< toList (R.ran _typeEdits)) - empty :: Patch empty = Patch mempty mempty -isEmpty :: Patch -> Bool -isEmpty p = p == empty - -allReferences :: Patch -> Set Reference -allReferences p = typeReferences p <> termReferences p - where - typeReferences p = - Set.fromList - [ r | (old, TypeEdit.Replace new) <- R.toList (_typeEdits p), r <- [old, new] - ] - termReferences p = - Set.fromList - [ r | (old, TermEdit.Replace new _) <- R.toList (_termEdits p), r <- [old, new] - ] - -- | Returns the set of references which are the target of an arrow in the patch allReferenceTargets :: Patch -> Set Reference allReferenceTargets p = typeReferences p <> termReferences p @@ -116,10 +90,6 @@ updateType r edit p = f p = p in p {_typeEdits = edits'} -conflicts :: Patch -> Patch -conflicts Patch {..} = - Patch (R.filterManyDom _termEdits) (R.filterManyDom _typeEdits) - instance Semigroup Patch where a <> b = Patch diff --git a/parser-typechecker/src/Unison/Codebase/Path.hs b/parser-typechecker/src/Unison/Codebase/Path.hs index d35a339990..5a7bba879d 100644 --- a/parser-typechecker/src/Unison/Codebase/Path.hs +++ b/parser-typechecker/src/Unison/Codebase/Path.hs @@ -7,7 +7,6 @@ module Unison.Codebase.Path pattern AbsolutePath', absPath_, Relative (..), - relPath_, pattern RelativePath', Resolve (..), pattern Empty, @@ -17,10 +16,8 @@ module Unison.Codebase.Path Unison.Codebase.Path.uncons, empty, isAbsolute, - isRelative, absoluteEmpty, absoluteEmpty', - relativeEmpty, relativeEmpty', currentPath, prefix, @@ -37,7 +34,6 @@ module Unison.Codebase.Path Split, Split', HQSplit', - ancestors, -- * utilities longestPathPrefix, @@ -54,7 +50,6 @@ module Unison.Codebase.Path fromName', fromPath', unsafeParseText, - unsafeParseText', toAbsoluteSplit, toSplit', toList, @@ -66,7 +61,6 @@ module Unison.Codebase.Path relToText, unsplit, unsplit', - unsplitAbsolute, nameFromHQSplit, nameFromHQSplit', nameFromSplit', @@ -76,10 +70,6 @@ module Unison.Codebase.Path -- * things that could be replaced with `Cons` instances cons, - - -- * things that could be replaced with `Snoc` instances - snoc, - unsnoc, ) where @@ -93,7 +83,6 @@ import Data.List.NonEmpty qualified as List.NonEmpty import Data.Sequence (Seq ((:<|), (:|>))) import Data.Sequence qualified as Seq import Data.Text qualified as Text -import GHC.Exts qualified as GHC import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name @@ -112,13 +101,6 @@ 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 - -- | An absolute from the current project root newtype Absolute = Absolute {unabsolute :: Path} deriving (Eq, Ord) @@ -129,9 +111,6 @@ absPath_ = lens unabsolute (\_ new -> Absolute new) -- Typically refers to a path from the current namespace. newtype Relative = Relative {unrelative :: Path} deriving (Eq, Ord) -relPath_ :: Lens' Relative Path -relPath_ = lens unrelative (\_ new -> Relative new) - -- | A namespace that may be either absolute or relative, This is the most general type that should be used. newtype Path' = Path' {unPath' :: Either Absolute Relative} deriving (Eq, Ord) @@ -140,10 +119,6 @@ isAbsolute :: Path' -> Bool isAbsolute (AbsolutePath' _) = True isAbsolute _ = False -isRelative :: Path' -> Bool -isRelative (RelativePath' _) = True -isRelative _ = False - isCurrentPath :: Path' -> Bool isCurrentPath p = p == currentPath @@ -178,10 +153,6 @@ unsplit' = \case unsplit :: Split -> Path unsplit (Path p, a) = Path (p :|> a) -unsplitAbsolute :: (Absolute, NameSegment) -> Absolute -unsplitAbsolute = - coerce unsplit - nameFromHQSplit :: HQSplit -> HQ'.HashQualified Name nameFromHQSplit = nameFromHQSplit' . first (RelativePath' . Relative) @@ -251,9 +222,6 @@ toAbsoluteSplit a (p, s) = (resolve a p, s) absoluteEmpty :: Absolute absoluteEmpty = Absolute empty -relativeEmpty :: Relative -relativeEmpty = Relative empty - relativeEmpty' :: Path' relativeEmpty' = RelativePath' (Relative empty) @@ -272,9 +240,6 @@ toList = Foldable.toList . toSeq fromList :: [NameSegment] -> Path fromList = Path . Seq.fromList -ancestors :: Absolute -> Seq Absolute -ancestors (Absolute (Path segments)) = Absolute . Path <$> Seq.inits segments - hqSplitFromName' :: Name -> HQSplit' hqSplitFromName' = fmap HQ'.fromName . splitFromName' @@ -326,12 +291,6 @@ singleton n = fromList [n] cons :: NameSegment -> Path -> Path cons = Lens.cons -snoc :: Path -> NameSegment -> Path -snoc = Lens.snoc - -unsnoc :: Path -> Maybe (Path, NameSegment) -unsnoc = Lens.unsnoc - uncons :: Path -> Maybe (NameSegment, Path) uncons = Lens.uncons @@ -383,18 +342,6 @@ empty = Path mempty instance Show Path where show = Text.unpack . toText -instance From Path Text where - from = toText - -instance From Absolute Text where - from = absToText - -instance From Relative Text where - from = relToText - -instance From Path' Text where - from = toText' - -- | Note: This treats the path as relative. toText :: Path -> Text toText = @@ -411,22 +358,6 @@ unsafeParseText = \case "" -> empty text -> fromName (Name.unsafeParseText text) --- | Construct a Path' from a text --- --- >>> fromText' "a.b.c" --- a.b.c --- --- >>> fromText' ".a.b.c" --- .a.b.c --- --- >>> show $ fromText' "" --- "" -unsafeParseText' :: Text -> Path' -unsafeParseText' = \case - "" -> RelativePath' (Relative mempty) - "." -> AbsolutePath' (Absolute mempty) - text -> fromName' (Name.unsafeParseText text) - toText' :: Path' -> Text toText' path = case toName' path of @@ -437,8 +368,6 @@ toText' path = {-# COMPLETE Empty, (:>) #-} -deriving anyclass instance AsEmpty Path - instance Cons Path Path NameSegment NameSegment where _Cons = prism (uncurry cons) uncons where @@ -449,18 +378,6 @@ instance Cons Path Path NameSegment NameSegment where Path (hd :<| tl) -> Right (hd, Path tl) _ -> Left p -instance Cons Path' Path' NameSegment NameSegment where - _Cons = prism (uncurry cons) uncons - where - cons :: NameSegment -> Path' -> Path' - cons ns (AbsolutePath' p) = AbsolutePath' (ns :< p) - cons ns (RelativePath' p) = RelativePath' (ns :< p) - uncons :: Path' -> Either Path' (NameSegment, Path') - uncons p = case p of - AbsolutePath' (ns :< tl) -> Right (ns, AbsolutePath' tl) - RelativePath' (ns :< tl) -> Right (ns, RelativePath' tl) - _ -> Left p - instance Snoc Relative Relative NameSegment NameSegment where _Snoc = prism (uncurry snocRelative) $ \case Relative (Lens.unsnoc -> Just (s, a)) -> Right (Relative s, a) @@ -469,26 +386,6 @@ instance Snoc Relative Relative NameSegment NameSegment where snocRelative :: Relative -> NameSegment -> Relative snocRelative r n = Relative . (`Lens.snoc` n) $ unrelative r -instance Cons Relative Relative NameSegment NameSegment where - _Cons = prism (uncurry cons) uncons - where - cons :: NameSegment -> Relative -> Relative - cons ns (Relative p) = Relative (ns :< p) - uncons :: Relative -> Either Relative (NameSegment, Relative) - uncons p = case p of - Relative (ns :< tl) -> Right (ns, Relative tl) - _ -> Left p - -instance Cons Absolute Absolute NameSegment NameSegment where - _Cons = prism (uncurry cons) uncons - where - cons :: NameSegment -> Absolute -> Absolute - cons ns (Absolute p) = Absolute (ns :< p) - uncons :: Absolute -> Either Absolute (NameSegment, Absolute) - uncons p = case p of - Absolute (ns :< tl) -> Right (ns, Absolute tl) - _ -> Left p - instance Snoc Absolute Absolute NameSegment NameSegment where _Snoc = prism (uncurry snocAbsolute) $ \case Absolute (Lens.unsnoc -> Just (s, a)) -> Right (Absolute s, a) @@ -533,29 +430,12 @@ class Resolve l r o where instance Resolve Path Path Path where resolve (Path l) (Path r) = Path (l <> r) -instance Resolve Relative Relative Relative where - resolve (Relative (Path l)) (Relative (Path r)) = Relative (Path (l <> r)) - instance Resolve Absolute Relative Absolute where resolve (Absolute l) (Relative r) = Absolute (resolve l r) -instance Resolve Absolute Relative Path' where - resolve l r = AbsolutePath' (resolve l r) - instance Resolve Absolute Path Absolute where resolve (Absolute l) r = Absolute (resolve l r) -instance Resolve Path' Path' Path' where - resolve _ a@(AbsolutePath' {}) = a - resolve (AbsolutePath' a) (RelativePath' r) = AbsolutePath' (resolve a r) - resolve (RelativePath' r1) (RelativePath' r2) = RelativePath' (resolve r1 r2) - -instance Resolve Path' Split' Path' where - resolve l r = resolve l (unsplit' r) - -instance Resolve Path' Split' Split' where - resolve l (r, ns) = (resolve l r, ns) - instance Resolve Absolute HQSplit HQSplitAbsolute where resolve l (r, hq) = (resolve l (Relative r), hq) diff --git a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs index 79bb738e6d..8d8b5812c2 100644 --- a/parser-typechecker/src/Unison/Codebase/Path/Parse.hs +++ b/parser-typechecker/src/Unison/Codebase/Path/Parse.hs @@ -10,7 +10,6 @@ module Unison.Codebase.Path.Parse -- * Path parsers pathP, - pathP', splitP, splitP', ) @@ -19,7 +18,6 @@ where import Data.Text qualified as Text import Text.Megaparsec (Parsec) import Text.Megaparsec qualified as P -import Text.Megaparsec.Char qualified as P (char) import Text.Megaparsec.Internal qualified as P (withParsecT) import Unison.Codebase.Path import Unison.HashQualifiedPrime qualified as HQ' @@ -76,14 +74,6 @@ pathP :: Parsec (Lexer.Token Text) [Char] Path pathP = (unsplit <$> splitP) <|> pure empty -pathP' :: Parsec (Lexer.Token Text) [Char] Path' -pathP' = - asum - [ unsplit' <$> splitP', - P.char '.' $> absoluteEmpty', - pure relativeEmpty' - ] - splitP :: Parsec (Lexer.Token Text) [Char] Split splitP = splitFromName <$> P.withParsecT (fmap NameSegment.renderParseErr) Name.relativeNameP diff --git a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs index 651f7f2ca5..6024d33d8a 100644 --- a/parser-typechecker/src/Unison/Codebase/ProjectPath.hs +++ b/parser-typechecker/src/Unison/Codebase/ProjectPath.hs @@ -11,7 +11,6 @@ module Unison.Codebase.ProjectPath path, toProjectAndBranch, projectAndBranch_, - toText, toIds, toNames, projectPathParser, @@ -57,10 +56,6 @@ instance From ProjectPathNames Text where from (ProjectPath proj branch (Path.Absolute path)) = into @Text (ProjectAndBranch proj branch) <> ":" <> Path.toText path -instance From (ProjectPathG () ProjectBranchName) Text where - from (ProjectPath () branch (Path.Absolute path)) = - "/" <> into @Text branch <> ":" <> Path.toText path - type ProjectPath = ProjectPathG Project ProjectBranch projectBranchRoot :: ProjectAndBranch Project ProjectBranch -> ProjectPath @@ -93,10 +88,6 @@ instance Bifoldable ProjectPathG where instance Bitraversable ProjectPathG where bitraverse f g (ProjectPath p b path) = ProjectPath <$> f p <*> g b <*> pure path -toText :: ProjectPathG Project ProjectBranch -> Text -toText (ProjectPath proj branch path) = - into @Text (proj ^. #name) <> "/" <> into @Text (branch ^. #name) <> ":" <> Path.absToText path - absPath_ :: Lens' (ProjectPathG p b) Path.Absolute absPath_ = lens absPath set where diff --git a/parser-typechecker/src/Unison/Codebase/Serialization.hs b/parser-typechecker/src/Unison/Codebase/Serialization.hs deleted file mode 100644 index 565f0d7f46..0000000000 --- a/parser-typechecker/src/Unison/Codebase/Serialization.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE RankNTypes #-} - -module Unison.Codebase.Serialization where - -import Data.ByteString (ByteString, readFile, writeFile) -import Data.Bytes.Get (MonadGet, runGetS) -import Data.Bytes.Put (MonadPut, runPutS) -import System.FilePath (takeDirectory) -import UnliftIO (MonadIO, liftIO) -import UnliftIO.Directory (createDirectoryIfMissing, doesFileExist) -import Prelude hiding (readFile, writeFile) - -type Get a = forall m. (MonadGet m) => m a - -type Put a = forall m. (MonadPut m) => a -> m () - --- todo: do we use this? -data Format a = Format - { get :: Get a, - put :: Put a - } - -getFromBytes :: Get a -> ByteString -> Maybe a -getFromBytes getA bytes = - case runGetS getA bytes of Left _ -> Nothing; Right a -> Just a - -getFromFile :: (MonadIO m) => Get a -> FilePath -> m (Maybe a) -getFromFile getA file = do - b <- doesFileExist file - if b then getFromBytes getA <$> liftIO (readFile file) else pure Nothing - -getFromFile' :: (MonadIO m) => Get a -> FilePath -> m (Either String a) -getFromFile' getA file = do - b <- doesFileExist file - if b - then runGetS getA <$> liftIO (readFile file) - else pure . Left $ "No such file: " ++ file - -putBytes :: Put a -> a -> ByteString -putBytes put a = runPutS (put a) - -putWithParentDirs :: (MonadIO m) => Put a -> FilePath -> a -> m () -putWithParentDirs putA file a = do - createDirectoryIfMissing True (takeDirectory file) - liftIO . writeFile file $ putBytes putA a diff --git a/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs b/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs index 2872ec53d2..8f0f7730dd 100644 --- a/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs +++ b/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs @@ -1,7 +1,5 @@ module Unison.Codebase.ShortCausalHash - ( toString, - toHash, - fromHash, + ( fromHash, fromFullHash, fromText, ShortCausalHash (..), @@ -19,12 +17,6 @@ import Unison.Prelude newtype ShortCausalHash = ShortCausalHash {toText :: Text} -- base32hex characters deriving stock (Eq, Ord, Generic) -toString :: ShortCausalHash -> String -toString = Text.unpack . toText - -toHash :: (Coercible Hash.Hash h) => ShortCausalHash -> Maybe h -toHash = fmap coerce . Hash.fromBase32HexText . toText - fromHash :: Int -> CausalHash -> ShortCausalHash fromHash len = ShortCausalHash . Text.take len . Hash.toBase32HexText . unCausalHash diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 498736d031..2e08bdb3d9 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -8,7 +8,6 @@ module Unison.Codebase.SqliteCodebase BackupStrategy (..), VacuumStrategy (..), CodebaseLockOption (..), - copyCodebase, ) where @@ -46,9 +45,9 @@ import Unison.Type (Type) import Unison.Util.Cache qualified as Cache import Unison.WatchKind qualified as UF import UnliftIO (finally) -import UnliftIO.Directory (createDirectoryIfMissing, doesFileExist) import UnliftIO qualified as UnliftIO import UnliftIO.Concurrent qualified as UnliftIO +import UnliftIO.Directory (createDirectoryIfMissing, doesFileExist) import UnliftIO.STM debug :: Bool @@ -309,23 +308,3 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action withTryFileLock (lockfilePath root) Exclusive (\_flock -> runInIO ma) <&> \case Nothing -> Left OpenCodebaseFileLockFailed Just x -> x - -data Entity m - = B CausalHash (m (Branch m)) - | O Hash - -instance Show (Entity m) where - show (B h _) = "B " ++ take 10 (show h) - show (O h) = "O " ++ take 10 (show h) - --- | Given two codebase roots (e.g. "./mycodebase"), safely copy the codebase --- at the source to the destination. --- Note: this does not copy the .unisonConfig file. -copyCodebase :: (MonadIO m) => CodebasePath -> CodebasePath -> m () -copyCodebase src dest = liftIO $ do - createDirectoryIfMissing True (makeCodebaseDirPath dest) - withConnection ("copy-from:" <> src) src $ \srcConn -> do - Sqlite.vacuumInto srcConn (makeCodebasePath dest) - -- We need to reset the journal mode because vacuum-into clears it. - withConnection ("copy-to:" <> dest) dest $ \destConn -> do - Sqlite.trySetJournalMode destConn Sqlite.JournalMode'WAL diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Branch/Dependencies.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Branch/Dependencies.hs deleted file mode 100644 index b4eeb72bad..0000000000 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Branch/Dependencies.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} - -module Unison.Codebase.SqliteCodebase.Branch.Dependencies where - -import Data.Map qualified as Map -import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) -import Data.Set qualified as Set -import U.Codebase.HashTags (CausalHash, PatchHash) -import Unison.Codebase.Branch.Type as Branch -import Unison.Codebase.Causal qualified as Causal -import Unison.Codebase.Patch (Patch) -import Unison.ConstructorReference (GConstructorReference (..)) -import Unison.Hash (Hash) -import Unison.NameSegment (NameSegment) -import Unison.Prelude -import Unison.Reference (Reference, pattern Derived) -import Unison.Referent (Referent) -import Unison.Referent qualified as Referent -import Unison.Util.Relation qualified as R -import Unison.Util.Star2 qualified as Star2 - -type Branches m = [(CausalHash, m (Branch m))] - -data Dependencies = Dependencies - { patches :: Set PatchHash, - terms :: Set Hash, - decls :: Set Hash - } - deriving (Show) - deriving (Generic) - deriving (Semigroup, Monoid) via GenericSemigroupMonoid Dependencies - -data Dependencies' = Dependencies' - { patches' :: [PatchHash], - terms' :: [Hash], - decls' :: [Hash] - } - deriving (Eq, Show) - deriving (Generic) - deriving (Semigroup, Monoid) via GenericSemigroupMonoid Dependencies' - -to' :: Dependencies -> Dependencies' -to' Dependencies {..} = Dependencies' (toList patches) (toList terms) (toList decls) - -fromBranch :: (Applicative m) => Branch m -> (Branches m, Dependencies) -fromBranch (Branch c) = case c of - 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) - -fromBranch0 :: (Applicative m) => Branch0 m -> (Branches m, Dependencies) -fromBranch0 b = - ( fromChildren (b ^. Branch.children), - fromTermsStar (b ^. Branch.terms) - <> fromTypesStar (b ^. Branch.types) - <> fromEdits (b ^. Branch.edits) - ) - where - fromChildren :: (Applicative m) => Map NameSegment (Branch m) -> Branches m - fromChildren m = [(Branch.headHash b, pure b) | b <- toList m] - references :: Branch.Star r NameSegment -> [r] - references = toList . R.dom . Star2.d1 - mdValues :: Branch.Star r NameSegment -> [Reference] - mdValues = toList . R.ran . Star2.d2 - fromTermsStar :: Branch.Star Referent NameSegment -> Dependencies - fromTermsStar s = Dependencies mempty terms decls - where - terms = - Set.fromList $ - [h | Referent.Ref (Derived h _) <- references s] - ++ [h | (Derived h _) <- mdValues s] - decls = - Set.fromList $ - [h | Referent.Con (ConstructorReference (Derived h _i) _) _ <- references s] - fromTypesStar :: Branch.Star Reference NameSegment -> Dependencies - fromTypesStar s = Dependencies mempty terms decls - where - terms = Set.fromList [h | (Derived h _) <- mdValues s] - decls = Set.fromList [h | (Derived h _) <- references s] - fromEdits :: Map NameSegment (PatchHash, m Patch) -> Dependencies - fromEdits m = Dependencies (Set.fromList . fmap fst $ toList m) mempty mempty diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs index 7237c0bd8e..e69c08dece 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs @@ -323,11 +323,6 @@ 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 diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs index 066c4c03a9..ff1bbcc7f8 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2.hs @@ -16,7 +16,6 @@ import Control.Monad.State.Strict import Control.Monad.Trans.Except (throwE) import Control.Monad.Trans.Writer.CPS (Writer, execWriter, tell) import Data.Generics.Product -import Data.Generics.Sum (_Ctor) import Data.List.Extra (nubOrd) import Data.Map qualified as Map import Data.Set qualified as Set @@ -844,9 +843,6 @@ someRef_ = lens getter setter 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 = 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 8f99d3c557..6131ec6142 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema1To2/DbHelpers.hs @@ -1,13 +1,10 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema1To2.DbHelpers ( dbBranchHash, dbPatchHash, - syncCausalHash, ) where -import Data.Set qualified as Set -import Data.Vector qualified as Vector -import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..)) +import U.Codebase.HashTags (BranchHash (..), PatchHash (..)) import U.Codebase.Reference qualified as S hiding (Reference) import U.Codebase.Reference qualified as S.Reference import U.Codebase.Referent qualified as S.Referent @@ -15,7 +12,6 @@ import U.Codebase.Sqlite.Branch.Full (DbMetadataSet) import U.Codebase.Sqlite.Branch.Full qualified as S import U.Codebase.Sqlite.Branch.Full qualified as S.Branch.Full import U.Codebase.Sqlite.Branch.Full qualified as S.MetadataSet -import U.Codebase.Sqlite.Causal qualified as S import U.Codebase.Sqlite.DbId qualified as Db import U.Codebase.Sqlite.Patch.Full qualified as S import U.Codebase.Sqlite.Patch.TermEdit qualified as S (TermEdit) @@ -32,13 +28,6 @@ import Unison.Sqlite (Transaction) import Unison.Util.Map qualified as Map import Unison.Util.Set qualified as Set -syncCausalHash :: S.SyncCausalFormat -> Transaction CausalHash -syncCausalHash S.SyncCausalFormat {valueHash = valueHashId, parents = parentChIds} = do - fmap (CausalHash . Hashing.contentHash) $ - Hashing.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 BranchHash dbBranchHash (S.Branch.Full.Branch tms tps patches children) = fmap (BranchHash . Hashing.contentHash) $ diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 050d7f5fda..03ef5497df 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -9,24 +9,14 @@ -- are unified with non-sqlite operations in the Codebase interface, like 'appendReflog'. module Unison.Codebase.SqliteCodebase.Operations where -import Control.Comonad.Cofree qualified as Cofree import Data.Bitraversable (bitraverse) import Data.Either.Extra () -import Data.Functor.Compose (Compose (..)) -import Data.List qualified as List import Data.List.NonEmpty.Extra (NonEmpty ((:|)), maximum1) import Data.Map qualified as Map -import Data.Maybe (fromJust) import Data.Set qualified as Set import Data.UUID.V4 qualified as UUID -import U.Codebase.Branch qualified as V2Branch -import U.Codebase.Branch.Diff (TreeDiff (TreeDiff)) -import U.Codebase.Branch.Diff qualified as BranchDiff -import U.Codebase.HashTags (BranchHash, CausalHash (unCausalHash), PatchHash) -import U.Codebase.Projects qualified as Projects +import U.Codebase.HashTags (BranchHash, CausalHash (unCausalHash)) import U.Codebase.Reference qualified as C.Reference -import U.Codebase.Referent qualified as C.Referent -import U.Codebase.Sqlite.DbId (ObjectId) import U.Codebase.Sqlite.DbId qualified as Db import U.Codebase.Sqlite.NameLookups (PathSegments (..), ReversedName (..)) import U.Codebase.Sqlite.NamedRef qualified as S @@ -41,7 +31,6 @@ import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) import Unison.Builtin qualified as Builtins import Unison.Codebase.Branch (Branch (..)) import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Patch (Patch) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.Codebase.ShortCausalHash (ShortCausalHash) @@ -53,7 +42,6 @@ import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.DataDeclaration (Decl) import Unison.DataDeclaration qualified as Decl import Unison.Hash (Hash) -import Unison.Hashing.V2.Convert qualified as Hashing import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment.Internal (NameSegment (NameSegment)) @@ -131,35 +119,6 @@ data BufferEntry a = BufferEntry } 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) @@ -341,16 +300,6 @@ tryFlushTermBuffer termBuffer = h in loop -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) - putTypeDeclarationComponent :: TVar (Map Hash TermBufferEntry) -> TVar (Map Hash DeclBufferEntry) -> @@ -443,24 +392,6 @@ branchExists h = Nothing -> pure False Just hId -> Q.isCausalHash hId -getPatch :: PatchHash -> Transaction (Maybe Patch) -getPatch h = - runMaybeT do - patchId <- MaybeT (Q.loadPatchObjectIdForPrimaryHash h) - patch <- lift (Ops.expectPatch patchId) - pure (Cv.patch2to1 patch) - --- | Put a patch into the codebase. --- --- Note that 'putBranch' may also put patches. -putPatch :: PatchHash -> Patch -> Transaction () -putPatch h p = - void $ Ops.savePatch v2HashHandle h (Cv.patch1to2 p) - --- | Check whether the given patch exists in the codebase. -patchExists :: PatchHash -> Transaction Bool -patchExists h = fmap isJust $ Q.loadPatchObjectIdForPrimaryHash h - dependentsImpl :: Q.DependentsSelector -> Reference -> Transaction (Set Reference.Id) dependentsImpl selector r = Set.map Cv.referenceid2to1 @@ -562,9 +493,6 @@ defnReferencesByPrefix ot (ShortHash.ShortHash prefix cycle _cid) = do >>= pure . Set.fromList pure $ Set.map Cv.referenceid2to1 refs -termReferencesByPrefix :: ShortHash -> Transaction (Set Reference.Id) -termReferencesByPrefix = defnReferencesByPrefix OT.TermComponent - -- | Get the set of type declarations whose hash matches the given prefix. typeReferencesByPrefix :: ShortHash -> Transaction (Set Reference.Id) typeReferencesByPrefix = defnReferencesByPrefix OT.DeclComponent @@ -595,16 +523,6 @@ causalHashesByPrefix sh = do -- but do we want to be able to refer to a namespace without its history? Ops.causalHashesByPrefix (Cv.sch1to2 sh) --- 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 -declExists = termExists - --- `before b1 b2` is undefined if `b2` not in the codebase -before :: CausalHash -> CausalHash -> Transaction Bool -before h1 h2 = - fromJust <$> Ops.before h1 h2 - -- | Construct a 'ScopedNames' which can produce names which are relative to the provided -- Path. -- @@ -649,86 +567,6 @@ namesAtPath bh path = do Nothing -> Nothing Just stripped -> Just (Name.makeRelative stripped, ref) --- | Add an index for the provided branch hash if one doesn't already exist. -ensureNameLookupForBranchHash :: - (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - -- | An optional branch which we may already have an index for. - -- This should be a branch which is relatively similar to the branch we're creating a name - -- lookup for, e.g. a recent ancestor of the new branch. The more similar it is, the faster - -- the less work we'll need to do. - Maybe BranchHash -> - BranchHash -> - Sqlite.Transaction () -ensureNameLookupForBranchHash getDeclType mayFromBranchHash toBranchHash = do - Ops.checkBranchHashNameLookupExists toBranchHash >>= \case - True -> pure () - False -> do - (fromBranch, mayExistingLookupBH) <- case mayFromBranchHash of - Nothing -> pure (V2Branch.empty, Nothing) - Just fromBH -> do - Ops.checkBranchHashNameLookupExists fromBH >>= \case - True -> (,Just fromBH) <$> Ops.expectBranchByBranchHash fromBH - False -> do - -- TODO: We can probably infer a good starting branch by crawling through - -- history looking for a Branch Hash we already have an index for. - pure (V2Branch.empty, Nothing) - toBranch <- Ops.expectBranchByBranchHash toBranchHash - depMounts <- Projects.inferDependencyMounts toBranch <&> fmap (first (coerce @_ @PathSegments . Path.toList)) - let depMountPaths = (Path.fromList . coerce) . fst <$> depMounts - treeDiff <- ignoreDepMounts depMountPaths <$> BranchDiff.diffBranches fromBranch toBranch - let namePrefix = Nothing - Ops.buildNameLookupForBranchHash - mayExistingLookupBH - toBranchHash - ( \save -> do - BranchDiff.streamNameChanges namePrefix treeDiff \_prefix (BranchDiff.NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals}) -> do - termNameAddsWithCT <- do - for termNameAdds \(name, ref) -> do - refWithCT <- addReferentCT ref - pure $ toNamedRef (name, refWithCT) - save (termNameAddsWithCT, toNamedRef <$> termNameRemovals) (toNamedRef <$> typeNameAdds, toNamedRef <$> typeNameRemovals) - ) - -- Ensure all of our dependencies have name lookups too. - for_ depMounts \(_path, depBranchHash) -> do - -- TODO: see if we can find a way to infer a good fromHash for dependencies - ensureNameLookupForBranchHash getDeclType Nothing depBranchHash - Ops.associateNameLookupMounts toBranchHash depMounts - where - alterTreeDiffAtPath :: (Functor m) => Path -> (TreeDiff m -> TreeDiff m) -> TreeDiff m -> TreeDiff m - alterTreeDiffAtPath path f (TreeDiff cfr) = - case path of - Path.Empty -> f (TreeDiff cfr) - (segment Path.:< rest) -> - let (a Cofree.:< (Compose rest')) = cfr - in TreeDiff (a Cofree.:< Compose (Map.adjust (fmap (coerce $ alterTreeDiffAtPath rest f)) segment rest')) - -- Delete portions of the diff which are covered by dependency mounts. - ignoreDepMounts :: (Applicative m) => [Path] -> TreeDiff m -> TreeDiff m - ignoreDepMounts depMounts treeDiff = - foldl' (\acc path -> alterTreeDiffAtPath path (const mempty) acc) treeDiff depMounts - toNamedRef :: (Name, ref) -> S.NamedRef ref - toNamedRef (name, ref) = S.NamedRef {reversedSegments = coerce $ Name.reverseSegments name, ref = ref} - 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) - --- | Regenerate the name lookup index for the given branch hash from scratch. --- This shouldn't be necessary in normal operation, but it's useful to fix name lookups if --- they somehow get corrupt, or during local testing and debugging. -regenerateNameLookup :: - (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> - BranchHash -> - Sqlite.Transaction () -regenerateNameLookup getDeclType bh = do - Ops.checkBranchHashNameLookupExists bh >>= \case - True -> do - bhId <- Q.expectBranchHashId bh - Q.deleteNameLookup bhId - ensureNameLookupForBranchHash getDeclType Nothing bh - False -> ensureNameLookupForBranchHash getDeclType Nothing bh - -- | Given a transaction, return a transaction that first checks a semispace cache of the given size. -- -- The transaction should probably be read-only, as we (of course) don't hit SQLite on a cache hit. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs deleted file mode 100644 index b9247fdf70..0000000000 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/SyncEphemeral.hs +++ /dev/null @@ -1,18 +0,0 @@ -module Unison.Codebase.SqliteCodebase.SyncEphemeral where - -import U.Codebase.HashTags (CausalHash) -import U.Codebase.Sqlite.DbId (SchemaVersion) -import Unison.Hash (Hash) -import Unison.Prelude - -data Dependencies = Dependencies - { definitions :: Set Hash, - branches :: Set Hash - } - -data Error - = SrcWrongSchema SchemaVersion - | DestWrongSchema SchemaVersion - | DisappearingBranch CausalHash - deriving stock (Show) - deriving anyclass (Exception) diff --git a/parser-typechecker/src/Unison/Codebase/TermEdit.hs b/parser-typechecker/src/Unison/Codebase/TermEdit.hs index fbc396a5c4..6da9bbc0fd 100644 --- a/parser-typechecker/src/Unison/Codebase/TermEdit.hs +++ b/parser-typechecker/src/Unison/Codebase/TermEdit.hs @@ -5,10 +5,6 @@ import Unison.Reference (Reference) data TermEdit = Replace Reference Typing | Deprecate deriving (Eq, Ord, Show) -references :: TermEdit -> [Reference] -references (Replace r _) = [r] -references Deprecate = [] - -- Replacements with the Same type can be automatically propagated. -- Replacements with a Subtype can be automatically propagated but may result in dependents getting more general types, so requires re-inference. -- Replacements of a Different type need to be manually propagated by the programmer. @@ -18,14 +14,3 @@ data Typing = Same | Subtype | Different toReference :: TermEdit -> Maybe Reference toReference (Replace r _) = Just r toReference Deprecate = Nothing - -isTypePreserving :: TermEdit -> Bool -isTypePreserving e = case e of - Replace _ Same -> True - Replace _ Subtype -> True - _ -> False - -isSame :: TermEdit -> Bool -isSame e = case e of - Replace _ Same -> True - _ -> False diff --git a/parser-typechecker/src/Unison/Codebase/TypeEdit.hs b/parser-typechecker/src/Unison/Codebase/TypeEdit.hs index 758c0d3c8c..e0b30101c6 100644 --- a/parser-typechecker/src/Unison/Codebase/TypeEdit.hs +++ b/parser-typechecker/src/Unison/Codebase/TypeEdit.hs @@ -5,10 +5,6 @@ import Unison.Reference (Reference) data TypeEdit = Replace Reference | Deprecate deriving (Eq, Ord, Show) -references :: TypeEdit -> [Reference] -references (Replace r) = [r] -references Deprecate = [] - toReference :: TypeEdit -> Maybe Reference toReference (Replace r) = Just r toReference Deprecate = Nothing diff --git a/parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs b/parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs index 0958aaf9c4..4c42443ec4 100644 --- a/parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs +++ b/parser-typechecker/src/Unison/DataDeclaration/Dependencies.hs @@ -2,28 +2,18 @@ module Unison.DataDeclaration.Dependencies ( -- Too many variants of decl dependencies. Read carefully to choose the right one. DD.declTypeDependencies, DD.typeDependencies, - DD.labeledTypeDependencies, - DD.labeledDeclTypeDependencies, - DD.labeledDeclDependenciesIncludingSelf, - labeledDeclDependenciesIncludingSelfAndFieldAccessors, hashFieldAccessors, ) where import Control.Lens import Data.Map qualified as Map -import Data.Set qualified as Set -import Data.Set.Lens (setOf) import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration.Records (generateRecordAccessors) import Unison.Hashing.V2.Convert qualified as Hashing -import Unison.LabeledDependency qualified as LD import Unison.Prelude import Unison.PrettyPrintEnv (PrettyPrintEnv) -import Unison.PrettyPrintEnv qualified as PPE import Unison.Reference (TermReferenceId, TypeReference) -import Unison.Referent (Referent) -import Unison.Referent qualified as Referent import Unison.Result qualified as Result import Unison.Syntax.Var qualified as Var (namespaced) import Unison.Term (Term) @@ -32,45 +22,8 @@ import Unison.Type qualified as Type import Unison.Typechecker qualified as Typechecker import Unison.Typechecker.TypeLookup (TypeLookup (..)) import Unison.Util.Tuple qualified as Tuple -import Unison.Var (Var) import Unison.Var qualified as Var --- | Generate the LabeledDependencies for everything in a Decl, including the Decl itself, all --- its constructors, all referenced types, and all possible record accessors. --- --- Note that we can't actually tell whether the Decl was originally a record or not, so we --- include all possible accessors, but they may or may not exist in the codebase. -labeledDeclDependenciesIncludingSelfAndFieldAccessors :: (Var v) => TypeReference -> (DD.Decl v a) -> Set LD.LabeledDependency -labeledDeclDependenciesIncludingSelfAndFieldAccessors selfRef decl = - DD.labeledDeclDependenciesIncludingSelf selfRef decl - <> case decl of - Left _effect -> mempty - Right dataDecl -> - fieldAccessorRefs selfRef dataDecl - & maybe Set.empty (Set.map LD.TermReferent) - --- | Generate Referents for all possible field accessors of a Decl. --- --- Returns @Nothing@ if this couldn't be a record because it doesn't contain exactly one constructor, or because the --- record contains a field with a higher rank type (and thus fails type inference). -fieldAccessorRefs :: forall v a. (Var v) => TypeReference -> DD.DataDeclaration v a -> Maybe (Set Referent) -fieldAccessorRefs declRef dd = do - [(_, typ)] <- Just (DD.constructors dd) - - -- This name isn't important, we just need a name to generate field names from. - -- The field names are thrown away afterwards. - let typeName = Var.named "Type" - -- These names are arbitrary and don't show up anywhere. - let vars :: [v] - -- We add `n` to the end of the variable name as a quick fix to #4752, but we suspect there's a more - -- fundamental fix to be made somewhere in the term printer to automatically suffix a var name with its - -- freshened id if it would be ambiguous otherwise. - vars = [Var.freshenId (fromIntegral n) (Var.named ("_" <> tShow n)) | n <- [0 .. Type.arity typ - 1]] - - accessors <- hashFieldAccessors PPE.empty typeName vars declRef dd - - Just (setOf (folded . _1 . to Referent.fromTermReferenceId) accessors) - -- | Generate Referents for all possible field accessors of a Decl. -- -- Returns @Nothing@ if inferring/typechecking of any accessor fails, which shouldn't normally happen, but does when diff --git a/parser-typechecker/src/Unison/KindInference/Constraint/Solved.hs b/parser-typechecker/src/Unison/KindInference/Constraint/Solved.hs index d806663a33..058e6dd713 100644 --- a/parser-typechecker/src/Unison/KindInference/Constraint/Solved.hs +++ b/parser-typechecker/src/Unison/KindInference/Constraint/Solved.hs @@ -1,15 +1,10 @@ module Unison.KindInference.Constraint.Solved ( Constraint (..), - prov, - loc, ) where -import Control.Lens (Traversal, Traversal') import Unison.KindInference.Constraint.Provenance (Provenance) -import Unison.KindInference.Constraint.Provenance qualified as Provenance import Unison.KindInference.Constraint.TypeProvenance (TypeProvenance) -import Unison.KindInference.Constraint.TypeProvenance qualified as TP -- | Solved constraints -- @@ -20,19 +15,3 @@ data Constraint uv v loc | IsAbility (Provenance v loc) | IsArr (Provenance v loc) uv uv deriving stock (Show, Eq, Ord) - -prov :: - Traversal - (Constraint uv v loc) - (Constraint uv v loc') - (Provenance v loc) - (Provenance v loc') -prov f = \case - IsType x -> IsType <$> TP.prov f x - IsAbility x -> IsAbility <$> f x - IsArr l a b -> (\x -> IsArr x a b) <$> f l -{-# INLINE prov #-} - -loc :: Traversal' (Constraint uv v loc) loc -loc = prov . Provenance.loc -{-# INLINE loc #-} diff --git a/parser-typechecker/src/Unison/KindInference/Constraint/TypeProvenance.hs b/parser-typechecker/src/Unison/KindInference/Constraint/TypeProvenance.hs index d8ed9bb2f0..162a857bd5 100644 --- a/parser-typechecker/src/Unison/KindInference/Constraint/TypeProvenance.hs +++ b/parser-typechecker/src/Unison/KindInference/Constraint/TypeProvenance.hs @@ -1,10 +1,8 @@ module Unison.KindInference.Constraint.TypeProvenance ( TypeProvenance (..), - prov, ) where -import Control.Lens (Traversal) import Unison.KindInference.Constraint.Provenance (Provenance) -- | Provenance of an @IsType@ constraint. @IsType@ constraints arise @@ -15,14 +13,3 @@ data TypeProvenance v loc = NotDefault (Provenance v loc) | Default deriving stock (Show, Eq, Ord) - -prov :: - Traversal - (TypeProvenance v loc) - (TypeProvenance v loc') - (Provenance v loc) - (Provenance v loc') -prov f = \case - Default -> pure Default - NotDefault p -> NotDefault <$> f p -{-# INLINE prov #-} diff --git a/parser-typechecker/src/Unison/KindInference/Generate.hs b/parser-typechecker/src/Unison/KindInference/Generate.hs index 0886cacc4c..cc9e2c3e29 100644 --- a/parser-typechecker/src/Unison/KindInference/Generate.hs +++ b/parser-typechecker/src/Unison/KindInference/Generate.hs @@ -1,8 +1,7 @@ -- | Handles generating kind constraints to be fed to the kind -- constraint solver (found in "Unison.KindInference.Solve"). module Unison.KindInference.Generate - ( typeConstraints, - termConstraints, + ( termConstraints, declComponentConstraints, builtinConstraints, ) @@ -34,12 +33,6 @@ import Unison.Var (Type (User), Var (typed), freshIn) -- Constraints arising from Types -------------------------------------------------------------------------------- --- | Generate kind constraints arising from a given type. The given --- @UVar@ is constrained to have the kind of the given type. -typeConstraints :: (Var v, Ord loc) => UVar v loc -> Type.Type v loc -> Gen v loc [GeneratedConstraint v loc] -typeConstraints resultVar typ = - flatten bottomUp <$> typeConstraintTree resultVar typ - typeConstraintTree :: (Var v, Ord loc) => UVar v loc -> Type.Type v loc -> Gen v loc (ConstraintTree v loc) typeConstraintTree resultVar term@ABT.Term {annotation, out} = do case out of diff --git a/parser-typechecker/src/Unison/Parsers.hs b/parser-typechecker/src/Unison/Parsers.hs index 13ce658a8a..01b18504a6 100644 --- a/parser-typechecker/src/Unison/Parsers.hs +++ b/parser-typechecker/src/Unison/Parsers.hs @@ -1,40 +1,13 @@ module Unison.Parsers where -import Data.Text qualified as Text -import Unison.Builtin qualified as Builtin import Unison.Parser.Ann (Ann) -import Unison.Prelude -import Unison.PrintError (defaultWidth, prettyParseError) -import Unison.Symbol (Symbol) import Unison.Syntax.FileParser qualified as FileParser import Unison.Syntax.Parser qualified as Parser -import Unison.Syntax.TermParser qualified as TermParser import Unison.Syntax.TypeParser qualified as TypeParser -import Unison.Term (Term) import Unison.Type (Type) import Unison.UnisonFile (UnisonFile) -import Unison.Util.Pretty qualified as Pr import Unison.Var (Var) -unsafeGetRightFrom :: (Var v, Show v) => String -> Either (Parser.Err v) a -> a -unsafeGetRightFrom src = - either (error . Pr.toANSI defaultWidth . prettyParseError src) id - -parse :: - (Monad m, Var v) => - Parser.P v m a -> - String -> - Parser.ParsingEnv m -> - m (Either (Parser.Err v) a) -parse p = Parser.run (Parser.root p) - -parseTerm :: - (Monad m, Var v) => - String -> - Parser.ParsingEnv m -> - m (Either (Parser.Err v) (Term v Ann)) -parseTerm = parse TermParser.term - parseType :: (Monad m, Var v) => String -> @@ -49,39 +22,3 @@ parseFile :: Parser.ParsingEnv m -> m (Either (Parser.Err v) (UnisonFile v Ann)) parseFile filename s = Parser.run' (Parser.rootFile FileParser.file) s filename - -readAndParseFile :: - (MonadIO m, Var v) => - Parser.ParsingEnv m -> - FilePath -> - m (Either (Parser.Err v) (UnisonFile v Ann)) -readAndParseFile penv fileName = do - txt <- liftIO (readUtf8 fileName) - let src = Text.unpack txt - parseFile fileName src penv - -unsafeParseTerm :: (Monad m, Var v) => String -> Parser.ParsingEnv m -> m (Term v Ann) -unsafeParseTerm s env = - unsafeGetRightFrom s <$> parseTerm s env - -unsafeReadAndParseFile :: - Parser.ParsingEnv IO -> FilePath -> IO (UnisonFile Symbol Ann) -unsafeReadAndParseFile penv fileName = do - txt <- readUtf8 fileName - let str = Text.unpack txt - unsafeGetRightFrom str <$> parseFile fileName str penv - -unsafeParseFileBuiltinsOnly :: - FilePath -> IO (UnisonFile Symbol Ann) -unsafeParseFileBuiltinsOnly = - unsafeReadAndParseFile $ - Parser.ParsingEnv - { uniqueNames = mempty, - uniqueTypeGuid = \_ -> pure Nothing, - names = Builtin.names, - maybeNamespace = Nothing, - localNamespacePrefixedTypesAndConstructors = mempty - } - -unsafeParseFile :: (Monad m) => String -> Parser.ParsingEnv m -> m (UnisonFile Symbol Ann) -unsafeParseFile s pEnv = unsafeGetRightFrom s <$> parseFile "" s pEnv diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/IntervalSet.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/IntervalSet.hs index 7bd4a3fe59..50af5716d4 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/IntervalSet.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/IntervalSet.hs @@ -6,14 +6,9 @@ module Unison.PatternMatchCoverage.IntervalSet insert, delete, difference, - intersection, complement, null, - member, - extractSingleton, intersectIntervals, - map, - foldr, lookupMin, lookupMax, ) @@ -43,21 +38,6 @@ lookupMin = fmap fst . IntMap.lookupMin . unIntervalSet lookupMax :: IntervalSet -> Maybe Int lookupMax = fmap snd . IntMap.lookupMax . unIntervalSet -member :: Int -> IntervalSet -> Bool -member i is = - case splitLookupLE i is of - (_, m, _) -> case m of - Nothing -> False - Just (_, ub) -> i <= ub - -foldr :: (Int -> Int -> b -> b) -> b -> IntervalSet -> b -foldr f z = IntMap.foldrWithKey f z . unIntervalSet - -map :: ((Int, Int) -> (Int, Int)) -> IntervalSet -> IntervalSet -map f = IntervalSet . foldr phi IntMap.empty - where - phi k v b = let (k', v') = f (k, v) in IntMap.insert k' v' b - -- | insert inclusive bounds interval into set insert :: (Int, Int) -> IntervalSet -> IntervalSet insert i@(lb, ub) is @@ -116,18 +96,9 @@ complement (IntervalSet m) = fromAscList . (\xs -> Prelude.foldr phi z xs Nothin Nothing -> [] Just x -> [x] -intersection :: IntervalSet -> IntervalSet -> IntervalSet -intersection a b = difference a (complement b) - null :: IntervalSet -> Bool null = IntMap.null . unIntervalSet -extractSingleton :: IntervalSet -> Maybe Int -extractSingleton (IntervalSet m) = case IntMap.toList m of - [(lb, ub)] - | lb == ub -> Just lb - _ -> Nothing - -- | add two integers, sticking to a bound if it would overflow safeAdd :: Int -> Int -> Int safeAdd a b = diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/ListPat.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/ListPat.hs index 60178fb11d..338a3ea6e6 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/ListPat.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/ListPat.hs @@ -1,15 +1,7 @@ module Unison.PatternMatchCoverage.ListPat where -import Unison.Util.Pretty - data ListPat = Cons | Snoc | Nil deriving stock (Show, Eq, Ord) - -prettyListPat :: ListPat -> Pretty ColorText -prettyListPat = \case - Cons -> "Cons" - Snoc -> "Snoc" - Nil -> "Nil" diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs index 7a353817a6..ce8a8a4c06 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/Literal.hs @@ -1,21 +1,14 @@ module Unison.PatternMatchCoverage.Literal ( Literal (..), - prettyLiteral, ) where import Unison.ConstructorReference (ConstructorReference) import Unison.PatternMatchCoverage.EffectHandler import Unison.PatternMatchCoverage.IntervalSet (IntervalSet) -import Unison.PatternMatchCoverage.PmLit (PmLit, prettyPmLit) -import Unison.PrettyPrintEnv qualified as PPE -import Unison.Syntax.TermPrinter qualified as TermPrinter -import Unison.Syntax.TypePrinter qualified as TypePrinter +import Unison.PatternMatchCoverage.PmLit (PmLit) import Unison.Term (Term') import Unison.Type (Type) -import Unison.Typechecker.TypeVar (TypeVar, lowerTerm) -import Unison.Util.Pretty -import Unison.Var (Var) -- | Refinement type literals (fig 3) data Literal vt v loc @@ -67,27 +60,3 @@ data Literal vt v loc | -- | Introduce a binding for a term Let v (Term' vt v loc) (Type vt loc) deriving stock (Show) - -prettyLiteral :: (Var v) => Literal (TypeVar b v) v loc -> Pretty ColorText -prettyLiteral = \case - T -> "✓" - F -> "⨉" - PosCon var con convars -> - let xs = pc con : fmap (\(trm, typ) -> sep " " [pv trm, ":", TypePrinter.pretty PPE.empty typ]) convars ++ ["<-", pv var] - in sep " " xs - NegCon var con -> sep " " [pv var, "≠", pc con] - PosEffect var con convars -> - let xs = pc con : fmap (\(trm, typ) -> sep " " [pv trm, ":", TypePrinter.pretty PPE.empty typ]) convars ++ ["<-", pv var] - in sep " " xs - NegEffect var con -> sep " " [pv var, "≠", pc con] - PosLit var lit -> sep " " [prettyPmLit lit, "<-", pv var] - NegLit var lit -> sep " " [pv var, "≠", prettyPmLit lit] - PosListHead root n el _ -> sep " " [pv el, "<-", "head", pc n, pv root] - PosListTail root n el _ -> sep " " [pv el, "<-", "tail", pc n, pv root] - NegListInterval var x -> sep " " [pv var, "≠", string (show x)] - Effectful var -> "!" <> pv var - Let var expr typ -> sep " " ["let", pv var, "=", TermPrinter.pretty PPE.empty (lowerTerm expr), ":", TypePrinter.pretty PPE.empty typ] - where - pv = string . show - pc :: forall a. (Show a) => a -> Pretty ColorText - pc = string . show diff --git a/parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs b/parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs index 8986f4c409..da45ff6557 100644 --- a/parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs +++ b/parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs @@ -431,7 +431,7 @@ inhabited fuel x nc0 = in foldr phi (\_ -> pure Nothing) cs nc' newtype Fuel = Fuel Int - deriving newtype (Show, Eq, Ord, Enum, Bounded, Num) + deriving newtype (Show, Eq, Ord, Num) initFuel :: Fuel initFuel = 8 diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv.hs b/parser-typechecker/src/Unison/PrettyPrintEnv.hs index 005bce8472..93c4b7a617 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv.hs @@ -17,7 +17,6 @@ module Unison.PrettyPrintEnv -- | Exported only for cases where the codebase's configured hash length is unavailable. todoHashLength, addFallback, - union, empty, ) where @@ -101,22 +100,6 @@ addFallback primary fallback = else primaryNames ) --- | Finds names from both PPEs, if left unbiased the name from the left ppe is preferred. --- --- This is distinct from `addFallback` with respect to biasing; --- A bias applied to a union might select a name in the right half of the union. --- Whereas, a bias applied to the result of `addFallback` will bias within the available names --- inside the left PPE and will only search in the fallback if there aren't ANY names in the --- primary ppe. --- --- If you don't know the difference, it's likely you want 'addFallback' where you add global --- names as a fallback for local names. -union :: PrettyPrintEnv -> PrettyPrintEnv -> PrettyPrintEnv -union e1 e2 = - PrettyPrintEnv - (\r -> termNames e1 r ++ termNames e2 r) - (\r -> typeNames e1 r ++ typeNames e2 r) - -- todo: these need to be a dynamic length, but we need additional info todoHashLength :: Int todoHashLength = 10 diff --git a/parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs b/parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs index cace699ec8..ccf0f24c0d 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs @@ -14,23 +14,12 @@ type MonadPretty v m = (Var v, MonadReader (PrettyPrintEnv, Set v) m) getPPE :: (MonadPretty v m) => m PrettyPrintEnv getPPE = view _1 --- | Run a computation with a modified PrettyPrintEnv, restoring the original -withPPE :: (MonadPretty v m) => PrettyPrintEnv -> m a -> m a -withPPE p = local (set _1 p) - -applyPPE :: (MonadPretty v m) => (PrettyPrintEnv -> a) -> m a -applyPPE = views _1 - applyPPE2 :: (MonadPretty v m) => (PrettyPrintEnv -> a -> b) -> a -> m b applyPPE2 f a = views _1 (`f` a) applyPPE3 :: (MonadPretty v m) => (PrettyPrintEnv -> a -> b -> c) -> a -> b -> m c applyPPE3 f a b = views _1 (\ppe -> f ppe a b) --- | Run a computation with a modified PrettyPrintEnv, restoring the original -modifyPPE :: (MonadPretty v m) => (PrettyPrintEnv -> PrettyPrintEnv) -> m a -> m a -modifyPPE = local . over _1 - modifyTypeVars :: (MonadPretty v m) => (Set v -> Set v) -> m a -> m a modifyTypeVars = local . over _2 diff --git a/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs b/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs index 1712b59c2d..fdd40e5522 100644 --- a/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs +++ b/parser-typechecker/src/Unison/PrettyPrintEnvDecl.hs @@ -3,13 +3,12 @@ module Unison.PrettyPrintEnvDecl ( PrettyPrintEnvDecl (..), biasTo, - empty, addFallback, ) where import Unison.Name (Name) -import Unison.Prelude hiding (empty) +import Unison.Prelude import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) import Unison.PrettyPrintEnv qualified as PPE @@ -35,9 +34,6 @@ biasTo targets PrettyPrintEnvDecl {unsuffixifiedPPE, suffixifiedPPE} = suffixifiedPPE = PPE.biasTo targets suffixifiedPPE } -empty :: PrettyPrintEnvDecl -empty = PrettyPrintEnvDecl PPE.empty PPE.empty - -- | Will use names from the fallback pped if no names were found in the primary. -- @addFallback primary fallback@ addFallback :: PrettyPrintEnvDecl -> PrettyPrintEnvDecl -> PrettyPrintEnvDecl diff --git a/parser-typechecker/src/Unison/PrintError.hs b/parser-typechecker/src/Unison/PrintError.hs index 9d5dd0cf84..0d53032500 100644 --- a/parser-typechecker/src/Unison/PrintError.hs +++ b/parser-typechecker/src/Unison/PrintError.hs @@ -9,7 +9,6 @@ module Unison.PrintError printNoteWithSource, renderCompilerBug, renderNoteAsANSI, - renderParseErrorAsANSI, renderParseErrors, ) where @@ -1221,10 +1220,6 @@ showConstructor env r = fromString . Text.unpack . HQ.toText $ PPE.patternName env r -_posToEnglish :: (IsString s) => L.Pos -> s -_posToEnglish (L.Pos l c) = - fromString $ "Line " ++ show l ++ ", Column " ++ show c - rangeForToken :: L.Token a -> Range rangeForToken t = Range (L.start t) (L.end t) @@ -1280,9 +1275,6 @@ renderNoteAsANSI :: String renderNoteAsANSI w e s n = Pr.toANSI w $ printNoteWithSource e s n -renderParseErrorAsANSI :: (Var v) => Pr.Width -> String -> Parser.Err v -> String -renderParseErrorAsANSI w src = Pr.toANSI w . prettyParseError src - printNoteWithSource :: (Var v, Annotated a, Show a, Ord a) => Env -> @@ -1301,19 +1293,6 @@ printNoteWithSource env s (CompilerBug (Result.TypecheckerBug c)) = printNoteWithSource _env _s (CompilerBug c) = fromString $ "Compiler bug: " <> show c -_printPosRange :: String -> L.Pos -> L.Pos -> String -_printPosRange s (L.Pos startLine startCol) _end = - -- todo: multi-line ranges - -- todo: ranges - _printArrowsAtPos s startLine startCol - -_printArrowsAtPos :: String -> Int -> Int -> String -_printArrowsAtPos s line column = - let lineCaret s i = s ++ if i == line then "\n" ++ columnCaret else "" - columnCaret = replicate (column - 1) '-' ++ "^" - source = unlines (uncurry lineCaret <$> lines s `zip` [1 ..]) - in source - -- Wow, epic view pattern for picking out a lexer error pattern LexerError :: [L.Token L.Lexeme] -> L.Err -> Maybe (P.ErrorItem (L.Token L.Lexeme)) pattern LexerError ts e <- Just (P.Tokens (firstLexerError -> Just (ts, e))) diff --git a/parser-typechecker/src/Unison/Result.hs b/parser-typechecker/src/Unison/Result.hs index 1c542c524f..d09325f0bd 100644 --- a/parser-typechecker/src/Unison/Result.hs +++ b/parser-typechecker/src/Unison/Result.hs @@ -1,7 +1,5 @@ module Unison.Result where -import Control.Error.Util (note) -import Control.Monad.Except (ExceptT (..)) import Control.Monad.Fail qualified as Fail import Control.Monad.Morph qualified as Morph import Control.Monad.Writer (MonadWriter (..), WriterT (..), runWriterT) @@ -43,27 +41,9 @@ makeResult :: (Applicative m) => notes -> Maybe a -> ResultT notes m a makeResult notes value = MaybeT (WriterT (pure (value, notes))) -isSuccess :: (Functor f) => ResultT note f a -> f Bool -isSuccess = (isJust . fst <$>) . runResultT - -isFailure :: (Functor f) => ResultT note f a -> f Bool -isFailure = (isNothing . fst <$>) . runResultT - -toMaybe :: (Functor f) => ResultT note f a -> f (Maybe a) -toMaybe = (fst <$>) . runResultT - runResultT :: ResultT notes f a -> f (Maybe a, notes) runResultT = runWriterT . runMaybeT --- Returns the `Result` in the `f` functor. -getResult :: (Functor f) => ResultT notes f a -> f (Result notes a) -getResult r = uncurry (flip Result) <$> runResultT r - -toEither :: (Functor f) => ResultT notes f a -> ExceptT notes f a -toEither r = ExceptT (go <$> runResultT r) - where - go (may, notes) = note notes may - tell1 :: (Monad f) => note -> ResultT (Seq note) f () tell1 = tell . pure diff --git a/parser-typechecker/src/Unison/Syntax/NamePrinter.hs b/parser-typechecker/src/Unison/Syntax/NamePrinter.hs index 8c3a70708d..5b83d35a74 100644 --- a/parser-typechecker/src/Unison/Syntax/NamePrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/NamePrinter.hs @@ -3,8 +3,6 @@ module Unison.Syntax.NamePrinter where import Data.Text qualified as Text import Unison.HashQualified qualified as HQ import Unison.HashQualifiedPrime qualified as HQ' -import Unison.LabeledDependency (LabeledDependency) -import Unison.LabeledDependency qualified as LD import Unison.Name (Name) import Unison.Prelude import Unison.Reference (Reference) @@ -53,9 +51,6 @@ prettyReferent :: Int -> Referent -> Pretty SyntaxText prettyReferent len = prettyHashQualified . HQ.take len . HQ.fromReferent -prettyLabeledDependency :: Int -> LabeledDependency -> Pretty SyntaxText -prettyLabeledDependency len = LD.fold (prettyReference len) (prettyReferent len) - prettyShortHash :: (IsString s) => ShortHash -> Pretty s prettyShortHash = fromString . Text.unpack . SH.toText diff --git a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs index f506467a39..2d9c727a1f 100644 --- a/parser-typechecker/src/Unison/Syntax/TermPrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TermPrinter.hs @@ -5,7 +5,6 @@ module Unison.Syntax.TermPrinter prettyBlock', pretty', prettyBinding, - prettyBinding', prettyBindingWithoutTypeSignature, prettyDoc2, pretty0, @@ -931,16 +930,6 @@ prettyBinding_ :: prettyBinding_ go ppe n tm = runPretty (avoidShadowing tm ppe) . fmap go $ prettyBinding0 (ac Basement Block Map.empty MaybeDoc) n tm -prettyBinding' :: - (Var v) => - PrettyPrintEnv -> - Width -> - HQ.HashQualified Name -> - Term v a -> - ColorText -prettyBinding' ppe width v t = - PP.render width . PP.syntaxToColor $ prettyBinding ppe v t - prettyBinding0 :: (MonadPretty v m) => AmbientContext -> diff --git a/parser-typechecker/src/Unison/Syntax/TypePrinter.hs b/parser-typechecker/src/Unison/Syntax/TypePrinter.hs index 271546e776..7744bf7570 100644 --- a/parser-typechecker/src/Unison/Syntax/TypePrinter.hs +++ b/parser-typechecker/src/Unison/Syntax/TypePrinter.hs @@ -11,8 +11,6 @@ module Unison.Syntax.TypePrinter prettySignaturesST, prettySignaturesCT, prettySignaturesCTCollapsed, - prettySignaturesAlt, - prettySignaturesAlt', runPretty, ) where @@ -213,36 +211,3 @@ prettySignaturesST ppe ts = t <- pretty0 Map.empty (-1) typ let col = fmt S.TypeAscriptionColon ": " pure $ (col <> t) `PP.orElse` (col <> PP.indentNAfterNewline 2 t) - --- todo: provide sample output in comment; different from prettySignatures' -prettySignaturesAlt' :: - (Var v) => - PrettyPrintEnv -> - [([HashQualified Name], Type v a)] -> - [Pretty ColorText] -prettySignaturesAlt' ppe ts = runPretty ppe $ - do - ts' <- traverse f ts - pure $ map PP.syntaxToColor $ PP.align ts' - where - f :: (MonadPretty v m) => ([HashQualified Name], Type v a) -> m (Pretty SyntaxText, Pretty SyntaxText) - f (names, typ) = do - typ' <- pretty0 Map.empty (-1) typ - let col = fmt S.TypeAscriptionColon ": " - pure - ( PP.commas . fmap (\name -> styleHashQualified'' (fmt $ S.HashQualifier name) name) $ names, - (col <> typ') `PP.orElse` (col <> PP.indentNAfterNewline 2 typ') - ) - --- prettySignatures'' :: Var v => [(Name, Type v a)] -> [Pretty ColorText] --- prettySignatures'' env ts = prettySignatures' env (first HQ.fromName <$> ts) - -prettySignaturesAlt :: - (Var v) => - PrettyPrintEnv -> - [([HashQualified Name], Type v a)] -> - Pretty ColorText -prettySignaturesAlt ppe ts = - PP.lines - . map PP.group - $ prettySignaturesAlt' ppe ts diff --git a/parser-typechecker/src/Unison/Typechecker.hs b/parser-typechecker/src/Unison/Typechecker.hs index 340572df72..6584df9c30 100644 --- a/parser-typechecker/src/Unison/Typechecker.hs +++ b/parser-typechecker/src/Unison/Typechecker.hs @@ -1,19 +1,15 @@ {-# LANGUAGE TemplateHaskell #-} -- | This module is the primary interface to the Unison typechecker --- module Unison.Typechecker (admissibleTypeAt, check, check', checkAdmissible', equals, locals, subtype, isSubtype, synthesize, synthesize', typeAt, wellTyped) where module Unison.Typechecker ( synthesize, synthesizeAndResolve, - check, - wellTyped, isEqual, isSubtype, fitsScheme, Env (..), Notes (..), Resolution (..), - Name, NamedReference (..), Context.PatternMatchCoverageCheckAndKindInferenceSwitch (..), ) @@ -21,7 +17,7 @@ where import Control.Lens import Control.Monad.Fail (fail) -import Control.Monad.State (StateT, get, modify, execState, State) +import Control.Monad.State (State, StateT, execState, get, modify) import Control.Monad.Writer import Data.Foldable import Data.Map qualified as Map @@ -49,8 +45,6 @@ import Unison.Util.List (uniqueBy) import Unison.Var (Var) import Unison.Var qualified as Var -type Name = Text - data Notes v loc = Notes { bugs :: Seq (Context.CompilerBug v loc), errors :: Seq (Context.ErrorNote v loc), @@ -233,7 +227,7 @@ typeDirectedNameResolution ppe oldNotes oldType env = do addTypedComponent (Context.TopLevelComponent vtts) = for_ vtts \(v, typ, _) -> let name = Name.unsafeParseVar (Var.reset v) - in #topLevelComponents %= Map.insert name (NamedReference name typ (Context.ReplacementVar v)) + in #topLevelComponents %= Map.insert name (NamedReference name typ (Context.ReplacementVar v)) addTypedComponent _ = pure () suggest :: [Resolution v loc] -> Result (Notes v loc) () @@ -347,64 +341,3 @@ typeDirectedNameResolution ppe oldNotes oldType env = do (TypeVar.liftType foundType) replace (if b then Context.Exact else Context.WrongType) - --- | Check whether a term matches a type, using a --- function to resolve the type of @Ref@ constructors --- contained in the term. Returns @typ@ if successful, --- and a note about typechecking failure otherwise. -check :: - (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc) => - PrettyPrintEnv -> - Env v loc -> - Term v loc -> - Type v loc -> - ResultT (Notes v loc) f (Type v loc) -check ppe env term typ = - synthesize - ppe - Context.PatternMatchCoverageCheckAndKindInferenceSwitch'Enabled - env - (Term.ann (ABT.annotation term) term typ) - --- | `checkAdmissible' e t` tests that `(f : t -> r) e` is well-typed. --- If `t` has quantifiers, these are moved outside, so if `t : forall a . a`, --- this will check that `(f : forall a . a -> a) e` is well typed. --- checkAdmissible' :: Var v => Term v -> Type v -> Either Note (Type v) --- checkAdmissible' term typ = --- synthesize' (Term.blank() `Term.ann_` tweak typ `Term.app_` term) --- where --- tweak (Type.ForallNamed' v body) = Type.forall() v (tweak body) --- tweak t = Type.arrow() t t --- | Returns `True` if the expression is well-typed, `False` otherwise -wellTyped :: (Monad f, Var v, BuiltinAnnotation loc, Ord loc, Show loc) => PrettyPrintEnv -> Env v loc -> Term v loc -> f Bool -wellTyped ppe env term = go <$> runResultT (synthesize ppe Context.PatternMatchCoverageCheckAndKindInferenceSwitch'Enabled env term) - where - go (may, _) = isJust may - --- | @subtype a b@ is @Right b@ iff @f x@ is well-typed given --- @x : a@ and @f : b -> t@. That is, if a value of type `a` --- can be passed to a function expecting a `b`, then `subtype a b` --- returns `Right b`. This function returns @Left note@ with information --- about the reason for subtyping failure otherwise. --- --- Example: @subtype (forall a. a -> a) (Int -> Int)@ returns @Right (Int -> Int)@. --- subtype :: Var v => Type v -> Type v -> Either Note (Type v) --- subtype t1 t2 = error "todo" --- let (t1', t2') = (ABT.vmap TypeVar.Universal t1, ABT.vmap TypeVar.Universal t2) --- in case Context.runM (Context.subtype t1' t2') --- (Context.MEnv Context.env0 [] Map.empty True) of --- Left e -> Left e --- Right _ -> Right t2 - --- | Returns true if @subtype t1 t2@ returns @Right@, false otherwise --- isSubtype :: Var v => Type v -> Type v -> Bool --- isSubtype t1 t2 = case subtype t1 t2 of --- Left _ -> False --- Right _ -> True - --- | Returns true if the two type are equal, up to alpha equivalence and --- order of quantifier introduction. Note that alpha equivalence considers: --- `forall b a . a -> b -> a` and --- `forall a b . a -> b -> a` to be different types --- equals :: Var v => Type v -> Type v -> Bool --- equals t1 t2 = isSubtype t1 t2 && isSubtype t2 t1 diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 767fa37316..cbe7c18476 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -26,7 +26,6 @@ module Unison.Typechecker.Context lookupAnn, lookupSolved, apply, - isEqual, isSubtype, fitsScheme, isRedundant, @@ -622,12 +621,6 @@ debugTypes tag t1 t2 debugPatternsEnabled :: Bool debugPatternsEnabled = False -_logContext :: (Ord loc, Var v) => String -> M v loc () -_logContext msg = when debugEnabled $ do - ctx <- getContext - let !_ = trace ("\n" ++ msg ++ ": " ++ show ctx) () - setContext ctx - usedVars :: (Ord v) => Context v loc -> Set v usedVars = allVars . info @@ -3360,11 +3353,6 @@ isSubtype :: isSubtype t1 t2 = run PPE.empty PatternMatchCoverageCheckAndKindInferenceSwitch'Enabled Map.empty Map.empty (isSubtype' t1 t2) -isEqual :: - (Var v, Ord loc) => Type v loc -> Type v loc -> Either (CompilerBug v loc) Bool -isEqual t1 t2 = - (&&) <$> isSubtype t1 t2 <*> isSubtype t2 t1 - instance (Var v) => Show (Element v loc) where show (Var v) = case v of TypeVar.Universal x -> "@" <> show x diff --git a/parser-typechecker/src/Unison/Typechecker/Extractor.hs b/parser-typechecker/src/Unison/Typechecker/Extractor.hs index 7e977f4367..65adc121db 100644 --- a/parser-typechecker/src/Unison/Typechecker/Extractor.hs +++ b/parser-typechecker/src/Unison/Typechecker/Extractor.hs @@ -1,16 +1,12 @@ module Unison.Typechecker.Extractor where import Control.Monad.Reader -import Data.List qualified as List import Data.List.NonEmpty (NonEmpty) import Data.Set qualified as Set -import Unison.Blank qualified as B -import Unison.ConstructorReference (ConstructorReference) import Unison.KindInference (KindError) import Unison.Pattern (Pattern) import Unison.Prelude hiding (whenM) import Unison.Term qualified as Term -import Unison.Type (Type) import Unison.Type qualified as Type import Unison.Typechecker.Context qualified as C import Unison.Util.Monoid (whenM) @@ -23,8 +19,6 @@ type Extractor e a = MaybeT (Reader e) a type ErrorExtractor v loc a = Extractor (C.ErrorNote v loc) a -type InfoExtractor v loc a = Extractor (C.InfoNote v loc) a - type PathExtractor v loc a = Extractor (C.PathElement v loc) a type SubseqExtractor v loc a = SubseqExtractor' (C.ErrorNote v loc) a @@ -38,17 +32,6 @@ extract = runReader . runMaybeT subseqExtractor :: (C.ErrorNote v loc -> [Ranged a]) -> SubseqExtractor v loc a subseqExtractor f = SubseqExtractor' f -traceSubseq :: (Show a) => String -> SubseqExtractor' n a -> SubseqExtractor' n a -traceSubseq s ex = SubseqExtractor' $ \n -> - let rs = runSubseq ex n - in trace (if null s then show rs else s ++ ": " ++ show rs) rs - -traceNote :: - (Show a) => String -> ErrorExtractor v loc a -> ErrorExtractor v loc a -traceNote s ex = extractor $ \n -> - let result = extract ex n - in trace (if null s then show result else s ++ ": " ++ show result) result - unique :: SubseqExtractor v loc a -> ErrorExtractor v loc a unique ex = extractor $ \note -> case runSubseq ex note of [Pure a] -> Just a @@ -62,51 +45,6 @@ data Ranged a | Ranged {get :: a, start :: Int, end :: Int} deriving (Functor, Show) --- | collects the regions where `xa` doesn't match / aka invert a set of intervals --- unused, but don't want to delete it yet - Aug 30, 2018 -_no :: SubseqExtractor' n a -> SubseqExtractor' n () -_no xa = SubseqExtractor' $ \note -> - let as = runSubseq xa note - in if null [a | Pure a <- as] - then -- results are not full - - if null as - then [Pure ()] -- results are empty, make them full - -- not full and not empty, find the negation - else - reverse . fst $ - foldl' - go - ([], Nothing) - (List.sort $ fmap toPairs as) - else [] -- results were full, make them empty - where - toPairs :: Ranged a -> (Int, Int) - toPairs (Pure _) = error "this case should be avoided by the if!" - toPairs (Ranged _ start end) = (start, end) - - go :: ([Ranged ()], Maybe Int) -> (Int, Int) -> ([Ranged ()], Maybe Int) - go ([], Nothing) (0, r) = ([], Just (r + 1)) - go ([], Nothing) (l, r) = ([Ranged () 0 (l - 1)], Just r) - go (_ : _, Nothing) _ = error "state machine bug in Extractor2.no" - go (rs, Just r0) (l, r) = - (if r0 + 1 <= l - 1 then Ranged () (r0 + 1) (l - 1) : rs else rs, Just r) - --- unused / untested -_any :: SubseqExtractor v loc () -_any = _any' (\n -> pathLength n - 1) - where - pathLength :: C.ErrorNote v loc -> Int - pathLength = length . toList . C.path - -_any' :: (n -> Int) -> SubseqExtractor' n () -_any' getLast = SubseqExtractor' $ \note -> - Pure () : do - let last = getLast note - start <- [0 .. last] - end <- [0 .. last] - pure $ Ranged () start end - -- Kind of a newtype for Ranged.Ranged. -- The Eq instance ignores the embedded value data DistinctRanged a = DistinctRanged a Int Int @@ -164,22 +102,12 @@ asPathExtractor = fromPathExtractor . extractor Just a -> [Ranged a i i] Nothing -> [] -inSynthesize :: SubseqExtractor v loc (C.Term v loc) -inSynthesize = asPathExtractor $ \case - C.InSynthesize t -> Just t - _ -> Nothing - inSubtype :: SubseqExtractor v loc (C.Type v loc, C.Type v loc) inSubtype = asPathExtractor $ \case C.InSubtype found expected -> Just (found, expected) C.InEquate found expected -> Just (found, expected) _ -> Nothing -inEquate :: SubseqExtractor v loc (C.Type v loc, C.Type v loc) -inEquate = asPathExtractor $ \case - C.InEquate lhs rhs -> Just (lhs, rhs) - _ -> Nothing - inCheck :: SubseqExtractor v loc (C.Term v loc, C.Type v loc) inCheck = asPathExtractor $ \case C.InCheck e t -> Just (e, t) @@ -268,12 +196,6 @@ typeMismatch = C.TypeMismatch c -> pure c _ -> mzero -illFormedType :: ErrorExtractor v loc (C.Context v loc) -illFormedType = - cause >>= \case - C.IllFormedType c -> pure c - _ -> mzero - unknownSymbol :: ErrorExtractor v loc (loc, v) unknownSymbol = cause >>= \case @@ -303,36 +225,10 @@ abilityEqFailure = C.AbilityEqFailure lhs rhs ctx -> pure (lhs, rhs, ctx) _ -> mzero -effectConstructorWrongArgCount :: - ErrorExtractor - v - loc - (C.ExpectedArgCount, C.ActualArgCount, ConstructorReference) -effectConstructorWrongArgCount = - cause >>= \case - C.EffectConstructorWrongArgCount expected actual r -> - pure (expected, actual, r) - _ -> mzero - -malformedEffectBind :: - ErrorExtractor v loc (C.Type v loc, C.Type v loc, [C.Type v loc]) -malformedEffectBind = - cause >>= \case - C.MalformedEffectBind ctor ctorResult es -> pure (ctor, ctorResult, es) - _ -> mzero - -solvedBlank :: InfoExtractor v loc (B.Recorded loc, v, C.Type v loc) -solvedBlank = extractor $ \n -> case n of - C.SolvedBlank b v t -> pure (b, v, t) - _ -> mzero - -- Misc -- errorNote :: ErrorExtractor v loc (C.ErrorNote v loc) errorNote = extractor $ Just . id -infoNote :: InfoExtractor v loc (C.InfoNote v loc) -infoNote = extractor $ Just . id - innermostTerm :: ErrorExtractor v loc (C.Term v loc) innermostTerm = extractor $ \n -> case C.innermostErrorTerm n of Just e -> pure e @@ -341,17 +237,6 @@ innermostTerm = extractor $ \n -> case C.innermostErrorTerm n of path :: ErrorExtractor v loc [C.PathElement v loc] path = extractor $ pure . toList . C.path --- Informational notes -- -topLevelComponent :: - InfoExtractor - v - loc - [(v, Type v loc, RedundantTypeAnnotation)] -topLevelComponent = extractor go - where - go (C.TopLevelComponent c) = Just c - go _ = Nothing - instance Functor (SubseqExtractor' n) where fmap = liftM diff --git a/parser-typechecker/src/Unison/Typechecker/TypeError.hs b/parser-typechecker/src/Unison/Typechecker/TypeError.hs index 2f829cbef1..af61ec2dd2 100644 --- a/parser-typechecker/src/Unison/Typechecker/TypeError.hs +++ b/parser-typechecker/src/Unison/Typechecker/TypeError.hs @@ -116,8 +116,6 @@ data TypeInfo v loc = TopLevelComponent {definitions :: [(v, Type v loc, RedundantTypeAnnotation)]} deriving (Show) -type TypeNote v loc = Either (TypeError v loc) (TypeInfo v loc) - typeErrorFromNote :: (Ord loc, Show loc, Var v) => C.ErrorNote v loc -> TypeError v loc typeErrorFromNote n = case Ex.extract allErrors n of @@ -155,11 +153,6 @@ allErrors = kindInferenceFailure ] -topLevelComponent :: Ex.InfoExtractor v a (TypeInfo v a) -topLevelComponent = do - defs <- Ex.topLevelComponent - pure $ TopLevelComponent defs - redundantPattern :: Ex.ErrorExtractor v a (TypeError v a) redundantPattern = do ploc <- Ex.redundantPattern diff --git a/parser-typechecker/src/Unison/Typechecker/TypeLookup.hs b/parser-typechecker/src/Unison/Typechecker/TypeLookup.hs index e94f38b9dc..79e02085c2 100644 --- a/parser-typechecker/src/Unison/Typechecker/TypeLookup.hs +++ b/parser-typechecker/src/Unison/Typechecker/TypeLookup.hs @@ -25,18 +25,6 @@ typeOfReferent tl r = case r of Referent.Con r CT.Data -> typeOfDataConstructor tl r Referent.Con r CT.Effect -> typeOfEffectConstructor tl r --- bombs if not found -unsafeConstructorType :: TypeLookup v a -> TypeReference -> CT.ConstructorType -unsafeConstructorType tl r = - fromMaybe - (error $ "no constructor type for " <> show r) - (constructorType tl r) - -constructorType :: TypeLookup v a -> TypeReference -> Maybe CT.ConstructorType -constructorType tl r = - (const CT.Data <$> Map.lookup r (dataDecls tl)) - <|> (const CT.Effect <$> Map.lookup r (effectDecls tl)) - typeOfDataConstructor :: TypeLookup v a -> ConstructorReference -> Maybe (Type v a) typeOfDataConstructor tl (ConstructorReference r cid) = go =<< Map.lookup r (dataDecls tl) where diff --git a/parser-typechecker/src/Unison/UnisonFile.hs b/parser-typechecker/src/Unison/UnisonFile.hs index 785482bac6..40fcc4bff6 100644 --- a/parser-typechecker/src/Unison/UnisonFile.hs +++ b/parser-typechecker/src/Unison/UnisonFile.hs @@ -31,7 +31,6 @@ module Unison.UnisonFile indexByReference, lookupDecl, nonEmpty, - termSignatureExternalLabeledDependencies, topLevelComponents, typecheckedUnisonFile, Unison.UnisonFile.rewrite, @@ -54,8 +53,6 @@ import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration qualified as DataDeclaration import Unison.Hash qualified as Hash import Unison.Hashing.V2.Convert qualified as Hashing -import Unison.LabeledDependency (LabeledDependency) -import Unison.LabeledDependency qualified as LD import Unison.Prelude import Unison.Reference (Reference, TermReference, TypeReference) import Unison.Reference qualified as Reference @@ -63,9 +60,8 @@ import Unison.Referent qualified as Referent import Unison.Term (Term) import Unison.Term qualified as Term import Unison.Type (Type) -import Unison.Type qualified as Type import Unison.Typechecker.TypeLookup qualified as TL -import Unison.UnisonFile.Type (TypecheckedUnisonFile (..), UnisonFile (..), pattern TypecheckedUnisonFile, pattern UnisonFile) +import Unison.UnisonFile.Type (TypecheckedUnisonFile (..), UnisonFile (..), pattern UnisonFile) import Unison.Util.Defns (Defns (..), DefnsF) import Unison.Util.List qualified as List import Unison.Var (Var) @@ -318,24 +314,6 @@ topLevelComponents :: topLevelComponents file = topLevelComponents' file ++ [comp | (TestWatch, comp) <- watchComponents file] --- External type references that appear in the types of the file's terms -termSignatureExternalLabeledDependencies :: - (Ord v) => TypecheckedUnisonFile v a -> Set LabeledDependency -termSignatureExternalLabeledDependencies - (TypecheckedUnisonFile dataDeclarations' effectDeclarations' _ _ hashTerms) = - Set.difference - ( Set.map LD.typeRef - . foldMap Type.dependencies - . fmap (\(_a, _r, _wk, _e, t) -> t) - . toList - $ hashTerms - ) - -- exclude any references that are defined in this file - ( Set.fromList $ - (map (LD.typeRef . fst) . toList) dataDeclarations' - <> (map (LD.typeRef . fst) . toList) effectDeclarations' - ) - -- Returns the dependencies of the `UnisonFile` input. Needed so we can -- load information about these dependencies before starting typechecking. dependencies :: (Monoid a, Var v) => UnisonFile v a -> DefnsF Set TermReference TypeReference diff --git a/parser-typechecker/src/Unison/Util/CycleTable.hs b/parser-typechecker/src/Unison/Util/CycleTable.hs deleted file mode 100644 index 21118c0099..0000000000 --- a/parser-typechecker/src/Unison/Util/CycleTable.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Unison.Util.CycleTable where - -import Data.HashTable.IO (BasicHashTable) -import Data.HashTable.IO qualified as HT -import Data.Hashable (Hashable) -import Data.Mutable qualified as M - --- A hash table along with a unique number which gets incremented on --- each insert. This is used as an implementation detail by `CyclicEq`, --- `CyclicOrd`, etc to be able to compare, hash, or serialize cyclic structures. - -data CycleTable k v = CycleTable - { table :: BasicHashTable k v, - sizeRef :: M.IOPRef Int - } - -new :: Int -> IO (CycleTable k v) -new size = do - t <- HT.newSized size - r <- M.newRef 0 - pure (CycleTable t r) - -lookup :: (Hashable k, Eq k) => k -> CycleTable k v -> IO (Maybe v) -lookup k t = HT.lookup (table t) k - -insert :: (Hashable k, Eq k) => k -> v -> CycleTable k v -> IO () -insert k v t = do - HT.insert (table t) k v - M.modifyRef (sizeRef t) (1 +) - -size :: CycleTable k v -> IO Int -size h = M.readRef (sizeRef h) - -insertEnd :: (Hashable k, Eq k) => k -> CycleTable k Int -> IO () -insertEnd k t = do - n <- size t - insert k n t diff --git a/parser-typechecker/src/Unison/Util/CyclicEq.hs b/parser-typechecker/src/Unison/Util/CyclicEq.hs deleted file mode 100644 index 4846a64592..0000000000 --- a/parser-typechecker/src/Unison/Util/CyclicEq.hs +++ /dev/null @@ -1,79 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} - -module Unison.Util.CyclicEq where - -import Data.Sequence qualified as S -import Data.Vector (Vector) -import Data.Vector qualified as V -import Unison.Prelude -import Unison.Util.CycleTable qualified as CT - -{- - Typeclass used for comparing potentially cyclic types for equality. - Cyclic types may refer to themselves indirectly, so something is needed to - prevent an infinite loop in these cases. The basic idea: when a subexpression - is first examined, its "id" (represented as some `Int`) may be added to the - mutable hash table along with its position. The next time that same id is - encountered, it will be compared based on this position. - -} -class CyclicEq a where - -- Map from `Ref` ID to position in the stream - -- If a ref is encountered again, we use its mapped ID - cyclicEq :: CT.CycleTable Int Int -> CT.CycleTable Int Int -> a -> a -> IO Bool - -bothEq' :: - (Eq a, CyclicEq b) => - CT.CycleTable Int Int -> - CT.CycleTable Int Int -> - a -> - a -> - b -> - b -> - IO Bool -bothEq' h1 h2 a1 a2 b1 b2 = - if a1 == a2 - then cyclicEq h1 h2 b1 b2 - else pure False - -bothEq :: - (CyclicEq a, CyclicEq b) => - CT.CycleTable Int Int -> - CT.CycleTable Int Int -> - a -> - a -> - b -> - b -> - IO Bool -bothEq h1 h2 a1 a2 b1 b2 = - cyclicEq h1 h2 a1 a2 >>= \b -> - if b - then cyclicEq h1 h2 b1 b2 - else pure False - -instance (CyclicEq a) => CyclicEq [a] where - cyclicEq h1 h2 (x : xs) (y : ys) = bothEq h1 h2 x y xs ys - cyclicEq _ _ [] [] = pure True - cyclicEq _ _ _ _ = pure False - -instance (CyclicEq a) => CyclicEq (S.Seq a) where - cyclicEq h1 h2 xs ys = - if S.length xs == S.length ys - then cyclicEq h1 h2 (toList xs) (toList ys) - else pure False - -instance (CyclicEq a) => CyclicEq (Vector a) where - cyclicEq h1 h2 xs ys = - if V.length xs /= V.length ys - then pure False - else go 0 h1 h2 xs ys - where - go !i !h1 !h2 !xs !ys = - if i >= V.length xs - then pure True - else do - b <- cyclicEq h1 h2 (xs V.! i) (ys V.! i) - if b - then go (i + 1) h1 h2 xs ys - else pure False diff --git a/parser-typechecker/src/Unison/Util/CyclicOrd.hs b/parser-typechecker/src/Unison/Util/CyclicOrd.hs deleted file mode 100644 index c67c39af33..0000000000 --- a/parser-typechecker/src/Unison/Util/CyclicOrd.hs +++ /dev/null @@ -1,73 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE Strict #-} -{-# LANGUAGE StrictData #-} - -module Unison.Util.CyclicOrd where - -import Data.Sequence qualified as S -import Data.Vector (Vector) -import Data.Vector qualified as V -import Unison.Prelude -import Unison.Util.CycleTable (CycleTable) -import Unison.Util.CycleTable qualified as CT - --- Same idea as `CyclicEq`, but for ordering. -class CyclicOrd a where - -- Map from `Ref` ID to position in the stream - -- If a ref is encountered again, we use its mapped ID - cyclicOrd :: CycleTable Int Int -> CycleTable Int Int -> a -> a -> IO Ordering - -bothOrd' :: - (Ord a, CyclicOrd b) => - CT.CycleTable Int Int -> - CT.CycleTable Int Int -> - a -> - a -> - b -> - b -> - IO Ordering -bothOrd' h1 h2 a1 a2 b1 b2 = case compare a1 a2 of - EQ -> cyclicOrd h1 h2 b1 b2 - c -> pure c - -bothOrd :: - (CyclicOrd a, CyclicOrd b) => - CT.CycleTable Int Int -> - CT.CycleTable Int Int -> - a -> - a -> - b -> - b -> - IO Ordering -bothOrd h1 h2 a1 a2 b1 b2 = - cyclicOrd h1 h2 a1 a2 >>= \b -> - if b == EQ - then cyclicOrd h1 h2 b1 b2 - else pure b - -instance (CyclicOrd a) => CyclicOrd [a] where - cyclicOrd h1 h2 (x : xs) (y : ys) = bothOrd h1 h2 x y xs ys - cyclicOrd _ _ [] [] = pure EQ - cyclicOrd _ _ [] _ = pure LT - cyclicOrd _ _ _ [] = pure GT - -instance (CyclicOrd a) => CyclicOrd (S.Seq a) where - cyclicOrd h1 h2 xs ys = cyclicOrd h1 h2 (toList xs) (toList ys) - -instance (CyclicOrd a) => CyclicOrd (Vector a) where - cyclicOrd h1 h2 xs ys = go 0 h1 h2 xs ys - where - go !i !h1 !h2 !xs !ys = - if i >= V.length xs && i >= V.length ys - then pure EQ - else - if i >= V.length xs - then pure LT - else - if i >= V.length ys - then pure GT - else do - b <- cyclicOrd h1 h2 (xs V.! i) (ys V.! i) - if b == EQ - then go (i + 1) h1 h2 xs ys - else pure b diff --git a/parser-typechecker/src/Unison/Util/Exception.hs b/parser-typechecker/src/Unison/Util/Exception.hs deleted file mode 100644 index a2a394d21a..0000000000 --- a/parser-typechecker/src/Unison/Util/Exception.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Unison.Util.Exception where - -import Control.Concurrent.Async (waitCatch, withAsync) -import Unison.Prelude - --- These are adapted from: https://github.com/snoyberg/classy-prelude/blob/ccd19f2c62882c69d5dcdd3da5c0df1031334c5a/classy-prelude/ClassyPrelude.hs#L320 --- License is MIT: https://github.com/snoyberg/classy-prelude/blob/ccd19f2c62882c69d5dcdd3da5c0df1031334c5a/classy-prelude/LICENSE - --- Catch all exceptions except asynchronous exceptions. -tryAny :: (MonadIO m) => IO a -> m (Either SomeException a) -tryAny action = liftIO $ withAsync action waitCatch - --- Catch all exceptions except asynchronous exceptions. -catchAny :: IO a -> (SomeException -> IO a) -> IO a -catchAny action onE = tryAny action >>= either onE return diff --git a/parser-typechecker/src/Unison/Util/TQueue.hs b/parser-typechecker/src/Unison/Util/TQueue.hs index 23ebfa6791..35d360ad6d 100644 --- a/parser-typechecker/src/Unison/Util/TQueue.hs +++ b/parser-typechecker/src/Unison/Util/TQueue.hs @@ -1,8 +1,6 @@ module Unison.Util.TQueue where -import Control.Concurrent.Async qualified as Async import Data.Sequence (Seq ((:<|)), (|>)) -import Data.Sequence qualified as S import Unison.Prelude import UnliftIO.STM hiding (TQueue) @@ -11,19 +9,6 @@ data TQueue a = TQueue (TVar (Seq a)) (TVar Word64) newIO :: forall a m. (MonadIO m) => m (TQueue a) newIO = TQueue <$> newTVarIO mempty <*> newTVarIO 0 -size :: TQueue a -> STM Int -size (TQueue q _) = S.length <$> readTVar q - --- Waits for this queue to reach a size <= target. --- Consumes no elements; it's expected there is some --- other thread which is consuming elements from the queue. -awaitSize :: Int -> TQueue a -> STM () -awaitSize target q = - size q >>= \n -> - if n <= target - then pure () - else retrySTM - peek :: TQueue a -> STM a peek (TQueue v _) = readTVar v >>= \case @@ -46,13 +31,6 @@ tryDequeue (TQueue v _) = a :<| as -> writeTVar v as *> pure (Just a) _ -> pure Nothing -dequeueN :: TQueue a -> Int -> STM [a] -dequeueN (TQueue v _) n = - readTVar v >>= \s -> - if length s >= n - then writeTVar v (S.drop n s) $> toList (S.take n s) - else retrySTM - -- return the number of enqueues over the life of the queue enqueueCount :: TQueue a -> STM Word64 enqueueCount (TQueue _ count) = readTVar count @@ -67,31 +45,3 @@ enqueue :: TQueue a -> a -> STM () enqueue (TQueue v count) a = do modifyTVar' v (|> a) modifyTVar' count (+ 1) - -raceIO :: (MonadIO m) => STM a -> STM b -> m (Either a b) -raceIO a b = liftIO do - aa <- Async.async $ atomically a - ab <- Async.async $ atomically b - Async.waitEitherCancel aa ab - --- take all elements up to but not including the first not satisfying cond -tryPeekWhile :: (a -> Bool) -> TQueue a -> STM [a] -tryPeekWhile cond (TQueue v _) = toList . S.takeWhileL cond <$> readTVar v - --- block until at least one element is enqueued not satisfying cond, --- then return the prefix before that -takeWhile :: (a -> Bool) -> TQueue a -> STM [a] -takeWhile cond (TQueue v _) = - readTVar v >>= \s -> - let (left, right) = S.spanl cond s - in if null right - then retrySTM - else writeTVar v right $> toList left - -peekWhile :: (a -> Bool) -> TQueue a -> STM [a] -peekWhile cond (TQueue v _) = - readTVar v >>= \s -> - let (left, right) = S.spanl cond s - in if null right - then retrySTM - else pure $ toList left diff --git a/parser-typechecker/src/Unison/Util/Text.hs b/parser-typechecker/src/Unison/Util/Text.hs index c588e35743..f79382c85e 100644 --- a/parser-typechecker/src/Unison/Util/Text.hs +++ b/parser-typechecker/src/Unison/Util/Text.hs @@ -71,9 +71,6 @@ 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 @@ -210,8 +207,6 @@ instance R.Index Chunk Char where instance R.Reverse Chunk where reverse (Chunk n t) = Chunk n (T.reverse t) -instance R.Sized Text where size (Text t) = R.size t - instance Show Text where show t = show (toText t) diff --git a/parser-typechecker/src/Unison/Util/Text/Pattern.hs b/parser-typechecker/src/Unison/Util/Text/Pattern.hs index 3ae41def21..d38ef5d165 100644 --- a/parser-typechecker/src/Unison/Util/Text/Pattern.hs +++ b/parser-typechecker/src/Unison/Util/Text/Pattern.hs @@ -195,11 +195,9 @@ compile (Replicate m n p) !err !success = case p of | (i, rest) <- Text.dropWhileMax ok n t, i >= m = success acc rest | otherwise = err acc t -charInPred, charNotInPred :: [Char] -> Char -> Bool +charInPred :: [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) charPatternPred :: CharPattern -> Char -> Bool charPatternPred Any = const True diff --git a/parser-typechecker/src/Unison/Util/TransitiveClosure.hs b/parser-typechecker/src/Unison/Util/TransitiveClosure.hs index b20eb23976..067f85f9c0 100644 --- a/parser-typechecker/src/Unison/Util/TransitiveClosure.hs +++ b/parser-typechecker/src/Unison/Util/TransitiveClosure.hs @@ -19,17 +19,3 @@ transitiveClosure getDependencies open = deps <- getDependencies h go (Set.insert h closed) (toList deps ++ t) in go Set.empty (toList open) - -transitiveClosure' :: (Ord a) => (a -> Set a) -> Set a -> Set a -transitiveClosure' f as = runIdentity $ transitiveClosure (pure . f) as - -transitiveClosure1 :: - forall m a. - (Monad m, Ord a) => - (a -> m (Set a)) -> - a -> - m (Set a) -transitiveClosure1 f a = transitiveClosure f (Set.singleton a) - -transitiveClosure1' :: (Ord a) => (a -> Set a) -> a -> Set a -transitiveClosure1' f a = runIdentity $ transitiveClosure1 (pure . f) a diff --git a/parser-typechecker/tests/Unison/Core/Test/Name.hs b/parser-typechecker/tests/Unison/Core/Test/Name.hs index 61293d3240..dd3ea0b189 100644 --- a/parser-typechecker/tests/Unison/Core/Test/Name.hs +++ b/parser-typechecker/tests/Unison/Core/Test/Name.hs @@ -15,7 +15,6 @@ test = tests [ scope "compareSuffix" (tests testCompareSuffix), scope "endsWithReverseSegments" (tests testEndsWithReverseSegments), - scope "endsWithSegments" (tests testEndsWithSegments), scope "segments" (tests testSegments), scope "splitName" (tests testSplitName), scope "suffixSearch" (tests testSuffixSearch), @@ -43,17 +42,6 @@ testEndsWithReverseSegments = (expectEqual False (endsWithReverseSegments (Name.unsafeParseText "a.b.c") [NameSegment "d"])) ] -testEndsWithSegments :: [Test ()] -testEndsWithSegments = - [ scope "a.b.c ends with []" (expectEqual True (endsWithSegments (Name.unsafeParseText "a.b.c") [])), - scope - "a.b.c ends with [b, c]" - (expectEqual True (endsWithSegments (Name.unsafeParseText "a.b.c") [NameSegment "b", NameSegment "c"])), - scope - "a.b.c doesn't end with [d]" - (expectEqual False (endsWithSegments (Name.unsafeParseText "a.b.c") [NameSegment "d"])) - ] - testSegments :: [Test ()] testSegments = [ do diff --git a/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs b/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs index c6147308dc..9c97b7e478 100644 --- a/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs +++ b/parser-typechecker/tests/Unison/Test/Codebase/Causal.hs @@ -42,42 +42,9 @@ test = \$ testCommonAncestor -- $ prop_mergeCommonAncestor --} scope "lca.hasLca" lcaPairTest, - scope "lca.noLca" noLcaPairTest, - scope "beforeHash" $ beforeHashTests + scope "lca.noLca" noLcaPairTest ] -beforeHashTests :: Test () -beforeHashTests = do - -- c1 and c2 have unrelated histories - c1 <- pure $ Causal.one (0 :: Int64) - c2 <- pure $ Causal.one (1 :: Int64) - -- c1' and c2' are extension of c1 and c2, respectively - c1' <- pure $ Causal.cons 2 c1 - c2' <- pure $ Causal.cons 3 c2 - c12 <- Causal.threeWayMerge sillyMerge c1' c2' - - -- verifying basic properties of `before` for these examples - expect' =<< before c1 c1 - expect' =<< before c1 c12 - expect' =<< before c2 c2 - expect' =<< before c2 c12 - expect' =<< before c2 c2' - expect' =<< before c1 c1' - expect' . not =<< before c1 c2 - expect' . not =<< before c2 c1 - - -- make sure the search cutoff works - - -- even though both start with `Causal.one 0`, that's - -- more than 10 steps back from `longCausal 1000`, so we - -- want this to be false - expect' . not =<< before c1 (longCausal (1000 :: Int64)) - ok - where - before h c = Causal.beforeHash 10 (Causal.currentHash h) c - sillyMerge _lca l _r = pure l - longCausal 0 = Causal.one 0 - longCausal n = Causal.cons n (longCausal (n - 1)) - int64 :: Test Int64 int64 = random @@ -181,7 +148,7 @@ threeWayMerge' :: Causal Identity (Set Int64) -> Causal Identity (Set Int64) -> Identity (Causal Identity (Set Int64)) -threeWayMerge' = Causal.threeWayMerge (easyCombine setCombine setDiff setPatch) +threeWayMerge' = Causal.threeWayMerge' Causal.lca (easyCombine setCombine setDiff setPatch) -- merge x mempty == x, merge mempty x == x testIdentity :: Causal Identity (Set Int64) -> Causal Identity (Set Int64) -> Bool diff --git a/parser-typechecker/tests/Unison/Test/CodebaseInit.hs b/parser-typechecker/tests/Unison/Test/CodebaseInit.hs index 1397bc8599..070c5c33b1 100644 --- a/parser-typechecker/tests/Unison/Test/CodebaseInit.hs +++ b/parser-typechecker/tests/Unison/Test/CodebaseInit.hs @@ -14,12 +14,6 @@ import Unison.Codebase.Init import Unison.Codebase.Init qualified as CI import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..)) --- keep it off for CI, since the random temp dirs it generates show up in the --- output, which causes the test output to change, and the "no change" check --- to fail -writeTranscriptOutput :: Bool -writeTranscriptOutput = False - test :: Test () test = scope "Codebase.Init" $ diff --git a/parser-typechecker/tests/Unison/Test/Common.hs b/parser-typechecker/tests/Unison/Test/Common.hs index e1d880002c..e89bd86c67 100644 --- a/parser-typechecker/tests/Unison/Test/Common.hs +++ b/parser-typechecker/tests/Unison/Test/Common.hs @@ -2,6 +2,8 @@ module Unison.Test.Common ( hqLength, t, tm, + unsafeGetRightFrom, + renderParseErrorAsANSI, parseAndSynthesizeAsFile, parsingEnv, ) @@ -62,6 +64,12 @@ showParseError :: String showParseError s = Pr.toANSI 60 . prettyParseError s +unsafeGetRightFrom :: (Var v, Show v) => String -> Either (Parser.Err v) a -> a +unsafeGetRightFrom src = either (error . showParseError src) id + +renderParseErrorAsANSI :: (Var v) => Pr.Width -> String -> Parser.Err v -> String +renderParseErrorAsANSI w src = Pr.toANSI w . prettyParseError src + parseAndSynthesizeAsFile :: [Type Symbol] -> FilePath -> diff --git a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs index 425d9bd267..f393a6d1a2 100644 --- a/parser-typechecker/tests/Unison/Test/DataDeclaration.hs +++ b/parser-typechecker/tests/Unison/Test/DataDeclaration.hs @@ -12,7 +12,7 @@ import Unison.DataDeclaration qualified as DD import Unison.Hash qualified as Hash import Unison.Hashing.V2.Convert qualified as Hashing import Unison.Parser.Ann (Ann) -import Unison.Parsers (unsafeParseFile) +import Unison.Parsers (parseFile) import Unison.Prelude import Unison.Reference qualified as R import Unison.Symbol (Symbol) @@ -40,9 +40,10 @@ test = ] file :: UnisonFile Symbol Ann -file = - runIdentity . flip unsafeParseFile Common.parsingEnv $ - [r| +file = Common.unsafeGetRightFrom contents . runIdentity $ parseFile "" contents Common.parsingEnv + where + contents = + [r| structural type Bool = True | False structural type Bool' = False | True @@ -63,22 +64,6 @@ structural type Long' a = Long' (Ling' a) | Lnong structural type Ling' a = Ling' a (Long' a) |] --- faketest = scope "termparser" . tests . map parses $ --- ["x" --- , "match x with\n" ++ --- " {Pair x y} -> 1\n" ++ --- " {State.set 42 -> k} -> k 42\n" --- ] --- --- builtins = Map.fromList --- [("Pair", (R.Builtin "Pair", 0)), --- ("State.set", (R.Builtin "State", 0))] --- --- parses s = scope s $ do --- let p = unsafeParseTerm s builtins :: Term Symbol --- noteScoped $ "parsing: " ++ s ++ "\n " ++ show p --- ok - unhashComponentTest :: Test () unhashComponentTest = tests diff --git a/parser-typechecker/tests/Unison/Test/Referent.hs b/parser-typechecker/tests/Unison/Test/Referent.hs index 0eeb807bf9..2a9e4bd69a 100644 --- a/parser-typechecker/tests/Unison/Test/Referent.hs +++ b/parser-typechecker/tests/Unison/Test/Referent.hs @@ -2,7 +2,6 @@ module Unison.Test.Referent where -import Data.Text (Text) import Data.Text qualified as Text import EasyTest import Unison.Reference qualified as Rf @@ -60,21 +59,21 @@ test = ] where h = "#1tdqrgl90qnmqvrff0j76kg2rnajq7n8j54e9cbk4p8pdi41q343bnh8h2rv6nadhlin8teg8371d445pvo0as7j2sav8k401d2s3no" - suffix1 = Rf.showSuffix 0 - suffix2 = Rf.showSuffix 3 - ref txt = scope (Text.unpack txt) $ case Rf.fromText txt of + suffix1 = show (0 :: Rf.Pos) + suffix2 = show (3 :: Rf.Pos) + ref txt = scope txt case Rf.fromText $ Text.pack txt of Left e -> fail e Right r1 -> case Rf.fromText (Rf.toText r1) of Left e -> fail e Right r2 -> expect (r1 == r2) - r :: Text -> Test () - r txt = scope (Text.unpack txt) $ case R.fromText txt of + r :: String -> Test () + r txt = scope txt case R.fromText $ Text.pack txt of Nothing -> fail "oh noes" Just referent -> case R.fromText (R.toText referent) of Nothing -> fail "oh noes" Just referent2 -> expect (referent == referent2) - sh :: Text -> Test () - sh txt = scope (Text.unpack txt) $ case SH.fromText txt of + sh :: String -> Test () + sh txt = scope txt case SH.fromText $ Text.pack txt of Nothing -> fail "oh noes" Just shorthash -> case SH.fromText (SH.toText shorthash) of Nothing -> fail "oh noes" diff --git a/parser-typechecker/tests/Unison/Test/Syntax/FileParser.hs b/parser-typechecker/tests/Unison/Test/Syntax/FileParser.hs index 7896d75fd9..c52798ab72 100644 --- a/parser-typechecker/tests/Unison/Test/Syntax/FileParser.hs +++ b/parser-typechecker/tests/Unison/Test/Syntax/FileParser.hs @@ -6,8 +6,6 @@ import Data.Set (elems) import EasyTest import Text.Megaparsec.Error qualified as MPE import Unison.Parser.Ann qualified as P -import Unison.Parsers (unsafeGetRightFrom, unsafeParseFileBuiltinsOnly) -import Unison.PrintError (renderParseErrorAsANSI) import Unison.Symbol (Symbol) import Unison.Syntax.FileParser (file) import Unison.Syntax.Parser qualified as P @@ -48,11 +46,6 @@ test1 = ] ] -test2 :: Test () -test2 = - scope "test2" $ - (io $ unsafeParseFileBuiltinsOnly "unison-src/test1.u") *> ok - test :: Test () test = scope "fileparser" . tests $ @@ -73,7 +66,8 @@ expectFileParseFailure s expectation = scope s $ do Just (MPE.ErrorCustom e) -> expectation e Just _ -> crash "Error encountered was not custom" Nothing -> crash "No error found" - Left e -> crash ("Parser failed with an error which was a trivial parser error: " ++ renderParseErrorAsANSI 80 s e) + Left e -> + crash $ "Parser failed with an error which was a trivial parser error: " ++ Common.renderParseErrorAsANSI 80 s e emptyWatchTest :: Test () emptyWatchTest = @@ -119,6 +113,6 @@ parses :: String -> Test () parses s = scope s $ do let p :: UnisonFile Symbol P.Ann !p = - unsafeGetRightFrom s . runIdentity $ + Common.unsafeGetRightFrom s . runIdentity $ P.run (P.rootFile file) s Common.parsingEnv pure p >> ok diff --git a/parser-typechecker/tests/Unison/Test/Syntax/TermParser.hs b/parser-typechecker/tests/Unison/Test/Syntax/TermParser.hs index f93b69ba86..7fa2829553 100644 --- a/parser-typechecker/tests/Unison/Test/Syntax/TermParser.hs +++ b/parser-typechecker/tests/Unison/Test/Syntax/TermParser.hs @@ -6,11 +6,9 @@ module Unison.Test.Syntax.TermParser where import Control.Applicative import Control.Monad (join) import Data.Functor.Identity (Identity (..)) -import EasyTest +import EasyTest hiding (run) import Text.Megaparsec qualified as P import Text.RawString.QQ -import Unison.Parsers qualified as Ps -import Unison.PrintError (renderParseErrorAsANSI) import Unison.Symbol (Symbol) import Unison.Syntax.Parser import Unison.Syntax.TermParser qualified as TP @@ -216,8 +214,8 @@ parses = parseWith TP.term parseWith :: P Symbol Identity a -> String -> Test () parseWith p s = scope (join . take 1 $ lines s) $ - case runIdentity (Ps.parse @_ @Symbol p s Common.parsingEnv) of + case runIdentity (run (root p) s Common.parsingEnv) of Left e -> do - note $ renderParseErrorAsANSI 60 s e - crash $ renderParseErrorAsANSI 60 s e + note $ Common.renderParseErrorAsANSI 60 s e + crash $ Common.renderParseErrorAsANSI 60 s e Right _ -> ok diff --git a/parser-typechecker/tests/Unison/Test/Syntax/TypePrinter.hs b/parser-typechecker/tests/Unison/Test/Syntax/TypePrinter.hs index 69a09a6874..1326acfcb5 100644 --- a/parser-typechecker/tests/Unison/Test/Syntax/TypePrinter.hs +++ b/parser-typechecker/tests/Unison/Test/Syntax/TypePrinter.hs @@ -59,10 +59,6 @@ tc_diff s expected = tc_diff_rtt True s expected 0 tc :: String -> Test () tc s = tc_diff s s --- Use renderBroken to render the output to some maximum width. -tc_breaks :: String -> PP.Width -> String -> Test () -tc_breaks s width expected = tc_diff_rtt True s expected width - test :: Test () test = scope "typeprinter" . tests $ diff --git a/parser-typechecker/tests/Unison/Test/Typechecker/Components.hs b/parser-typechecker/tests/Unison/Test/Typechecker/Components.hs deleted file mode 100644 index 99325ab8f3..0000000000 --- a/parser-typechecker/tests/Unison/Test/Typechecker/Components.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Unison.Test.Typechecker.Components where - --- import Control.Monad -import EasyTest - --- import Unison.Parsers (unsafeParseTerm) --- import qualified Unison.Note as Note --- import qualified Unison.Test.Common as Common --- import qualified Unison.Typechecker.Components as Components - -test :: Test () -test = scope "Typechecker.Components" $ ok - --- [ --- -- simple case, no minimization done --- t "{ id x = x; g = id 42; y = id id g; y }" --- "{ id x = x; g = id 42; y = id id g; y }" --- -- check that we get let generalization --- , t "{ id x = x; g = id 42; y = id id g; y }" --- "{ id x = x; g = id 42; y = id id g; y }" --- -- check that we preserve order of components as much as possible --- , t "{ id2 x = x; id1 x = x; id3 x = x; id3 }" --- "{ id2 x = x; id1 x = x; id3 x = x; id3 }" --- -- check that we reorder according to dependencies --- , t "{ g = id 42; y = id id g; id x = x; y }" --- "{ id x = x; g = id 42; y = id id g; y }" --- -- insane example, checks for: generalization, reordering, --- -- preservation of order when possible --- , t "{ g = id 42; y = id id g; ping x = pong x; pong x = id (ping x); id x = x; y }" --- "{ id x = x; g = id 42; y = id id g ; ({ ping x = pong x; pong x = id (ping x) ; y })}" --- ] --- where --- t before after = scope (before ++ " ⟹ " ++ after) $ do --- let term = unsafeParseTerm before --- let after' = Components.minimize' term --- guard $ Common.typechecks' after' --- expect (unsafeParseTerm after == after') diff --git a/parser-typechecker/tests/Unison/Test/Var.hs b/parser-typechecker/tests/Unison/Test/Var.hs index a28afff085..f0b12ec601 100644 --- a/parser-typechecker/tests/Unison/Test/Var.hs +++ b/parser-typechecker/tests/Unison/Test/Var.hs @@ -19,8 +19,6 @@ test = Var.inferOutput, Var.inferPatternPureE, Var.inferPatternPureV, - Var.inferPatternBindE, - Var.inferPatternBindV, Var.inferTypeConstructor, Var.inferTypeConstructorArg ] diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index f08a2f969e..b8ef4b15d7 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -24,7 +24,6 @@ flag optimized library exposed-modules: U.Codebase.Branch.Diff - U.Codebase.Projects Unison.Builtin Unison.Builtin.Decls Unison.Builtin.Terms @@ -33,7 +32,6 @@ library Unison.Codebase.Branch.BranchDiff Unison.Codebase.Branch.Merge Unison.Codebase.Branch.Names - Unison.Codebase.Branch.Raw Unison.Codebase.Branch.Type Unison.Codebase.BranchDiff Unison.Codebase.BranchUtil @@ -48,7 +46,6 @@ library Unison.Codebase.Init Unison.Codebase.Init.CreateCodebaseError Unison.Codebase.Init.OpenCodebaseError - Unison.Codebase.Init.Type Unison.Codebase.IntegrityCheck Unison.Codebase.MainTerm Unison.Codebase.Metadata @@ -58,11 +55,9 @@ library Unison.Codebase.ProjectPath Unison.Codebase.PushBehavior Unison.Codebase.Runtime - Unison.Codebase.Serialization Unison.Codebase.ShortCausalHash Unison.Codebase.SqliteCodebase Unison.Codebase.SqliteCodebase.Branch.Cache - Unison.Codebase.SqliteCodebase.Branch.Dependencies Unison.Codebase.SqliteCodebase.Conversions Unison.Codebase.SqliteCodebase.Migrations Unison.Codebase.SqliteCodebase.Migrations.Helpers @@ -76,7 +71,6 @@ library Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema7To8 Unison.Codebase.SqliteCodebase.Operations Unison.Codebase.SqliteCodebase.Paths - Unison.Codebase.SqliteCodebase.SyncEphemeral Unison.Codebase.TermEdit Unison.Codebase.TermEdit.Typing Unison.Codebase.Type @@ -150,11 +144,6 @@ library Unison.UnisonFile.Names Unison.UnisonFile.Summary Unison.UnisonFile.Type - Unison.Util.CycleTable - Unison.Util.CyclicEq - Unison.Util.CyclicOrd - Unison.Util.EnumContainers - Unison.Util.Exception Unison.Util.Logger Unison.Util.Pretty.MegaParsec Unison.Util.RefPromise @@ -199,32 +188,24 @@ library build-depends: ListLike , aeson - , async , atomic-primops , base - , bytes - , bytestring , concurrent-output , containers >=0.6.3 - , errors , extra , filelock , filepath , free , generic-lens - , hashable - , hashtables , lens , megaparsec , mmorph , mtl - , mutable-containers , network-uri , nonempty-containers , pretty-simple , regex-tdfa , semialign - , semigroups , servant-client , stm , text @@ -278,7 +259,6 @@ test-suite parser-typechecker-tests Unison.Test.Term Unison.Test.Type Unison.Test.Typechecker - Unison.Test.Typechecker.Components Unison.Test.Typechecker.Context Unison.Test.Typechecker.TypeError Unison.Test.Util.Pretty diff --git a/stack.yaml b/stack.yaml index e4e4470f68..ff2a28229a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -10,6 +10,10 @@ flags: allow-different-user: true build: + haddock-arguments: + haddock-args: + - --optghc=-Wno-missing-pattern-synonym-signatures + - --optghc=-Wno-name-shadowing interleaved-output: false packages: diff --git a/unison-cli-integration/integration-tests/IntegrationTests/ArgumentParsing.hs b/unison-cli-integration/integration-tests/IntegrationTests/ArgumentParsing.hs index 02ef8fce9e..0f3528e35e 100644 --- a/unison-cli-integration/integration-tests/IntegrationTests/ArgumentParsing.hs +++ b/unison-cli-integration/integration-tests/IntegrationTests/ArgumentParsing.hs @@ -77,9 +77,6 @@ expectExitCode expected cmd args stdin = scope (intercalate " " (cmd : args)) do note $ printf "\n[Time: %s sec]" $ show diff expectEqual code expected -defaultArgs :: [String] -defaultArgs = ["--codebase-create", tempCodebase] - clearTempCodebase :: () -> IO () clearTempCodebase _ = System.Directory.removePathForcibly tempCodebase diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 68ecf3431a..ab7e9ec1e1 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -15,7 +15,6 @@ dependencies: - unison-parser-typechecker - unison-prelude - megaparsec - - directory library: source-dirs: src @@ -41,6 +40,7 @@ library: - concurrent-output - containers >= 0.6.3 - cryptonite + - directory - either - errors - extra @@ -120,6 +120,7 @@ tests: - here - lens - lsp-types + - safe - temporary - these - unison-cli @@ -142,6 +143,7 @@ executables: ghc-options: -threaded -rtsopts "-with-rtsopts=-I0 -N -qn4 -qg1" -v0 dependencies: - code-page + - directory - easytest - filepath - silently diff --git a/unison-cli/src/ArgParse.hs b/unison-cli/src/ArgParse.hs index 90ec1f9ee7..17c0623e30 100644 --- a/unison-cli/src/ArgParse.hs +++ b/unison-cli/src/ArgParse.hs @@ -53,8 +53,6 @@ import Options.Applicative.Help.Pretty qualified as P import Stats import System.Environment (lookupEnv) import Text.Megaparsec qualified as Megaparsec -import Unison.Codebase.Path qualified as Path -import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.ProjectPath (ProjectPathNames) import Unison.Codebase.ProjectPath qualified as PP import Unison.CommandLine.Types (ShouldWatchFiles (..)) @@ -177,15 +175,6 @@ initCommand = command "init" (info initParser (progDesc initHelp)) initHelp = "This command is has been removed. Use --codebase-create instead to create a codebase in the specified directory when starting the UCM." -runDesc :: String -> String -> String -runDesc cmd location = - "Execute a definition from " - <> location - <> ", passing on the provided arguments. " - <> " To pass flags to your program, use `" - <> cmd - <> " -- --my-flag`" - runSymbolCommand :: Mod CommandFields Command runSymbolCommand = command "run" (info runSymbolParser (fullDesc <> progDesc help)) @@ -453,16 +442,6 @@ noFileWatchFlag = where noFileWatchHelp = "If set, ucm will not respond to changes in unison files. Instead, you can use the 'load' command." -readAbsolutePath :: ReadM Path.Absolute -readAbsolutePath = do - readPath' >>= \case - Path.AbsolutePath' abs -> pure abs - Path.RelativePath' rel -> - OptParse.readerError $ - "Expected an absolute path, but the path " - <> show rel - <> " was relative. Try adding a `.` prefix, e.g. `.path.to.project`" - nativeRuntimePathFlag :: Parser (Maybe FilePath) nativeRuntimePathFlag = optional . strOption $ @@ -471,13 +450,6 @@ nativeRuntimePathFlag = <> help "Path to native runtime files" <> noGlobal -readPath' :: ReadM Path.Path' -readPath' = do - strPath <- OptParse.str - case Path.parsePath' strPath of - Left err -> OptParse.readerError (Text.unpack err) - Right path' -> pure path' - readProjectAndBranchNames :: ReadM (ProjectAndBranch ProjectName ProjectBranchName) readProjectAndBranchNames = do str <- OptParse.str diff --git a/unison-cli/src/Unison/Cli/Monad.hs b/unison-cli/src/Unison/Cli/Monad.hs index 500a015a9a..d36f9a65cf 100644 --- a/unison-cli/src/Unison/Cli/Monad.hs +++ b/unison-cli/src/Unison/Cli/Monad.hs @@ -22,7 +22,6 @@ module Unison.Cli.Monad -- * Acquiring resources with, with_, - withE, -- * Short-circuiting label, @@ -284,15 +283,6 @@ with_ resourceK action = Cli \env k s -> resourceK (runCli env s action) >>= feed k --- | A variant of 'with' for the variant of bracketing function that may return a Left rather than call the provided --- continuation. -withE :: (forall x. (a -> IO x) -> IO (Either e x)) -> (Either e a -> Cli b) -> Cli b -withE resourceK action = - Cli \env k s -> - resourceK (\a -> runCli env s (action (Right a))) >>= \case - Left err -> runCli env s (action (Left err)) >>= feed k - Right result -> feed k result - data X = forall a. X !Unique !LoopState a deriving anyclass (Exception) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 242ee77635..a2c2c6c877 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -3,12 +3,9 @@ module Unison.Cli.MonadUtils ( -- * Paths getCurrentPath, - getCurrentProjectName, - getCurrentProjectBranchName, getCurrentProjectPath, resolvePath, resolvePath', - resolvePath'ToAbsolute, resolveSplit', -- * Project and branch resolution @@ -18,10 +15,6 @@ module Unison.Cli.MonadUtils -- * Branches -- ** Resolving branch identifiers - resolveAbsBranchId, - resolveAbsBranchIdV2, - resolveBranchId, - resolveBranchIdToAbsBranchId, resolveShortCausalHash, -- ** Getting/setting branches @@ -38,15 +31,12 @@ module Unison.Cli.MonadUtils expectBranchAtPath', expectBranch0AtPath, expectBranch0AtPath', - assertNoBranchAtPath', branchExistsAtPath', -- ** Updating branches stepAt', stepAt, - stepAtM, stepManyAt, - stepManyAtM, updateProjectBranchRoot, updateProjectBranchRoot_, updateAtM, @@ -87,9 +77,7 @@ import Control.Monad.Reader (ask) import Control.Monad.State import Data.Foldable import Data.Set qualified as Set -import U.Codebase.Branch qualified as V2 (Branch) import U.Codebase.Branch qualified as V2Branch -import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Sqlite.Project (Project) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) @@ -101,7 +89,6 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch (..), Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.BranchUtil qualified as BranchUtil -import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch @@ -118,7 +105,7 @@ import Unison.NameSegment qualified as NameSegment import Unison.Names (Names) import Unison.Parser.Ann (Ann (..)) import Unison.Prelude -import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) +import Unison.Project (ProjectAndBranch (..)) import Unison.Reference (TypeReference) import Unison.Referent (Referent) import Unison.Sqlite (Transaction) @@ -154,14 +141,6 @@ getCurrentPath :: Cli Path.Absolute getCurrentPath = do view PP.absPath_ <$> getCurrentProjectPath -getCurrentProjectName :: Cli ProjectName -getCurrentProjectName = do - view (#project . #name) <$> getCurrentProjectPath - -getCurrentProjectBranchName :: Cli ProjectBranchName -getCurrentProjectBranchName = do - view (#branch . #name) <$> getCurrentProjectPath - -- | Resolve a @Path@ (interpreted as relative) to a @Path.Absolute@, per the current path. resolvePath :: Path -> Cli PP.ProjectPath resolvePath path = do @@ -174,10 +153,6 @@ resolvePath' path' = do pp <- getCurrentProjectPath pure $ pp & PP.absPath_ %~ \p -> Path.resolve p path' -resolvePath'ToAbsolute :: Path' -> Cli Path.Absolute -resolvePath'ToAbsolute path' = do - view PP.absPath_ <$> resolvePath' path' - -- | Resolve a path split, per the current path. resolveSplit' :: (Path', a) -> Cli (PP.ProjectPath, a) resolveSplit' = @@ -186,44 +161,6 @@ resolveSplit' = ------------------------------------------------------------------------------------------------------------------------ -- Branch resolution --- | Resolve an @AbsBranchId@ to the corresponding @Branch IO@, or fail if no such branch hash is found. (Non-existent --- branches by path are OK - the empty branch will be returned). -resolveAbsBranchId :: Input.AbsBranchId -> Cli (Branch IO) -resolveAbsBranchId = \case - Input.BranchAtSCH hash -> resolveShortCausalHash hash - Input.BranchAtPath absPath -> do - pp <- resolvePath' (Path' (Left absPath)) - getBranchFromProjectPath pp - Input.BranchAtProjectPath pp -> getBranchFromProjectPath pp - --- | V2 version of 'resolveAbsBranchId2'. -resolveAbsBranchIdV2 :: - (forall void. Output.Output -> Sqlite.Transaction void) -> - ProjectAndBranch Project ProjectBranch -> - Input.AbsBranchId -> - Sqlite.Transaction (V2.Branch Sqlite.Transaction) -resolveAbsBranchIdV2 rollback (ProjectAndBranch proj branch) = \case - Input.BranchAtSCH shortHash -> do - hash <- resolveShortCausalHashToCausalHash rollback shortHash - causal <- (Codebase.expectCausalBranchByCausalHash hash) - V2Causal.value causal - Input.BranchAtPath absPath -> do - let pp = PP.ProjectPath proj branch absPath - Codebase.getShallowBranchAtProjectPath pp - Input.BranchAtProjectPath pp -> Codebase.getShallowBranchAtProjectPath pp - --- | Resolve a @BranchId@ to the corresponding @Branch IO@, or fail if no such branch hash is found. (Non-existent --- branches by path are OK - the empty branch will be returned). -resolveBranchId :: Input.BranchId -> Cli (Branch IO) -resolveBranchId branchId = do - absBranchId <- resolveBranchIdToAbsBranchId branchId - resolveAbsBranchId absBranchId - --- | Resolve a @BranchId@ to an @AbsBranchId@. -resolveBranchIdToAbsBranchId :: Input.BranchId -> Cli Input.AbsBranchId -resolveBranchIdToAbsBranchId = - traverse (fmap (view PP.absPath_) . resolvePath') - -- | Resolve a @ShortCausalHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found. resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO) resolveShortCausalHash shortHash = do @@ -320,14 +257,6 @@ expectBranch0AtPath :: Path -> Cli (Branch0 IO) expectBranch0AtPath = expectBranch0AtPath' . Path' . Right . Path.Relative --- | Assert that there's "no branch" at an absolute or relative path, or return early if there is one, where "no branch" --- means either there's actually no branch, or there is a branch whose head is empty (i.e. it may have a history, but no --- current terms/types etc). -assertNoBranchAtPath' :: Path' -> Cli () -assertNoBranchAtPath' path' = do - whenM (branchExistsAtPath' path') do - Cli.returnEarly (Output.BranchAlreadyExists path') - -- | Check if there's a branch at an absolute or relative path -- -- "no branch" means either there's actually no branch, or there is a branch whose head is empty (i.e. it may have a history, but no @@ -358,12 +287,6 @@ stepAt' :: Cli Bool stepAt' cause (pp, action) = stepManyAt' pp.branch cause [(pp.absPath, action)] -stepAtM :: - Text -> - (ProjectPath, Branch0 IO -> IO (Branch0 IO)) -> - Cli () -stepAtM cause (pp, action) = stepManyAtM pp.branch cause [(pp.absPath, action)] - stepManyAt :: ProjectBranch -> Text -> @@ -383,17 +306,6 @@ stepManyAt' pb reason actions = do didChange <- updateProjectBranchRoot pb reason (\oldRoot -> pure (newRoot, oldRoot /= newRoot)) pure didChange --- Like stepManyAt, but doesn't update the last saved root -stepManyAtM :: - ProjectBranch -> - Text -> - [(Path.Absolute, Branch0 IO -> IO (Branch0 IO))] -> - Cli () -stepManyAtM pb reason actions = do - updateProjectBranchRoot pb reason \oldRoot -> do - newRoot <- liftIO (Branch.stepManyAtM (makeActionsUnabsolute actions) oldRoot) - pure (newRoot, ()) - -- | Update a branch at the given path, returning `True` if -- an update occurred and false otherwise updateAtM :: diff --git a/unison-cli/src/Unison/Cli/NamesUtils.hs b/unison-cli/src/Unison/Cli/NamesUtils.hs index 889e055bdf..5da476276f 100644 --- a/unison-cli/src/Unison/Cli/NamesUtils.hs +++ b/unison-cli/src/Unison/Cli/NamesUtils.hs @@ -1,7 +1,6 @@ -- | Utilities that have to do with constructing names objects. module Unison.Cli.NamesUtils ( currentNames, - currentProjectRootNames, projectBranchNames, ) where @@ -18,10 +17,6 @@ currentNames :: Cli Names currentNames = do Branch.toNames <$> Cli.getCurrentBranch0 -currentProjectRootNames :: Cli Names -currentProjectRootNames = do - Branch.toNames <$> Cli.getCurrentProjectRoot0 - projectBranchNames :: ProjectBranch -> Cli Names projectBranchNames pb = do Branch.toNames . Branch.head <$> Cli.getProjectBranchRoot pb diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index 07a67d1c63..730852c3a5 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -3,15 +3,11 @@ -- | Small combinators that pretty-print small types in a canonical way for human consumption, such as hashes, file -- paths, and project names. module Unison.Cli.Pretty - ( displayBranchHash, - prettyAbsolute, + ( prettyAbsolute, prettyProjectPath, prettyBranchRelativePath, prettyBase32Hex#, prettyBase32Hex, - prettyBranchId, - prettyCausalHash, - prettyDeclPair, prettyDeclTriple, prettyFilePath, prettyHash, @@ -44,8 +40,6 @@ module Unison.Cli.Pretty prettyURI, prettyUnisonFile, prettyWhichBranchEmpty, - prettyWriteRemoteNamespace, - shareOrigin, unsafePrettyTermResultSigFull', prettyTermDisplayObjects, prettyTypeDisplayObjects, @@ -61,7 +55,6 @@ import Data.Time (UTCTime) import Data.Time.Format.Human (HumanTimeLocale (..), defaultHumanTimeLocale, humanReadableTimeI18N') import Network.URI (URI) import Network.URI qualified as URI -import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Reference qualified as Reference import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite @@ -70,7 +63,6 @@ import U.Util.Base32Hex qualified as Base32Hex import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..)) import Unison.Cli.Share.Projects.Types qualified as Share import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject)) -import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.RemoteRepo ( ReadRemoteNamespace (..), @@ -146,13 +138,6 @@ prettyReadRemoteNamespaceWith :: (a -> Text) -> ReadRemoteNamespace a -> Pretty prettyReadRemoteNamespaceWith printProject = P.group . P.blue . P.text . RemoteRepo.printReadRemoteNamespace printProject -prettyWriteRemoteNamespace :: (ProjectAndBranch ProjectName ProjectBranchName) -> Pretty -prettyWriteRemoteNamespace = - P.group . P.blue . P.text . RemoteRepo.printWriteRemoteNamespace - -shareOrigin :: Text -shareOrigin = "https://share.unison-lang.org" - prettyRepoInfo :: Share.RepoInfo -> Pretty prettyRepoInfo (Share.RepoInfo repoInfo) = P.blue (P.text repoInfo) @@ -188,12 +173,6 @@ prettyNamespaceKey = \case Right (ProjectAndBranch project branch) -> prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name)) -prettyBranchId :: Input.AbsBranchId -> Pretty -prettyBranchId = \case - Input.BranchAtSCH sch -> prettySCH sch - Input.BranchAtPath absPath -> prettyAbsolute $ absPath - Input.BranchAtProjectPath pp -> prettyProjectPath pp - prettyRelative :: Path.Relative -> Pretty prettyRelative = P.blue . P.shown @@ -210,9 +189,6 @@ prettyProjectPath (PP.ProjectPath project branch path) = prettySCH :: (IsString s) => ShortCausalHash -> P.Pretty s prettySCH hash = P.group $ "#" <> P.text (SCH.toText hash) -prettyCausalHash :: (IsString s) => CausalHash -> P.Pretty s -prettyCausalHash hash = P.group $ "#" <> P.text (Hash.toBase32HexText . unCausalHash $ hash) - prettyBase32Hex :: (IsString s) => Base32Hex -> P.Pretty s prettyBase32Hex = P.text . Base32Hex.toText @@ -321,13 +297,6 @@ prettyDeclTriple (name, _, displayDecl) = case displayDecl of MissingObject _ -> mempty -- these need to be handled elsewhere UserObject decl -> P.syntaxToColor $ DeclPrinter.prettyDeclHeader name decl -prettyDeclPair :: - (Var v) => - PPE.PrettyPrintEnv -> - (Reference, DisplayObject () (DD.Decl v a)) -> - Pretty -prettyDeclPair ppe (r, dt) = prettyDeclTriple (PPE.typeName ppe r, r, dt) - prettyTermName :: PPE.PrettyPrintEnv -> Referent -> Pretty prettyTermName ppe r = P.syntaxToColor $ @@ -344,10 +313,6 @@ prettyWhichBranchEmpty = \case WhichBranchEmptyHash hash -> P.shown hash WhichBranchEmptyPath pp -> prettyProjectPath pp --- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef -displayBranchHash :: CausalHash -> Text -displayBranchHash = ("#" <>) . Hash.toBase32HexText . unCausalHash - prettyHumanReadableTime :: UTCTime -> UTCTime -> Pretty prettyHumanReadableTime now time = P.green . P.string $ humanReadableTimeI18N' terseTimeLocale now time diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index 4f196c1b61..b33ee3e139 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -20,15 +20,10 @@ module Unison.Cli.ProjectUtils expectRemoteProjectById, expectRemoteProjectByName, expectRemoteProjectBranchById, - loadRemoteProjectBranchByName, expectRemoteProjectBranchByName, - loadRemoteProjectBranchByNames, expectRemoteProjectBranchByNames, - expectRemoteProjectBranchByTheseNames, -- * Projecting out common things - justTheIds, - justTheIds', justTheNames, -- * Other helpers @@ -85,14 +80,6 @@ resolveBranchRelativePath brp = do pp <- Cli.getCurrentProjectPath pure $ pp & PP.absPath_ %~ \curPath -> Path.resolve curPath newPath' -justTheIds :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId -justTheIds x = - ProjectAndBranch x.project.projectId x.branch.branchId - -justTheIds' :: Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId -justTheIds' branch = - ProjectAndBranch branch.projectId branch.branchId - justTheNames :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectName ProjectBranchName justTheNames x = ProjectAndBranch x.project.name x.branch.name @@ -253,16 +240,6 @@ expectRemoteProjectBranchById includeSquashed projectAndBranch = do projectAndBranchIds = projectAndBranch & over #project fst & over #branch fst projectAndBranchNames = projectAndBranch & over #project snd & over #branch snd -loadRemoteProjectBranchByName :: - IncludeSquashedHead -> - ProjectAndBranch RemoteProjectId ProjectBranchName -> - Cli (Maybe Share.RemoteProjectBranch) -loadRemoteProjectBranchByName includeSquashed projectAndBranch = - Share.getProjectBranchByName includeSquashed projectAndBranch <&> \case - Share.GetProjectBranchResponseBranchNotFound -> Nothing - Share.GetProjectBranchResponseProjectNotFound -> Nothing - Share.GetProjectBranchResponseSuccess branch -> Just branch - expectRemoteProjectBranchByName :: IncludeSquashedHead -> ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName -> @@ -276,15 +253,6 @@ expectRemoteProjectBranchByName includeSquashed projectAndBranch = doesntExist = remoteProjectBranchDoesntExist (projectAndBranch & over #project snd) -loadRemoteProjectBranchByNames :: - IncludeSquashedHead -> - ProjectAndBranch ProjectName ProjectBranchName -> - Cli (Maybe Share.RemoteProjectBranch) -loadRemoteProjectBranchByNames includeSquashed (ProjectAndBranch projectName branchName) = - runMaybeT do - project <- MaybeT (Share.getProjectByName projectName) - MaybeT (loadRemoteProjectBranchByName includeSquashed (ProjectAndBranch (project ^. #projectId) branchName)) - expectRemoteProjectBranchByNames :: IncludeSquashedHead -> ProjectAndBranch ProjectName ProjectBranchName -> @@ -293,39 +261,6 @@ expectRemoteProjectBranchByNames includeSquashed (ProjectAndBranch projectName b project <- expectRemoteProjectByName projectName expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (project ^. #projectId, project ^. #projectName) branchName) --- Expect a remote project branch by a "these names". --- --- If both names are provided, use them. --- --- If only a project name is provided, use branch name "main". --- --- If only a branch name is provided, use the current branch's remote mapping (falling back to its parent, etc) to get --- the project. -expectRemoteProjectBranchByTheseNames :: IncludeSquashedHead -> These ProjectName ProjectBranchName -> Cli Share.RemoteProjectBranch -expectRemoteProjectBranchByTheseNames includeSquashed = \case - This remoteProjectName -> do - remoteProject <- expectRemoteProjectByName remoteProjectName - let remoteProjectId = remoteProject ^. #projectId - let remoteBranchName = unsafeFrom @Text "main" - expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) - That branchName -> do - PP.ProjectPath localProject localBranch _restPath <- Cli.getCurrentProjectPath - let localProjectId = localProject ^. #projectId - let localBranchId = localBranch ^. #branchId - Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case - Just (remoteProjectId, _maybeProjectBranchId) -> do - remoteProjectName <- Cli.runTransaction (Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri) - expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) branchName) - Nothing -> do - Cli.returnEarly $ - Output.NoAssociatedRemoteProject - Share.hardCodedUri - (ProjectAndBranch (localProject ^. #name) (localBranch ^. #name)) - These projectName branchName -> do - remoteProject <- expectRemoteProjectByName projectName - let remoteProjectId = remoteProject ^. #projectId - expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, projectName) branchName) - remoteProjectBranchDoesntExist :: ProjectAndBranch ProjectName ProjectBranchName -> Cli void remoteProjectBranchDoesntExist projectAndBranch = Cli.returnEarly (Output.RemoteProjectBranchDoesntExist Share.hardCodedUri projectAndBranch) diff --git a/unison-cli/src/Unison/Cli/TypeCheck.hs b/unison-cli/src/Unison/Cli/TypeCheck.hs index b7e74a231f..817e6d181a 100644 --- a/unison-cli/src/Unison/Cli/TypeCheck.hs +++ b/unison-cli/src/Unison/Cli/TypeCheck.hs @@ -1,24 +1,17 @@ module Unison.Cli.TypeCheck ( computeTypecheckingEnvironment, - typecheckTerm, ) where -import Data.Map.Strict qualified as Map import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.FileParsers qualified as FileParsers import Unison.Parser.Ann (Ann (..)) -import Unison.Prelude -import Unison.Result qualified as Result import Unison.Sqlite qualified as Sqlite -import Unison.Symbol (Symbol (Symbol)) -import Unison.Term (Term) +import Unison.Symbol (Symbol) import Unison.Type (Type) import Unison.Typechecker qualified as Typechecker import Unison.UnisonFile (UnisonFile) -import Unison.UnisonFile qualified as UF -import Unison.Var qualified as Var computeTypecheckingEnvironment :: FileParsers.ShouldUseTndr Sqlite.Transaction -> @@ -32,28 +25,3 @@ computeTypecheckingEnvironment shouldUseTndr codebase ambientAbilities unisonFil ambientAbilities (Codebase.typeLookupForDependencies codebase) unisonFile - -typecheckTerm :: - Codebase IO Symbol Ann -> - Term Symbol Ann -> - Sqlite.Transaction - ( Result.Result - (Seq (Result.Note Symbol Ann)) - (Type Symbol Ann) - ) -typecheckTerm codebase tm = do - let v = Symbol 0 (Var.Inference Var.Other) - let file = UF.UnisonFileId mempty mempty (Map.singleton v (External, tm)) mempty - typeLookup <- Codebase.typeLookupForDependencies codebase (UF.dependencies file) - let typecheckingEnv = - Typechecker.Env - { ambientAbilities = [], - typeLookup, - termsByShortname = Map.empty, - topLevelComponents = Map.empty - } - pure $ fmap extract $ FileParsers.synthesizeFile typecheckingEnv file - where - extract tuf - | [[(_, _, _, ty)]] <- UF.topLevelComponents' tuf = ty - | otherwise = error "internal error: typecheckTerm" diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 265a04a886..aee1a5ed57 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -134,7 +134,7 @@ import Unison.Parsers qualified as Parsers import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnv.Names qualified as PPE -import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo, empty) +import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo) import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Reference (Reference) @@ -771,7 +771,7 @@ loop e = do names <- lift Cli.currentNames let buildPPED uf tf = let names' = (fromMaybe mempty $ (UF.typecheckedToNames <$> tf) <|> (UF.toNames <$> uf)) `Names.shadowing` names - in pure (PPED.makePPED (PPE.hqNamer 10 names') (PPE.suffixifyByHashName names')) + in pure (PPED.makePPED (PPE.hqNamer 10 names') (PPE.suffixifyByHashName names')) let formatWidth = 80 currentPath <- lift $ Cli.getCurrentPath updates <- MaybeT $ Format.formatFile buildPPED formatWidth currentPath pf tf Nothing @@ -1382,25 +1382,6 @@ confirmedCommand i = do loopState <- State.get pure $ Just i == (loopState ^. #lastInput) --- return `name` and `name....` -_searchBranchPrefix :: Branch m -> Name -> [SearchResult] -_searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of - Nothing -> [] - Just (init, last) -> case Branch.getAt init b of - Nothing -> [] - Just b -> SR.fromNames . Names.prefix0 n $ names0 - where - lastName = Name.fromSegment last - subnames = - Branch.toNames . Branch.head $ - Branch.getAt' (Path.singleton last) b - rootnames = - Names.filter (== lastName) - . Branch.toNames - . set Branch.children mempty - $ Branch.head b - names0 = rootnames <> Names.prefix0 lastName subnames - searchResultsFor :: Names -> [Referent] -> [Reference] -> [SearchResult] searchResultsFor ns terms types = [ SR.termSearchResult ns name ref @@ -1475,7 +1456,7 @@ doCompile profile native output main = do outf | native = output | otherwise = output <> ".uc" - copts = Runtime.defaultCompileOpts { Runtime.profile = profile } + copts = Runtime.defaultCompileOpts {Runtime.profile = profile} whenJustM ( liftIO $ Runtime.compileTo theRuntime copts codeLookup ppe ref outf diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs index 54fc3f870e..c402193e3e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs @@ -33,7 +33,7 @@ import Unison.Pattern qualified as Pattern import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnv.Names qualified as PPE -import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo, empty) +import Unison.PrettyPrintEnvDecl qualified as PPE hiding (biasTo) import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Reference qualified as Reference diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs index ddc2fe39d2..d500fd7ed8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs @@ -1,25 +1,20 @@ module Unison.Codebase.Editor.HandleInput.TermResolution ( lookupTermRefs, lookupTermRefWithType, - resolveCon, - resolveTerm, - resolveTermRef, resolveMainRef, ) where import Control.Monad.Reader (ask) import Control.Monad.Trans (liftIO) -import Data.Maybe (catMaybes, fromJust) -import Data.Set (fromList, toList) +import Data.Maybe (catMaybes) +import Data.Set (toList) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.NamesUtils qualified as Cli import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Output (Output (..)) -import Unison.Codebase.Path (hqSplitFromName') import Unison.Codebase.Runtime qualified as Runtime -import Unison.ConstructorReference import Unison.HashQualified qualified as HQ import Unison.Name (Name) import Unison.Names (Names) @@ -30,7 +25,7 @@ import Unison.PrettyPrintEnv.Names qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Reference (Reference) -import Unison.Referent (Referent, pattern Con, pattern Ref) +import Unison.Referent (Referent, pattern Ref) import Unison.Symbol (Symbol) import Unison.Type (Type) import Unison.Typechecker qualified as Typechecker @@ -38,16 +33,6 @@ import Unison.Typechecker qualified as Typechecker lookupTerm :: HQ.HashQualified Name -> Names -> [Referent] lookupTerm hq parseNames = toList (Names.lookupHQTerm Names.IncludeSuffixes hq parseNames) -lookupCon :: - HQ.HashQualified Name -> - Names -> - ([ConstructorReference], [Referent]) -lookupCon hq parseNames = - unzip . catMaybes . fmap extract $ lookupTerm hq parseNames - where - extract rt@(Con rf _) = Just (rf, rt) - extract _ = Nothing - lookupTermRefs :: HQ.HashQualified Name -> Names -> ([Reference], [Referent]) lookupTermRefs hq parseNames = @@ -72,45 +57,6 @@ lookupTermRefWithType codebase name = do annot tm = fmap ((,) tm) <$> Codebase.getTypeOfTerm codebase tm -resolveTerm :: HQ.HashQualified Name -> Cli Referent -resolveTerm name = do - names <- Cli.currentNames - let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) - let suffixifiedPPE = PPED.suffixifiedPPE pped - case lookupTerm name names of - [] -> Cli.returnEarly (TermNotFound $ fromJust parsed) - where - parsed = hqSplitFromName' <$> HQ.toName name - [rf] -> pure rf - rfs -> - Cli.returnEarly (TermAmbiguous suffixifiedPPE name (fromList rfs)) - -resolveCon :: HQ.HashQualified Name -> Cli ConstructorReference -resolveCon name = do - names <- Cli.currentNames - let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) - let suffixifiedPPE = PPED.suffixifiedPPE pped - case lookupCon name names of - ([], _) -> Cli.returnEarly (TermNotFound $ fromJust parsed) - where - parsed = hqSplitFromName' <$> HQ.toName name - ([co], _) -> pure co - (_, rfts) -> - Cli.returnEarly (TermAmbiguous suffixifiedPPE name (fromList rfts)) - -resolveTermRef :: HQ.HashQualified Name -> Cli Reference -resolveTermRef name = do - names <- Cli.currentNames - let pped = PPED.makePPED (PPE.hqNamer 10 names) (PPE.suffixifyByHash names) - let suffixifiedPPE = PPED.suffixifiedPPE pped - case lookupTermRefs name names of - ([], _) -> Cli.returnEarly (TermNotFound $ fromJust parsed) - where - parsed = hqSplitFromName' <$> HQ.toName name - ([rf], _) -> pure rf - (_, rfts) -> - Cli.returnEarly (TermAmbiguous suffixifiedPPE name (fromList rfts)) - resolveMainRef :: HQ.HashQualified Name -> Cli (Reference, PrettyPrintEnv) resolveMainRef main = do Cli.Env {codebase, runtime} <- ask diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 9514afde74..48cedd7d31 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -69,12 +69,6 @@ data BranchIdG p | BranchAtProjectPath ProjectPath deriving stock (Eq, Show, Functor, Foldable, Traversable) -instance (From p Text) => From (BranchIdG p) Text where - from = \case - BranchAtSCH h -> "#" <> SCH.toText h - BranchAtPath p -> from p - BranchAtProjectPath pp -> from pp - type BranchId = BranchIdG Path' type BranchId2 = Either ShortCausalHash BranchRelativePath @@ -126,8 +120,8 @@ data Input | PullI !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput | ResetI (BranchId2 {- namespace to reset it to -}) (Maybe UnresolvedProjectBranch {- ProjectBranch to reset -}) - -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? - | -- Does it make sense to fork from not-the-root of a Github repo? + | -- todo: Q: Does it make sense to publish to not-the-root of a Github repo? + -- Does it make sense to fork from not-the-root of a Github repo? -- used in Welcome module to give directions to user CreateMessage (P.Pretty P.ColorText) | -- Change directory. diff --git a/unison-cli/src/Unison/Codebase/Editor/SlurpComponent.hs b/unison-cli/src/Unison/Codebase/Editor/SlurpComponent.hs index 3e51fb9aa2..f2166b3dc7 100644 --- a/unison-cli/src/Unison/Codebase/Editor/SlurpComponent.hs +++ b/unison-cli/src/Unison/Codebase/Editor/SlurpComponent.hs @@ -11,10 +11,6 @@ module Unison.Codebase.Editor.SlurpComponent -- ** Predicates isEmpty, - -- ** Set operations - difference, - intersection, - -- ** Closure closeWithDependencies, ) @@ -45,20 +41,6 @@ isEmpty sc = Set.null sc.types && Set.null sc.terms && Set.null sc.ctors empty :: SlurpComponent empty = SlurpComponent {types = Set.empty, terms = Set.empty, ctors = Set.empty} -difference :: SlurpComponent -> SlurpComponent -> SlurpComponent -difference c1 c2 = SlurpComponent {types = types', terms = terms', ctors = ctors'} - where - types' = c1.types `Set.difference` c2.types - terms' = c1.terms `Set.difference` c2.terms - ctors' = c1.ctors `Set.difference` c2.ctors - -intersection :: SlurpComponent -> SlurpComponent -> SlurpComponent -intersection c1 c2 = SlurpComponent {types = types', terms = terms', ctors = ctors'} - where - types' = c1.types `Set.intersection` c2.types - terms' = c1.terms `Set.intersection` c2.terms - ctors' = c1.ctors `Set.intersection` c2.ctors - instance Semigroup SlurpComponent where c1 <> c2 = SlurpComponent diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 14e7412c4e..d15a07ca86 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -1,6 +1,5 @@ module Unison.Codebase.Editor.UriParser ( readRemoteNamespaceParser, - parseReadShareLooseCode, writeRemoteNamespace, ) where @@ -23,8 +22,6 @@ import Unison.Prelude import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser) import Unison.Syntax.Lexer qualified import Unison.Syntax.NameSegment qualified as NameSegment -import Unison.Util.Pretty qualified as P -import Unison.Util.Pretty.MegaParsec qualified as P type P = P.Parsec Void Text.Text @@ -43,11 +40,6 @@ projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier = P.notFollowedBy (C.char '.') pure projectAndBranch -parseReadShareLooseCode :: String -> String -> Either (P.Pretty P.ColorText) ReadShareLooseCode -parseReadShareLooseCode label input = - let printError err = P.lines [P.string "I couldn't parse this as a share path.", P.prettyPrintParseError input err] - in first printError (P.parse readShareLooseCode label (Text.pack input)) - -- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4" -- Just (WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})) writeRemoteNamespace :: P (These ProjectName ProjectBranchName) @@ -79,15 +71,6 @@ shareUserHandle :: P ShareUserHandle shareUserHandle = do ShareUserHandle . Text.pack <$> P.some (P.satisfy \c -> isAlphaNum c || c == '-' || c == '_') -data Scheme = Ssh | Https - deriving (Eq, Ord, Show) - -data User = User Text - deriving (Eq, Ord, Show) - -data HostInfo = HostInfo Text (Maybe Text) - deriving (Eq, Ord, Show) - nameSegment :: P NameSegment nameSegment = NameSegment.unsafeParseText . Text.pack diff --git a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs index cc49baa3ce..e96e369608 100644 --- a/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs +++ b/unison-cli/src/Unison/CommandLine/BranchRelativePath.hs @@ -4,7 +4,6 @@ module Unison.CommandLine.BranchRelativePath branchRelativePathParser, parseIncrementalBranchRelativePath, IncrementalBranchRelativePath (..), - toText, ) where @@ -16,7 +15,6 @@ import Text.Megaparsec qualified as Megaparsec import Text.Megaparsec.Char qualified as Megaparsec import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path -import Unison.Codebase.ProjectPath (ProjectPathG (..)) import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Project qualified as Project @@ -233,9 +231,3 @@ branchRelativePathParser = pure $ QualifiedBranchPath projName branchName (fromMaybe Path.absoluteEmpty mpath) Right branch -> pure $ BranchPathInCurrentProject branch (fromMaybe Path.absoluteEmpty mpath) - -toText :: BranchRelativePath -> Text -toText = \case - BranchPathInCurrentProject pbName path -> ProjectPath () pbName path & into @Text - QualifiedBranchPath projName pbName path -> ProjectPath projName pbName path & into @Text - UnqualifiedPath path' -> Path.toText' path' diff --git a/unison-cli/src/Unison/CommandLine/Completion.hs b/unison-cli/src/Unison/CommandLine/Completion.hs index 10a838373e..dcdb7063cf 100644 --- a/unison-cli/src/Unison/CommandLine/Completion.hs +++ b/unison-cli/src/Unison/CommandLine/Completion.hs @@ -12,9 +12,6 @@ module Unison.CommandLine.Completion prefixCompletePatch, noCompletions, prefixCompleteNamespace, - -- Unused for now, but may be useful later - prettyCompletion, - fixupCompletion, haskelineTabComplete, sharePathCompletion, ) @@ -318,12 +315,6 @@ prettyCompletionWithQueryPrefix endWithSpace query s = let coloredMatch = P.hiBlack (P.string query) <> P.string (drop (length query) s) in Line.Completion s (P.toAnsiUnbroken coloredMatch) endWithSpace --- discards formatting in favor of better alignment --- prettyCompletion (s, p) = Line.Completion s (P.toPlainUnbroken p) True --- preserves formatting, but Haskeline doesn't know how to align -prettyCompletion :: Bool -> (String, P.Pretty P.ColorText) -> Line.Completion -prettyCompletion endWithSpace (s, p) = Line.Completion s (P.toAnsiUnbroken p) endWithSpace - -- | Constructs a list of 'Completion's from a query and completion options by -- filtering them for prefix matches. A completion will be selected if it's an exact match for -- a provided option. @@ -332,22 +323,6 @@ exactComplete q ss = go <$> filter (isPrefixOf q) ss where go s = prettyCompletionWithQueryPrefix (s == q) q s --- workaround for https://github.com/judah/haskeline/issues/100 --- if the common prefix of all the completions is smaller than --- the query, we make all the replacements equal to the query, --- which will preserve what the user has typed -fixupCompletion :: String -> [Line.Completion] -> [Line.Completion] -fixupCompletion _q [] = [] -fixupCompletion _q [c] = [c] -fixupCompletion q cs@(h : t) = - let commonPrefix (h1 : t1) (h2 : t2) | h1 == h2 = h1 : commonPrefix t1 t2 - commonPrefix _ _ = "" - overallCommonPrefix = - foldl commonPrefix (Line.replacement h) (Line.replacement <$> t) - in if not (q `isPrefixOf` overallCommonPrefix) - then [c {Line.replacement = q} | c <- cs] - else cs - sharePathCompletion :: (MonadIO m) => AuthenticatedHttpClient -> diff --git a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs index 37fdff8b18..de3c930902 100644 --- a/unison-cli/src/Unison/CommandLine/FZFResolvers.hs +++ b/unison-cli/src/Unison/CommandLine/FZFResolvers.hs @@ -7,7 +7,6 @@ module Unison.CommandLine.FZFResolvers projectDependencyResolver, projectNameOptions, projectBranchOptions, - projectBranchOptionsWithinCurrentProject, fuzzySelectFromList, multiResolver, definitionResolver, @@ -18,8 +17,6 @@ module Unison.CommandLine.FZFResolvers projectAndOrBranchArg, projectOrBranchResolver, projectBranchResolver, - projectBranchWithinCurrentProjectResolver, - projectNameResolver, fuzzySelectHeader, ) where @@ -154,12 +151,6 @@ projectOrBranchResolver = multiResolver [projectBranchOptions, namespaceOptions] projectBranchResolver :: FZFResolver projectBranchResolver = FZFResolver {getOptions = projectBranchOptions} -projectBranchWithinCurrentProjectResolver :: FZFResolver -projectBranchWithinCurrentProjectResolver = FZFResolver {getOptions = projectBranchOptionsWithinCurrentProject} - -projectNameResolver :: FZFResolver -projectNameResolver = FZFResolver {getOptions = projectNameOptions} - -- | All possible local project names -- E.g. '@unison/base' projectNameOptions :: OptionFetcher @@ -173,13 +164,6 @@ projectBranchOptions codebase _projCtx _searchBranch0 = do Codebase.runTransaction codebase Q.loadAllProjectBranchNamePairs <&> fmap (into @Text . fst) --- | All possible local branch names within the current project. --- E.g. '@unison/base/main' -projectBranchOptionsWithinCurrentProject :: OptionFetcher -projectBranchOptionsWithinCurrentProject codebase projCtx _searchBranch0 = do - Codebase.runTransaction codebase (Q.loadAllProjectBranchesBeginningWith (projCtx ^. #project . #projectId) Nothing) - <&> fmap (into @Text . snd) - -- | Exported from here just so the debug command and actual implementation can use the same -- messaging. -- diff --git a/unison-cli/src/Unison/CommandLine/Helpers.hs b/unison-cli/src/Unison/CommandLine/Helpers.hs index d50258e304..e42fb1c97a 100644 --- a/unison-cli/src/Unison/CommandLine/Helpers.hs +++ b/unison-cli/src/Unison/CommandLine/Helpers.hs @@ -8,13 +8,9 @@ module Unison.CommandLine.Helpers aside, bigproblem, note, - nothingTodo, - plural, plural', - problem, tip, warn, - warnNote, ) where @@ -23,9 +19,6 @@ import Unison.Prelude import Unison.Util.Pretty qualified as P import Prelude hiding (readFile, writeFile) -warnNote :: String -> String -warnNote s = "⚠️ " <> s - backtick :: (IsString s) => P.Pretty s -> P.Pretty s backtick s = P.group ("`" <> s <> "`") @@ -41,26 +34,12 @@ aside a b = P.column2 [(a <> ":", b)] warn :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s warn = emojiNote "⚠️" -problem :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s -problem = emojiNote "❗️" - bigproblem :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s bigproblem = emojiNote "‼️" emojiNote :: (ListLike s Char, IsString s) => String -> P.Pretty s -> P.Pretty s emojiNote lead s = P.group (fromString lead) <> "\n" <> P.wrap s -nothingTodo :: (ListLike s Char, IsString s) => P.Pretty s -> P.Pretty s -nothingTodo = emojiNote "😶" - --- `plural [] "cat" "cats" = "cats"` --- `plural ["meow"] "cat" "cats" = "cat"` --- `plural ["meow", "meow"] "cat" "cats" = "cats"` -plural :: (Foldable f) => f a -> b -> b -> b -plural items one other = case toList items of - [_] -> one - _ -> other - plural' :: (Integral a) => a -> b -> b -> b plural' 1 one _other = one plural' _ _one other = other diff --git a/unison-cli/src/Unison/CommandLine/InputPattern.hs b/unison-cli/src/Unison/CommandLine/InputPattern.hs index cc628559e6..0396519716 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -12,12 +12,7 @@ module Unison.CommandLine.InputPattern FZFResolver (..), IsOptional (..), Visibility (..), - - -- * Currently Unused - minArgs, - maxArgs, unionSuggestions, - suggestionFallbacks, ) where @@ -130,35 +125,6 @@ argInfo InputPattern {args, patternName} i = go (i, args) argType :: InputPattern -> Int -> Maybe ArgumentType argType ip i = snd <$> (argInfo ip i) -minArgs :: InputPattern -> Int -minArgs (InputPattern {args, patternName}) = - go (args ^.. folded . _2) - where - go [] = 0 - go (Required : argTypes) = 1 + go argTypes - go [_] = 0 - go _ = - error $ - "Invalid args for InputPattern (" - <> show patternName - <> "): " - <> show args - -maxArgs :: InputPattern -> Maybe Int -maxArgs (InputPattern {args, patternName}) = go argTypes - where - argTypes = args ^.. folded . _2 - go [] = Just 0 - go (Required : argTypes) = (1 +) <$> go argTypes - go [Optional] = Just 0 - go [_] = Nothing - go _ = - error $ - "Invalid args for InputPattern (" - <> show patternName - <> "): " - <> show argTypes - -- | Union suggestions from all possible completions unionSuggestions :: forall m v a. @@ -180,29 +146,3 @@ unionSuggestions suggesters inp codebase httpClient path = do suggesters & foldMapM \suggester -> suggester inp codebase httpClient path & fmap List.nubOrd - --- | Try the first completer, if it returns no suggestions, try the second, etc. -suggestionFallbacks :: - forall m v a. - (MonadIO m) => - [ ( String -> - Codebase m v a -> - AuthenticatedHttpClient -> - PP.ProjectPath -> - m [Line.Completion] - ) - ] -> - ( String -> - Codebase m v a -> - AuthenticatedHttpClient -> - PP.ProjectPath -> - m [Line.Completion] - ) -suggestionFallbacks suggesters inp codebase httpClient path = go suggesters - where - go (s : rest) = do - suggestions <- s inp codebase httpClient path - if null suggestions - then go rest - else pure suggestions - go [] = pure [] diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index f0b2463570..288529e7ff 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -513,41 +513,6 @@ handleBranchIdArg = SA.Namespace hash -> pure . BranchAtSCH $ SCH.fromFullHash hash otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg --- | TODO: Maybe remove? -_handleBranchIdOrProjectArg :: - I.Argument -> - Either (P.Pretty CT.ColorText) (These Input.BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)) -_handleBranchIdOrProjectArg = - either - (\str -> maybe (Left $ expectedButActually' "a branch" str) pure $ branchIdOrProject str) - \case - SA.Namespace hash -> pure . This . BranchAtSCH $ SCH.fromFullHash hash - SA.AbsolutePath path -> pure . This . BranchAtPath $ Path.absoluteToPath' path - SA.Name name -> pure . This . BranchAtPath $ Path.fromName' name - SA.NameWithBranchPrefix (BranchAtSCH _) name -> pure . This . BranchAtPath $ Path.fromName' name - SA.NameWithBranchPrefix (BranchAtPath prefix) name -> - pure . This . BranchAtPath . Path.fromName' $ Path.prefixNameIfRel (Path.AbsolutePath' prefix) name - SA.ProjectBranch pb -> pure $ That pb - otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType - where - branchIdOrProject :: - String -> - Maybe - ( These - Input.BranchId - (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - ) - branchIdOrProject str = - let branchIdRes = Input.parseBranchId str - projectRes = - tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - (Text.pack str) - in case (branchIdRes, projectRes) of - (Left _, Left _) -> Nothing - (Left _, Right pr) -> Just (That pr) - (Right bid, Left _) -> Just (This bid) - (Right bid, Right pr) -> Just (These bid pr) - handleBranchId2Arg :: I.Argument -> Either (P.Pretty P.ColorText) Input.BranchId2 handleBranchId2Arg = either diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 1f1f6aac14..8e670c2d3d 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -73,7 +73,6 @@ import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.CommandLine.FZFResolvers qualified as FZFResolvers import Unison.CommandLine.Helpers (bigproblem, note, tip) -import Unison.CommandLine.InputPattern (InputPattern) import Unison.CommandLine.InputPatterns (makeExample') import Unison.CommandLine.InputPatterns qualified as IP import Unison.ConstructorReference (GConstructorReference (..)) @@ -2340,16 +2339,6 @@ prettyTransportError = \case responseRequestId = fmap Text.decodeUtf8 . List.lookup "X-RequestId" . Foldable.toList @Seq . Servant.responseHeaders -prettyEntityType :: Share.EntityType -> Pretty -prettyEntityType = \case - Share.TermComponentType -> "term component" - Share.DeclComponentType -> "type component" - Share.PatchType -> "patch" - Share.PatchDiffType -> "patch diff" - Share.NamespaceType -> "namespace" - Share.NamespaceDiffType -> "namespace diff" - Share.CausalType -> "causal" - invalidRepoInfo :: Text -> Share.RepoInfo -> Pretty invalidRepoInfo err repoInfo = P.lines @@ -2373,23 +2362,6 @@ hashMismatchFromShare supplied computed = P.wrap $ "The hash computed by Share is: " <> prettyHash32 computed ] -pushPublicNote :: InputPattern -> Text -> [Text] -> Pretty -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 - ] - needDependencies :: Share.NeedDependencies Hash32 -> Pretty needDependencies (Share.NeedDependencies hashes) = -- maybe todo: stuff in all the args to CheckAndSetPush @@ -2411,33 +2383,10 @@ noReadPermissionForRepo :: Share.RepoInfo -> Pretty noReadPermissionForRepo repoInfo = P.wrap $ P.text "The server said you don't have permission to read" <> P.group (prettyRepoInfo repoInfo <> ".") -noWritePermissionForPath :: Share.Path -> Pretty -noWritePermissionForPath 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.pushCreate uname ys - noWritePermissionForRepo :: Share.RepoInfo -> Pretty noWritePermissionForRepo repoInfo = P.wrap $ P.text "The server said you don't have permission to write" <> P.group (prettyRepoInfo repoInfo <> ".") -notFastForward :: Share.Path -> Pretty -notFastForward path = - P.lines $ - [ P.wrap $ - "There are some changes at" <> prettySharePath path <> "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 - shareProjectNotFound :: Text -> Pretty shareProjectNotFound projectShortHand = P.lines @@ -3441,9 +3390,6 @@ watchPrinter src ppe ann kind term isHit = ] ] -filestatusTip :: Pretty -filestatusTip = tip "Use `help filestatus` to learn more." - prettyDiff :: Names.Diff -> Pretty prettyDiff diff = let orig = Names.originalNames diff diff --git a/unison-cli/src/Unison/LSP/CodeLens.hs b/unison-cli/src/Unison/LSP/CodeLens.hs index a5017ee99d..5c1ed7cd11 100644 --- a/unison-cli/src/Unison/LSP/CodeLens.hs +++ b/unison-cli/src/Unison/LSP/CodeLens.hs @@ -6,7 +6,6 @@ module Unison.LSP.CodeLens where import Control.Lens hiding (List) -import Data.Aeson qualified as Aeson import Data.Map qualified as Map import Data.Text qualified as Text import Language.LSP.Protocol.Lens hiding (error) @@ -21,30 +20,6 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Syntax.TypePrinter qualified as TypePrinter import Unison.Util.Pretty qualified as CT -data TypeSigInsertion = TypeSigInsertion - { range :: Range, - typeSignature :: Text, - fileUri :: Uri - } - -instance Aeson.ToJSON TypeSigInsertion where - toJSON (TypeSigInsertion range typeSignature fileUri) = - Aeson.object - [ "range" Aeson..= range, - "typeSignature" Aeson..= typeSignature, - "fileUri" Aeson..= fileUri - ] - -instance Aeson.FromJSON TypeSigInsertion where - parseJSON = Aeson.withObject "TypeSigInsertion" $ \o -> - TypeSigInsertion - <$> o - Aeson..: "range" - <*> o - Aeson..: "typeSignature" - <*> o - Aeson..: "fileUri" - -- | Computes code actions for a document. codeLensHandler :: Msg.TRequestMessage 'Msg.Method_TextDocumentCodeLens -> (Either Msg.ResponseError ([CodeLens] |? Null) -> Lsp ()) -> Lsp () codeLensHandler m respond = diff --git a/unison-cli/src/Unison/LSP/FileAnalysis.hs b/unison-cli/src/Unison/LSP/FileAnalysis.hs index 2b5363c7ff..5143dd3860 100644 --- a/unison-cli/src/Unison/LSP/FileAnalysis.hs +++ b/unison-cli/src/Unison/LSP/FileAnalysis.hs @@ -40,7 +40,6 @@ import Unison.LSP.Orphans () import Unison.LSP.Types import Unison.LSP.VFS qualified as VFS import Unison.Name (Name) -import Unison.Names (Names) import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) import Unison.Parsers qualified as Parsers @@ -126,11 +125,6 @@ checkFile doc = runMaybeT do let fileAnalysis = FileAnalysis {diagnostics = diagnosticRanges, codeActions = codeActionRanges, fileSummary, typeSignatureHints, ..} pure fileAnalysis --- | Get the location of user defined definitions within the file -getFileDefLocations :: Uri -> MaybeT Lsp (Map Symbol (Set Ann)) -getFileDefLocations uri = do - fileDefLocations <$> getFileSummary uri - fileAnalysisWorker :: Lsp () fileAnalysisWorker = forever do dirtyFilesV <- asks dirtyFilesVar @@ -401,21 +395,6 @@ getFileAnalysis uri = do Debug.debugM Debug.LSP "Got file analysis" uri pure r --- | Build a Names from a file if it's parseable. --- --- If the file typechecks, generate names from that, --- otherwise, generate names from the 'parsed' file. Note that the --- names for a parsed file contains only names for parts of decls, since --- we don't know references within terms before typechecking due to TDNR. --- This should be fine though, since those references will all be kept in the --- ABT as symbols anyways. --- --- See UF.toNames and UF.typecheckedToNames for more info. -getFileNames :: Uri -> MaybeT Lsp Names -getFileNames fileUri = do - FileAnalysis {typecheckedFile = tf, parsedFile = pf} <- getFileAnalysis fileUri - hoistMaybe (fmap UF.typecheckedToNames tf <|> fmap UF.toNames pf) - getFileSummary :: Uri -> MaybeT Lsp FileSummary getFileSummary uri = do FileAnalysis {fileSummary} <- getFileAnalysis uri diff --git a/unison-cli/src/Unison/LSP/HandlerUtils.hs b/unison-cli/src/Unison/LSP/HandlerUtils.hs index 404d0dc638..e191ee80cb 100644 --- a/unison-cli/src/Unison/LSP/HandlerUtils.hs +++ b/unison-cli/src/Unison/LSP/HandlerUtils.hs @@ -19,20 +19,6 @@ import UnliftIO.MVar import UnliftIO.STM import UnliftIO.Timeout (timeout) --- | Cancels an in-flight request -cancelRequest :: (Int32 |? Text) -> Lsp () -cancelRequest lspId = do - cancelMapVar <- asks cancellationMapVar - cancel <- atomically $ do - cancellers <- readTVar cancelMapVar - let (mayCancel, newMap) = Map.updateLookupWithKey (\_k _io -> Nothing) lspId cancellers - case mayCancel of - Nothing -> pure (pure ()) - Just cancel -> do - writeTVar cancelMapVar newMap - pure cancel - liftIO cancel - withDebugging :: (Show (Msg.TRequestMessage message), Show (Msg.MessageResult message)) => (Msg.TRequestMessage message -> (Either Msg.ResponseError (Msg.MessageResult message) -> Lsp ()) -> Lsp ()) -> diff --git a/unison-cli/src/Unison/LSP/Orphans.hs b/unison-cli/src/Unison/LSP/Orphans.hs index 78df273ce1..66a23cc724 100644 --- a/unison-cli/src/Unison/LSP/Orphans.hs +++ b/unison-cli/src/Unison/LSP/Orphans.hs @@ -6,14 +6,8 @@ module Unison.LSP.Orphans where import Control.Lens -import Language.LSP.Protocol.Lens (HasTextDocument (..), HasUri (..)) +import Language.LSP.Protocol.Lens (HasUri (..)) import Language.LSP.Protocol.Types -instance HasTextDocument TextDocumentIdentifier TextDocumentIdentifier where - textDocument = Prelude.id - -instance HasTextDocument VersionedTextDocumentIdentifier VersionedTextDocumentIdentifier where - textDocument = Prelude.id - instance HasUri NormalizedUri Uri where uri = iso fromNormalizedUri toNormalizedUri diff --git a/unison-cli/src/Unison/LSP/Types.hs b/unison-cli/src/Unison/LSP/Types.hs index 268034ea5a..f622204d78 100644 --- a/unison-cli/src/Unison/LSP/Types.hs +++ b/unison-cli/src/Unison/LSP/Types.hs @@ -5,18 +5,15 @@ module Unison.LSP.Types where -import Colog.Core hiding (Lens') import Control.Comonad.Cofree (Cofree) import Control.Comonad.Cofree qualified as Cofree import Control.Lens hiding (List, (:<)) -import Control.Monad.Except import Control.Monad.Reader import Data.Aeson qualified as Aeson import Data.IntervalMap.Lazy (IntervalMap) import Data.IntervalMap.Lazy qualified as IM import Data.Map qualified as Map import Ki qualified -import Language.LSP.Logging qualified as LSP import Language.LSP.Protocol.Lens import Language.LSP.Protocol.Message (MessageDirection (..), MessageKind (..), Method, TMessage, TNotificationMessage, fromServerNot) import Language.LSP.Protocol.Types @@ -37,7 +34,6 @@ import Unison.Prelude import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl) import Unison.Referent (Referent) import Unison.Result (Note) -import Unison.Server.Backend qualified as Backend import Unison.Server.NameSearch (NameSearch) import Unison.Sqlite qualified as Sqlite import Unison.Symbol @@ -51,19 +47,6 @@ import UnliftIO newtype Lsp a = Lsp {runLspM :: ReaderT Env (LspM Config) a} deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadReader Env, MonadLsp Config) --- | Log an info message to the client's LSP log. -logInfo :: Text -> Lsp () -logInfo msg = do - let LogAction log = LSP.defaultClientLogger - log (WithSeverity msg Info) - --- | Log an error message to the client's LSP log, this will be shown to the user in most LSP --- implementations. -logError :: Text -> Lsp () -logError msg = do - let LogAction log = LSP.defaultClientLogger - log (WithSeverity msg Error) - -- | Environment for the Lsp monad. data Env = Env { -- contains handlers for talking to the client. @@ -175,10 +158,6 @@ defaultLSPConfig = Config {..} formattingWidth = 80 maxCompletions = Just 100 --- | Lift a backend computation into the Lsp monad. -lspBackend :: Backend.Backend IO a -> Lsp (Either Backend.BackendError a) -lspBackend = liftIO . runExceptT . flip runReaderT (Backend.BackendEnv False) . Backend.runBackend - sendNotification :: forall (m :: Method 'ServerToClient 'Notification). (TMessage m ~ TNotificationMessage m) => TNotificationMessage m -> Lsp () sendNotification notif = do sendServerMessage <- asks (resSendMessage . lspContext) @@ -224,6 +203,3 @@ includeEdits uri replacement ranges rca = getConfig :: Lsp Config getConfig = LSP.getConfig - -setConfig :: Config -> Lsp () -setConfig = LSP.setConfig diff --git a/unison-cli/src/Unison/Share/Sync/Types.hs b/unison-cli/src/Unison/Share/Sync/Types.hs index a53d14acbb..634e86f29c 100644 --- a/unison-cli/src/Unison/Share/Sync/Types.hs +++ b/unison-cli/src/Unison/Share/Sync/Types.hs @@ -40,7 +40,6 @@ data CodeserverTransportError | UnexpectedResponse Servant.Response | UnreachableCodeserver Servant.BaseUrl deriving stock (Show) - deriving anyclass (Exception) data SyncError e = TransportError CodeserverTransportError diff --git a/unison-cli/tests/Unison/Test/LSP.hs b/unison-cli/tests/Unison/Test/LSP.hs index 02af644740..e146aa7151 100644 --- a/unison-cli/tests/Unison/Test/LSP.hs +++ b/unison-cli/tests/Unison/Test/LSP.hs @@ -27,7 +27,6 @@ import Unison.LSP.FileAnalysis.UnusedBindings qualified as UnusedBindings import Unison.LSP.Queries qualified as LSPQ import Unison.Lexer.Pos qualified as Lexer import Unison.Parser.Ann (Ann (..)) -import Unison.Parser.Ann qualified as Ann import Unison.Parsers qualified as Parsers import Unison.Pattern qualified as Pattern import Unison.Prelude @@ -341,9 +340,35 @@ annotationNestingTest (name, src) = scope name do & traverse_ \(_fileAnn, _refId, _wk, trm, _typ) -> assertAnnotationsAreNested trm +-- | Checks whether an annotation contains another annotation. +-- +-- i.e. pos ∈ [start, end) +-- +-- >>> Intrinsic `encompasses` Ann (L.Pos 1 1) (L.Pos 2 1) +-- Nothing +-- +-- >>> External `encompasses` Ann (L.Pos 1 1) (L.Pos 2 1) +-- Nothing +-- +-- >>> Ann (L.Pos 0 0) (L.Pos 0 10) `encompasses` Ann (L.Pos 0 1) (L.Pos 0 5) +-- Just True +-- +-- >>> Ann (L.Pos 1 0) (L.Pos 1 10) `encompasses` Ann (L.Pos 0 0) (L.Pos 2 0) +-- Just False +encompasses :: Ann -> Ann -> Maybe Bool +encompasses Intrinsic _ = Nothing +encompasses External _ = Nothing +encompasses _ Intrinsic = Nothing +encompasses _ External = Nothing +encompasses (GeneratedFrom outer) inner = outer `encompasses` inner +encompasses outer (GeneratedFrom inner) = outer `encompasses` inner +encompasses (Ann outerStart outerEnd) (Ann innerStart innerEnd) = + Just $ outerStart <= innerStart && innerEnd <= outerEnd + -- | Asserts that for all nodes in the provided ABT EXCEPT Abs nodes, the annotations of all child nodes are -- within the span of the parent node. -assertAnnotationsAreNested :: forall f. (Foldable f, Functor f, Show (f (Either String Ann))) => ABT.Term f Symbol Ann -> Test () +assertAnnotationsAreNested :: + forall f. (Foldable f, Functor f, Show (f (Either String Ann))) => ABT.Term f Symbol Ann -> Test () assertAnnotationsAreNested term = do case cata alg term of Right _ -> pure () @@ -359,7 +384,7 @@ assertAnnotationsAreNested term = do ABT.Abs _ _ -> pure (ann <> childSpan) _ -> do - case ann `Ann.encompasses` childSpan of + case ann `encompasses` childSpan of -- one of the annotations isn't in the file, don't bother checking. Nothing -> pure (ann <> childSpan) Just isInFile diff --git a/unison-cli/tests/Unison/Test/Ucm.hs b/unison-cli/tests/Unison/Test/Ucm.hs index c0d2cb0977..a5c24b2f19 100644 --- a/unison-cli/tests/Unison/Test/Ucm.hs +++ b/unison-cli/tests/Unison/Test/Ucm.hs @@ -4,7 +4,6 @@ module Unison.Test.Ucm ( initCodebase, - deleteCodebase, runTranscript, lowLevel, CodebaseFormat (..), @@ -15,10 +14,11 @@ module Unison.Test.Ucm where import Control.Monad (when) +import Data.Char qualified as Char +import Data.Text (Text) import Data.Text qualified as Text -import System.Directory (removeDirectoryRecursive) +import Safe.Foldable (minimumMay) import System.IO.Temp qualified as Temp -import U.Util.Text (stripMargin) import Unison.Codebase (CodebasePath) import Unison.Codebase qualified as Codebase import Unison.Codebase.Init qualified as Codebase.Init @@ -27,7 +27,7 @@ import Unison.Codebase.SqliteCodebase qualified as SC import Unison.Codebase.Transcript.Runner qualified as Transcript import Unison.Codebase.Verbosity qualified as Verbosity import Unison.Parser.Ann (Ann) -import Unison.Prelude (traceM) +import Unison.Prelude (fromMaybe, traceM) import Unison.PrettyTerminal qualified as PT import Unison.Symbol (Symbol) import Unison.Util.Pretty qualified as P @@ -59,8 +59,32 @@ initCodebase fmt = do Left CreateCodebaseAlreadyExists -> fail $ P.toANSI 80 "Codebase already exists" Right _ -> pure $ Codebase tmp fmt -deleteCodebase :: Codebase -> IO () -deleteCodebase (Codebase path _) = removeDirectoryRecursive path +-- | remove however many spaces prefix all of the lines of the input +-- e.g. +-- stripMargin [here| +-- def foo: +-- blah blah +-- |] == [here| +-- def foo: +-- blah blah +-- |]T +stripMargin :: Text -> Text +stripMargin str = + let stripLen = + fromMaybe 0 + . minimumMay + . map (Text.length . fst . Text.span (== ' ')) + . filter (not . Text.all Char.isSpace) + $ Text.lines str + dropFirstIf f = \case + h : t | f h -> t + x -> x + dropLastIf f = reverse . dropFirstIf f . reverse + in Text.unlines + . dropLastIf Text.null + . dropFirstIf Text.null + . map (Text.drop stripLen) + $ Text.lines str runTranscript :: Codebase -> Transcript -> IO TranscriptOutput runTranscript (Codebase codebasePath fmt) transcript = do diff --git a/unison-cli/tests/Unison/Test/UriParser.hs b/unison-cli/tests/Unison/Test/UriParser.hs index 4c64958f0e..dee21c7416 100644 --- a/unison-cli/tests/Unison/Test/UriParser.hs +++ b/unison-cli/tests/Unison/Test/UriParser.hs @@ -6,14 +6,9 @@ import Data.These (These (..)) import Data.Void (Void) import EasyTest import Text.Megaparsec qualified as P -import Unison.Codebase.Editor.RemoteRepo - ( ReadRemoteNamespace (..), - ) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..)) import Unison.Codebase.Editor.UriParser qualified as UriParser -import Unison.Codebase.Path qualified as Path -import Unison.Codebase.ShortCausalHash (ShortCausalHash (..)) import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) -import Unison.NameSegment.Internal (NameSegment (NameSegment)) import Unison.Project (ProjectBranchSpecifier (..)) test :: Test () @@ -38,9 +33,6 @@ test = ] ] -mkPath :: [Text] -> Path.Path -mkPath = Path.fromList . fmap NameSegment - branchR :: These Text Text -> ReadRemoteNamespace (These ProjectName ProjectBranchName) branchR = ReadShare'ProjectBranch . \case @@ -55,9 +47,6 @@ branchW = That branch -> That (UnsafeProjectBranchName branch) These project branch -> These (UnsafeProjectName project) (UnsafeProjectBranchName branch) -sch :: Text -> Maybe ShortCausalHash -sch = Just . ShortCausalHash - -- | @parserTests name parser goodCases badCases@ tests @parser@ against each case in @goodCases@ and @badCases@, -- expecting success or failure, respectively. parserTests :: (Eq a, Show a) => Text -> P.Parsec Void Text a -> [(Text, a)] -> [Text] -> Test () diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index d7952578d9..b916cc094f 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -387,13 +387,13 @@ test-suite cli-tests , code-page , containers , cryptonite - , directory , easytest , extra , here , lens , lsp-types , megaparsec + , safe , temporary , text , these diff --git a/unison-core/package.yaml b/unison-core/package.yaml index 0df2aff34a..4bb512612c 100644 --- a/unison-core/package.yaml +++ b/unison-core/package.yaml @@ -42,6 +42,7 @@ tests: - base - code-page - easytest + - megaparsec - text - these - unison-core diff --git a/unison-core/src/Unison/ABT.hs b/unison-core/src/Unison/ABT.hs index d838b2a730..b174412829 100644 --- a/unison-core/src/Unison/ABT.hs +++ b/unison-core/src/Unison/ABT.hs @@ -18,12 +18,9 @@ module Unison.ABT Term (..), Term' (..), Var (..), - V (..), Subst (..), -- * Combinators & Traversals - fresh, - unvar, freshenS, freshInBoth, freshenBothWrt, @@ -47,7 +44,6 @@ module Unison.ABT foreachSubterm, freeVarOccurrences, isFreeIn, - occurrences, extraMap, vmap, vmapM, @@ -59,7 +55,6 @@ module Unison.ABT substInheritAnnotation, substsInheritAnnotation, find, - find', FindAction (..), containsExpression, rewriteExpression, @@ -69,7 +64,6 @@ module Unison.ABT rewriteDown_, -- * Safe Term constructors & Patterns - annotate, annotatedVar, var, tm, @@ -78,13 +72,11 @@ module Unison.ABT absChain, absChain', abs', - absr, unabs, unabsA, dropAbs, cycle, cycle', - cycler, pattern Abs', pattern Abs'', pattern AbsN', @@ -156,31 +148,6 @@ baseFunctor_ f t = Tm fx -> Tm <$> f (fx) x -> pure x --- deriving instance (Data a, Data v, Typeable f, Data (f (Term f v a)), Ord v) => Data (Term f v a) - -data V v = Free v | Bound v deriving (Eq, Ord, Show, Functor) - -unvar :: V v -> v -unvar (Free v) = v -unvar (Bound v) = v - -instance (Var v) => Var (V v) where - freshIn s v = freshIn (Set.map unvar s) <$> v - -wrap :: (Functor f, Foldable f, Var v) => v -> Term f (V v) a -> (V v, Term f (V v) a) -wrap v t = - if Set.member (Free v) (freeVars t) - then let v' = fresh t (Bound v) in (v', rename (Bound v) v' t) - else (Bound v, t) - -wrap' :: - (Functor f, Foldable f, Var v) => - v -> - Term f (V v) a -> - (V v -> Term f (V v) a -> c) -> - c -wrap' v t f = uncurry f (wrap v t) - -- Annotate the tree with the set of bound variables at each node. annotateBound :: (Ord v, Foldable f, Functor f) => Term f v a -> Term f v (a, Set v) annotateBound = go Set.empty @@ -197,10 +164,6 @@ annotateBound = go Set.empty isFreeIn :: (Ord v) => v -> Term f v a -> Bool isFreeIn v t = Set.member v (freeVars t) --- | Replace the annotation with the given argument. -annotate :: a -> Term f v a -> Term f v a -annotate a (Term fvs _ out) = Term fvs a out - amap :: (Functor f, Foldable f, Ord v) => (a -> a2) -> Term f v a -> Term f v a2 amap = amap' . const @@ -263,13 +226,6 @@ abs = abs' () abs' :: (Ord v) => a -> v -> Term f v a -> Term f v a abs' = U.Core.ABT.abs -absr :: (Functor f, Foldable f, Var v) => v -> Term f (V v) () -> Term f (V v) () -absr = absr' () - --- | Rebuild an `abs`, renaming `v` to avoid capturing any `Free v` in `body`. -absr' :: (Functor f, Foldable f, Var v) => a -> v -> Term f (V v) a -> Term f (V v) a -absr' a v body = wrap' v body $ \v body -> abs' a v body - absChain :: (Ord v) => [v] -> Term f v () -> Term f v () absChain vs t = foldr abs t vs @@ -288,12 +244,6 @@ cycle = cycle' () cycle' :: a -> Term f v a -> Term f v a 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 - -cycler :: (Functor f, Foldable f, Var v) => [v] -> Term f (V v) () -> Term f (V v) () -cycler = cycler' () - renames :: (Foldable f, Functor f, Var v) => Map v v -> @@ -341,9 +291,6 @@ changeVars m t = case out t of Just v -> annotatedVar (annotation t) v Tm v -> tm' (annotation t) (changeVars m <$> v) -fresh :: (Var v) => Term f v a -> v -> v -fresh t = freshIn (freeVars t) - -- Numbers the free vars by the position where they're first -- used within the term. See usage in `Type.normalizeForallOrder` numberedFreeVars :: (Ord v, Foldable f) => Term f v a -> Map v Int @@ -375,15 +322,6 @@ substs :: Term f v a substs replacements body = foldr (uncurry subst) body (reverse replacements) --- Count the number times the given variable appears free in the term -occurrences :: (Foldable f, Var v) => v -> Term f v a -> Int -occurrences v t | not (v `isFreeIn` t) = 0 -occurrences v t = case out t of - Var v2 -> if v == v2 then 1 else 0 - Cycle t -> occurrences v t - Abs v2 t -> if v == v2 then 0 else occurrences v t - Tm t -> foldl' (\s t -> s + occurrences v t) 0 $ Foldable.toList t - rebuildUp :: (Ord v, Foldable f, Functor f) => (f (Term f v a) -> f (Term f v a)) -> @@ -646,13 +584,6 @@ find p t = case p t of Abs _ body -> Unison.ABT.find p body Tm body -> Foldable.concat (Unison.ABT.find p <$> body) -find' :: - (Ord v, Foldable f, Functor f) => - (Term f v a -> Bool) -> - Term f v a -> - [Term f v a] -find' p = Unison.ABT.find (\t -> if p t then Found t else Continue) - components :: (Var v) => [(v, Term f v a)] -> [[(v, Term f v a)]] components = Components.components freeVars diff --git a/unison-core/src/Unison/ABT/Normalized.hs b/unison-core/src/Unison/ABT/Normalized.hs index b04bb439d3..d89ba58501 100644 --- a/unison-core/src/Unison/ABT/Normalized.hs +++ b/unison-core/src/Unison/ABT/Normalized.hs @@ -16,7 +16,6 @@ module Unison.ABT.Normalized alpha, renames, rename, - transform, ) where @@ -186,11 +185,3 @@ rename :: Term f v -> Term f v rename old new = renames (Map.singleton new 1) (Map.singleton old new) - -transform :: - (Var v, Bifunctor g, Bifoldable f, Bifoldable g) => - (forall a b. f a b -> g a b) -> - Term f v -> - Term g v -transform phi (TTm body) = TTm . second (transform phi) $ phi body -transform phi (TAbs u body) = TAbs u $ transform phi body diff --git a/unison-core/src/Unison/ConstructorType.hs b/unison-core/src/Unison/ConstructorType.hs index a0e2b2940b..a488f05f50 100644 --- a/unison-core/src/Unison/ConstructorType.hs +++ b/unison-core/src/Unison/ConstructorType.hs @@ -4,4 +4,4 @@ module Unison.ConstructorType where import Unison.Prelude -data ConstructorType = Data | Effect deriving (Eq, Ord, Show, Enum, Generic) +data ConstructorType = Data | Effect deriving (Eq, Ord, Show, Generic) diff --git a/unison-core/src/Unison/DataDeclaration.hs b/unison-core/src/Unison/DataDeclaration.hs index 5972bd9abe..deaaef138a 100644 --- a/unison-core/src/Unison/DataDeclaration.hs +++ b/unison-core/src/Unison/DataDeclaration.hs @@ -8,7 +8,6 @@ module Unison.DataDeclaration Modifier (..), allVars, asDataDecl, - bindReferences, constructorCount, constructorNames, constructors, @@ -18,11 +17,8 @@ module Unison.DataDeclaration constructorIds, declConstructorReferents, declTypeDependencies, - labeledDeclTypeDependencies, - labeledDeclDependenciesIncludingSelf, declFields, typeDependencies, - labeledTypeDependencies, unhashComponent, mkDataDecl', mkEffectDecl', @@ -45,9 +41,6 @@ import Unison.ABT qualified as ABT import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorType qualified as CT import Unison.DataDeclaration.ConstructorId (ConstructorId) -import Unison.LabeledDependency qualified as LD -import Unison.Name qualified as Name -import Unison.Names.ResolutionResult qualified as Names import Unison.Prelude import Unison.Reference (Reference, TypeReference) import Unison.Reference qualified as Reference @@ -72,28 +65,6 @@ asDataDecl = either toDataDecl id declTypeDependencies :: (Ord v) => Decl v a -> Set Reference declTypeDependencies = either (typeDependencies . toDataDecl) typeDependencies -labeledDeclTypeDependencies :: (Ord v) => Decl v a -> Set LD.LabeledDependency -labeledDeclTypeDependencies = Set.map LD.TypeReference . declTypeDependencies - --- | Compute the dependencies of a data declaration, --- including the type itself and references for each of its constructors. --- --- NOTE: You may prefer labeledDeclDependenciesIncludingSelfAndFieldAccessors in --- Unison.DataDeclaration.Dependencies, it also includes Referents for accessors of record --- fields. -labeledDeclDependenciesIncludingSelf :: (Ord v) => Reference.TypeReference -> Decl v a -> Set LD.LabeledDependency -labeledDeclDependenciesIncludingSelf selfRef decl = - labeledDeclTypeDependencies decl <> (Set.singleton $ LD.TypeReference selfRef) <> labeledConstructorRefs - where - labeledConstructorRefs :: Set LD.LabeledDependency - labeledConstructorRefs = - case selfRef of - Reference.Builtin {} -> mempty - Reference.DerivedId selfRefId -> - declConstructorReferents selfRefId decl - & fmap (LD.TermReferent . fmap Reference.DerivedId) - & Set.fromList - constructorType :: Decl v a -> CT.ConstructorType constructorType = \case Left {} -> CT.Effect @@ -205,18 +176,6 @@ allVars (DataDeclaration _ _ bound ctors) = allVars' :: (Ord v) => Decl v a -> Set v allVars' = allVars . either toDataDecl id -bindReferences :: - (Var v) => - (v -> Name.Name) -> - Set v -> - Map Name.Name Reference -> - DataDeclaration v a -> - Names.ResolutionResult a (DataDeclaration v a) -bindReferences unsafeVarToName keepFree names (DataDeclaration m a bound constructors) = do - constructors <- for constructors $ \(a, v, ty) -> - (a,v,) <$> Type.bindReferences unsafeVarToName keepFree names ty - pure $ DataDeclaration m a bound constructors - -- | All references to types mentioned in the given data declaration's fields/constructors -- Note: Does not include references to the constructors or the decl itself -- (unless the decl is self-referential) @@ -226,9 +185,6 @@ typeDependencies :: (Ord v) => DataDeclaration v a -> Set TypeReference typeDependencies dd = Set.unions (Type.dependencies <$> constructorTypes dd) -labeledTypeDependencies :: (Ord v) => DataDeclaration v a -> Set LD.LabeledDependency -labeledTypeDependencies = Set.map LD.TypeReference . typeDependencies - mkEffectDecl' :: Modifier -> a -> [v] -> [(a, v, Type v a)] -> EffectDeclaration v a mkEffectDecl' m a b cs = EffectDeclaration (DataDeclaration m a b cs) @@ -237,13 +193,6 @@ mkDataDecl' :: Modifier -> a -> [v] -> [(a, v, Type v a)] -> DataDeclaration v a mkDataDecl' = DataDeclaration -data F a - = Type (Type.F a) - | LetRec [a] a - | Constructors [a] - | Modified Modifier a - deriving (Functor, Foldable, Show) - updateDependencies :: (Ord v) => Map Reference Reference -> Decl v a -> Decl v a updateDependencies typeUpdates decl = back $ diff --git a/unison-core/src/Unison/DeclNameLookup.hs b/unison-core/src/Unison/DeclNameLookup.hs index 70543061fc..a8f381e182 100644 --- a/unison-core/src/Unison/DeclNameLookup.hs +++ b/unison-core/src/Unison/DeclNameLookup.hs @@ -6,7 +6,6 @@ module Unison.DeclNameLookup where import Data.Map.Strict qualified as Map -import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) import Unison.Name (Name) import Unison.Prelude @@ -38,7 +37,6 @@ data DeclNameLookup = DeclNameLookup declToConstructors :: !(Map Name [Name]) } deriving stock (Generic) - deriving (Semigroup) via (GenericSemigroupMonoid DeclNameLookup) expectDeclName :: (HasCallStack) => DeclNameLookup -> Name -> Name expectDeclName DeclNameLookup {constructorToDecl} x = diff --git a/unison-core/src/Unison/HashQualified.hs b/unison-core/src/Unison/HashQualified.hs index d143dc4740..2808fee53b 100644 --- a/unison-core/src/Unison/HashQualified.hs +++ b/unison-core/src/Unison/HashQualified.hs @@ -1,6 +1,5 @@ module Unison.HashQualified where -import Data.Text qualified as Text import Unison.ConstructorReference (ConstructorReference) import Unison.ConstructorReference qualified as ConstructorReference import Unison.Name (Name) @@ -35,26 +34,6 @@ toName = \case HashQualified name _ -> Just name HashOnly _ -> Nothing --- Sort the list of names by length of segments: smaller number of --- segments is listed first. NameOnly < Hash qualified < Hash only --- --- Examples: --- [foo.bar.baz, bar.baz] -> [bar.baz, foo.bar.baz] --- [#a29dj2k91, foo.bar.baz] -> [foo.bar.baz, #a29dj2k91] --- [foo.bar#abc, foo.bar] -> [foo.bar, foo.bar#abc] --- [.foo.bar, foo.bar] -> [foo.bar, .foo.bar] -sortByLength :: [HashQualified Name] -> [HashQualified Name] -sortByLength hs = sortOn f hs - where - 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 -hasHash = isJust . toHash - toHash :: HashQualified n -> Maybe ShortHash toHash = \case NameOnly _ -> Nothing @@ -77,9 +56,6 @@ take i = \case HashOnly s -> HashOnly (SH.shortenTo i s) HashQualified n s -> if i == 0 then NameOnly n else HashQualified n (SH.shortenTo i s) -toStringWith :: (n -> String) -> HashQualified n -> String -toStringWith f = Text.unpack . toTextWith (Text.pack . f) - toTextWith :: (n -> Text) -> HashQualified n -> Text toTextWith f = \case NameOnly name -> f name @@ -106,19 +82,6 @@ fromPattern r = HashOnly $ ConstructorReference.toShortHash r fromName :: n -> HashQualified n fromName = NameOnly --- todo: find this logic elsewhere and replace with call to this -matchesNamedReferent :: Name -> Referent -> HashQualified Name -> Bool -matchesNamedReferent n r = \case - NameOnly n' -> n' == n - HashOnly sh -> sh `SH.isPrefixOf` Referent.toShortHash r - HashQualified n' sh -> n' == n && sh `SH.isPrefixOf` Referent.toShortHash r - -matchesNamedReference :: Name -> Reference -> HashQualified Name -> Bool -matchesNamedReference n r = \case - NameOnly n' -> n' == n - HashOnly sh -> sh `SH.isPrefixOf` Reference.toShortHash r - HashQualified n' sh -> n' == n && sh `SH.isPrefixOf` Reference.toShortHash r - -- Use `requalify hq . Referent.Ref` if you want to pass in a `Reference`. requalify :: HashQualified Name -> Referent -> HashQualified Name requalify hq r = case hq of diff --git a/unison-core/src/Unison/HashQualifiedPrime.hs b/unison-core/src/Unison/HashQualifiedPrime.hs index 19c341f4d6..9c5dffc1b4 100644 --- a/unison-core/src/Unison/HashQualifiedPrime.hs +++ b/unison-core/src/Unison/HashQualifiedPrime.hs @@ -25,12 +25,6 @@ toHQ = \case NameOnly n -> HQ.NameOnly n HashQualified n sh -> HQ.HashQualified n sh -fromHQ :: HQ.HashQualified n -> Maybe (HashQualified n) -fromHQ = \case - HQ.NameOnly n -> Just $ NameOnly n - HQ.HashQualified n sh -> Just $ HashQualified n sh - HQ.HashOnly {} -> Nothing - -- | Like 'fromHQ', but if the 'HQ.HashQualified' is just a 'ShortHash', return it on the 'Left', rather than as a -- 'Nothing'. fromHQ2 :: HQ.HashQualified n -> Either ShortHash (HashQualified n) @@ -52,17 +46,6 @@ take i = \case n@(NameOnly _) -> n HashQualified n s -> if i == 0 then NameOnly n else HashQualified n (SH.shortenTo i s) -toNameOnly :: HashQualified n -> HashQualified n -toNameOnly = fromName . toName - -toHash :: HashQualified n -> Maybe ShortHash -toHash = \case - NameOnly _ -> Nothing - HashQualified _ sh -> Just sh - -toStringWith :: (n -> String) -> HashQualified n -> String -toStringWith f = Text.unpack . toTextWith (Text.pack . f) - toTextWith :: (n -> Text) -> HashQualified n -> Text toTextWith f = \case NameOnly name -> f name @@ -79,11 +62,6 @@ fromNamedReference n r = HashQualified n (Reference.toShortHash r) fromName :: n -> HashQualified n fromName = NameOnly -fromNameHash :: n -> Maybe ShortHash -> HashQualified n -fromNameHash name = \case - Nothing -> NameOnly name - Just hash -> HashQualified name hash - matchesNamedReferent :: (Eq n) => n -> Referent -> HashQualified n -> Bool matchesNamedReferent n r = \case NameOnly n' -> n' == n @@ -100,13 +78,6 @@ requalify hq r = case hq of NameOnly n -> fromNamedReferent n r HashQualified n _ -> fromNamedReferent n r --- | Sort the list of names by length of segments: smaller number of segments is listed first. NameOnly < HashQualified -sortByLength :: [HashQualified Name] -> [HashQualified Name] -sortByLength = - sortOn \case - NameOnly name -> (length (Name.reverseSegments name), Nothing, Name.isAbsolute name) - HashQualified name hash -> (length (Name.reverseSegments name), Just hash, Name.isAbsolute name) - instance (Name.Alphabetical n) => Name.Alphabetical (HashQualified n) where compareAlphabetical (NameOnly n) (NameOnly n2) = Name.compareAlphabetical n n2 -- NameOnly comes first diff --git a/unison-core/src/Unison/Hashable.hs b/unison-core/src/Unison/Hashable.hs index 69f7173bef..8e1605aae7 100644 --- a/unison-core/src/Unison/Hashable.hs +++ b/unison-core/src/Unison/Hashable.hs @@ -1,6 +1,5 @@ module Unison.Hashable ( accumulate', - hash, Accumulate (..), Token (..), ) @@ -11,17 +10,9 @@ import Data.ByteArray qualified as BA import Data.ByteString qualified as B import Data.ByteString.Builder (doubleBE, int64BE, toLazyByteString, word64BE) import Data.ByteString.Lazy qualified as BL -import Data.Map qualified as Map -import Data.Set qualified as Set import Unison.Hash (Hash) import Unison.Hash qualified as Hash import Unison.Prelude -import Unison.Util.Relation (Relation) -import Unison.Util.Relation qualified as Relation -import Unison.Util.Relation3 (Relation3) -import Unison.Util.Relation3 qualified as Relation3 -import Unison.Util.Relation4 (Relation4) -import Unison.Util.Relation4 qualified as Relation4 data Token h = Tag !Word8 @@ -38,12 +29,8 @@ class Accumulate h where fromBytes :: ByteString -> h toBytes :: h -> ByteString -accumulateToken :: (Accumulate h, Hashable t) => t -> Token h -accumulateToken = Hashed . accumulate' - -hash, accumulate' :: (Accumulate h, Hashable t) => t -> h +accumulate' :: (Accumulate h, Hashable t) => t -> h accumulate' = accumulate . tokens -hash = accumulate' -- | NOTE: This typeclass is distinct from 'Unison.Hashing.V2.Hashable', which is the -- content-based hashish class used for Unison types & terms. @@ -54,54 +41,9 @@ hash = accumulate' class Hashable t where tokens :: (Accumulate h) => t -> [Token h] -instance (Hashable a) => Hashable [a] where - tokens = map accumulateToken - -instance (Hashable a, Hashable b) => Hashable (a, b) where - tokens (a, b) = [accumulateToken a, accumulateToken b] - -instance (Hashable a) => Hashable (Set.Set a) where - tokens = tokens . Set.toList - -instance (Hashable k, Hashable v) => Hashable (Map.Map k v) where - tokens = tokens . Map.toList - -instance (Hashable a, Hashable b) => Hashable (Relation a b) where - tokens = tokens . Relation.toList - -instance (Hashable d1, Hashable d2, Hashable d3) => Hashable (Relation3 d1 d2 d3) where - tokens s = [accumulateToken $ Relation3.toNestedList s] - -instance (Hashable d1, Hashable d2, Hashable d3, Hashable d4) => Hashable (Relation4 d1 d2 d3 d4) where - tokens s = [accumulateToken $ Relation4.toNestedList s] - -instance Hashable () where - tokens _ = [] - -instance Hashable Double where - tokens d = [Double d] - -instance Hashable Text where - tokens s = [Text s] - -instance Hashable Char where - tokens c = [Nat $ fromIntegral $ fromEnum c] - instance Hashable ByteString where tokens bs = [Bytes bs] -instance Hashable Word64 where - tokens w = [Nat w] - -instance Hashable Int64 where - tokens w = [Int w] - -instance Hashable Bool where - tokens b = [Tag . fromIntegral $ fromEnum b] - -instance Hashable Hash where - tokens h = [Bytes (Hash.toByteString h)] - instance Accumulate Hash where accumulate = fromBytes . BA.convert . CH.hashFinalize . go CH.hashInit where diff --git a/unison-core/src/Unison/LabeledDependency.hs b/unison-core/src/Unison/LabeledDependency.hs index 0f17f18387..ea2cbdeade 100644 --- a/unison-core/src/Unison/LabeledDependency.hs +++ b/unison-core/src/Unison/LabeledDependency.hs @@ -9,7 +9,6 @@ module Unison.LabeledDependency dataConstructor, effectConstructor, fold, - referents, LabeledDependency (..), pattern ConReference, pattern TermReference, @@ -17,10 +16,8 @@ module Unison.LabeledDependency ) where -import Data.Set qualified as Set import Unison.ConstructorReference (ConstructorReference) import Unison.ConstructorType (ConstructorType (Data, Effect)) -import Unison.Prelude hiding (fold) import Unison.Reference (Id, Reference, Reference' (DerivedId)) import Unison.Referent (Referent) import Unison.Referent qualified as Referent @@ -62,9 +59,6 @@ dataConstructor r = ConReference r Data effectConstructor :: ConstructorReference -> LabeledDependency effectConstructor r = ConReference r Effect -referents :: (Foldable f) => f Referent -> Set LabeledDependency -referents rs = Set.fromList (map referent $ toList rs) - fold :: (Reference -> a) -> (Referent -> a) -> LabeledDependency -> a fold f _ (TypeReference r) = f r fold _ g (TermReferent r) = g r diff --git a/unison-core/src/Unison/Name.hs b/unison-core/src/Unison/Name.hs index 2b8cb8f83d..0ecd2209f8 100644 --- a/unison-core/src/Unison/Name.hs +++ b/unison-core/src/Unison/Name.hs @@ -13,13 +13,10 @@ module Unison.Name countSegments, isAbsolute, isRelative, - isPrefixOf, beginsWithSegment, endsWith, endsWithReverseSegments, - endsWithSegments, stripReversedPrefix, - tryStripReversedPrefix, reverseSegments, segments, suffixes, @@ -46,7 +43,6 @@ module Unison.Name suffixifyByHashName, sortByText, sortNamed, - sortNames, splits, suffixFrom, @@ -157,22 +153,6 @@ beginsWithSegment :: Name -> NameSegment -> Bool beginsWithSegment name segment = segment == List.NonEmpty.head (segments name) --- | @endsWithSegments x y@ returns whether @x@ ends with @y@. --- --- >>> endsWithSegments "a.b.c" ["b", "c"] --- True --- --- >>> endsWithSegments "a.b.c" ["d"] --- False --- --- >>> endsWithSegments "a.b.c" [] --- True --- --- /O(n)/, where /n/ is the number of name segments. -endsWithSegments :: Name -> [NameSegment] -> Bool -endsWithSegments name ss = - endsWithReverseSegments name (reverse ss) - -- | Like 'endsWithSegments', but accepts a list of name segments in reverse order. -- -- Slightly more efficient than 'endsWithSegments'. @@ -201,36 +181,6 @@ stripReversedPrefix (Name p segs) suffix = do nonEmptyStripped <- List.NonEmpty.nonEmpty stripped pure $ Name p nonEmptyStripped --- | Like 'stripReversedPrefix' but if the prefix doesn't match, or if it would strip the --- entire name away just return the original name. --- --- >>> tryStripReversedPrefix (fromReverseSegments ("c" :| ["b", "a"])) ["b", "a"] --- Name Relative (NameSegment {toText = "c"} :| []) --- >>> tryStripReversedPrefix (fromReverseSegments ("y" :| ["x"])) ["b", "a"] --- Name Relative (NameSegment {toText = "y"} :| [NameSegment {toText = "x"}]) --- --- >>> tryStripReversedPrefix (fromReverseSegments ("c" :| ["b", "a"])) ["b", "a"] --- Name Relative (NameSegment {toText = "c"} :| []) -tryStripReversedPrefix :: Name -> [NameSegment] -> Name -tryStripReversedPrefix n s = fromMaybe n (stripReversedPrefix n s) - --- | @isPrefixOf x y@ returns whether @x@ is a prefix of (or equivalent to) @y@, which is false if one name is relative --- and the other is absolute. --- --- >>> isPrefixOf "a.b" "a.b.c" --- True --- --- >>> isPrefixOf "a.b.c" "a.b.c" --- True --- --- >>> isPrefixOf ".a.b" "a.b.c" --- False --- --- /O(n)/, where /n/ is the number of name segments. -isPrefixOf :: Name -> Name -> Bool -isPrefixOf (Name p0 ss0) (Name p1 ss1) = - p0 == p1 && List.isPrefixOf (reverse (toList ss0)) (reverse (toList ss1)) - joinDot :: (HasCallStack) => Name -> Name -> Name joinDot n1@(Name p0 ss0) n2@(Name p1 ss1) = case p1 of @@ -430,10 +380,6 @@ sortNamed :: (Name -> Text) -> (a -> Name) -> [a] -> [a] sortNamed toText f = sortByText (toText . f) -sortNames :: (Name -> Text) -> [Name] -> [Name] -sortNames toText = - sortNamed toText id - -- | Return all "splits" of a relative name, which pair a possibly-empty prefix of name segments with a suffix, such -- that the original name is equivalent to @prefix + suffix@. -- diff --git a/unison-core/src/Unison/Name/Forward.hs b/unison-core/src/Unison/Name/Forward.hs index 164be3d542..cea87e1e9b 100644 --- a/unison-core/src/Unison/Name/Forward.hs +++ b/unison-core/src/Unison/Name/Forward.hs @@ -1,7 +1,6 @@ module Unison.Name.Forward where -import Data.List qualified as List -import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) +import Data.List.NonEmpty (NonEmpty) import Unison.Name qualified as Name import Unison.Name.Internal (Name) import Unison.NameSegment (NameSegment) @@ -11,9 +10,3 @@ newtype ForwardName = ForwardName {toList :: NonEmpty NameSegment} deriving (Eq, -- | O(d) fromName :: Name -> ForwardName fromName n = ForwardName $ Name.segments n - -stripNamePrefix :: ForwardName -> ForwardName -> Maybe ForwardName -stripNamePrefix (ForwardName (p :| ps)) (ForwardName (n :| ns)) = - if p /= n - then Nothing - else ForwardName <$> maybe Nothing nonEmpty (List.stripPrefix ps ns) diff --git a/unison-core/src/Unison/Names.hs b/unison-core/src/Unison/Names.hs index f2de8182bd..7d17e380d2 100644 --- a/unison-core/src/Unison/Names.hs +++ b/unison-core/src/Unison/Names.hs @@ -3,21 +3,15 @@ module Unison.Names ( Names (..), - addTerm, - addType, labeledReferences, conflicts, contains, difference, filter, - filterByHQs, - filterBySHs, - filterTypes, fromReferenceIds, fromUnconflictedReferenceIds, map, makeAbsolute, - makeRelative, fuzzyFind, hqName, hqTermName, @@ -30,12 +24,9 @@ module Unison.Names _hqTypeAliases, mapNames, prefix0, - restrictReferences, refTermsNamed, - refTermsHQNamed, referenceIds, termReferences, - termReferents, typeReferences, termsNamed, typesNamed, @@ -80,8 +71,6 @@ import Unison.Reference (Reference, TermReference, TermReferenceId, TypeReferenc import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent -import Unison.ShortHash (ShortHash) -import Unison.ShortHash qualified as SH import Unison.Util.Defns (Defns (..), DefnsF) import Unison.Util.Nametree (Nametree, unflattenNametree) import Unison.Util.Relation (Relation) @@ -135,9 +124,6 @@ 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 :: @@ -201,15 +187,6 @@ labeledReferences Names {..} = Set.map LD.typeRef (Relation.ran types) <> Set.map LD.referent (Relation.ran terms) -termReferents :: Names -> Set Referent -termReferents Names {..} = R.ran terms - -restrictReferences :: Set Reference -> Names -> Names -restrictReferences refs Names {..} = Names terms' types' - where - terms' = R.filterRan ((`Set.member` refs) . Referent.toReference) terms - types' = R.filterRan (`Set.member` refs) types - -- | Prefer names in the first argument, falling back to names in the second. -- This can be used to shadow names in the codebase with names in a unison file for instance: -- e.g. @shadowing scratchFileNames codebaseNames@ @@ -233,19 +210,6 @@ refTermsNamed :: Names -> Name -> Set TermReference refTermsNamed names n = Set.mapMaybe Referent.toTermReference (termsNamed names n) --- | Get all terms with a specific hash-qualified name. -refTermsHQNamed :: Names -> HQ.HashQualified Name -> Set TermReference -refTermsHQNamed names = \case - HQ.NameOnly name -> refTermsNamed names name - HQ.HashOnly _hash -> Set.empty - HQ.HashQualified name hash -> - let f :: Referent -> Maybe TermReference - f ref0 = do - ref <- Referent.toTermReference ref0 - guard (Reference.isPrefixOf hash ref) - Just ref - in Set.mapMaybe f (termsNamed names name) - typesNamed :: Names -> Name -> Set TypeReference typesNamed = flip R.lookupDom . (.types) @@ -261,12 +225,6 @@ termAliases names n r = Set.delete n $ namesForReferent names r typeAliases :: Names -> Name -> TypeReference -> Set Name typeAliases names n r = Set.delete n $ namesForReference names r -addType :: Name -> TypeReference -> Names -> Names -addType n r = (<> fromTypes [(n, r)]) - -addTerm :: Name -> Referent -> Names -> Names -addTerm n r = (<> fromTerms [(n, r)]) - -- | Like hqTermName and hqTypeName, but considers term and type names to -- conflict with each other (so will hash-qualify if there is e.g. both a term -- and a type named "foo"). @@ -365,26 +323,6 @@ prefix0 n = filter :: (Name -> Bool) -> Names -> Names filter f (Names terms types) = Names (R.filterDom f terms) (R.filterDom f types) --- currently used for filtering before a conditional `add` -filterByHQs :: Set (HQ'.HashQualified Name) -> Names -> Names -filterByHQs hqs Names {..} = Names terms' types' - where - terms' = R.filter f terms - types' = R.filter g types - f (n, r) = any (HQ'.matchesNamedReferent n r) hqs - g (n, r) = any (HQ'.matchesNamedReference n r) hqs - -filterBySHs :: Set ShortHash -> Names -> Names -filterBySHs shs Names {..} = Names terms' types' - where - terms' = R.filter f terms - types' = R.filter g types - f (_n, r) = any (`SH.isPrefixOf` Referent.toShortHash r) shs - g (_n, r) = any (`SH.isPrefixOf` Reference.toShortHash r) shs - -filterTypes :: (Name -> Bool) -> Names -> Names -filterTypes f (Names terms types) = Names terms (R.filterDom f types) - difference :: Names -> Names -> Names difference a b = Names diff --git a/unison-core/src/Unison/NamesWithHistory.hs b/unison-core/src/Unison/NamesWithHistory.hs index 4ec19c2788..34279d3717 100644 --- a/unison-core/src/Unison/NamesWithHistory.hs +++ b/unison-core/src/Unison/NamesWithHistory.hs @@ -5,16 +5,12 @@ module Unison.NamesWithHistory ( diff, - push, lookupHQType, - lookupHQType', lookupHQTerm, - lookupHQTerm', lookupRelativeHQType, lookupRelativeHQType', lookupRelativeHQTerm, lookupRelativeHQTerm', - hasTermNamed, hasTypeNamed, typeName, termNamesByLength, @@ -26,8 +22,6 @@ module Unison.NamesWithHistory ) where -import Data.List.Extra (nubOrd) -import Data.Map qualified as Map import Data.Set qualified as Set import Unison.ConstructorReference (ConstructorReference) import Unison.ConstructorType qualified as CT @@ -42,7 +36,6 @@ import Unison.Prelude import Unison.Reference as Reference import Unison.Referent as Referent import Unison.ShortHash (ShortHash) -import Unison.Util.List qualified as List import Unison.Util.Relation (Relation) import Unison.Util.Relation qualified as R import Unison.Util.Relation qualified as Relation @@ -77,32 +70,6 @@ data Diff = Diff } deriving (Show) -push :: Names -> Names -> Names -push n0 ns = unionLeft0 n1 ns - where - n1 = suffixify0 n0 - unionLeft0 :: Names -> Names -> Names - unionLeft0 n1 n2 = Names terms' types' - where - terms' = terms n1 <> R.subtractDom (R.dom $ terms n1) (terms n2) - types' = types n1 <> R.subtractDom (R.dom $ types n1) (types n2) - -- For all names in `ns`, (ex: foo.bar.baz), generate the list of suffixes - -- of that name [[foo.bar.baz], [bar.baz], [baz]]. Any suffix which uniquely - -- refers to a single definition is added as an alias - -- - -- If `Names` were more like a `[Names]`, then `push` could just cons - -- onto the list and we could get rid of all this complex logic. The - -- complexity here is that we have to "bake the shadowing" into a single - -- Names, taking into account suffix-based name resolution. - suffixify0 :: Names -> Names - suffixify0 ns = ns <> suffixNs - where - suffixNs = Names (R.fromList uniqueTerms) (R.fromList uniqueTypes) - terms' = List.multimap [(n, ref) | (n0, ref) <- R.toList (terms ns), n <- Name.suffixes n0] - types' = List.multimap [(n, ref) | (n0, ref) <- R.toList (types ns), n <- Name.suffixes n0] - uniqueTerms = [(n, ref) | (n, nubOrd -> [ref]) <- Map.toList terms'] - uniqueTypes = [(n, ref) | (n, nubOrd -> [ref]) <- Map.toList types'] - -- Find all types whose name has a suffix matching the provided `HashQualified`, -- returning types with relative names if they exist, and otherwise -- returning types with absolute names. @@ -124,14 +91,6 @@ lookupHQType :: SearchType -> HashQualified Name -> Names -> Set TypeReference lookupHQType searchType = lookupHQRef searchType Names.types Reference.isPrefixOf --- | Find all types whose name has a suffix matching the provided 'HashQualified''. See 'lookupHQType'. -lookupHQType' :: SearchType -> HQ'.HashQualified Name -> Names -> Set TypeReference -lookupHQType' searchType = - lookupHQType searchType . HQ'.toHQ - -hasTermNamed :: SearchType -> Name -> Names -> Bool -hasTermNamed searchType n ns = not (Set.null $ lookupHQTerm searchType (HQ.NameOnly n) ns) - hasTypeNamed :: SearchType -> Name -> Names -> Bool hasTypeNamed searchType n ns = not (Set.null $ lookupHQType searchType (HQ.NameOnly n) ns) @@ -156,11 +115,6 @@ lookupHQTerm :: SearchType -> HashQualified Name -> Names -> Set Referent lookupHQTerm searchType = lookupHQRef searchType Names.terms Referent.isPrefixOf --- | Find all terms whose name has a suffix matching the provided 'HashQualified''. See 'lookupHQTerm'. -lookupHQTerm' :: SearchType -> HQ'.HashQualified Name -> Names -> Set Referent -lookupHQTerm' searchType = - lookupHQTerm searchType . HQ'.toHQ - -- Helper that unifies looking up a set of references/referents by a hash-qualified suffix. -- -- See 'lookupHQTerm', 'lookupHQType' for monomorphic versions. diff --git a/unison-core/src/Unison/Pattern.hs b/unison-core/src/Unison/Pattern.hs index 3ebc6b22e7..428b4a2552 100644 --- a/unison-core/src/Unison/Pattern.hs +++ b/unison-core/src/Unison/Pattern.hs @@ -11,8 +11,6 @@ import Data.Set qualified as Set import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) import Unison.ConstructorType qualified as CT import Unison.DataDeclaration.ConstructorId (ConstructorId) -import Unison.LabeledDependency (LabeledDependency) -import Unison.LabeledDependency qualified as LD import Unison.Prelude import Unison.Reference (Reference) import Unison.Referent (Referent) @@ -104,10 +102,6 @@ instance Show (Pattern loc) where show (SequenceLiteral _ ps) = "Sequence " <> intercalate ", " (fmap show ps) show (SequenceOp _ ph op pt) = "Sequence " <> show ph <> " " <> show op <> " " <> show pt -application :: Pattern loc -> Bool -application (Constructor _ _ (_ : _)) = True -application _ = False - loc :: Pattern loc -> loc loc = \case Unbound loc -> loc @@ -198,12 +192,3 @@ generalizedDependencies literalType dataConstructor dataType effectConstructor e Text _ _ -> [literalType Type.textRef] Char _ _ -> [literalType Type.charRef] ) - -labeledDependencies :: Pattern loc -> Set LabeledDependency -labeledDependencies = - generalizedDependencies - LD.typeRef - (\r i -> LD.dataConstructor (ConstructorReference r i)) - LD.typeRef - (\r i -> LD.effectConstructor (ConstructorReference r i)) - LD.typeRef diff --git a/unison-core/src/Unison/Project.hs b/unison-core/src/Unison/Project.hs index 73070e7a1d..db5a1516d3 100644 --- a/unison-core/src/Unison/Project.hs +++ b/unison-core/src/Unison/Project.hs @@ -10,7 +10,6 @@ module Unison.Project projectNameToUserProjectSlugs, prependUserSlugToProjectName, ProjectBranchName, - projectBranchNameUserSlug, ProjectBranchNameKind (..), classifyProjectBranchName, ProjectBranchNameOrLatestRelease (..), @@ -282,19 +281,6 @@ classifyProjectBranchName (UnsafeProjectBranchName branchName) = Just (StructuredProjectBranchName'NothingSpecial _name) -> ProjectBranchNameKind'NothingSpecial Nothing -> error (reportBug "E800424" ("Invalid project branch name: " ++ Text.unpack branchName)) --- | Get the user slug at the beginning of a project branch name, if there is one. --- --- >>> projectBranchNameUserSlug "@arya/topic" --- Just "arya" --- --- >>> projectBranchNameUserSlug "topic" --- Nothing -projectBranchNameUserSlug :: ProjectBranchName -> Maybe Text -projectBranchNameUserSlug (UnsafeProjectBranchName branchName) = - if Text.head branchName == '@' - then Just (Text.takeWhile (/= '/') (Text.drop 1 branchName)) - else Nothing - -- | A project branch name, or the latest release of its project. data ProjectBranchNameOrLatestRelease = ProjectBranchNameOrLatestRelease'LatestRelease @@ -376,17 +362,6 @@ projectAndBranchNamesParser2 = do branch <- projectBranchNameParser False pure (ProjectAndBranchNames'Unambiguous (That branch)) --- TODO this should go away in favor of ProjectAndBranchNames -instance From (These ProjectName ProjectBranchName) Text where - from = \case - This project1 -> into @Text project1 - That branch1 -> Text.Builder.run (Text.Builder.char '/' <> Text.Builder.text (into @Text branch1)) - These project1 branch1 -> - Text.Builder.run $ - Text.Builder.text (into @Text project1) - <> Text.Builder.char '/' - <> Text.Builder.text (into @Text branch1) - instance TryFrom Text (These ProjectName ProjectBranchName) where tryFrom = maybeTryFrom (Megaparsec.parseMaybe (projectAndBranchNamesParser ProjectBranchSpecifier'Name)) @@ -429,27 +404,6 @@ fullyQualifiedProjectAndBranchNamesParser = do branch <- projectBranchNameParser False pure (ProjectAndBranch project branch) --- | @project/branch@ syntax, where the branch is optional. -instance From (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) Text where - from = \case - ProjectAndBranch project Nothing -> into @Text project - ProjectAndBranch project (Just branch) -> - Text.Builder.run $ - Text.Builder.text (into @Text project) - <> Text.Builder.char '/' - <> Text.Builder.text (into @Text branch) - -instance TryFrom Text (ProjectAndBranch ProjectName (Maybe ProjectBranchName)) where - tryFrom = - maybeTryFrom (Megaparsec.parseMaybe (projectAndOptionalBranchParser ProjectBranchSpecifier'Name)) - --- | Attempt to parse a project and branch name from a string where both are required. -instance TryFrom Text (ProjectAndBranch ProjectName ProjectBranchName) where - tryFrom = - maybeTryFrom $ \txt -> do - ProjectAndBranch projectName mayBranchName <- Megaparsec.parseMaybe (projectAndOptionalBranchParser ProjectBranchSpecifier'Name) txt - ProjectAndBranch projectName <$> mayBranchName - instance TryFrom Text (ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) where tryFrom = maybeTryFrom (Megaparsec.parseMaybe (projectAndOptionalBranchParser ProjectBranchSpecifier'NameOrLatestRelease)) @@ -480,10 +434,6 @@ instance From (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) Text wher <> Text.Builder.char '/' <> Text.Builder.text (into @Text branch) -instance TryFrom Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) where - tryFrom = - maybeTryFrom (Megaparsec.parseMaybe branchWithOptionalProjectParser) - -- Valid things: -- -- 1. branch diff --git a/unison-core/src/Unison/Reference.hs b/unison-core/src/Unison/Reference.hs index d66eea09cd..0788ea33eb 100644 --- a/unison-core/src/Unison/Reference.hs +++ b/unison-core/src/Unison/Reference.hs @@ -14,15 +14,11 @@ module Unison.Reference Id' (..), Pos, CycleSize, - Size, TermReference, TermReferenceId, TypeReference, TypeReferenceId, derivedBase32Hex, - component, - components, - groupByComponent, componentFor, componentFromLength, unsafeFromText, @@ -30,7 +26,6 @@ module Unison.Reference fromText, readSuffix, showShort, - showSuffix, toHash, toId, fromId, @@ -47,7 +42,6 @@ where import Control.Lens (Prism') import Data.Char (isDigit) import Data.Generics.Sum (_Ctor) -import Data.Map qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text import U.Codebase.Reference @@ -89,9 +83,6 @@ pattern DerivedId x = ReferenceDerived x _DerivedId :: Prism' Reference Id _DerivedId = _Ctor @"ReferenceDerived" -showSuffix :: Pos -> Text -showSuffix = Text.pack . show - readSuffix :: Text -> Either String Pos readSuffix = \case pos @@ -114,8 +105,6 @@ showShort numHashChars = SH.toText . SH.shortenTo numHashChars . toShortHash type Pos = Word64 -type Size = CycleSize - type CycleSize = Word64 -- enumerate the `a`s and associates them with corresponding `Reference.Id`s @@ -173,20 +162,3 @@ fromText t = case Text.split (== '#') t of _ -> bail where bail = Left $ "couldn't parse a Reference from " <> Text.unpack t - -component :: H.Hash -> [k] -> [(k, Id)] -component h ks = - let - in [(k, (Id h i)) | (k, i) <- ks `zip` [0 ..]] - -components :: [(H.Hash, [k])] -> [(k, Id)] -components sccs = uncurry component =<< sccs - -groupByComponent :: [(k, Reference)] -> [[(k, Reference)]] -groupByComponent refs = done $ foldl' insert Map.empty refs - where - insert m (k, r@(Derived h _)) = - Map.unionWith (<>) m (Map.fromList [(Right h, [(k, r)])]) - insert m (k, r) = - Map.unionWith (<>) m (Map.fromList [(Left r, [(k, r)])]) - done m = sortOn snd <$> toList m diff --git a/unison-core/src/Unison/Referent.hs b/unison-core/src/Unison/Referent.hs index bf89ed878f..3940e22cbc 100644 --- a/unison-core/src/Unison/Referent.hs +++ b/unison-core/src/Unison/Referent.hs @@ -8,15 +8,12 @@ module Unison.Referent Id, pattern RefId, pattern ConId, - fold, - toId, toReference, toReferenceId, toConstructorReference, toConstructorReferenceId, toTermReference, toTermReferenceId, - fromId, fromTermReference, fromTermReferenceId, fromText, @@ -38,7 +35,6 @@ import Unison.ConstructorReference (ConstructorReference, ConstructorReferenceId import Unison.ConstructorReference qualified as ConstructorReference import Unison.ConstructorType (ConstructorType) import Unison.ConstructorType qualified as CT -import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.Prelude hiding (fold) import Unison.Reference (Reference, TermReference, TermReferenceId) import Unison.Reference qualified as R @@ -77,20 +73,6 @@ pattern ConId r t = Con' r t -- referentToTerm moved to Term.fromReferent -- termToReferent moved to Term.toReferent -toId :: Referent -> Maybe Id -toId = \case - Ref (Reference.ReferenceDerived r) -> - Just (RefId r) - Con (ConstructorReference (Reference.ReferenceDerived r) i) t -> - Just (ConId (ConstructorReference r i) t) - _ -> Nothing - -fromId :: Id -> Referent -fromId = \case - RefId r -> Ref (Reference.ReferenceDerived r) - ConId (ConstructorReference r i) t -> - Con (ConstructorReference (Reference.ReferenceDerived r) i) t - -- todo: move these to ShortHash module toShortHash :: Referent -> ShortHash toShortHash = \case @@ -190,8 +172,3 @@ fromText t = refPart = Text.dropWhileEnd (/= '#') t cidPart' = Text.takeWhileEnd (/= '#') t cidPart = Text.drop 1 cidPart' - -fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a -fold fr fc = \case - Ref' r -> fr r - Con' (ConstructorReference r i) ct -> fc r i ct diff --git a/unison-core/src/Unison/ReferentPrime.hs b/unison-core/src/Unison/ReferentPrime.hs index a51aff374f..260d6de31d 100644 --- a/unison-core/src/Unison/ReferentPrime.hs +++ b/unison-core/src/Unison/ReferentPrime.hs @@ -6,14 +6,12 @@ module Unison.ReferentPrime -- * Basic queries isConstructor, - Unison.ReferentPrime.fold, -- * Lenses reference_, -- * Conversions toReference', - toTermReference, toTypeReference, ) where @@ -21,7 +19,6 @@ where import Control.Lens (Lens, lens) import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorType (ConstructorType) -import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.Prelude -- | Specifies a term. @@ -49,11 +46,6 @@ isConstructor :: Referent' r -> Bool isConstructor Con' {} = True isConstructor _ = False -toTermReference :: Referent' r -> Maybe r -toTermReference = \case - Ref' r -> Just r - _ -> Nothing - toReference' :: Referent' r -> r toReference' = \case Ref' r -> r @@ -63,8 +55,3 @@ toTypeReference :: Referent' r -> Maybe r toTypeReference = \case Con' (ConstructorReference r _i) _t -> Just r _ -> Nothing - -fold :: (r -> a) -> (r -> ConstructorId -> ConstructorType -> a) -> Referent' r -> a -fold fr fc = \case - Ref' r -> fr r - Con' (ConstructorReference r i) ct -> fc r i ct diff --git a/unison-core/src/Unison/Settings.hs b/unison-core/src/Unison/Settings.hs index df600df9b3..008327e656 100644 --- a/unison-core/src/Unison/Settings.hs +++ b/unison-core/src/Unison/Settings.hs @@ -5,12 +5,6 @@ debugNoteLoc = False debugNoteSummary = False debugRevealForalls = False -renderTermMaxLength :: Int -renderTermMaxLength = 30 - -demoHideVarNumber :: Bool -demoHideVarNumber = False - removePureEffects :: Bool removePureEffects = True diff --git a/unison-core/src/Unison/Term.hs b/unison-core/src/Unison/Term.hs index 884a7a8978..77df3c9a6e 100644 --- a/unison-core/src/Unison/Term.hs +++ b/unison-core/src/Unison/Term.hs @@ -234,9 +234,6 @@ patternMap f = go -- Safe since `Match` is only ctor that has embedded `Pattern ap` arg ABT.Tm ts -> unsafeCoerce $ ABT.Tm (fmap go ts) -vmap :: (Ord v2) => (v -> v2) -> Term v a -> Term v2 a -vmap f = ABT.vmap f . typeMap (ABT.vmap f) - vtmap :: (Ord vt2) => (vt -> vt2) -> Term' vt v a -> Term' vt2 v a vtmap f = typeMap (ABT.vmap f) @@ -316,26 +313,9 @@ unannotate = go f' -> ABT.tm (unsafeCoerce f') go _ = error "unpossible" -wrapV :: (Ord v) => Term v a -> Term (ABT.V v) a -wrapV = vmap ABT.Bound - --- | All variables mentioned in the given term. --- Includes both term and type variables, both free and bound. -allVars :: (Ord v) => Term v a -> Set v -allVars tm = - Set.fromList $ - ABT.allVars tm ++ [v | tp <- allTypes tm, v <- ABT.allVars tp] - where - allTypes tm = case tm of - Ann' e tp -> tp : allTypes e - _ -> foldMap allTypes $ ABT.out tm - freeVars :: Term' vt v a -> Set v freeVars = ABT.freeVars -freeTypeVars :: (Ord vt) => Term' vt v a -> Set vt -freeTypeVars t = Map.keysSet $ freeTypeVarAnnotations t - freeTypeVarAnnotations :: (Ord vt) => Term' vt v a -> Map vt [a] freeTypeVarAnnotations e = multimap $ go Set.empty e where @@ -556,13 +536,6 @@ pattern Handle' h body <- (ABT.out -> ABT.Tm (Handle h body)) pattern Apps' :: Term2 vt at ap v a -> [Term2 vt at ap v a] -> Term2 vt at ap v a pattern Apps' f args <- (unApps -> Just (f, args)) --- begin pretty-printer helper patterns -pattern Ands' :: [Term2 vt at ap v a] -> Term2 vt at ap v a -> Term2 vt at ap v a -pattern Ands' ands lastArg <- (unAnds -> Just (ands, lastArg)) - -pattern Ors' :: [Term2 vt at ap v a] -> Term2 vt at ap v a -> Term2 vt at ap v a -pattern Ors' ors lastArg <- (unOrs -> Just (ors, lastArg)) - pattern AppsPred' :: Term2 vt at ap v a -> [Term2 vt at ap v a] -> @@ -574,22 +547,8 @@ pattern BinaryApp' :: Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a - -pattern BinaryApps' :: - [(Term2 vt at ap v a, Term2 vt at ap v a)] -> - Term2 vt at ap v a -> - Term2 vt at ap v a - pattern BinaryApp' f arg1 arg2 <- (unBinaryApp -> Just (f, arg1, arg2)) -pattern BinaryApps' apps lastArg <- (unBinaryApps -> Just (apps, lastArg)) - -pattern BinaryAppsPred' :: - [(Term2 vt at ap v a, Term2 vt at ap v a)] -> - Term2 vt at ap v a -> - (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) -pattern BinaryAppsPred' apps lastArg <- (unBinaryAppsPred -> Just (apps, lastArg)) - pattern BinaryAppPred' :: Term2 vt at ap v a -> Term2 vt at ap v a -> @@ -597,15 +556,6 @@ pattern BinaryAppPred' :: (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) pattern BinaryAppPred' f arg1 arg2 <- (unBinaryAppPred -> Just (f, arg1, arg2)) -pattern OverappliedBinaryAppPred' :: - Term2 vt at ap v a -> - Term2 vt at ap v a -> - Term2 vt at ap v a -> - [Term2 vt at ap v a] -> - (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) -pattern OverappliedBinaryAppPred' f arg1 arg2 rest <- - (unOverappliedBinaryAppPred -> Just (f, arg1, arg2, rest)) - -- end pretty-printer helper patterns pattern Ann' :: ABT.Term (F typeVar typeAnn patternAnn) v a -> @@ -732,17 +682,11 @@ pattern LetRecNamedAnnotatedTop' :: pattern LetRecNamedAnnotatedTop' top ann bs e <- (unLetRecNamedAnnotated -> Just (top, ann, bs, e)) -fresh :: (Var v) => Term0 v -> v -> v -fresh = ABT.fresh - -- some smart constructors var :: a -> v -> Term2 vt at ap v a var = ABT.annotatedVar -var' :: (Var v) => Text -> Term0' vt v -var' = var () . Var.named - ref :: (Ord v) => a -> Reference -> Term2 vt at ap v a ref a r = ABT.tm' a (Ref r) @@ -785,20 +729,9 @@ text a = ABT.tm' a . Text char :: (Ord v) => a -> Char -> Term2 vt at ap v a char a = ABT.tm' a . Char -watch :: (Var v, Semigroup a) => a -> String -> Term v a -> Term v a -watch a note e = - apps' (builtin a "Debug.watch") [text a (Text.pack note), e] - -watchMaybe :: (Var v, Semigroup a) => Maybe String -> Term v a -> Term v a -watchMaybe Nothing e = e -watchMaybe (Just note) e = watch (ABT.annotation e) note e - blank :: (Ord v) => a -> Term2 vt at ap v a blank a = ABT.tm' a (Blank B.Blank) -placeholder :: (Ord v) => a -> String -> Term2 vt a ap v a -placeholder a s = ABT.tm' a . Blank $ B.Recorded (B.Placeholder a s) - resolve :: (Ord v) => at -> ab -> String -> Term2 vt ab ap v at resolve at ab s = ABT.tm' at . Blank $ B.Recorded (B.Resolve ab s) @@ -811,10 +744,6 @@ constructor a ref = ABT.tm' a (Constructor ref) request :: (Ord v) => a -> ConstructorReference -> Term2 vt at ap v a request a ref = ABT.tm' a (Request ref) --- todo: delete and rename app' to app -app_ :: (Ord v) => Term0' vt v -> Term0' vt v -> Term0' vt v -app_ f arg = ABT.tm (App f arg) - app :: (Ord v) => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a app a f arg = ABT.tm' a (App f arg) @@ -853,9 +782,6 @@ apps' = foldl' (\f t -> app (ABT.annotation f <> ABT.annotation t) f t) iff :: (Ord v) => a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a -> Term2 vt at ap v a iff a cond t f = ABT.tm' a (If cond t f) -ann_ :: (Ord v) => Term0' vt v -> Type vt () -> Term0' vt v -ann_ e t = ABT.tm (Ann e t) - ann :: (Ord v) => a -> @@ -969,24 +895,6 @@ letRec isTop blockAnn bindings e = body :: Term' vt v a body = ABT.tm' blockAnn (LetRec isTop (map snd bindings) e) --- | Smart constructor for let rec blocks. Each binding in the block may --- reference any other binding in the block in its body (including itself), --- and the output expression may also reference any binding in the block. -letRec_ :: (Ord v) => IsTop -> [(v, Term0' vt v)] -> Term0' vt v -> Term0' vt v -letRec_ _ [] e = e -letRec_ isTop bindings e = ABT.cycle (foldr (ABT.abs . fst) z bindings) - where - z = ABT.tm (LetRec isTop (map snd bindings) e) - --- | Smart constructor for let blocks. Each binding in the block may --- reference only previous bindings in the block, not including itself. --- The output expression may reference any binding in the block. --- todo: delete me -let1_ :: (Ord v) => IsTop -> [(v, Term0' vt v)] -> Term0' vt v -> Term0' vt v -let1_ isTop bindings e = foldr f e bindings - where - f (v, b) body = ABT.tm (Let isTop b (ABT.abs v body)) - -- | annotations are applied to each nested Let expression let1 :: (Ord v, Semigroup a) => @@ -998,6 +906,9 @@ let1 isTop bindings e = foldr f e bindings where f ((ann, v), b) body = ABT.tm' (ann <> ABT.annotation body) (Let isTop b (ABT.abs' ann v body)) +-- | Smart constructor for let blocks. Each binding in the block may +-- reference only previous bindings in the block, not including itself. +-- The output expression may reference any binding in the block. let1' :: (Semigroup a, Ord v) => IsTop -> @@ -1079,30 +990,6 @@ unLetRec (unLetRecNamed -> Just (isTop, bs, e)) = ) unLetRec _ = Nothing -unAnds :: - Term2 vt at ap v a -> - Maybe - ( [Term2 vt at ap v a], - Term2 vt at ap v a - ) -unAnds t = case t of - And' i o -> case unAnds i of - Just (as, xLast) -> Just (xLast : as, o) - Nothing -> Just ([i], o) - _ -> Nothing - -unOrs :: - Term2 vt at ap v a -> - Maybe - ( [Term2 vt at ap v a], - Term2 vt at ap v a - ) -unOrs t = case t of - Or' i o -> case unOrs i of - Just (as, xLast) -> Just (xLast : as, o) - Nothing -> Just ([i], o) - _ -> Nothing - unApps :: Term2 vt at ap v a -> Maybe (Term2 vt at ap v a, [Term2 vt at ap v a]) @@ -1129,46 +1016,6 @@ unBinaryApp t = case unApps t of Just (f, [arg1, arg2]) -> Just (f, arg1, arg2) _ -> Nothing --- Special case for overapplied binary operators -unOverappliedBinaryAppPred :: - (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) -> - Maybe - ( Term2 vt at ap v a, - Term2 vt at ap v a, - Term2 vt at ap v a, - [Term2 vt at ap v a] - ) -unOverappliedBinaryAppPred (t, pred) = case unApps t of - Just (f, arg1 : arg2 : rest) | pred f -> Just (f, arg1, arg2, rest) - _ -> Nothing - --- "((a1 `f1` a2) `f2` a3)" becomes "Just ([(a2, f2), (a1, f1)], a3)" -unBinaryApps :: - Term2 vt at ap v a -> - Maybe - ( [(Term2 vt at ap v a, Term2 vt at ap v a)], - Term2 vt at ap v a - ) -unBinaryApps t = unBinaryAppsPred (t, const True) - --- Same as unBinaryApps but taking a predicate controlling whether we match on a given binary function. -unBinaryAppsPred :: - ( Term2 vt at ap v a, - Term2 vt at ap v a -> Bool - ) -> - Maybe - ( [ ( Term2 vt at ap v a, - Term2 vt at ap v a - ) - ], - Term2 vt at ap v a - ) -unBinaryAppsPred (t, pred) = case unBinaryAppPred (t, pred) of - Just (f, x, y) -> case unBinaryAppsPred (x, pred) of - Just (as, xLast) -> Just ((xLast, f) : as, y) - Nothing -> Just ([(x, f)], y) - _ -> Nothing - unBinaryAppPred :: (Term2 vt at ap v a, Term2 vt at ap v a -> Bool) -> Maybe @@ -1341,16 +1188,6 @@ updateDependencies termUpdates typeUpdates = ABT.rebuildUp go u (MatchCase pat g b) = MatchCase (Pattern.updateDependencies termUpdates pat) g b go f = f --- | If the outermost term is a function application, --- perform substitution of the argument into the body -betaReduce :: (Var v) => Term0 v -> Term0 v -betaReduce (App' (Lam' f) arg) = ABT.bind f arg -betaReduce e = e - -betaNormalForm :: (Var v) => Term0 v -> Term0 v -betaNormalForm (App' f a) = betaNormalForm (betaReduce (app () (betaNormalForm f) a)) -betaNormalForm e = e - -- x -> f x => f etaNormalForm :: (Ord v) => Term0 v -> Term0 v etaNormalForm tm = case tm of @@ -1407,10 +1244,6 @@ fromReferent a = \case CT.Data -> constructor a r CT.Effect -> request a r --- Used to find matches of `@rewrite case` rules -containsExpression :: (Var v, Var typeVar, Eq typeAnn) => Term2 typeVar typeAnn loc v a -> Term2 typeVar typeAnn loc v a -> Bool -containsExpression = ABT.containsExpression - -- Used to find matches of `@rewrite case` rules -- Returns `Nothing` if `pat` can't be interpreted as a `Pattern` -- (like `1 + 1` is not a valid pattern, but `Some x` can be) diff --git a/unison-core/src/Unison/Type.hs b/unison-core/src/Unison/Type.hs index a1fd4fec52..b855f6ac01 100644 --- a/unison-core/src/Unison/Type.hs +++ b/unison-core/src/Unison/Type.hs @@ -7,18 +7,12 @@ import Control.Monad.Writer.Strict qualified as Writer import Data.Generics.Sum (_Ctor) import Data.List.Extra (nubOrd) import Data.Map qualified as Map -import Data.Monoid (Any (..)) -import Data.Sequence qualified as Seq import Data.Set qualified as Set import Unison.ABT qualified as ABT -import Unison.HashQualified qualified as HQ import Unison.Kind qualified as K import Unison.LabeledDependency qualified as LD -import Unison.Name qualified as Name -import Unison.Names.ResolutionResult qualified as Names import Unison.Prelude - ( Const (Const, getConst), - Generic, + ( Generic, Generic1, Identity (runIdentity), Map, @@ -28,12 +22,10 @@ import Unison.Prelude join, sortOn, ($>), - (<&>), ) import Unison.Reference (TypeReference) import Unison.Reference qualified as Reference import Unison.Settings qualified as Settings -import Unison.Util.List qualified as List import Unison.Var (Var) import Unison.Var qualified as Var @@ -57,9 +49,6 @@ _Ref = _Ctor @"Ref" -- | Types are represented as ABTs over the base functor F, with variables in `v` type Type v a = ABT.Term F v a -wrapV :: (Ord v) => Type v a -> Type (ABT.V v) a -wrapV = ABT.vmap ABT.Bound - freeVars :: Type v a -> Set v freeVars = ABT.freeVars @@ -67,22 +56,6 @@ bindExternal :: (ABT.Var v) => [(v, TypeReference)] -> Type v a -> Type v a bindExternal bs = ABT.substsInheritAnnotation [(v, ref () r) | (v, r) <- bs] -bindReferences :: - (Var v) => - (v -> Name.Name) -> - Set v -> - Map Name.Name TypeReference -> - Type v a -> - Names.ResolutionResult a (Type v a) -bindReferences unsafeVarToName keepFree ns t = - let fvs = ABT.freeVarOccurrences keepFree t - rs = [(v, a, Map.lookup (unsafeVarToName v) ns) | (v, a) <- fvs] - ok (v, _a, Just r) = pure (v, r) - ok (v, a, Nothing) = - Left $ - Seq.singleton (Names.TypeResolutionFailure (HQ.NameOnly (unsafeVarToName v)) a Names.NotFound) - in List.validate ok rs <&> \es -> bindExternal es t - newtype Monotype v a = Monotype {getPolytype :: Type v a} deriving (Eq) instance (Show v) => Show (Monotype v a) where @@ -126,9 +99,6 @@ pattern App' f x <- ABT.Tm' (App f x) pattern Apps' :: Type v a -> [Type v a] -> Type v a pattern Apps' f args <- (unApps -> Just (f, args)) -pattern Pure' :: (Ord v) => Type v a -> Type v a -pattern Pure' t <- (unPure -> Just t) - pattern Request' :: [Type v a] -> Type v a -> Type v a pattern Request' ets res <- Apps' (Ref' ((== effectRef) -> True)) [(flattenEffects -> ets), res] @@ -180,11 +150,6 @@ pattern Cycle' xs t <- ABT.Cycle' xs t pattern Abs' :: (Foldable f, Functor f, ABT.Var v) => ABT.Subst f v a -> ABT.Term f v a pattern Abs' subst <- ABT.Abs' subst -unPure :: (Ord v) => Type v a -> Maybe (Type v a) -unPure (Effect'' [] t) = Just t -unPure (Effect'' _ _) = Nothing -unPure t = Just t - unArrows :: Type v a -> Maybe [Type v a] unArrows t = case go t of [_] -> Nothing; l -> Just l @@ -243,12 +208,6 @@ unEffects1 :: (Ord v) => Type v a -> Maybe ([Type v a], Type v a) unEffects1 (Effect1' (Effects' es) a) = Just (es, a) unEffects1 _ = Nothing --- | True if the given type is a function, possibly quantified -isArrow :: (ABT.Var v) => Type v a -> Bool -isArrow (ForallNamed' _ t) = isArrow t -isArrow (Arrow' _ _) = True -isArrow _ = False - -- some smart constructors ref :: (Ord v) => a -> TypeReference -> Type v a @@ -263,9 +222,6 @@ termLink a = ABT.tm' a . Ref $ termLinkRef typeLink :: (Ord v) => a -> Type v a typeLink a = ABT.tm' a . Ref $ typeLinkRef -derivedBase32Hex :: (Ord v) => TypeReference -> a -> Type v a -derivedBase32Hex r a = ref a r - intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, bytesRef, effectRef, termLinkRef, typeLinkRef :: TypeReference intRef = Reference.Builtin "Int" natRef = Reference.Builtin "Nat" @@ -461,20 +417,6 @@ forAll a v body = ABT.tm' a (Forall (ABT.abs' a v body)) introOuter :: (Ord v) => a -> v -> Type v a -> Type v a introOuter a v body = ABT.tm' a (IntroOuter (ABT.abs' a v body)) -iff :: (Var v) => Type v () -iff = forAll () aa $ arrows (f <$> [boolean (), a, a]) a - where - aa = Var.named "a" - a = var () aa - f x = ((), x) - -iff' :: (Var v) => a -> Type v a -iff' loc = forAll loc aa $ arrows (f <$> [boolean loc, a, a]) a - where - aa = Var.named "a" - a = var loc aa - f x = (loc, x) - iff2 :: (Var v) => a -> Type v a iff2 loc = forAll loc aa $ arrows (f <$> [a, a]) a where @@ -482,11 +424,6 @@ iff2 loc = forAll loc aa $ arrows (f <$> [a, a]) a a = var loc aa f x = (loc, x) -andor :: (Ord v) => Type v () -andor = arrows (f <$> [boolean (), boolean ()]) $ boolean () - where - f x = ((), x) - andor' :: (Ord v) => a -> Type v a andor' a = arrows (f <$> [boolean a, boolean a]) $ boolean a where @@ -495,16 +432,10 @@ andor' a = arrows (f <$> [boolean a, boolean a]) $ boolean a var :: (Ord v) => a -> v -> Type v a var = ABT.annotatedVar -v' :: (Var v) => Text -> Type v () -v' s = ABT.var (Var.named s) - -- Like `v'`, but creates an annotated variable given an annotation av' :: (Var v) => a -> Text -> Type v a av' a s = ABT.annotatedVar a (Var.named s) -forAll' :: (Var v) => a -> [Text] -> Type v a -> Type v a -forAll' a vs body = foldr (forAll a) body (Var.named <$> vs) - foralls :: (Ord v) => a -> [v] -> Type v a -> Type v a foralls a vs body = foldr (forAll a) body vs @@ -546,13 +477,6 @@ stripEffect :: (Ord v) => Type v a -> ([Type v a], Type v a) stripEffect (Effect' e t) = case stripEffect t of (ei, t) -> (e ++ ei, t) stripEffect t = ([], t) --- The type of the flipped function application operator: --- `(a -> (a -> b) -> b)` -flipApply :: (Var v) => Type v () -> Type v () -flipApply t = forAll () b $ arrow () (arrow () t (var () b)) (var () b) - where - b = ABT.fresh t (Var.named "b") - generalize' :: (Var v) => Var.Type -> Type v a -> Type v a generalize' k t = generalize vsk t where @@ -565,10 +489,6 @@ generalize vs t = foldr f t vs f v t = if Set.member v (ABT.freeVars t) then forAll (ABT.annotation t) v t else t -unforall :: Type v a -> Type v a -unforall (ForallsNamed' _ t) = t -unforall t = t - unforall' :: Type v a -> ([v], Type v a) unforall' (ForallsNamed' vs t) = (vs, t) unforall' t = ([], t) @@ -588,12 +508,6 @@ updateDependencies typeUpdates = ABT.rebuildUp go go (Ref r) = Ref (Map.findWithDefault r r typeUpdates) go f = f -usesEffects :: (Ord v) => Type v a -> Bool -usesEffects t = getAny . getConst $ ABT.visit go t - where - go (Effect1' _ _) = Just (Const (Any True)) - go _ = Nothing - -- Returns free effect variables in the given type, for instance, in: -- -- ∀ e3 . a ->{e,e2} b ->{e3} c @@ -745,13 +659,6 @@ editFunctionResult f = go (\x -> ABT.Term (s <> freeVars x) a $ ABT.Abs v x) $ go r _ -> f (ABT.Term s a t) -functionResult :: Type v a -> Maybe (Type v a) -functionResult = go False - where - go inArr (ForallNamed' _ body) = go inArr body - go _inArr (Arrow' _i o) = go True o - go inArr t = if inArr then Just t else Nothing - -- | Bind all free variables (not in `except`) that start with a lowercase -- letter and are unqualified with an outer `forall`. -- `a -> a` becomes `∀ a . a -> a` diff --git a/unison-core/src/Unison/Util/Defns.hs b/unison-core/src/Unison/Util/Defns.hs index 5f56166d01..1e62cda713 100644 --- a/unison-core/src/Unison/Util/Defns.hs +++ b/unison-core/src/Unison/Util/Defns.hs @@ -3,14 +3,8 @@ module Unison.Util.Defns DefnsF, DefnsF2, DefnsF3, - DefnsF4, alignDefnsWith, defnsAreEmpty, - hoistDefnsF, - mapDefns, - unzipDefns, - unzipDefnsWith, - zipDefns, zipDefnsWith, zipDefnsWith3, zipDefnsWith4, @@ -54,9 +48,6 @@ type DefnsF2 f g terms types = type DefnsF3 f g h terms types = Defns (f (g (h terms))) (f (g (h types))) -type DefnsF4 f g h i terms types = - Defns (f (g (h (i terms)))) (f (g (h (i types)))) - alignDefnsWith :: (Semialign f) => (These a b -> c) -> Defns (f a) (f b) -> f c alignDefnsWith f defns = alignWith f defns.terms defns.types @@ -65,28 +56,6 @@ defnsAreEmpty :: (Foldable f, Foldable g) => Defns (f a) (g b) -> Bool defnsAreEmpty defns = null defns.terms && null defns.types -hoistDefnsF :: (forall x. f x -> g x) -> DefnsF f a b -> DefnsF g a b -hoistDefnsF f (Defns x y) = - Defns (f x) (f y) - -mapDefns :: (a -> b) -> Defns a a -> Defns b b -mapDefns f = - bimap f f - -unzipDefns :: Defns (tm1, tm2) (ty1, ty2) -> (Defns tm1 ty1, Defns tm2 ty2) -unzipDefns = - unzipDefnsWith id id - -unzipDefnsWith :: (tm1 -> (tm2, tm3)) -> (ty1 -> (ty2, ty3)) -> Defns tm1 ty1 -> (Defns tm2 ty2, Defns tm3 ty3) -unzipDefnsWith f g (Defns terms1 types1) = - let (terms2, terms3) = f terms1 - (types2, types3) = g types1 - in (Defns terms2 types2, Defns terms3 types3) - -zipDefns :: Defns tm1 ty1 -> Defns tm2 ty2 -> Defns (tm1, tm2) (ty1, ty2) -zipDefns = - zipDefnsWith (,) (,) - zipDefnsWith :: (tm1 -> tm2 -> tm3) -> (ty1 -> ty2 -> ty3) -> Defns tm1 ty1 -> Defns tm2 ty2 -> Defns tm3 ty3 zipDefnsWith f g (Defns terms1 types1) (Defns terms2 types2) = Defns (f terms1 terms2) (g types1 types2) diff --git a/unison-core/src/Unison/Util/Nametree.hs b/unison-core/src/Unison/Util/Nametree.hs index e87bdde344..a54202378f 100644 --- a/unison-core/src/Unison/Util/Nametree.hs +++ b/unison-core/src/Unison/Util/Nametree.hs @@ -15,7 +15,7 @@ where import Data.List.NonEmpty (NonEmpty, pattern (:|)) import Data.List.NonEmpty qualified as List.NonEmpty import Data.Map.Strict qualified as Map -import Data.Semialign (Semialign (alignWith), Unzip (unzipWith), Zip (zipWith)) +import Data.Semialign (Semialign (alignWith)) import Data.These (These (..), these) import Unison.Name (Name) import Unison.Name qualified as Name @@ -38,19 +38,6 @@ instance Semialign Nametree where alignWith f (Nametree x xs) (Nametree y ys) = Nametree (f (These x y)) (alignWith (these (fmap (f . This)) (fmap (f . That)) (alignWith f)) xs ys) -instance Zip Nametree where - zipWith :: (a -> b -> c) -> Nametree a -> Nametree b -> Nametree c - zipWith f (Nametree x xs) (Nametree y ys) = - Nametree (f x y) (zipWith (zipWith f) xs ys) - -instance Unzip Nametree where - unzipWith :: (c -> (a, b)) -> Nametree c -> (Nametree a, Nametree b) - unzipWith f (Nametree x xs) = - (Nametree y ys, Nametree z zs) - where - (y, z) = f x - (ys, zs) = unzipWith (unzipWith f) xs - -- | Traverse over a nametree, with access to the list of name segments (in reverse order) leading to each value. traverseNametreeWithName :: (Applicative f) => ([NameSegment] -> a -> f b) -> Nametree a -> f (Nametree b) traverseNametreeWithName f = diff --git a/unison-core/src/Unison/Var.hs b/unison-core/src/Unison/Var.hs index 981378624a..27312716a3 100644 --- a/unison-core/src/Unison/Var.hs +++ b/unison-core/src/Unison/Var.hs @@ -9,8 +9,6 @@ module Unison.Var inferInput, inferOther, inferOutput, - inferPatternBindE, - inferPatternBindV, inferPatternPureE, inferPatternPureV, inferTypeConstructor, @@ -117,8 +115,6 @@ missingResult, inferAbility, inferPatternPureE, inferPatternPureV, - inferPatternBindE, - inferPatternBindV, inferTypeConstructor, inferTypeConstructorArg, inferOther :: @@ -130,8 +126,6 @@ inferOutput = typed (Inference Output) inferAbility = typed (Inference Ability) inferPatternPureE = typed (Inference PatternPureE) inferPatternPureV = typed (Inference PatternPureV) -inferPatternBindE = typed (Inference PatternBindE) -inferPatternBindV = typed (Inference PatternBindV) inferTypeConstructor = typed (Inference TypeConstructor) inferTypeConstructorArg = typed (Inference TypeConstructorArg) inferOther = typed (Inference Other) diff --git a/unison-core/test/Main.hs b/unison-core/test/Main.hs index 82ef44b629..6478aeaf02 100644 --- a/unison-core/test/Main.hs +++ b/unison-core/test/Main.hs @@ -6,9 +6,15 @@ import Data.Text qualified as Text import Data.These (These (..)) import EasyTest import System.IO.CodePage (withCP65001) +import Text.Megaparsec qualified as Megaparsec import Unison.Core.Project import Unison.Prelude -import Unison.Project (ProjectAndBranchNames (..)) +import Unison.Project + ( ProjectAndBranchNames (..), + ProjectBranchSpecifier (..), + branchWithOptionalProjectParser, + projectAndOptionalBranchParser, + ) main :: IO () main = @@ -86,7 +92,7 @@ projectTests = scope (Text.unpack input) $ expectEqual (Just (ProjectAndBranch project branch)) - (either (const Nothing) Just (tryFrom @Text @(ProjectAndBranch ProjectName (Maybe ProjectBranchName)) input)) + (Megaparsec.parseMaybe (projectAndOptionalBranchParser ProjectBranchSpecifier'Name) input) t "project" "project" Nothing t "project/" "project" Nothing t "project/branch" "project" (Just "branch") @@ -104,7 +110,7 @@ projectTests = scope (Text.unpack input) $ expectEqual (Just (ProjectAndBranch project branch)) - (either (const Nothing) Just (tryFrom @Text @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) input)) + (Megaparsec.parseMaybe branchWithOptionalProjectParser input) t "branch" Nothing "branch" t "@user/branch" Nothing "@user/branch" t "releases/1.2.3" Nothing "releases/1.2.3" diff --git a/unison-core/unison-core1.cabal b/unison-core/unison-core1.cabal index e4e71afc9e..758e7e87ae 100644 --- a/unison-core/unison-core1.cabal +++ b/unison-core/unison-core1.cabal @@ -165,6 +165,7 @@ test-suite tests base , code-page , easytest + , megaparsec , text , these , unison-core diff --git a/unison-hashing-v2/package.yaml b/unison-hashing-v2/package.yaml index a0d531c550..91f5fde730 100644 --- a/unison-hashing-v2/package.yaml +++ b/unison-hashing-v2/package.yaml @@ -17,7 +17,6 @@ dependencies: - unison-hash - unison-hashing - unison-prelude - - unison-util-relation library: exposed-modules: diff --git a/unison-hashing-v2/src/Unison/Hashing/V2/Tokenizable.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Tokenizable.hs index 5543f83000..28c197a62c 100644 --- a/unison-hashing-v2/src/Unison/Hashing/V2/Tokenizable.hs +++ b/unison-hashing-v2/src/Unison/Hashing/V2/Tokenizable.hs @@ -18,12 +18,6 @@ import Data.Set qualified as Set import Unison.Hash (Hash) import Unison.Hash qualified as Hash import Unison.Prelude -import Unison.Util.Relation (Relation) -import Unison.Util.Relation qualified as Relation -import Unison.Util.Relation3 (Relation3) -import Unison.Util.Relation3 qualified as Relation3 -import Unison.Util.Relation4 (Relation4) -import Unison.Util.Relation4 qualified as Relation4 -- | The version of the current hashing function. -- This should be incremented every time the hashing function is changed. @@ -83,18 +77,6 @@ instance (Tokenizable a) => Tokenizable (Set.Set a) where instance (Tokenizable k, Tokenizable v) => Tokenizable (Map.Map k v) where tokens = tokens . Map.toList -instance (Tokenizable a, Tokenizable b) => Tokenizable (Relation a b) where - tokens = tokens . Relation.toList - -instance (Tokenizable d1, Tokenizable d2, Tokenizable d3) => Tokenizable (Relation3 d1 d2 d3) where - tokens s = [accumulateToken $ Relation3.toNestedList s] - -instance (Tokenizable d1, Tokenizable d2, Tokenizable d3, Tokenizable d4) => Tokenizable (Relation4 d1 d2 d3 d4) where - tokens s = [accumulateToken $ Relation4.toNestedList s] - -instance Tokenizable () where - tokens _ = [] - instance Tokenizable Double where tokens d = [Double d] @@ -104,9 +86,6 @@ instance Tokenizable Text where instance Tokenizable Char where tokens c = [Nat $ fromIntegral $ fromEnum c] -instance Tokenizable ByteString where - tokens bs = [Bytes bs] - instance Tokenizable Word64 where tokens w = [Nat w] diff --git a/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs b/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs index b1397d0e81..3199495eb5 100644 --- a/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs +++ b/unison-hashing-v2/src/Unison/Hashing/V2/Type.hs @@ -7,16 +7,6 @@ module Unison.Hashing.V2.Type -- * find by type index stuff typeToReference, typeToReferenceMentions, - - -- * builtin term references - booleanRef, - charRef, - effectRef, - floatRef, - intRef, - listRef, - natRef, - textRef, ) where @@ -94,16 +84,6 @@ unForalls t = go t [] ref :: (Ord v) => a -> Reference -> Type v a ref a = ABT.tm' a . TypeRef -intRef, natRef, floatRef, booleanRef, textRef, charRef, listRef, effectRef :: Reference -intRef = ReferenceBuiltin "Int" -natRef = ReferenceBuiltin "Nat" -floatRef = ReferenceBuiltin "Float" -booleanRef = ReferenceBuiltin "Boolean" -textRef = ReferenceBuiltin "Text" -charRef = ReferenceBuiltin "Char" -listRef = ReferenceBuiltin "Sequence" -effectRef = ReferenceBuiltin "Effect" - forAll :: (Ord v) => a -> v -> Type v a -> Type v a forAll a v body = ABT.tm' a (TypeForall (ABT.abs' a v body)) diff --git a/unison-hashing-v2/unison-hashing-v2.cabal b/unison-hashing-v2/unison-hashing-v2.cabal index feae301be6..5a577f7fd9 100644 --- a/unison-hashing-v2/unison-hashing-v2.cabal +++ b/unison-hashing-v2/unison-hashing-v2.cabal @@ -78,5 +78,4 @@ library , unison-hash , unison-hashing , unison-prelude - , unison-util-relation default-language: Haskell2010 diff --git a/unison-merge/src/Unison/Merge/EitherWayI.hs b/unison-merge/src/Unison/Merge/EitherWayI.hs index e76c12671c..f012f0abb0 100644 --- a/unison-merge/src/Unison/Merge/EitherWayI.hs +++ b/unison-merge/src/Unison/Merge/EitherWayI.hs @@ -1,7 +1,5 @@ module Unison.Merge.EitherWayI ( EitherWayI (..), - includingAlice, - excludingAlice, value, ) where @@ -13,18 +11,6 @@ data EitherWayI a | AliceAndBob a deriving stock (Functor, Show) -includingAlice :: EitherWayI a -> Maybe a -includingAlice = \case - OnlyAlice x -> Just x - AliceAndBob x -> Just x - OnlyBob _ -> Nothing - -excludingAlice :: EitherWayI a -> Maybe a -excludingAlice = \case - OnlyBob x -> Just x - OnlyAlice _ -> Nothing - AliceAndBob _ -> Nothing - value :: EitherWayI a -> a value = \case OnlyAlice x -> x diff --git a/unison-merge/src/Unison/Merge/Synhash.hs b/unison-merge/src/Unison/Merge/Synhash.hs index c281f0b6a2..d59113b14c 100644 --- a/unison-merge/src/Unison/Merge/Synhash.hs +++ b/unison-merge/src/Unison/Merge/Synhash.hs @@ -26,9 +26,7 @@ -- "foo" would have the same syntactic hash. This indicates (to our merge algorithm) that this was an auto-propagated -- update. module Unison.Merge.Synhash - ( synhashType, - synhashTerm, - synhashBuiltinTerm, + ( synhashBuiltinTerm, synhashDerivedTerm, synhashBuiltinDecl, synhashDerivedDecl, @@ -58,8 +56,6 @@ import Unison.Pattern qualified as Pattern import Unison.Prelude import Unison.PrettyPrintEnv (PrettyPrintEnv) import Unison.PrettyPrintEnv qualified as PPE -import Unison.Reference (Reference' (..), TermReferenceId) -import Unison.Reference qualified as V1 import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Syntax.Name qualified as Name (toText, unsafeParseVar) @@ -215,17 +211,6 @@ hashReferentToken :: PrettyPrintEnv -> Referent -> Token hashReferentToken ppe = hashHQNameToken . PPE.termNameOrHashOnlyFq ppe -synhashTerm :: - forall m v a. - (Monad m, Var v) => - (TermReferenceId -> m (Term v a)) -> - PrettyPrintEnv -> - V1.TermReference -> - m Hash -synhashTerm loadTerm ppe = \case - ReferenceBuiltin builtin -> pure (synhashBuiltinTerm builtin) - ReferenceDerived ref -> synhashDerivedTerm ppe <$> loadTerm ref - hashTermFTokens :: (Var v) => PrettyPrintEnv -> Term.F v a a () -> [Token] hashTermFTokens ppe = \case Term.Int n -> [H.Tag 0, H.Int n] @@ -254,13 +239,6 @@ hashTermFTokens ppe = \case Term.TermLink rf -> [H.Tag 19, hashReferentToken ppe rf] Term.TypeLink r -> [H.Tag 20, hashTypeReferenceToken ppe r] --- | Syntactically hash a type, using reference names rather than hashes. --- Two types will have the same syntactic hash if they would --- print the the same way under the given pretty-print env. -synhashType :: (Var v) => PrettyPrintEnv -> Type v a -> Hash -synhashType ppe ty = - H.accumulate $ hashTypeTokens ppe [] ty - hashTypeTokens :: forall v a. (Var v) => PrettyPrintEnv -> [v] -> Type v a -> [Token] hashTypeTokens ppe = go where diff --git a/unison-merge/src/Unison/Merge/ThreeWay.hs b/unison-merge/src/Unison/Merge/ThreeWay.hs index cc9d24c47d..5d3fa2e345 100644 --- a/unison-merge/src/Unison/Merge/ThreeWay.hs +++ b/unison-merge/src/Unison/Merge/ThreeWay.hs @@ -4,8 +4,6 @@ module Unison.Merge.ThreeWay ) where -import Data.Semialign (Semialign (alignWith), Unzip (unzipWith), Zip (zipWith)) -import Data.These (These (..)) import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Prelude @@ -16,33 +14,6 @@ data ThreeWay a = ThreeWay } deriving stock (Foldable, Functor, Generic, Traversable) -instance Applicative ThreeWay where - pure :: a -> ThreeWay a - pure x = - ThreeWay x x x - - (<*>) :: ThreeWay (a -> b) -> ThreeWay a -> ThreeWay b - ThreeWay f g h <*> ThreeWay x y z = - ThreeWay (f x) (g y) (h z) - -instance Semialign ThreeWay where - alignWith :: (These a b -> c) -> ThreeWay a -> ThreeWay b -> ThreeWay c - alignWith f (ThreeWay a b c) (ThreeWay x y z) = - ThreeWay (f (These a x)) (f (These b y)) (f (These c z)) - -instance Unzip ThreeWay where - unzipWith :: (c -> (a, b)) -> ThreeWay c -> (ThreeWay a, ThreeWay b) - unzipWith f (ThreeWay a b c) = - let (i, x) = f a - (j, y) = f b - (k, z) = f c - in (ThreeWay i j k, ThreeWay x y z) - -instance Zip ThreeWay where - zipWith :: (a -> b -> c) -> ThreeWay a -> ThreeWay b -> ThreeWay c - zipWith f (ThreeWay a b c) (ThreeWay x y z) = - ThreeWay (f a x) (f b y) (f c z) - forgetLca :: ThreeWay a -> TwoWay a forgetLca ThreeWay {alice, bob} = TwoWay {alice, bob} diff --git a/unison-merge/src/Unison/Merge/TwoWay.hs b/unison-merge/src/Unison/Merge/TwoWay.hs index bad9a928f9..e0fe092d9f 100644 --- a/unison-merge/src/Unison/Merge/TwoWay.hs +++ b/unison-merge/src/Unison/Merge/TwoWay.hs @@ -7,7 +7,6 @@ module Unison.Merge.TwoWay sequenceDefns, swap, twoWay, - unzipMap, who_, ) where @@ -79,18 +78,7 @@ twoWay :: (a -> a -> b) -> TwoWay a -> b twoWay f TwoWay {alice, bob} = f alice bob --- | Unzip a @Map k (TwoWay v)@ into a @TwoWay (Map k v)@. -unzipMap :: (Ord k) => Map k (TwoWay v) -> TwoWay (Map k v) -unzipMap = - fromPair . unzipWith (\TwoWay {alice, bob} -> (alice, bob)) - who_ :: EitherWay x -> Lens' (TwoWay a) a who_ = \case Alice _ -> #alice Bob _ -> #bob - --- - -fromPair :: (a, a) -> TwoWay a -fromPair (alice, bob) = - TwoWay {alice, bob} diff --git a/unison-merge/src/Unison/Merge/TwoWayI.hs b/unison-merge/src/Unison/Merge/TwoWayI.hs index 4983a3494a..23aa9f1dc8 100644 --- a/unison-merge/src/Unison/Merge/TwoWayI.hs +++ b/unison-merge/src/Unison/Merge/TwoWayI.hs @@ -6,10 +6,7 @@ module Unison.Merge.TwoWayI where import Control.Lens (Lens') -import Data.Semialign (Semialign, alignWith) import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) -import Data.These (These (..)) -import Data.Zip (Zip, zipWith) import Unison.Merge.EitherWayI (EitherWayI (..)) import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Prelude @@ -24,20 +21,6 @@ data TwoWayI a = TwoWayI deriving stock (Foldable, Functor, Generic) deriving (Monoid, Semigroup) via (GenericSemigroupMonoid (TwoWayI a)) -instance Applicative TwoWayI where - pure x = TwoWayI x x x - TwoWayI f g h <*> TwoWayI x y z = TwoWayI (f x) (g y) (h z) - -instance Semialign TwoWayI where - alignWith :: (These a b -> c) -> TwoWayI a -> TwoWayI b -> TwoWayI c - alignWith f = - zipWith \x y -> f (These x y) - -instance Zip TwoWayI where - zipWith :: (a -> b -> c) -> TwoWayI a -> TwoWayI b -> TwoWayI c - zipWith f (TwoWayI x1 x2 x3) (TwoWayI y1 y2 y3) = - TwoWayI (f x1 y1) (f x2 y2) (f x3 y3) - forgetBoth :: TwoWayI a -> TwoWay a forgetBoth TwoWayI {alice, bob} = TwoWay {alice, bob} diff --git a/unison-runtime/package.yaml b/unison-runtime/package.yaml index 6b76ed9274..369bbcf27b 100644 --- a/unison-runtime/package.yaml +++ b/unison-runtime/package.yaml @@ -38,7 +38,6 @@ library: - containers >= 0.6.3 - cryptonite - data-default - - data-memocombinators - deepseq - directory - exceptions diff --git a/unison-runtime/src/Unison/Runtime/ANF.hs b/unison-runtime/src/Unison/Runtime/ANF.hs index 0c2fa20ff8..9eb71af871 100644 --- a/unison-runtime/src/Unison/Runtime/ANF.hs +++ b/unison-runtime/src/Unison/Runtime/ANF.hs @@ -7,8 +7,7 @@ {-# LANGUAGE ViewPatterns #-} module Unison.Runtime.ANF - ( minimizeCyclesOrCrash, - pattern TVar, + ( pattern TVar, pattern TLit, pattern TBLit, pattern TApp, @@ -25,7 +24,6 @@ module Unison.Runtime.ANF pattern TFrc, pattern TLets, pattern TName, - pattern TBind, pattern TBinds, pattern TShift, pattern TMatch, @@ -105,9 +103,8 @@ import Unison.Prelude import Unison.Reference (Id, Reference, Reference' (Builtin, DerivedId)) import Unison.Referent (Referent, pattern Con, pattern Ref) import Unison.Symbol (Symbol) -import Unison.Term hiding (List, Ref, Text, float, fresh, resolve) +import Unison.Term hiding (List, Ref, Text, float, resolve) import Unison.Type qualified as Ty -import Unison.Typechecker.Components (minimize') import Unison.Util.Bytes (Bytes) import Unison.Util.EnumContainers as EC import Unison.Util.Pretty qualified as Pretty @@ -666,15 +663,7 @@ inlineAlias = ABT.visitPure $ \case Let1Named' v b@(Var' _) e -> Just . inlineAlias $ ABT.subst v b e _ -> Nothing -minimizeCyclesOrCrash :: (Var v) => Term v a -> Term v a -minimizeCyclesOrCrash t = case minimize' t of - Right t -> t - Left e -> - internalBug $ - "tried to minimize let rec with duplicate definitions: " - ++ show (fst <$> toList e) - -data Mem = UN | BX deriving (Eq, Ord, Show, Enum) +data Mem = UN | BX deriving (Eq, Ord, Show) -- Context entries with evaluation strategy data CTE v s @@ -703,7 +692,6 @@ data ANormalF v e -- correspond to constructors. newtype RTag = RTag Word64 deriving stock (Eq, Ord, Show, Read) - deriving newtype (EC.EnumKey) newtype CTag = CTag Word16 deriving stock (Eq, Ord, Show, Read) @@ -1119,27 +1107,12 @@ bind :: (Var v) => Cte v -> ANormal v -> ANormal v bind (ST d us ms bu) = TLets d us ms bu bind (LZ u f as) = TName u f as -unbind :: (Var v) => ANormal v -> Maybe (Cte v, ANormal v) -unbind (TLets d us ms bu bd) = Just (ST d us ms bu, bd) -unbind (TName u f as bd) = Just (LZ u f as, bd) -unbind _ = Nothing - unbinds :: (Var v) => ANormal v -> ([Cte v], ANormal v) unbinds (TLets d us ms bu (unbinds -> (ctx, bd))) = (ST d us ms bu : ctx, bd) unbinds (TName u f as (unbinds -> (ctx, bd))) = (LZ u f as : ctx, bd) unbinds tm = ([], tm) -pattern TBind :: - (Var v) => - Cte v -> - ANormal v -> - ANormal v -pattern TBind bn bd <- - (unbind -> Just (bn, bd)) - where - TBind bn bd = bind bn bd - pattern TBinds :: (Var v) => [Cte v] -> ANormal v -> ANormal v pattern TBinds ctx bd <- (unbinds -> (ctx, bd)) @@ -1149,7 +1122,7 @@ pattern TBinds ctx bd <- {-# COMPLETE TBinds #-} data SeqEnd = SLeft | SRight - deriving (Eq, Ord, Enum, Show) + deriving (Eq, Ord, Show) -- Note: MatchNumeric is a new form for matching directly on boxed -- numeric data. This leaves MatchIntegral around so that builtins can diff --git a/unison-runtime/src/Unison/Runtime/Array.hs b/unison-runtime/src/Unison/Runtime/Array.hs index 1b6d34fdc2..c3dd827de7 100644 --- a/unison-runtime/src/Unison/Runtime/Array.hs +++ b/unison-runtime/src/Unison/Runtime/Array.hs @@ -23,8 +23,6 @@ module Unison.Runtime.Array copyByteArray, copyMutableByteArray, moveByteArray, - readPrimArray, - writePrimArray, indexPrimArray, ) where @@ -194,27 +192,13 @@ checkIPArray name f arr i | otherwise = f arr i {-# inline checkIPArray #-} --- check index mutable prim array -checkIMPArray - :: CheckCtx - => Prim a - => String - -> (MutablePrimArray s a -> Int -> r) - -> MutablePrimArray s a -> Int -> r -checkIMPArray name f arr i - | i < 0 || sizeofMutablePrimArray arr <= i - = error $ name ++ " unsafe check out of bounds: " ++ show i - | otherwise = f arr i -{-# inline checkIMPArray #-} - #else type CheckCtx :: Constraint type CheckCtx = () -checkIMArray, checkIMPArray, checkIPArray :: String -> r -> r +checkIMArray, checkIPArray :: String -> r -> r checkCArray, checkCMArray, checkRMArray :: String -> r -> r checkIMArray _ = id -checkIMPArray _ = id checkCArray _ = id checkCMArray _ = id checkRMArray _ = id @@ -350,27 +334,6 @@ moveByteArray :: moveByteArray = checkCMBArray "moveByteArray" PA.moveByteArray {-# INLINE moveByteArray #-} -readPrimArray :: - (CheckCtx) => - (PrimMonad m) => - (Prim a) => - MutablePrimArray (PrimState m) a -> - Int -> - m a -readPrimArray = checkIMPArray "readPrimArray" PA.readPrimArray -{-# INLINE readPrimArray #-} - -writePrimArray :: - (CheckCtx) => - (PrimMonad m) => - (Prim a) => - MutablePrimArray (PrimState m) a -> - Int -> - a -> - m () -writePrimArray = checkIMPArray "writePrimArray" PA.writePrimArray -{-# INLINE writePrimArray #-} - indexPrimArray :: (CheckCtx) => (Prim a) => diff --git a/unison-runtime/src/Unison/Runtime/Builtin.hs b/unison-runtime/src/Unison/Runtime/Builtin.hs index 070bdd8118..debe399d25 100644 --- a/unison-runtime/src/Unison/Runtime/Builtin.hs +++ b/unison-runtime/src/Unison/Runtime/Builtin.hs @@ -42,7 +42,6 @@ import Crypto.PubKey.Ed25519 qualified as Ed25519 import Crypto.PubKey.RSA.PKCS15 qualified as RSA import Crypto.Random (getRandomBytes) import Data.Bits (shiftL, shiftR, (.|.)) -import Unison.Runtime.Builtin.Types import Data.ByteArray qualified as BA import Data.ByteString (hGet, hGetSome, hPut) import Data.ByteString.Lazy qualified as L @@ -163,6 +162,7 @@ import Unison.Runtime.ANF as ANF import Unison.Runtime.ANF.Rehash (checkGroupHashes) import Unison.Runtime.ANF.Serialize as ANF import Unison.Runtime.Array qualified as PA +import Unison.Runtime.Builtin.Types import Unison.Runtime.Crypto.Rsa as Rsa import Unison.Runtime.Exception (die) import Unison.Runtime.Foreign @@ -2265,7 +2265,7 @@ type FDecl v = -- means that the sandboxing check will by default consider them -- disallowed. data Sandbox = Tracked | Untracked - deriving (Eq, Ord, Show, Read, Enum, Bounded) + deriving (Eq, Ord, Show, Read) bomb :: Data.Text.Text -> a -> IO r bomb name _ = die $ "attempted to use sandboxed operation: " ++ Data.Text.unpack name diff --git a/unison-runtime/src/Unison/Runtime/Foreign.hs b/unison-runtime/src/Unison/Runtime/Foreign.hs index c9cd12fafb..92fb9118a6 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign.hs @@ -14,7 +14,6 @@ module Unison.Runtime.Foreign maybeUnwrapBuiltin, unwrapBuiltin, BuiltinForeign (..), - Tls (..), Failure (..), ) where @@ -252,8 +251,6 @@ instance BuiltinForeign X509.SignedCertificate where foreignRef = Tagged Ty.tlsS instance BuiltinForeign X509.PrivKey where foreignRef = Tagged Ty.tlsPrivateKeyRef -instance BuiltinForeign FilePath where foreignRef = Tagged Ty.filePathRef - instance BuiltinForeign TLS.Context where foreignRef = Tagged Ty.tlsRef instance BuiltinForeign (SuperGroup Symbol) where @@ -267,8 +264,6 @@ data HashAlgorithm where -- Reference is a reference to the hash algorithm HashAlgorithm :: (Hash.HashAlgorithm a) => Reference -> a -> HashAlgorithm -newtype Tls = Tls TLS.Context - data Failure a = Failure Reference Text a instance BuiltinForeign HashAlgorithm where foreignRef = Tagged Ty.hashAlgorithmRef diff --git a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs index de73cc7331..b9faee3903 100644 --- a/unison-runtime/src/Unison/Runtime/Foreign/Function.hs +++ b/unison-runtime/src/Unison/Runtime/Foreign/Function.hs @@ -24,11 +24,10 @@ import Data.Primitive.Array as PA import Data.Primitive.ByteArray as PA import Data.Sequence qualified as Sq import Data.Time.Clock.POSIX (POSIXTime) -import Data.Word (Word16, Word32, Word64, Word8) -import GHC.IO.Exception (IOErrorType (..), IOException (..)) +import Data.Word (Word64, Word8) import Network.Socket (Socket) import Network.UDP (UDPSocket) -import System.IO (BufferMode (..), Handle, IOMode, SeekMode) +import System.IO (BufferMode (..), Handle, SeekMode) import Unison.Builtin.Decls qualified as Ty import Unison.Reference (Reference) import Unison.Runtime.ANF (Mem (..), SuperGroup, Value, internalBug) @@ -107,14 +106,6 @@ 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" @@ -195,35 +186,6 @@ instance ustk <- bump ustk (ustk, bstk) <$ poke ustk 1 -ioeDecode :: Int -> IOErrorType -ioeDecode 0 = AlreadyExists -ioeDecode 1 = NoSuchThing -ioeDecode 2 = ResourceBusy -ioeDecode 3 = ResourceExhausted -ioeDecode 4 = EOF -ioeDecode 5 = IllegalOperation -ioeDecode 6 = PermissionDenied -ioeDecode 7 = UserError -ioeDecode _ = internalBug "ioeDecode" - -ioeEncode :: IOErrorType -> Int -ioeEncode AlreadyExists = 0 -ioeEncode NoSuchThing = 1 -ioeEncode ResourceBusy = 2 -ioeEncode ResourceExhausted = 3 -ioeEncode EOF = 4 -ioeEncode IllegalOperation = 5 -ioeEncode PermissionDenied = 6 -ioeEncode UserError = 7 -ioeEncode _ = internalBug "ioeDecode" - -instance ForeignConvention IOException where - readForeign = readForeignAs (bld . ioeDecode) - where - bld t = IOError Nothing t "" "" Nothing Nothing - - writeForeign = writeForeignAs (ioeEncode . ioe_type) - readForeignAs :: (ForeignConvention a) => (a -> b) -> @@ -292,13 +254,6 @@ readTypelink :: IO ([Int], [Int], Reference) readTypelink = readForeignAs (unwrapForeign . marshalToForeign) -instance ForeignConvention Double where - readForeign (i : us) bs ustk _ = (us,bs,) <$> peekOffD ustk i - readForeign _ _ _ _ = foreignCCError "Double" - writeForeign ustk bstk d = - bump ustk >>= \ustk -> - (ustk, bstk) <$ pokeD ustk d - instance ForeignConvention Bool where readForeign = readForeignEnum writeForeign = writeForeignEnum @@ -311,10 +266,6 @@ instance ForeignConvention SeekMode where readForeign = readForeignEnum writeForeign = writeForeignEnum -instance ForeignConvention IOMode where - readForeign = readForeignEnum - writeForeign = writeForeignEnum - instance ForeignConvention () where readForeign us bs _ _ = pure (us, bs, ()) writeForeign ustk bstk _ = pure (ustk, bstk) @@ -481,10 +432,6 @@ instance ForeignConvention Value where readForeign = readForeignBuiltin writeForeign = writeForeignBuiltin -instance ForeignConvention Foreign where - readForeign = readForeignAs marshalToForeign - writeForeign = writeForeignAs Foreign - instance ForeignConvention (PA.MutableArray s RClosure) where readForeign = readForeignAs (unwrapForeign . marshalToForeign) writeForeign = writeForeignAs (Foreign . Wrap marrayRef) diff --git a/unison-runtime/src/Unison/Runtime/IOSource.hs b/unison-runtime/src/Unison/Runtime/IOSource.hs index f690671fc5..a47c514577 100644 --- a/unison-runtime/src/Unison/Runtime/IOSource.hs +++ b/unison-runtime/src/Unison/Runtime/IOSource.hs @@ -5,7 +5,7 @@ module Unison.Runtime.IOSource where import Control.Lens (_2) import Control.Monad.Morph (hoist) -import Data.List (elemIndex, genericIndex) +import Data.List (elemIndex) import Data.Map qualified as Map import Data.Text qualified as Text import Text.RawString.QQ (r) @@ -95,37 +95,9 @@ typeNamedId s = typeNamed :: String -> R.Reference typeNamed = R.DerivedId . typeNamedId -abilityNamedId :: String -> R.Id -abilityNamedId s = - case Map.lookup (Var.nameds s) (UF.effectDeclarationsId' typecheckedFile) of - Nothing -> error $ "No builtin ability called: " <> s - Just (r, _) -> r - -eitherReference, - optionReference, - isTestReference, - isPropagatedReference :: - R.Reference -eitherReference = typeNamed "Either" -optionReference = typeNamed "Optional" -isTestReference = typeNamed "IsTest" -isPropagatedReference = typeNamed "IsPropagated" - -isTest :: (R.Reference, R.Reference) -isTest = (isTestReference, termNamed "metadata.isTest") - -isIOTest :: (R.Reference, R.Reference) -isIOTest = (isTestReference, termNamed "metadata.isIOTest") - isPropagatedValue :: R.Reference isPropagatedValue = termNamed "metadata.isPropagated" -eitherLeftId, eitherRightId, someId, noneId :: DD.ConstructorId -eitherLeftId = constructorNamed eitherReference "Either.Left" -eitherRightId = constructorNamed eitherReference "Either.Right" -someId = constructorNamed optionReference "Optional.Some" -noneId = constructorNamed optionReference "Optional.None" - authorRef, guidRef, copyrightHolderRef :: R.Reference authorRef = typeNamed "Author" guidRef = typeNamed "GUID" @@ -136,10 +108,6 @@ doc2Ref = typeNamed "Doc2" doc2SpecialFormRef = typeNamed "Doc2.SpecialForm" -doc2TermRef = typeNamed "Doc2.Term" - -prettyRef = typeNamed "Pretty" - prettyAnnotatedRef = typeNamed "Pretty.Annotated" ansiColorRef = typeNamed "ANSI.Color" @@ -348,8 +316,6 @@ pattern Doc2Example vs body <- Term.App' _term (Term.App' _any (Term.LamNamed' _ -- pulls out `body` in `Doc2.Term (Any 'body)` pattern Doc2Term body <- Term.App' _term (Term.App' _any (Term.LamNamed' _ body)) -pattern Doc2TermRef <- ((== doc2TermRef) -> True) - pattern PrettyAnnotatedRef <- ((== prettyAnnotatedRef) -> True) prettyEmptyId = constructorNamed prettyAnnotatedRef "Pretty.Annotated.Empty" @@ -384,8 +350,6 @@ pattern PrettyTable ann rows <- Term.Apps' (Term.Constructor' (ConstructorRefere pattern PrettyAppend ann tms <- Term.Apps' (Term.Constructor' (ConstructorReference PrettyAnnotatedRef ((==) prettyAppendId -> True))) [ann, Term.List' tms] -pattern PrettyRef <- ((== prettyRef) -> True) - prettyGetRef = termNamed "Pretty.get" doc2FormatConsoleRef = termNamed "syntax.docFormatConsole" @@ -514,15 +478,6 @@ constructorNamed ref name = . DD.constructorNames $ DD.asDataDecl decl -constructorName :: R.Reference -> DD.ConstructorId -> Text -constructorName ref cid = - case runIdentity . getTypeDeclaration codeLookup $ R.unsafeId ref of - Nothing -> - error $ - "There's a bug in the Unison runtime. Couldn't find type " - <> show ref - Just decl -> genericIndex (DD.constructorNames $ DD.asDataDecl decl) cid - -- .. todo - fill in the rest of these sourceString :: String @@ -1027,15 +982,6 @@ ImmutableByteArray.fromBytes bs = Scope.run do type Note = Result.Note Symbol Ann -type TFile = UF.TypecheckedUnisonFile Symbol Ann - -type SynthResult = - Result.Result - (Seq Note) - (Either (UF.UnisonFile Symbol Ann) TFile) - -type EitherResult = Either String TFile - showNotes :: (Foldable f) => String -> PrintError.Env -> f Note -> String showNotes source env = intercalateMap "\n\n" $ PrintError.renderNoteAsANSI 60 env source diff --git a/unison-runtime/src/Unison/Runtime/MCode.hs b/unison-runtime/src/Unison/Runtime/MCode.hs index 8f2f5a3d2d..4e948c617f 100644 --- a/unison-runtime/src/Unison/Runtime/MCode.hs +++ b/unison-runtime/src/Unison/Runtime/MCode.hs @@ -22,14 +22,12 @@ module Unison.Runtime.MCode RComb (..), pattern RCombIx, pattern RCombRef, - rCombToComb, GCombs, Combs, RCombs, CombIx (..), GRef (..), RRef, - Ref, UPrim1 (..), UPrim2 (..), BPrim1 (..), @@ -649,10 +647,6 @@ instance Eq RComb where instance Ord RComb where compare (RComb r1 _) (RComb r2 _) = compare r1 r2 --- | Convert an RComb to a Comb by forgetting the sections and keeping only the CombIx. -rCombToComb :: RComb -> Comb -rCombToComb (RComb _ix c) = rCombIx <$> c - -- | RCombs can be infinitely recursive so we show the CombIx instead. instance Show RComb where show (RComb ix _) = show ix @@ -660,9 +654,6 @@ instance Show RComb where -- | Map of combinators, parameterized by comb reference type type GCombs comb = EnumMap Word64 (GComb comb) --- | A reference to a combinator, parameterized by comb -type Ref = GRef CombIx - type RRef = GRef RComb data GRef comb diff --git a/unison-runtime/src/Unison/Runtime/Machine.hs b/unison-runtime/src/Unison/Runtime/Machine.hs index 14744462fc..5202990cda 100644 --- a/unison-runtime/src/Unison/Runtime/Machine.hs +++ b/unison-runtime/src/Unison/Runtime/Machine.hs @@ -107,15 +107,6 @@ refNumTm cc r = (M.lookup r -> Just w) -> pure w _ -> die $ "refNumTm: unknown reference: " ++ show r -refNumTy :: CCache -> Reference -> IO Word64 -refNumTy cc r = - refNumsTy cc >>= \case - (M.lookup r -> Just w) -> pure w - _ -> die $ "refNumTy: unknown reference: " ++ show r - -refNumTy' :: CCache -> Reference -> IO (Maybe Word64) -refNumTy' cc r = M.lookup r <$> refNumsTy cc - baseCCache :: Bool -> IO CCache baseCCache sandboxed = do CCache ffuncs sandboxed noTrace @@ -150,13 +141,6 @@ info ctx x = infos ctx (show x) infos :: String -> String -> IO () infos ctx s = putStrLn $ ctx ++ ": " ++ s -stk'info :: Stack 'BX -> IO () -stk'info s@(BS _ _ sp _) = do - let prn i - | i < 0 = return () - | otherwise = peekOff s i >>= print >> prn (i - 1) - prn sp - -- Entry point for evaluating a section eval0 :: CCache -> ActiveThreads -> RSection -> IO () eval0 !env !activeThreads !co = do @@ -226,34 +210,9 @@ apply1 callback env threadTracker clo = do where k0 = CB $ Hook callback --- Entry point for evaluating a saved continuation. --- --- The continuation must be from an evaluation context expecting a --- unit value. -jump0 :: - (Stack 'UN -> Stack 'BX -> IO ()) -> - CCache -> - ActiveThreads -> - Closure -> - IO () -jump0 !callback !env !activeThreads !clo = do - ustk <- alloc - bstk <- alloc - cmbs <- readTVarIO $ combs env - (denv, kf) <- - topDEnv cmbs <$> readTVarIO (refTy env) <*> readTVarIO (refTm env) - bstk <- bump bstk - poke bstk (Enum Rf.unitRef unitTag) - jump env denv activeThreads ustk bstk (kf k0) (BArg1 0) clo - where - k0 = CB (Hook callback) - unitValue :: Closure unitValue = Enum Rf.unitRef unitTag -lookupDenv :: Word64 -> DEnv -> Closure -lookupDenv p denv = fromMaybe BlackHole $ EC.lookup p denv - buildLit :: Reference -> Word64 -> MLit -> Closure buildLit rf tt (MI i) = DataU1 rf tt i buildLit _ _ (MT t) = Foreign (Wrap Rf.textRef t) @@ -1046,13 +1005,6 @@ closeArgs mode !ustk !bstk !useg !bseg args = ul = fsize ustk - ui bl = fsize bstk - bi -peekForeign :: Stack 'BX -> Int -> IO a -peekForeign bstk i = - peekOff bstk i >>= \case - Foreign x -> pure $ unwrapForeign x - _ -> die "bad foreign argument" -{-# INLINE peekForeign #-} - uprim1 :: Stack 'UN -> UPrim1 -> Int -> IO (Stack 'UN) uprim1 !ustk DECI !i = do m <- peekOff ustk i @@ -1849,18 +1801,6 @@ splitCont !denv !ustk !bstk !k !p = return (Captured ck uasz basz useg bseg, denv, ustk, bstk, k) {-# INLINE splitCont #-} -discardCont :: - DEnv -> - Stack 'UN -> - Stack 'BX -> - K -> - Word64 -> - IO (DEnv, Stack 'UN, Stack 'BX, K) -discardCont denv ustk bstk k p = - splitCont denv ustk bstk k p - <&> \(_, denv, ustk, bstk, k) -> (denv, ustk, bstk, k) -{-# INLINE discardCont #-} - resolve :: CCache -> DEnv -> Stack 'BX -> RRef -> IO Closure resolve _ _ _ (Env rComb) = pure $ PAp rComb unull bnull resolve _ _ bstk (Stk i) = peekOff bstk i @@ -1892,9 +1832,6 @@ resolveSection cc section = do dummyRef :: Reference dummyRef = Builtin (DTx.pack "dummy") -reserveIds :: Word64 -> TVar Word64 -> IO Word64 -reserveIds n free = atomically . stateTVar free $ \i -> (i, i + n) - updateMap :: (Semigroup s) => s -> TVar s -> STM s updateMap new0 r = do new <- evaluateSTM new0 diff --git a/unison-runtime/src/Unison/Runtime/Serialize.hs b/unison-runtime/src/Unison/Runtime/Serialize.hs index 064200cd55..5dfedc391c 100644 --- a/unison-runtime/src/Unison/Runtime/Serialize.hs +++ b/unison-runtime/src/Unison/Runtime/Serialize.hs @@ -71,16 +71,6 @@ putFloat = serializeBE getFloat :: (MonadGet m) => m Double getFloat = deserializeBE -putBool :: (MonadPut m) => Bool -> m () -putBool b = putWord8 (if b then 1 else 0) - -getBool :: (MonadGet m) => m Bool -getBool = d =<< getWord8 - where - d 0 = pure False - d 1 = pure True - d n = exn $ "getBool: bad tag: " ++ show n - putNat :: (MonadPut m) => Word64 -> m () putNat = putWord64be diff --git a/unison-runtime/src/Unison/Runtime/SparseVector.hs b/unison-runtime/src/Unison/Runtime/SparseVector.hs deleted file mode 100644 index 638d784faa..0000000000 --- a/unison-runtime/src/Unison/Runtime/SparseVector.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE BangPatterns #-} --- used for unsafe pointer equality -{-# LANGUAGE MagicHash #-} - -module Unison.Runtime.SparseVector where - -import Control.Monad.ST (ST) -import Data.Bits ((.&.), (.|.)) -import Data.Bits qualified as B -import Data.Vector.Unboxed qualified as UV -import Data.Vector.Unboxed.Mutable qualified as MUV -import GHC.Exts qualified as Exts -import Prelude hiding (unzip) - --- Denotes a `Nat -> Maybe a`. --- Representation is a `Vector a` along with a bitset --- that encodes the index of each element. --- Ex: `[(1,a), (5,b)]` is encoded as (100010, [a,b]) -data SparseVector bits a = SparseVector - { indices :: !bits, - elements :: !(UV.Vector a) - } - --- todo: instance (UV.Unbox a, B.FiniteBits bits, Num n) --- => Num (SparseVector bits n) - --- Denotationally: `map f v n = f <$> v n` -map :: (UV.Unbox a, UV.Unbox b) => (a -> b) -> SparseVector bits a -> SparseVector bits b -map f v = v {elements = UV.map f (elements v)} - --- Denotationally, a mask is a `Nat -> Bool`, so this implementation --- means: `mask ok v n = if ok n then v n else Nothing` -mask :: - forall a bits. - (UV.Unbox a, B.FiniteBits bits) => - bits -> - SparseVector bits a -> - SparseVector bits a -mask bits a = - if indices' == bits - then a -- check if mask is a superset - else SparseVector indices' $ - UV.create $ do - vec <- MUV.new (B.popCount indices') - go vec (indices a) bits 0 0 - where - indices' = indices a .&. bits - eas = elements a - go :: MUV.STVector s a -> bits -> bits -> Int -> Int -> ST s (MUV.STVector s a) - go !out !indAs !indBs !i !k = - if indAs == B.zeroBits || indBs == B.zeroBits - then pure out - else - let (!a1, !b1) = (B.countTrailingZeros indAs, B.countTrailingZeros indBs) - in if a1 == b1 - then do - MUV.write out k (eas UV.! (i + a1)) - go - out - (indAs `B.shiftR` (a1 + 1)) - (indBs `B.shiftR` (b1 + 1)) - (i + 1) - (k + 1) - else - if a1 < b1 - then - go - out - (indAs `B.shiftR` (a1 + 1)) - indBs - (i + 1) - k - else go out indAs (indBs `B.shiftR` (b1 + 1)) i k - --- Denotationally: `zipWith f a b n = f <$> a n <*> b n`, in other words, --- this takes the intersection of the two shapes. -zipWith :: - (UV.Unbox a, UV.Unbox b, UV.Unbox c, B.FiniteBits bits) => - (a -> b -> c) -> - SparseVector bits a -> - SparseVector bits b -> - SparseVector bits c -zipWith f a b = - if indices a `eq` indices b || indices a == indices b - then SparseVector (indices a) (UV.zipWith f (elements a) (elements b)) - else - let indices' = indices a .&. indices b - a' = mask indices' a - b' = mask indices' b - in SparseVector indices' (UV.zipWith f (elements a') (elements b')) - -_1 :: (UV.Unbox a, UV.Unbox b) => SparseVector bits (a, b) -> SparseVector bits a -_1 = fst . unzip - -_2 :: (UV.Unbox a, UV.Unbox b) => SparseVector bits (a, b) -> SparseVector bits b -_2 = snd . unzip - --- Denotationally: `unzip p = (\n -> fst <$> p n, \n -> snd <$> p n)` -unzip :: - (UV.Unbox a, UV.Unbox b) => - SparseVector bits (a, b) -> - (SparseVector bits a, SparseVector bits b) -unzip (SparseVector inds ps) = - let (as, bs) = UV.unzip ps - in (SparseVector inds as, SparseVector inds bs) - --- Denotationally: `choose bs a b n = if bs n then a n else b n` -choose :: - (B.FiniteBits bits, UV.Unbox a) => - bits -> - SparseVector bits a -> - SparseVector bits a -> - SparseVector bits a -choose bits t f - | B.zeroBits == bits = f - | B.complement bits == B.zeroBits = t - | otherwise -- it's a mix of true and false - = - merge (mask bits t) (mask (B.complement bits) f) - --- Denotationally: `merge a b n = a n <|> b n` -merge :: - forall a bits. - (B.FiniteBits bits, UV.Unbox a) => - SparseVector bits a -> - SparseVector bits a -> - SparseVector bits a -merge a b = SparseVector indices' tricky - where - indices' = indices a .|. indices b - tricky = UV.create $ do - vec <- MUV.new (B.popCount indices') - go vec (indices a) (indices b) 0 0 0 - (!eas, !ebs) = (elements a, elements b) - go :: MUV.STVector s a -> bits -> bits -> Int -> Int -> Int -> ST s (MUV.STVector s a) - go !out !indAs !indBs !i !j !k = - if indAs == B.zeroBits || indBs == B.zeroBits - then pure out - else - let (!a1, !b1) = (B.countTrailingZeros indAs, B.countTrailingZeros indBs) - in if a1 == b1 - then do - MUV.write out k (eas UV.! (i + a1)) - go - out - (indAs `B.shiftR` (a1 + 1)) - (indBs `B.shiftR` (b1 + 1)) - (i + 1) - (j + 1) - (k + 1) - else - if a1 < b1 - then do - MUV.write out k (eas UV.! (i + a1)) - go - out - (indAs `B.shiftR` (a1 + 1)) - indBs - (i + 1) - j - (k + 1) - else do - MUV.write out k (ebs UV.! (j + a1)) - go out indAs (indBs `B.shiftR` (b1 + 1)) i (j + 1) (k + 1) - --- Pointer equality a la Scala. -eq :: a -> a -> Bool -eq x y = Exts.isTrue# (Exts.reallyUnsafePtrEquality# x y Exts.==# 1#) -{-# INLINE eq #-} diff --git a/unison-runtime/src/Unison/Runtime/Stack.hs b/unison-runtime/src/Unison/Runtime/Stack.hs index b85707b1b3..d0a06e46e1 100644 --- a/unison-runtime/src/Unison/Runtime/Stack.hs +++ b/unison-runtime/src/Unison/Runtime/Stack.hs @@ -11,7 +11,6 @@ module Unison.Runtime.Stack GClosure (.., DataC, PApV, CapV), Closure, RClosure, - IxClosure, Callback (..), Augment (..), Dump (..), @@ -19,28 +18,23 @@ module Unison.Runtime.Stack Stack (..), Off, SZ, - FP, traceK, frameDataSize, marshalToForeign, unull, bnull, - peekD, peekOffD, pokeD, pokeOffD, - peekN, peekOffN, pokeN, pokeOffN, - peekBi, peekOffBi, pokeBi, pokeOffBi, peekOffS, pokeS, pokeOffS, - frameView, uscount, bscount, closureTermRefs, @@ -94,8 +88,6 @@ data K type RClosure = GClosure RComb -type IxClosure = GClosure CombIx - type Closure = GClosure RComb data GClosure comb @@ -211,8 +203,6 @@ type Off = Int type SZ = Int -type FP = Int - type UA = MutableByteArray (PrimState IO) type BA = MutableArray (PrimState IO) RClosure @@ -479,14 +469,6 @@ instance MEM 'UN where asize (US ap fp _ _) = fp - ap {-# INLINE asize #-} -peekN :: Stack 'UN -> IO Word64 -peekN (US _ _ sp stk) = readByteArray stk sp -{-# INLINE peekN #-} - -peekD :: Stack 'UN -> IO Double -peekD (US _ _ sp stk) = readByteArray stk sp -{-# INLINE peekD #-} - peekOffN :: Stack 'UN -> Int -> IO Word64 peekOffN (US _ _ sp stk) i = readByteArray stk (sp - i) {-# INLINE peekOffN #-} @@ -519,10 +501,6 @@ pokeOffBi :: (BuiltinForeign b) => Stack 'BX -> Int -> b -> IO () pokeOffBi bstk i x = pokeOff bstk i (Foreign $ wrapBuiltin x) {-# INLINE pokeOffBi #-} -peekBi :: (BuiltinForeign b) => Stack 'BX -> IO b -peekBi bstk = unwrapForeign . marshalToForeign <$> peek bstk -{-# INLINE peekBi #-} - peekOffBi :: (BuiltinForeign b) => Stack 'BX -> Int -> IO b peekOffBi bstk i = unwrapForeign . marshalToForeign <$> peekOff bstk i {-# INLINE peekOffBi #-} @@ -687,24 +665,6 @@ instance MEM 'BX where asize (BS ap fp _ _) = fp - ap -frameView :: (MEM b) => (Show (Elem b)) => Stack b -> IO () -frameView stk = putStr "|" >> gof False 0 - where - fsz = fsize stk - asz = asize stk - gof delim n - | n >= fsz = putStr "|" >> goa False 0 - | otherwise = do - when delim $ putStr "," - putStr . show =<< peekOff stk n - gof True (n + 1) - goa delim n - | n >= asz = putStrLn "|.." - | otherwise = do - when delim $ putStr "," - putStr . show =<< peekOff stk (fsz + n) - goa True (n + 1) - uscount :: Seg 'UN -> Int uscount seg = words $ sizeofByteArray seg diff --git a/unison-runtime/src/Unison/Runtime/Vector.hs b/unison-runtime/src/Unison/Runtime/Vector.hs deleted file mode 100644 index 51f2c40329..0000000000 --- a/unison-runtime/src/Unison/Runtime/Vector.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE GADTs #-} - -module Unison.Runtime.Vector where - -import Data.MemoCombinators qualified as Memo -import Data.Vector.Unboxed qualified as UV -import Unison.Prelude - --- A `Vec a` denotes a `Nat -> Maybe a` -data Vec a where - Scalar :: a -> Vec a - Vec :: (UV.Unbox a) => UV.Vector a -> Vec a - Pair :: Vec a -> Vec b -> Vec (a, b) - Choose :: Vec Bool -> Vec a -> Vec a -> Vec a - Mux :: Vec Nat -> Vec (Vec a) -> Vec a - --- todo: maybe make representation `(UV.Vector Nat -> UnboxedMap Nat a, Bound)` --- `UnboxedMap Nat a = (UV.Vector Nat, UV.Vector a)` --- UnboxedMap Nat could be implemented as an `UArray` --- `Bound` is Nat, max possible index --- then easy to implement `+`, `-`, etc - -type Nat = Word64 - -mu :: Vec a -> Nat -> Maybe a -mu v = case v of - Scalar a -> const (Just a) - Vec vs -> \i -> vs UV.!? fromIntegral i - Choose cond t f -> - let (condr, tr, tf) = (mu cond, mu t, mu f) - in \i -> condr i >>= \b -> if b then tr i else tf i - Mux mux branches -> - let muxr = mu mux - branchesr = Memo.integral $ let f = mu branches in \i -> mu <$> f i - in \i -> do j <- muxr i; b <- branchesr j; b i - Pair v1 v2 -> - let (v1r, v2r) = (mu v1, mu v2) - in \i -> liftA2 (,) (v1r i) (v2r i) - --- Returns the maximum `Nat` for which `mu v` may return `Just`. -bound :: Nat -> Vec a -> Nat -bound width v = case v of - Scalar _ -> width - Vec vs -> fromIntegral $ UV.length vs - Pair v1 v2 -> bound width v1 `min` bound width v2 - Choose cond _ _ -> bound width cond - Mux mux _ -> bound width mux - -toList :: Vec a -> [a] -toList v = - let n = bound maxBound v - muv = mu v - in catMaybes $ muv <$> [0 .. n] diff --git a/parser-typechecker/src/Unison/Util/EnumContainers.hs b/unison-runtime/src/Unison/Util/EnumContainers.hs similarity index 100% rename from parser-typechecker/src/Unison/Util/EnumContainers.hs rename to unison-runtime/src/Unison/Util/EnumContainers.hs diff --git a/unison-runtime/tests/Unison/Test/Common.hs b/unison-runtime/tests/Unison/Test/Common.hs index e1d880002c..dd361cac5d 100644 --- a/unison-runtime/tests/Unison/Test/Common.hs +++ b/unison-runtime/tests/Unison/Test/Common.hs @@ -2,6 +2,7 @@ module Unison.Test.Common ( hqLength, t, tm, + showParseError, parseAndSynthesizeAsFile, parsingEnv, ) diff --git a/unison-runtime/tests/Unison/Test/Runtime/ANF.hs b/unison-runtime/tests/Unison/Test/Runtime/ANF.hs index 84f97e0bf6..ace0b2bf05 100644 --- a/unison-runtime/tests/Unison/Test/Runtime/ANF.hs +++ b/unison-runtime/tests/Unison/Test/Runtime/ANF.hs @@ -23,21 +23,6 @@ import Unison.Util.EnumContainers as EC import Unison.Util.Text qualified as Util.Text import Unison.Var as Var --- testSNF s = ok --- where --- t0 = tm s --- snf = toSuperNormal (const 0) t0 - -simpleRefs :: Reference -> RTag -simpleRefs r - | r == Ty.natRef = 0 - | r == Ty.intRef = 1 - | r == Ty.floatRef = 2 - | r == Ty.booleanRef = 3 - | r == Ty.textRef = 4 - | r == Ty.charRef = 5 - | otherwise = 100 - runANF :: (Var v) => ANFM v a -> a runANF m = evalState (runReaderT m Set.empty) (0, 1, []) @@ -79,7 +64,7 @@ denormalize (TShift _ _ _) = error "denormalize shift" denormalize (TLet _ v _ bn bo) | typeOf v == ANFBlank = ABT.subst v dbn dbo - | otherwise = Term.let1_ False [(v, dbn)] dbo + | otherwise = Term.let1' False [(v, dbn)] dbo where dbn = denormalize bn dbo = denormalize bo @@ -105,19 +90,6 @@ denormalize (TApp f args) = Term.apps' df (Term.var () <$> args) FCont _ -> error "denormalize FCont" denormalize (TFrc _) = error "denormalize TFrc" -denormalizeRef :: RTag -> Reference -denormalizeRef r - | 0 <- rawTag r = Ty.natRef - | 1 <- rawTag r = Ty.intRef - | 2 <- rawTag r = Ty.floatRef - | 3 <- rawTag r = Ty.booleanRef - | 4 <- rawTag r = Ty.textRef - | 5 <- rawTag r = Ty.charRef - | otherwise = error "denormalizeRef" - -backReference :: Word64 -> Reference -backReference _ = error "backReference" - denormalizeMatch :: (Var v) => Branched (ANormal v) -> [Term.MatchCase () (Term.Term0 v)] denormalizeMatch b diff --git a/unison-runtime/tests/Unison/Test/Runtime/MCode.hs b/unison-runtime/tests/Unison/Test/Runtime/MCode.hs index 58118cf120..f98705ae7d 100644 --- a/unison-runtime/tests/Unison/Test/Runtime/MCode.hs +++ b/unison-runtime/tests/Unison/Test/Runtime/MCode.hs @@ -25,15 +25,9 @@ import Unison.Symbol (Symbol) import Unison.Term (unannotate) import Unison.Test.Common (tm) -dummyRef :: Reference -dummyRef = Builtin "dummy" - mainRef :: Reference mainRef = Builtin "main" -modifyTVarTest :: TVar a -> (a -> a) -> Test () -modifyTVarTest v f = io . atomically $ modifyTVar v f - testEval0 :: [(Reference, SuperGroup Symbol)] -> SuperGroup Symbol -> Test () testEval0 env main = ok << io do diff --git a/unison-runtime/tests/Unison/Test/UnisonSources.hs b/unison-runtime/tests/Unison/Test/UnisonSources.hs index 0f7cb980c5..24556885f6 100644 --- a/unison-runtime/tests/Unison/Test/UnisonSources.hs +++ b/unison-runtime/tests/Unison/Test/UnisonSources.hs @@ -12,7 +12,6 @@ import Unison.Builtin qualified as Builtin import Unison.Codebase.Runtime (Runtime, evaluateWatches) import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) -import Unison.Parsers qualified as Parsers import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnv.Names qualified as PPE @@ -21,6 +20,8 @@ import Unison.Result (Result, pattern Result) import Unison.Result qualified as Result import Unison.Runtime.Interface qualified as RTI import Unison.Symbol (Symbol) +import Unison.Syntax.Parser qualified as Parser +import Unison.Syntax.TermParser qualified as TermParser import Unison.Term qualified as Term import Unison.Test.Common (parseAndSynthesizeAsFile, parsingEnv) import Unison.Test.Common qualified as Common @@ -128,7 +129,7 @@ resultTest rt uf filepath = do if rFileExists then scope "result" $ do values <- io $ unpack <$> readUtf8 valueFile - let term = runIdentity (Parsers.parseTerm values parsingEnv) + let term = runIdentity (Parser.run (Parser.root TermParser.term) values parsingEnv) let report e = throwIO (userError $ toPlain 10000 e) (bindings, _, watches) <- io $ @@ -147,5 +148,5 @@ resultTest rt uf filepath = do -- note . show $ tm' -- note . show $ Term.amap (const ()) tm expectEqual tm' (Term.amap (const ()) tm) - Left e -> crash $ PrintError.renderParseErrorAsANSI 80 values e + Left e -> crash $ Common.showParseError values e else pure () diff --git a/unison-runtime/unison-runtime.cabal b/unison-runtime/unison-runtime.cabal index ea54c20b6a..d2eb5f5cfe 100644 --- a/unison-runtime/unison-runtime.cabal +++ b/unison-runtime/unison-runtime.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -47,9 +47,8 @@ library Unison.Runtime.MCode.Serialize Unison.Runtime.Pattern Unison.Runtime.Serialize - Unison.Runtime.SparseVector Unison.Runtime.Stack - Unison.Runtime.Vector + Unison.Util.EnumContainers hs-source-dirs: src default-extensions: @@ -99,7 +98,6 @@ library , crypton-x509-system , cryptonite , data-default - , data-memocombinators , deepseq , directory , exceptions diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 2df959ab4e..fc339929a9 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -12,7 +12,6 @@ dependencies: - aeson >= 2.0.0.0 - async - base - - binary - bytes - bytestring - containers @@ -31,7 +30,6 @@ dependencies: - mtl - nonempty-containers - openapi3 - - regex-tdfa - servant - servant-docs - servant-openapi3 diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index f40a85b248..ec6681d68a 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -28,7 +28,6 @@ module Unison.Server.Backend expandShortCausalHash, findDocInBranch, formatSuffixedType, - getShallowCausalAtPathFromRootHash, getTermTag, getTypeTag, hoistBackend, @@ -44,14 +43,12 @@ module Unison.Server.Backend termEntryDisplayName, termEntryHQName, termEntryToNamedTerm, - termEntryLabeledDependencies, termListEntry, termReferentsByShortHash, typeDeclHeader, typeEntryDisplayName, typeEntryHQName, typeEntryToNamedType, - typeEntryLabeledDependencies, typeListEntry, typeReferencesByShortHash, typeToSyntaxHeader, @@ -59,17 +56,11 @@ module Unison.Server.Backend docsForDefinitionName, normaliseRootCausalHash, - -- * Unused, could remove? - resolveRootBranchHash, - isTestResultList, - fixupNamesRelative, - -- * Re-exported for Share Server termsToSyntax, termsToSyntaxOf, typesToSyntax, typesToSyntaxOf, - definitionResultsDependencies, evalDocRef, mkTermDefinition, mkTypeDefinition, @@ -124,11 +115,9 @@ import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorReference qualified as ConstructorReference import Unison.ConstructorType qualified as CT import Unison.DataDeclaration qualified as DD -import Unison.DataDeclaration.Dependencies qualified as DD import Unison.HashQualified qualified as HQ import Unison.HashQualifiedPrime qualified as HQ' import Unison.Hashing.V2.Convert qualified as Hashing -import Unison.LabeledDependency qualified as LD import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) @@ -159,7 +148,6 @@ import Unison.Server.SearchResult qualified as SR import Unison.Server.SearchResultPrime qualified as SR' import Unison.Server.Syntax qualified as Syntax import Unison.Server.Types -import Unison.Server.Types qualified as ServerTypes import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as SH import Unison.Sqlite qualified as Sqlite @@ -278,18 +266,6 @@ data TermEntry v a = TermEntry } deriving (Eq, Ord, Show, Generic) -termEntryLabeledDependencies :: (Ord v) => TermEntry v a -> Set LD.LabeledDependency -termEntryLabeledDependencies TermEntry {termEntryType, termEntryReferent, termEntryTag, termEntryName} = - foldMap Type.labeledDependencies termEntryType - <> Set.singleton (LD.TermReferent (Cv.referent2to1UsingCT ct termEntryReferent)) - where - ct :: V2Referent.ConstructorType - ct = case termEntryTag of - ServerTypes.Constructor ServerTypes.Ability -> V2Referent.EffectConstructor - ServerTypes.Constructor ServerTypes.Data -> V2Referent.DataConstructor - ServerTypes.Doc -> V2Referent.DataConstructor - _ -> error $ "termEntryLabeledDependencies: Term is not a constructor, but the referent was a constructor. Tag: " <> show termEntryTag <> " Name: " <> show termEntryName <> " Referent: " <> show termEntryReferent - termEntryDisplayName :: TermEntry v a -> Text termEntryDisplayName = HQ'.toTextWith Name.toText . termEntryHQName @@ -308,10 +284,6 @@ data TypeEntry = TypeEntry } deriving (Eq, Ord, Show, Generic) -typeEntryLabeledDependencies :: TypeEntry -> Set LD.LabeledDependency -typeEntryLabeledDependencies TypeEntry {typeEntryReference} = - Set.singleton (LD.TypeReference typeEntryReference) - typeEntryDisplayName :: TypeEntry -> Text typeEntryDisplayName = HQ'.toTextWith Name.toText . typeEntryHQName @@ -414,14 +386,6 @@ 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.isEqual t resultListType - -resultListType :: (Ord v, Monoid a) => Type v a -resultListType = Type.app mempty (Type.list mempty) (Type.ref mempty Decls.testResultRef) - termListEntry :: (MonadIO m) => Codebase m Symbol Ann -> @@ -579,24 +543,6 @@ lsBranch codebase b0 = do ++ typeEntries ++ branchEntries --- Any absolute names in the input which have `root` as a prefix --- are converted to names relative to current path. All other names are --- converted to absolute names. For example: --- --- e.g. if currentPath = .foo.bar --- then name foo.bar.baz becomes baz --- name cat.dog becomes .cat.dog -fixupNamesRelative :: Path.Absolute -> Names -> Names -fixupNamesRelative root names = - case Path.toName $ Path.unabsolute root of - Nothing -> names - Just prefix -> Names.map (fixName prefix) names - where - fixName prefix n = - if root == Path.absoluteEmpty - then n - else fromMaybe (Name.makeAbsolute n) (Name.stripNamePrefix prefix n) - hqNameQuery :: Codebase m v Ann -> NameSearch Sqlite.Transaction -> @@ -663,26 +609,6 @@ data DefinitionResults = DefinitionResults } deriving stock (Show) --- | Finds ALL direct references contained within a 'DefinitionResults' so we can --- build a pretty printer for them. -definitionResultsDependencies :: DefinitionResults -> Set LD.LabeledDependency -definitionResultsDependencies (DefinitionResults {termResults, typeResults}) = - let topLevelTerms = Set.fromList . fmap LD.TermReference $ Map.keys termResults - topLevelTypes = Set.fromList . fmap LD.TypeReference $ Map.keys typeResults - termDeps = - termResults - & foldOf - ( folded - . beside - (to Type.labeledDependencies) - (to Term.labeledDependencies) - ) - typeDeps = - typeResults - & ifoldMap \typeRef ddObj -> - foldMap (DD.labeledDeclDependenciesIncludingSelfAndFieldAccessors typeRef) ddObj - in termDeps <> typeDeps <> topLevelTerms <> topLevelTypes - expandShortCausalHash :: ShortCausalHash -> Backend Sqlite.Transaction CausalHash expandShortCausalHash hash = do hashSet <- lift $ Codebase.causalHashesByPrefix hash @@ -693,15 +619,6 @@ expandShortCausalHash hash = do _ -> throwError . AmbiguousBranchHash hash $ Set.map (SCH.fromHash len) hashSet --- | Efficiently resolve a root hash and path to a shallow branch's causal. -getShallowCausalAtPathFromRootHash :: - CausalHash -> - Path -> - Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) -getShallowCausalAtPathFromRootHash rootHash path = do - shallowRoot <- Codebase.expectCausalBranchByCausalHash rootHash - Codebase.getShallowCausalAtPath path shallowRoot - formatType' :: (Var v) => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText formatType' ppe w = Pretty.render w . TypePrinter.prettySyntax ppe @@ -1004,12 +921,6 @@ resolveCausalHash bhash codebase = do mayBranch <- lift $ Codebase.getBranchForHash codebase bhash whenNothing mayBranch (throwError $ NoBranchForHash bhash) -resolveRootBranchHash :: - (MonadIO m) => ShortCausalHash -> Codebase m v a -> Backend m (Branch m) -resolveRootBranchHash sch codebase = do - h <- hoistBackend (Codebase.runTransaction codebase) (expandShortCausalHash sch) - resolveCausalHash h codebase - resolveRootBranchHashV2 :: ShortCausalHash -> Backend Sqlite.Transaction (V2Branch.CausalBranch Sqlite.Transaction) resolveRootBranchHashV2 sch = do diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index 1bbdfa5e24..f6bd1d06a7 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -375,9 +375,6 @@ docsBS = mungeString . markdown $ docsWithIntros [intro] api (Text.unpack $ _infoTitle infoObject) (toList $ Text.unpack <$> _infoDescription infoObject) -unisonAndDocsAPI :: Proxy UnisonAndDocsAPI -unisonAndDocsAPI = Proxy - api :: Proxy UnisonLocalAPI api = Proxy diff --git a/unison-share-api/src/Unison/Server/Doc.hs b/unison-share-api/src/Unison/Server/Doc.hs index ec2ee1cd1d..bca2927c79 100644 --- a/unison-share-api/src/Unison/Server/Doc.hs +++ b/unison-share-api/src/Unison/Server/Doc.hs @@ -153,20 +153,6 @@ data Src = Src SyntaxText SyntaxText deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON, ToSchema) --- | Evaluate the doc, then render it. -evalAndRenderDoc :: - forall v m. - (Var v, Monad m) => - PPE.PrettyPrintEnvDecl -> - (Reference -> m (Maybe (Term v ()))) -> - (Referent -> m (Maybe (Type v ()))) -> - (Term v () -> m (Maybe (Term v ()))) -> - (Reference -> m (Maybe (DD.Decl v ()))) -> - Term v () -> - m Doc -evalAndRenderDoc pped terms typeOf eval types tm = - renderDoc pped <$> evalDoc terms typeOf eval types tm - -- | Renders the given doc, which must have been evaluated using 'evalDoc' renderDoc :: forall v. @@ -469,44 +455,3 @@ data EvaluatedTerm v | MissingBuiltinTypeSig Reference | FoundTerm Reference (Type v ()) (Term v ()) deriving stock (Show, Eq, Generic) - --- Determines all dependencies which will be required to render a doc. -dependencies :: (Ord v) => EvaluatedDoc v -> Set LD.LabeledDependency -dependencies = foldMap dependenciesSpecial - --- | Determines all dependencies of a special form -dependenciesSpecial :: forall v. (Ord v) => EvaluatedSpecialForm v -> Set LD.LabeledDependency -dependenciesSpecial = \case - ESource srcs -> srcDeps srcs - EFoldedSource srcs -> srcDeps srcs - EExample trm -> Term.labeledDependencies trm - EExampleBlock trm -> Term.labeledDependencies trm - ELink ref -> either Term.labeledDependencies Set.singleton ref - ESignature sigtyps -> sigtypDeps sigtyps - ESignatureInline sig -> sigtypDeps [sig] - EEval trm mayTrm -> Term.labeledDependencies trm <> foldMap Term.labeledDependencies mayTrm - EEvalInline trm mayTrm -> Term.labeledDependencies trm <> foldMap Term.labeledDependencies mayTrm - EEmbed trm -> Term.labeledDependencies trm - EEmbedInline trm -> Term.labeledDependencies trm - EVideo {} -> mempty - EFrontMatter {} -> mempty - ELaTeXInline {} -> mempty - ESvg {} -> mempty - ERenderError (InvalidTerm trm) -> Term.labeledDependencies trm - where - sigtypDeps :: [(Referent, Type v a)] -> Set LD.LabeledDependency - sigtypDeps sigtyps = - sigtyps & foldMap \(ref, typ) -> - Set.singleton (LD.TermReferent ref) <> Type.labeledDependencies typ - srcDeps :: [EvaluatedSrc v] -> Set LD.LabeledDependency - srcDeps srcs = - srcs & foldMap \case - EvaluatedSrcDecl srcDecl -> case srcDecl of - MissingDecl ref -> Set.singleton (LD.TypeReference ref) - BuiltinDecl ref -> Set.singleton (LD.TypeReference ref) - FoundDecl ref decl -> Set.singleton (LD.TypeReference ref) <> DD.labeledDeclDependenciesIncludingSelf ref decl - EvaluatedSrcTerm srcTerm -> case srcTerm of - MissingTerm ref -> Set.singleton (LD.TermReference ref) - BuiltinTypeSig ref _ -> Set.singleton (LD.TermReference ref) - MissingBuiltinTypeSig ref -> Set.singleton (LD.TermReference ref) - FoundTerm ref typ trm -> Set.singleton (LD.TermReference ref) <> Type.labeledDependencies typ <> Term.labeledDependencies trm diff --git a/unison-share-api/src/Unison/Server/Errors.hs b/unison-share-api/src/Unison/Server/Errors.hs index 28e2e555f6..415a31bec1 100644 --- a/unison-share-api/src/Unison/Server/Errors.hs +++ b/unison-share-api/src/Unison/Server/Errors.hs @@ -30,15 +30,6 @@ import Unison.Server.Types import Unison.ShortHash qualified as SH import Unison.Syntax.HashQualified qualified as HQ (toText) -badHQN :: HashQualifiedName -> ServerError -badHQN hqn = - err400 - { errBody = - LazyText.encodeUtf8 (LazyText.fromStrict hqn) - <> " is not a well-formed name, hash, or hash-qualified name. " - <> "I expected something like `foo`, `#abc123`, or `foo#abc123`." - } - backendError :: Backend.BackendError -> ServerError backendError = \case Backend.NoSuchNamespace n -> diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs index c0e2d94841..33312cac43 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs @@ -6,7 +6,6 @@ module Unison.Server.Local.Endpoints.NamespaceDetails where import Data.Set qualified as Set import Servant (Capture, QueryParam, (:>)) -import Servant.Docs (DocCapture (..), ToCapture (..)) import Servant.OpenApi () import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash) @@ -35,12 +34,6 @@ type NamespaceDetailsAPI = :> QueryParam "renderWidth" Width :> APIGet NamespaceDetails -instance ToCapture (Capture "namespace" Text) where - toCapture _ = - DocCapture - "namespace" - "The fully qualified name of a namespace. The leading `.` is optional." - namespaceDetails :: Rt.Runtime Symbol -> Codebase IO Symbol Ann -> diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs index c60357548d..6fe38c04f5 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs @@ -2,20 +2,20 @@ {-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -Wno-orphans #-} -module Unison.Server.Local.Endpoints.NamespaceListing (serve, NamespaceListingAPI, NamespaceListing (..), NamespaceObject (..), NamedNamespace (..), NamedPatch (..), KindExpression (..)) where +module Unison.Server.Local.Endpoints.NamespaceListing + ( serve, + NamespaceListingAPI, + NamespaceListing (..), + NamespaceObject (..), + NamedNamespace (..), + NamedPatch (..), + ) +where import Data.Aeson import Data.OpenApi (ToSchema) -import Servant - ( QueryParam, - (:>), - ) -import Servant.Docs - ( DocQueryParam (..), - ParamKind (Normal), - ToParam (..), - ToSample (..), - ) +import Servant (QueryParam, (:>)) +import Servant.Docs (ToSample (..)) import Servant.OpenApi () import U.Codebase.Branch (NamespaceStats (..)) import U.Codebase.Causal qualified as V2Causal @@ -50,14 +50,6 @@ type NamespaceListingAPI = :> QueryParam "namespace" Path.Path :> APIGet NamespaceListing -instance ToParam (QueryParam "namespace" Text) where - toParam _ = - DocQueryParam - "namespace" - [".", ".base.List", "foo.bar"] - "The fully qualified name of a namespace. The leading `.` is optional." - Normal - instance ToSample NamespaceListing where toSamples _ = [ ( "When no value is provided for `namespace`, the root namespace `.` is " @@ -158,16 +150,6 @@ instance FromJSON NamedPatch where patchName <- o .: "patchName" pure NamedPatch {..} -newtype KindExpression = KindExpression {kindExpressionText :: Text} - deriving stock (Generic, Show) - deriving anyclass (ToSchema) - -instance ToJSON KindExpression where - toJSON KindExpression {..} = - object - [ "kindExpressionText" .= kindExpressionText - ] - backendListEntryToNamespaceObject :: (Var v) => PPE.PrettyPrintEnv -> diff --git a/unison-share-api/src/Unison/Server/Local/Endpoints/Projects.hs b/unison-share-api/src/Unison/Server/Local/Endpoints/Projects.hs index b908b7499b..d31105dd02 100644 --- a/unison-share-api/src/Unison/Server/Local/Endpoints/Projects.hs +++ b/unison-share-api/src/Unison/Server/Local/Endpoints/Projects.hs @@ -17,7 +17,6 @@ import Data.OpenApi (ToParamSchema, ToSchema) import GHC.Generics () import Servant import Servant.Docs -import Servant.Docs qualified as Docs import U.Codebase.Sqlite.Project qualified as SqliteProject import U.Codebase.Sqlite.Queries qualified as Q import Unison.Codebase (Codebase) @@ -82,10 +81,6 @@ instance ToParam (QueryParam "prefix" PrefixFilter) where "Filter by project or branch prefix" Normal -instance Docs.ToSample PrefixFilter where - toSamples _ = - singleSample $ PrefixFilter "my-proj" - projectListingEndpoint :: Codebase IO Symbol Ann -> Maybe PrefixFilter -> diff --git a/unison-share-api/src/Unison/Server/NameSearch.hs b/unison-share-api/src/Unison/Server/NameSearch.hs index 5e61cd8c30..1b10c23d59 100644 --- a/unison-share-api/src/Unison/Server/NameSearch.hs +++ b/unison-share-api/src/Unison/Server/NameSearch.hs @@ -1,8 +1,6 @@ module Unison.Server.NameSearch ( Search (..), NameSearch (..), - hoistSearch, - hoistNameSearch, applySearch, SearchType (..), ) @@ -35,27 +33,11 @@ data Search m r = Search matchesNamedRef :: Name -> r -> HQ'.HashQualified Name -> Bool } -hoistSearch :: (forall x. m x -> n x) -> Search m r -> Search n r -hoistSearch f Search {lookupNames, lookupRelativeHQRefs', makeResult, matchesNamedRef} = - Search - { lookupNames = f . lookupNames, - lookupRelativeHQRefs' = \st hqname -> f $ lookupRelativeHQRefs' st hqname, - makeResult = \n r -> f . makeResult n r, - matchesNamedRef = \n r -> matchesNamedRef n r - } - data NameSearch m = NameSearch { typeSearch :: Search m Reference, termSearch :: Search m Referent } -hoistNameSearch :: (forall x. m x -> n x) -> NameSearch m -> NameSearch n -hoistNameSearch f NameSearch {typeSearch, termSearch} = - NameSearch - { typeSearch = hoistSearch f typeSearch, - termSearch = hoistSearch f termSearch - } - -- | Interpret a 'Search' as a function from name to search results. applySearch :: (Show r, Monad m) => Search m r -> SearchType -> HQ'.HashQualified Name -> m [SR.SearchResult] applySearch Search {lookupNames, lookupRelativeHQRefs', makeResult, matchesNamedRef} searchType query = do diff --git a/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs b/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs index 8095d5bdce..8071d77080 100644 --- a/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs +++ b/unison-share-api/src/Unison/Server/NameSearch/Sqlite.hs @@ -1,137 +1,23 @@ module Unison.Server.NameSearch.Sqlite - ( resolveShortHash, - typeReferencesByShortHash, + ( typeReferencesByShortHash, termReferentsByShortHash, NameSearch (..), - nameSearchForPerspective, ) where import Control.Lens import Data.Set qualified as Set -import U.Codebase.Sqlite.NameLookups (PathSegments (..), ReversedName (..)) -import U.Codebase.Sqlite.NamedRef qualified as NamedRef -import U.Codebase.Sqlite.Operations qualified as Ops import Unison.Builtin qualified as Builtin import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase -import Unison.Codebase.Path qualified as Path -import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv -import Unison.HashQualifiedPrime qualified as HQ' -import Unison.LabeledDependency qualified as LD -import Unison.Name (Name) -import Unison.Name qualified as Name -import Unison.NameSegment.Internal (NameSegment (NameSegment)) -import Unison.NamesWithHistory (SearchType (ExactName, IncludeSuffixes)) import Unison.Prelude import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent -import Unison.Server.NameSearch (NameSearch (..), Search (..)) -import Unison.Server.SearchResult qualified as SR +import Unison.Server.NameSearch (NameSearch (..)) import Unison.ShortHash qualified as SH import Unison.Sqlite qualified as Sqlite -import Unison.Util.Set qualified as Set - -nameSearchForPerspective :: Codebase m v a -> Ops.NamesPerspective -> (NameSearch Sqlite.Transaction) -nameSearchForPerspective codebase namesPerspective@Ops.NamesPerspective {pathToMountedNameLookup} = do - NameSearch {typeSearch, termSearch} - where - -- Some searches will provide a fully-qualified name, so we need to strip off the - -- mount-path before we search or it will fail to find anything. - stripMountPathPrefix :: Name -> Name - stripMountPathPrefix name = Name.tryStripReversedPrefix name (reverse $ coerce pathToMountedNameLookup) - typeSearch = - Search - { lookupNames = lookupNamesForTypes, - lookupRelativeHQRefs' = \searchType n -> hqTypeSearch searchType . fmap stripMountPathPrefix $ n, - makeResult = \hqname r names -> pure $ SR.typeResult hqname r names, - matchesNamedRef = HQ'.matchesNamedReference - } - termSearch = - Search - { lookupNames = lookupNamesForTerms, - lookupRelativeHQRefs' = \searchType n -> hqTermSearch searchType . fmap stripMountPathPrefix $ n, - makeResult = \hqname r names -> pure $ SR.termResult hqname r names, - matchesNamedRef = HQ'.matchesNamedReferent - } - - lookupNamesForTypes :: Reference -> Sqlite.Transaction (Set (HQ'.HashQualified Name)) - lookupNamesForTypes ref = do - names <- Ops.typeNamesForRefWithinNamespace namesPerspective (Cv.reference1to2 ref) Nothing - names - & fmap (\segments -> HQ'.HashQualified (reversedSegmentsToName segments) (Reference.toShortHash ref)) - & Set.fromList - & pure - lookupNamesForTerms :: Referent -> Sqlite.Transaction (Set (HQ'.HashQualified Name)) - lookupNamesForTerms ref = do - names <- Ops.termNamesForRefWithinNamespace namesPerspective (Cv.referent1to2 ref) Nothing - names - & fmap (\segments -> HQ'.HashQualified (reversedSegmentsToName segments) (Referent.toShortHash ref)) - & Set.fromList - & pure - -- Search the codebase for matches to the given hq name. - -- Supports either an exact match or a suffix match. - hqTermSearch :: SearchType -> HQ'.HashQualified Name -> Sqlite.Transaction (Set Referent) - hqTermSearch searchStrat hqName = do - case hqName of - HQ'.NameOnly name -> do - namedRefs <- - case searchStrat of - ExactName -> Ops.termRefsForExactName namesPerspective (coerce $ Name.reverseSegments name) - IncludeSuffixes -> Ops.termNamesBySuffix namesPerspective (coerce $ Name.reverseSegments name) - namedRefs - & fmap - ( \(NamedRef.ref -> (ref, mayCT)) -> - Cv.referent2to1UsingCT (fromMaybe (error "Required constructor type for constructor but it was null") mayCT) ref - ) - & Set.fromList - & pure - HQ'.HashQualified name sh -> do - let fqn = fullyQualifyName name - termRefs <- termReferentsByShortHash codebase sh - Set.forMaybe termRefs \termRef -> do - matches <- Ops.termNamesForRefWithinNamespace namesPerspective (Cv.referent1to2 termRef) (Just . coerce $ Name.reverseSegments name) - -- Return a valid ref if at least one match was found. Require that it be an exact - -- match if specified. - if any (\n -> coerce (Name.reverseSegments fqn) == n || searchStrat /= ExactName) matches - then pure (Just termRef) - else pure Nothing - - -- Search the codebase for matches to the given hq name. - -- Supports either an exact match or a suffix match. - hqTypeSearch :: SearchType -> HQ'.HashQualified Name -> Sqlite.Transaction (Set Reference) - hqTypeSearch searchStrat hqName = do - case hqName of - HQ'.NameOnly name -> do - let fqn = fullyQualifyName name - namedRefs <- - case searchStrat of - ExactName -> Ops.typeRefsForExactName namesPerspective (coerce $ Name.reverseSegments fqn) - IncludeSuffixes -> Ops.typeNamesBySuffix namesPerspective (coerce $ Name.reverseSegments name) - namedRefs - & fmap (Cv.reference2to1 . NamedRef.ref) - & Set.fromList - & pure - HQ'.HashQualified name sh -> do - let fqn = fullyQualifyName name - typeRefs <- typeReferencesByShortHash sh - Set.forMaybe typeRefs \typeRef -> do - matches <- Ops.typeNamesForRefWithinNamespace namesPerspective (Cv.reference1to2 typeRef) (Just . coerce $ Name.reverseSegments name) - -- Return a valid ref if at least one match was found. Require that it be an exact - -- match if specified. - if any (\n -> coerce (Name.reverseSegments fqn) == n || searchStrat /= ExactName) matches - then pure (Just typeRef) - else pure Nothing - - reversedSegmentsToName :: ReversedName -> Name - reversedSegmentsToName = Name.fromReverseSegments . coerce - - -- Fully qualify a name by prepending the current namespace perspective's path - fullyQualifyName :: Name -> Name - fullyQualifyName = - Path.prefixNameIfRel (Path.AbsolutePath' . Path.Absolute . Path.fromList $ coerce pathToMountedNameLookup) -- | Look up types in the codebase by short hash, and include builtins. typeReferencesByShortHash :: SH.ShortHash -> Sqlite.Transaction (Set Reference) @@ -153,10 +39,3 @@ termReferentsByShortHash codebase sh = do (\r -> sh == Reference.toShortHash r) Builtin.intrinsicTermReferences pure (fromBuiltins <> Set.mapMonotonic (over Referent.reference_ Reference.DerivedId) fromCodebase) - --- | Resolves a shorthash into any possible matches. -resolveShortHash :: Codebase m v a -> SH.ShortHash -> Sqlite.Transaction (Set LD.LabeledDependency) -resolveShortHash codebase sh = do - terms <- Set.map LD.TermReferent <$> termReferentsByShortHash codebase sh - types <- Set.map LD.TypeReference <$> typeReferencesByShortHash sh - pure $ terms <> types diff --git a/unison-share-api/src/Unison/Server/Orphans.hs b/unison-share-api/src/Unison/Server/Orphans.hs index bab2d26fef..8693d4f642 100644 --- a/unison-share-api/src/Unison/Server/Orphans.hs +++ b/unison-share-api/src/Unison/Server/Orphans.hs @@ -6,30 +6,18 @@ module Unison.Server.Orphans where import Control.Lens import Data.Aeson import Data.Aeson qualified as Aeson -import Data.Binary -import Data.ByteString.Short (ShortByteString) -import Data.List.NonEmpty (NonEmpty (..)) import Data.OpenApi import Data.Proxy import Data.Text qualified as Text import Servant import Servant.Docs (DocCapture (DocCapture), DocQueryParam (..), ParamKind (..), ToCapture (..), ToParam (..)) -import U.Codebase.HashTags import Unison.Codebase.Editor.DisplayObject import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path -import Unison.Codebase.ShortCausalHash (ShortCausalHash (..)) -import Unison.Codebase.ShortCausalHash qualified as SCH -import Unison.ConstructorType (ConstructorType) -import Unison.ConstructorType qualified as CT import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) -import Unison.Hash (Hash (..)) -import Unison.Hash qualified as Hash import Unison.HashQualified qualified as HQ import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) -import Unison.Name qualified as Name -import Unison.NameSegment.Internal (NameSegment (NameSegment)) import Unison.Prelude import Unison.Project import Unison.Reference qualified as Reference @@ -39,73 +27,20 @@ import Unison.ShortHash qualified as SH import Unison.Syntax.HashQualified qualified as HQ (parseText) import Unison.Syntax.HashQualifiedPrime qualified as HQ' (parseText) import Unison.Syntax.Name qualified as Name (parseTextEither, toText) -import Unison.Syntax.NameSegment qualified as NameSegment 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 toJSON = Aeson.String . SH.toText -instance ToJSONKey ShortHash where - toJSONKey = contramap SH.toText (toJSONKey @Text) - instance FromJSON ShortHash where parseJSON = Aeson.withText "ShortHash" \txt -> case SH.fromText txt of Nothing -> fail $ "Invalid Shorthash" <> Text.unpack txt Just sh -> pure sh -instance FromJSONKey ShortHash where - fromJSONKey = - Aeson.FromJSONKeyTextParser \txt -> - case SH.fromText txt of - Nothing -> fail $ "Invalid Shorthash" <> Text.unpack txt - Just sh -> pure sh - -instance FromHttpApiData ShortCausalHash where - parseUrlPiece = maybe (Left "Invalid ShortCausalHash") Right . SCH.fromText - --- | Always renders to the form: #abcdef -instance ToHttpApiData ShortHash where - toQueryParam = SH.toText - --- | Accepts shorthashes of any of the following forms: --- @abcdef --- @@builtin --- #abcdef --- ##builtin --- abcdef -instance FromHttpApiData ShortHash where - parseUrlPiece txt = - Text.replace "@" "#" txt - & \t -> - ( if Text.isPrefixOf "#" t - then t - else ("#" <> t) - ) - & SH.fromText - & maybe (Left "Invalid ShortCausalHash") Right - instance ToSchema ShortHash where declareNamedSchema _ = declareNamedSchema (Proxy @Text) --- | Always renders to the form: #abcdef -instance ToHttpApiData Reference.Reference where - toQueryParam = Reference.toText - --- | Always renders to the form: #abcdef -instance ToHttpApiData Referent.Referent where - toQueryParam = Referent.toText - -- | Accepts shorthashes of any of the following forms: -- @abcdef -- @@builtin @@ -140,30 +75,12 @@ instance FromHttpApiData Referent.Referent where & Referent.fromText & maybe (Left "Invalid Referent") Right -instance ToSchema Reference where - declareNamedSchema _ = declareNamedSchema (Proxy @Text) - -deriving via ShortByteString instance Binary Hash - -deriving via Hash instance Binary CausalHash - -deriving via Text instance ToHttpApiData ShortCausalHash - instance (ToJSON b, ToJSON a) => ToJSON (DisplayObject b a) where toJSON = \case BuiltinObject b -> object ["tag" Aeson..= String "BuiltinObject", "contents" Aeson..= b] MissingObject sh -> object ["tag" Aeson..= String "MissingObject", "contents" Aeson..= sh] UserObject a -> object ["tag" Aeson..= String "UserObject", "contents" Aeson..= a] -instance (FromJSON a, FromJSON b) => FromJSON (DisplayObject b a) where - parseJSON = withObject "DisplayObject" \o -> do - tag <- o .: "tag" - case tag of - "BuiltinObject" -> BuiltinObject <$> o .: "contents" - "MissingObject" -> MissingObject <$> o .: "contents" - "UserObject" -> UserObject <$> o .: "contents" - _ -> fail $ "Invalid tag: " <> Text.unpack tag - 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 @@ -172,30 +89,9 @@ deriving instance (ToSchema b, ToSchema a) => ToSchema (DisplayObject b a) -- 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 ToJSONKey Name where - toJSONKey = contramap Name.toText (toJSONKey @Text) - instance ToSchema Name where declareNamedSchema _ = declareNamedSchema (Proxy @Text) -instance ToJSON NameSegment where - toJSON = toJSON . NameSegment.toEscapedText - -instance ToJSONKey NameSegment where - toJSONKey = contramap NameSegment.toEscapedText (toJSONKey @Text) - -deriving anyclass instance ToParamSchema ShortCausalHash - -instance ToParamSchema ShortHash where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & example ?~ Aeson.String "@abcdef" - instance ToParamSchema Reference.Reference where toParamSchema _ = mempty @@ -220,12 +116,6 @@ instance ToParamSchema Path.Path where & type_ ?~ OpenApiString & example ?~ Aeson.String "base.List" -instance ToParamSchema Path.Relative where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & example ?~ Aeson.String "base.List" - instance ToParam (QueryParam "name" Name) where toParam _ = DocQueryParam @@ -239,51 +129,14 @@ instance FromHttpApiData Name where deriving via Int instance FromHttpApiData Width -deriving via Int instance ToHttpApiData Width - deriving anyclass instance ToParamSchema Width -instance ToJSON ConstructorType where - toJSON = \case - CT.Data -> String "Data" - CT.Effect -> String "Effect" - -instance FromHttpApiData Path.Relative where - parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of - Left s -> Left 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 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 = Path.parsePath' (Text.unpack txt) - -instance ToHttpApiData Path.Path' where - toUrlPiece = tShow - instance FromHttpApiData Path.Path where parseUrlPiece txt = case Path.parsePath' (Text.unpack txt) of Left s -> Left s Right (Path.RelativePath' p) -> Right (Path.unrelative p) Right (Path.AbsolutePath' _) -> Left $ "Expected relative path, but " <> txt <> " was absolute." -instance ToCapture (Capture "hash" ShortHash) where - toCapture _ = - DocCapture - "hash" - "A shorthash for a term or type. E.g. @abcdef, #abcdef, @@builtin, ##builtin, abcdef" - instance ToCapture (Capture "hash" Reference.Reference) where toCapture _ = DocCapture @@ -296,12 +149,6 @@ instance ToCapture (Capture "hash" Referent.Referent) where "hash" "A hash reference for a term. E.g. @abcdef, #abcdef, @@builtin, ##builtin, abcdef" -instance ToCapture (Capture "fqn" Name) where - toCapture _ = - DocCapture - "fqn" - "The fully qualified name of a definition." - instance ToCapture (Capture "namespace" Path.Path) where toCapture _ = DocCapture @@ -323,15 +170,6 @@ instance ToSchema Path.Absolute where instance ToJSON (HQ.HashQualified Name) where toJSON = Aeson.String . HQ.toTextWith Name.toText -instance ToJSON (HQ.HashQualified NameSegment) where - toJSON = Aeson.String . HQ.toTextWith NameSegment.toEscapedText - -instance ToJSON (HQ'.HashQualified Name) where - toJSON = Aeson.String . HQ'.toTextWith Name.toText - -instance ToJSON (HQ'.HashQualified NameSegment) where - toJSON = Aeson.String . HQ'.toTextWith NameSegment.toEscapedText - instance FromJSON (HQ'.HashQualified Name) where parseJSON = Aeson.withText "HashQualified'" \txt -> maybe (fail "Invalid HashQualified' Name") pure $ HQ'.parseText txt @@ -340,49 +178,18 @@ instance FromJSON (HQ.HashQualified Name) where parseJSON = Aeson.withText "HashQualified" \txt -> maybe (fail "Invalid HashQualified Name") pure $ HQ.parseText txt -instance FromJSON (HQ'.HashQualified NameSegment) where - parseJSON = Aeson.withText "HashQualified'" \txt -> do - hqName <- maybe (fail "Invalid HashQualified' NameSegment") pure $ HQ'.parseText txt - for hqName \name -> case Name.segments name of - (ns :| []) -> pure ns - _ -> fail $ "Expected a single name segment but received several: " <> Text.unpack txt - -instance FromJSON (HQ.HashQualified NameSegment) where - parseJSON = Aeson.withText "HashQualified" \txt -> do - hqName <- maybe (fail "Invalid HashQualified' NameSegment") pure $ HQ.parseText txt - for hqName \name -> case Name.segments name of - (ns :| []) -> pure ns - _ -> fail $ "Expected a single name segment but received several: " <> Text.unpack txt - instance FromHttpApiData (HQ.HashQualified Name) where parseQueryParam txt = Text.replace "@" "#" txt & HQ.parseText & maybe (Left "Invalid Hash Qualified Name. Expected one of the following forms: name@hash, name, @hash") Right -instance FromHttpApiData (HQ'.HashQualified Name) where - parseQueryParam txt = - Text.replace "@" "#" txt - & HQ'.parseText - & maybe (Left "Invalid Hash Qualified Name. Expected one of the following forms: name@hash, name") Right - instance ToParamSchema (HQ.HashQualified n) where toParamSchema _ = mempty & type_ ?~ OpenApiString & example ?~ Aeson.String "name@hash" -instance ToParamSchema (HQ'.HashQualified n) where - toParamSchema _ = - mempty - & type_ ?~ OpenApiString - & example ?~ Aeson.String "name@hash" - -instance ToHttpApiData Name where - toQueryParam = Name.toText - -deriving newtype instance ToSchema NameSegment - deriving anyclass instance (ToSchema n) => ToSchema (HQ.HashQualified n) deriving anyclass instance (ToSchema n) => ToSchema (HQ'.HashQualified n) diff --git a/unison-share-api/src/Unison/Server/SearchResult.hs b/unison-share-api/src/Unison/Server/SearchResult.hs index 9dd8d09046..f6d5e5bb90 100644 --- a/unison-share-api/src/Unison/Server/SearchResult.hs +++ b/unison-share-api/src/Unison/Server/SearchResult.hs @@ -1,6 +1,5 @@ module Unison.Server.SearchResult where -import Data.Set qualified as Set import Unison.HashQualified (HashQualified) import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) @@ -59,39 +58,17 @@ name = \case Tm t -> termName t Tp t -> typeName t -aliases :: SearchResult -> Set (HQ'.HashQualified Name) -aliases = \case - Tm t -> termAliases t - Tp t -> typeAliases t - -- | TypeResults yield a `Referent.Ref` toReferent :: SearchResult -> Referent toReferent (Tm (TermResult _ r _)) = r toReferent (Tp (TypeResult _ r _)) = Referent.Ref r -truncateAliases :: Int -> SearchResult -> SearchResult -truncateAliases n = \case - Tm (TermResult hq r as) -> termResult hq r (Set.map (HQ'.take n) as) - Tp (TypeResult hq r as) -> typeResult hq r (Set.map (HQ'.take n) as) - -- | You may want to sort this list differently afterward. fromNames :: Names -> [SearchResult] fromNames b = map (uncurry (typeSearchResult b)) (R.toList . Names.types $ b) <> map (uncurry (termSearchResult b)) (R.toList . Names.terms $ b) -_fromNames :: Names -> [SearchResult] -_fromNames n0@(Names terms types) = typeResults <> termResults - where - typeResults = - [ typeSearchResult n0 name r - | (name, r) <- R.toList types - ] - termResults = - [ termSearchResult n0 name r - | (name, r) <- R.toList terms - ] - -- | Sort a list of search results by name. If names are equal, fall back to comparing by reference (putting types -- before terms). compareByName :: SearchResult -> SearchResult -> Ordering diff --git a/unison-share-api/src/Unison/Server/SearchResultPrime.hs b/unison-share-api/src/Unison/Server/SearchResultPrime.hs index b24c9f2c8a..92a3ce6df5 100644 --- a/unison-share-api/src/Unison/Server/SearchResultPrime.hs +++ b/unison-share-api/src/Unison/Server/SearchResultPrime.hs @@ -2,21 +2,15 @@ module Unison.Server.SearchResultPrime where -import Data.Set qualified as Set import Unison.Codebase.Editor.DisplayObject (DisplayObject) -import Unison.Codebase.Editor.DisplayObject qualified as DT import Unison.DataDeclaration (Decl) -import Unison.DataDeclaration qualified as DD import Unison.HashQualified qualified as HQ import Unison.HashQualifiedPrime qualified as HQ' -import Unison.LabeledDependency (LabeledDependency) -import Unison.LabeledDependency qualified as LD import Unison.Name (Name) import Unison.Prelude import Unison.Reference (Reference) import Unison.Referent (Referent) import Unison.Type (Type) -import Unison.Type qualified as Type data SearchResult' v a = Tm' (TermResult' v a) @@ -55,23 +49,7 @@ pattern Tp :: SearchResult' v a pattern Tp n t r as = Tp' (TypeResult' n t r as) -tmReferent :: SearchResult' v a -> Maybe Referent -tmReferent = \case Tm _ _ r _ -> Just r; _ -> Nothing - -tpReference :: SearchResult' v a -> Maybe Reference -tpReference = \case Tp _ _ r _ -> Just r; _ -> Nothing - foldResult' :: (TermResult' v a -> b) -> (TypeResult' v a -> b) -> SearchResult' v a -> b foldResult' f g = \case Tm' tm -> f tm Tp' tp -> g tp - --- todo: comment me out, is this actually useful, given what we saw in ShowDefinitionI? --- namely, that it doesn't include the Term's deps, just the Decl's and the --- result Term/Type names. -labeledDependencies :: (Ord v) => SearchResult' v a -> Set LabeledDependency -labeledDependencies = \case - Tm' (TermResult' _ t r _) -> - Set.insert (LD.referent r) $ maybe mempty (Set.map LD.typeRef . Type.dependencies) t - Tp' (TypeResult' _ d r _) -> - maybe mempty (DD.labeledDeclDependenciesIncludingSelf r) (DT.toMaybe d) diff --git a/unison-share-api/src/Unison/Server/Syntax.hs b/unison-share-api/src/Unison/Server/Syntax.hs index 728b550e34..774aad938b 100644 --- a/unison-share-api/src/Unison/Server/Syntax.hs +++ b/unison-share-api/src/Unison/Server/Syntax.hs @@ -24,12 +24,7 @@ import Unison.Referent qualified as Referent import Unison.Syntax.HashQualified qualified as HashQualified (toText) import Unison.Syntax.Name qualified as Name (unsafeParseText) import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText) -import Unison.Util.AnnotatedText - ( AnnotatedText (..), - Segment (..), - annotate, - segment, - ) +import Unison.Util.AnnotatedText (AnnotatedText (..), Segment (..), segment) import Unison.Util.SyntaxText qualified as SyntaxText type SyntaxText = AnnotatedText Element @@ -227,9 +222,6 @@ instance FromJSON Element where deriving instance ToSchema Element -syntax :: Element -> SyntaxText -> SyntaxText -syntax = annotate - firstReference :: SyntaxText -> Maybe UnisonHash firstReference (AnnotatedText segments) = firstJust reference (toList segments) diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 6139c395af..e91dc756af 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -11,46 +11,28 @@ import Data.Bifoldable (Bifoldable (..)) import Data.Bitraversable (Bitraversable (..)) import Data.ByteString.Lazy qualified as LZ import Data.Map qualified as Map -import Data.OpenApi - ( OpenApiType (..), - ToParamSchema (..), - ToSchema (..), - ) -import Data.OpenApi.Lens qualified as OpenApi +import Data.OpenApi (ToParamSchema (..), ToSchema (..)) import Data.Text qualified as Text import Data.Text.Lazy qualified as Text.Lazy import Data.Text.Lazy.Encoding qualified as Text import Servant qualified -import Servant.API - ( Capture, - FromHttpApiData (..), - Get, - Header, - Headers, - JSON, - QueryParam, - addHeader, - ) -import Servant.Docs (DocCapture (..), DocQueryParam (..), ParamKind (..), ToParam) +import Servant.API (FromHttpApiData (..), Get, Header, Headers, JSON, addHeader) import Servant.Docs qualified as Docs import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags -import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.DisplayObject (DisplayObject) import Unison.Codebase.Path qualified as Path import Unison.Core.Project (ProjectBranchName) import Unison.Hash qualified as Hash -import Unison.HashQualified qualified as HQ import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) import Unison.Prelude -import Unison.Project (ProjectAndBranch, ProjectName) +import Unison.Project (ProjectName) import Unison.Server.Doc (Doc) import Unison.Server.Orphans () import Unison.Server.Syntax qualified as Syntax import Unison.ShortHash (ShortHash) -import Unison.Syntax.HashQualified qualified as HQ (parseText) import Unison.Syntax.Name qualified as Name import Unison.Util.Pretty (Width (..)) @@ -64,10 +46,6 @@ type APIGet c = Get '[JSON] (APIHeaders c) type HashQualifiedName = Text -type NamespaceFQN = Text - -type Size = Int - type UnisonName = Text type UnisonHash = Text @@ -107,32 +85,6 @@ data ExactName name ref = ExactName } deriving stock (Show, Eq, Functor, Ord) -instance ToParamSchema (ExactName Name ShortHash) where - toParamSchema _ = - mempty - & OpenApi.type_ ?~ OpenApiString - & OpenApi.example ?~ Aeson.String "base.List" - -instance ToParam (QueryParam "exact-name" (ExactName Name ShortHash)) where - toParam _ = - DocQueryParam - "exact-name" - [] - "The fully qualified name of a namespace with a hash, denoted by a '@'. E.g. base.List.map@abc" - Normal - -instance Docs.ToCapture (Capture "fqn" (ExactName Name ShortHash)) where - toCapture _ = - DocCapture - "fqn" - "The fully qualified name of a namespace with a hash, denoted by a '@'. E.g. base.List.map@abc" - -exactToHQ :: ExactName name ShortHash -> HQ.HashQualified name -exactToHQ (ExactName {name, ref}) = HQ.HashQualified name ref - -exactToHQ' :: ExactName name ShortHash -> HQ'.HashQualified name -exactToHQ' (ExactName {name, ref}) = HQ'.HashQualified name ref - instance Bifunctor ExactName where bimap l r (ExactName a b) = ExactName (l a) (r b) @@ -142,18 +94,6 @@ instance Bifoldable ExactName where instance Bitraversable ExactName where bitraverse l r (ExactName a b) = ExactName <$> (l a) <*> (r b) -instance FromHttpApiData (ExactName Name ShortHash) where - parseQueryParam txt = - -- # is special in URLs, so we use @ for hash qualification instead; - -- e.g. ".base.List.map@abc" - -- e.g. ".base.Nat@@Nat" - case HQ.parseText (Text.replace "@" "#" txt) of - Nothing -> Left "Invalid absolute name with Hash" - Just hq' -> case hq' of - HQ.NameOnly _ -> Left "A name and hash are required, but only a name was provided" - HQ.HashOnly _ -> Left "A name and hash are required, but only a hash was provided" - HQ.HashQualified name ref -> Right $ ExactName {name, ref} - deriving via Bool instance FromHttpApiData Suffixify deriving anyclass instance ToParamSchema Suffixify @@ -193,20 +133,6 @@ instance ToJSON DefinitionDisplayResults where deriving instance ToSchema DefinitionDisplayResults -data TermDefinitionDiff = TermDefinitionDiff - { left :: TermDefinition, - right :: TermDefinition, - diff :: DisplayObjectDiff - } - deriving (Eq, Show, Generic) - -data TypeDefinitionDiff = TypeDefinitionDiff - { left :: TypeDefinition, - right :: TypeDefinition, - diff :: DisplayObjectDiff - } - deriving (Eq, Show, Generic) - newtype Suffixify = Suffixify {suffixified :: Bool} deriving (Eq, Ord, Show, Generic) @@ -307,16 +233,6 @@ data DisplayObjectDiff deriving instance ToSchema DisplayObjectDiff -data UnisonRef - = TypeRef UnisonHash - | TermRef UnisonHash - deriving (Eq, Ord, Show, Generic) - -unisonRefToText :: UnisonRef -> Text -unisonRefToText = \case - TypeRef r -> r - TermRef r -> r - data NamedTerm = NamedTerm { -- The name of the term, should be hash qualified if conflicted, otherwise name only. termName :: HQ'.HashQualified Name, @@ -419,53 +335,16 @@ mungeString = Text.encodeUtf8 . Text.Lazy.pack defaultWidth :: Width defaultWidth = 80 -discard :: (Applicative m) => a -> m () -discard = const $ pure () - mayDefaultWidth :: Maybe Width -> Width mayDefaultWidth = fromMaybe defaultWidth setCacheControl :: v -> APIHeaders v setCacheControl = addHeader @"Cache-Control" "public" -branchToUnisonHash :: Branch.Branch m -> UnisonHash -branchToUnisonHash b = - ("#" <>) . Hash.toBase32HexText . unCausalHash $ Branch.headHash b - v2CausalBranchToUnisonHash :: V2Branch.CausalBranch m -> UnisonHash v2CausalBranchToUnisonHash b = ("#" <>) . Hash.toBase32HexText . unCausalHash $ V2Causal.causalHash b -newtype ProjectBranchNameParam = ProjectBranchNameParam {unProjectBranchNameParam :: ProjectAndBranch ProjectName ProjectBranchName} - deriving (Eq, Show, Generic) - -instance ToParamSchema ProjectBranchNameParam where - toParamSchema _ = - mempty - & OpenApi.type_ ?~ OpenApiString - & OpenApi.example ?~ Aeson.String "@unison%2Fbase%2Fmain" - --- | Parses URL escaped project and branch names, e.g. `@unison%2Fbase%2Fmain` or `@unison%2Fbase%2F@runarorama%2Fmain` -instance FromHttpApiData ProjectBranchNameParam where - parseUrlPiece t = - case tryInto @(ProjectAndBranch ProjectName ProjectBranchName) t of - Left _ -> Left "Invalid project and branch name" - Right pab -> Right . ProjectBranchNameParam $ pab - -instance ToParam (QueryParam "project-and-branch" (ProjectBranchNameParam)) where - toParam _ = - DocQueryParam - "project_and_branch" - [] - "The name of a project and branch e.g. `@unison%2Fbase%2Fmain` or `@unison%2Fbase%2F@runarorama%2Fmain`" - Normal - -instance Docs.ToCapture (Capture "project-and-branch" ProjectBranchNameParam) where - toCapture _ = - DocCapture - "project-and-branch" - "The name of a project and branch e.g. `@unison%2Fbase%2Fmain` or `@unison%2Fbase%2F@runarorama%2Fmain`" - data TermDiffResponse = TermDiffResponse { project :: ProjectName, oldBranch :: ProjectBranchName, diff --git a/unison-share-api/src/Unison/Sync/API.hs b/unison-share-api/src/Unison/Sync/API.hs index 5cafebdfc3..30937866cb 100644 --- a/unison-share-api/src/Unison/Sync/API.hs +++ b/unison-share-api/src/Unison/Sync/API.hs @@ -1,14 +1,10 @@ {-# LANGUAGE DataKinds #-} -module Unison.Sync.API (API, api) where +module Unison.Sync.API (API) where -import Data.Proxy import Servant.API import Unison.Sync.Types -api :: Proxy API -api = Proxy - type API = "path" :> "get" :> GetCausalHashByPathEndpoint :<|> "entities" :> "download" :> DownloadEntitiesEndpoint diff --git a/unison-share-api/src/Unison/Sync/Common.hs b/unison-share-api/src/Unison/Sync/Common.hs index 43d124a3ae..1d8f9ed547 100644 --- a/unison-share-api/src/Unison/Sync/Common.hs +++ b/unison-share-api/src/Unison/Sync/Common.hs @@ -3,7 +3,6 @@ module Unison.Sync.Common ( expectEntity, -- * Type conversions - causalHashToHash32, hash32ToCausalHash, entityToTempEntity, tempEntityToEntity, @@ -38,11 +37,6 @@ expectEntity hash = do tempEntity <- Q.syncToTempEntity syncEntity pure (tempEntityToEntity tempEntity) --- 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 = diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 35d7030cc8..d496e6e7af 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -9,7 +9,6 @@ module Unison.Sync.Types RepoInfo (..), Path (..), pathRepoInfo, - pathCodebasePath, -- ** Entity types Entity (..), @@ -26,7 +25,6 @@ module Unison.Sync.Types -- *** Entity Traversals entityHashes_, - patchOldHashes_, patchNewHashes_, patchDiffHashes_, namespaceDiffHashes_, @@ -50,7 +48,6 @@ module Unison.Sync.Types -- * Common/shared error types HashMismatchForEntity (..), - InvalidParentage (..), NeedDependencies (..), EntityValidationError (..), ) @@ -106,9 +103,6 @@ data Path = Path pathRepoInfo :: Path -> RepoInfo pathRepoInfo (Path (p :| _)) = RepoInfo (Text.cons '@' p) -pathCodebasePath :: Path -> [Text] -pathCodebasePath (Path (_ :| ps)) = ps - instance ToJSON Path where toJSON (Path segments) = object @@ -319,11 +313,6 @@ instance (FromJSON text, FromJSON oldHash, FromJSON newHash) => FromJSON (Patch Base64Bytes bytes <- obj .: "bytes" pure Patch {..} -patchOldHashes_ :: (Applicative m) => (oldHash -> m oldHash') -> Patch text oldHash newHash -> m (Patch text oldHash' newHash) -patchOldHashes_ f (Patch {..}) = do - oldHashLookup <- traverse f oldHashLookup - pure (Patch {..}) - patchNewHashes_ :: (Applicative m) => (newHash -> m newHash') -> Patch text oldHash newHash -> m (Patch text oldHash newHash') patchNewHashes_ f (Patch {..}) = do newHashLookup <- traverse f newHashLookup @@ -521,11 +510,6 @@ instance ToJSON GetCausalHashByPathRequest where [ "path" .= path ] -instance FromJSON GetCausalHashByPathRequest where - parseJSON = Aeson.withObject "GetCausalHashByPathRequest" \obj -> do - path <- obj .: "path" - pure GetCausalHashByPathRequest {..} - data GetCausalHashByPathResponse = GetCausalHashByPathSuccess (Maybe HashJWT) | GetCausalHashByPathNoReadPermission Path @@ -533,13 +517,6 @@ data GetCausalHashByPathResponse | GetCausalHashByPathInvalidRepoInfo Text RepoInfo deriving stock (Show, Eq, Ord) -instance ToJSON GetCausalHashByPathResponse where - toJSON = \case - GetCausalHashByPathSuccess hashJWT -> jsonUnion "success" hashJWT - GetCausalHashByPathNoReadPermission path -> jsonUnion "no_read_permission" path - GetCausalHashByPathUserNotFound -> jsonUnion "user_not_found" () - GetCausalHashByPathInvalidRepoInfo msg repoInfo -> jsonUnion "invalid_repo_info" (msg, repoInfo) - instance FromJSON GetCausalHashByPathResponse where parseJSON = Aeson.withObject "GetCausalHashByPathResponse" \obj -> do obj .: "type" >>= Aeson.withText "type" \case @@ -565,16 +542,6 @@ instance ToJSON DownloadEntitiesRequest where "hashes" .= hashes ] -instance FromJSON DownloadEntitiesRequest where - parseJSON = Aeson.withObject "DownloadEntitiesRequest" \obj -> do - repoInfo <- - obj .: "repo_info" <|> do - -- Back-compat by converting old 'repo_name' fields into the new 'repo_info' format. - repoName <- obj .: "repo_name" - pure . RepoInfo $ "@" <> repoName - hashes <- obj .: "hashes" - pure DownloadEntitiesRequest {..} - data DownloadEntitiesResponse = DownloadEntitiesSuccess (NEMap Hash32 (Entity Text Hash32 HashJWT)) | DownloadEntitiesFailure DownloadEntitiesError @@ -590,15 +557,6 @@ data DownloadEntitiesError | DownloadEntitiesEntityValidationFailure EntityValidationError deriving stock (Eq, Show) -instance ToJSON DownloadEntitiesResponse where - toJSON = \case - DownloadEntitiesSuccess entities -> jsonUnion "success" entities - DownloadEntitiesFailure (DownloadEntitiesNoReadPermission repoInfo) -> jsonUnion "no_read_permission" repoInfo - DownloadEntitiesFailure (DownloadEntitiesInvalidRepoInfo msg repoInfo) -> jsonUnion "invalid_repo_info" (msg, repoInfo) - DownloadEntitiesFailure (DownloadEntitiesUserNotFound userHandle) -> jsonUnion "user_not_found" userHandle - DownloadEntitiesFailure (DownloadEntitiesProjectNotFound projectShorthand) -> jsonUnion "project_not_found" projectShorthand - DownloadEntitiesFailure (DownloadEntitiesEntityValidationFailure err) -> jsonUnion "entity_validation_failure" err - instance FromJSON DownloadEntitiesResponse where parseJSON = Aeson.withObject "DownloadEntitiesResponse" \obj -> obj .: "type" >>= Aeson.withText "type" \case @@ -616,14 +574,6 @@ data EntityValidationError | InvalidByteEncoding Hash32 EntityType Text {- decoding err msg -} | HashResolutionFailure Hash32 deriving stock (Show, Eq, Ord) - deriving anyclass (Exception) - -instance ToJSON EntityValidationError where - toJSON = \case - EntityHashMismatch typ mismatch -> jsonUnion "mismatched_hash" (object ["type" .= typ, "mismatch" .= mismatch]) - UnsupportedEntityType hash typ -> jsonUnion "unsupported_entity_type" (object ["hash" .= hash, "type" .= typ]) - InvalidByteEncoding hash typ errMsg -> jsonUnion "invalid_byte_encoding" (object ["hash" .= hash, "type" .= typ, "error" .= errMsg]) - HashResolutionFailure hash -> jsonUnion "hash_resolution_failure" hash instance FromJSON EntityValidationError where parseJSON = Aeson.withObject "EntityValidationError" \obj -> @@ -659,16 +609,6 @@ instance ToJSON UploadEntitiesRequest where "entities" .= entities ] -instance FromJSON UploadEntitiesRequest where - parseJSON = Aeson.withObject "UploadEntitiesRequest" \obj -> do - repoInfo <- - obj .: "repo_info" <|> do - -- Back-compat by converting old 'repo_name' fields into the new 'repo_info' format. - repoName <- obj .: "repo_name" - pure . RepoInfo $ "@" <> repoName - entities <- obj .: "entities" - pure UploadEntitiesRequest {..} - data UploadEntitiesResponse = UploadEntitiesSuccess | UploadEntitiesFailure UploadEntitiesError @@ -693,21 +633,6 @@ data HashMismatchForEntity = HashMismatchForEntity } deriving stock (Show, Eq, Ord) -instance ToJSON UploadEntitiesResponse where - toJSON = \case - UploadEntitiesSuccess -> jsonUnion "success" (Object mempty) - UploadEntitiesFailure (UploadEntitiesError'EntityValidationFailure err) -> - jsonUnion "entity_validation_failure" err - UploadEntitiesFailure (UploadEntitiesError'HashMismatchForEntity mismatch) -> - jsonUnion "hash_mismatch_for_entity" mismatch - UploadEntitiesFailure (UploadEntitiesError'InvalidRepoInfo msg repoInfo) -> - jsonUnion "invalid_repo_info" (msg, repoInfo) - UploadEntitiesFailure (UploadEntitiesError'NeedDependencies nd) -> jsonUnion "need_dependencies" nd - UploadEntitiesFailure (UploadEntitiesError'NoWritePermission repoInfo) -> jsonUnion "no_write_permission" repoInfo - UploadEntitiesFailure (UploadEntitiesError'ProjectNotFound projectShorthand) -> - jsonUnion "project_not_found" projectShorthand - UploadEntitiesFailure (UploadEntitiesError'UserNotFound userHandle) -> jsonUnion "user_not_found" userHandle - instance FromJSON UploadEntitiesResponse where parseJSON = Aeson.withObject "UploadEntitiesResponse" \obj -> obj .: "type" >>= Aeson.withText "type" \case @@ -724,13 +649,6 @@ instance FromJSON UploadEntitiesResponse where "project_not_found" -> UploadEntitiesFailure . UploadEntitiesError'ProjectNotFound <$> 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 -> @@ -740,16 +658,6 @@ instance FromJSON HashMismatchForEntity where <*> obj .: "computed" -data InvalidParentage = InvalidParentage {parent :: Hash32, child :: Hash32} - deriving stock (Show) - -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" - ------------------------------------------------------------------------------------------------------------------------ -- Common/shared error types @@ -758,10 +666,6 @@ data NeedDependencies hash = NeedDependencies } 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" @@ -772,10 +676,3 @@ instance (FromJSON hash, Ord hash) => FromJSON (NeedDependencies hash) where failText :: (MonadFail m) => Text -> m a failText = fail . Text.unpack - -jsonUnion :: (ToJSON a) => Text -> a -> Value -jsonUnion typeName val = - Aeson.object - [ "type" .= String typeName, - "payload" .= val - ] diff --git a/unison-share-api/src/Unison/Util/Find.hs b/unison-share-api/src/Unison/Util/Find.hs index 792d439b24..27cbb6bd94 100644 --- a/unison-share-api/src/Unison/Util/Find.hs +++ b/unison-share-api/src/Unison/Util/Find.hs @@ -1,77 +1,10 @@ module Unison.Util.Find - ( fuzzyFinder, - simpleFuzzyFinder, - simpleFuzzyScore, - fuzzyFindInBranch, - fuzzyFindMatchArray, - prefixFindInBranch, + ( simpleFuzzyScore, ) where -import Data.List qualified as List import Data.Text qualified as Text --- http://www.serpentine.com/blog/2007/02/27/a-haskell-regular-expression-tutorial/ --- https://www.stackage.org/haddock/lts-13.9/regex-base-0.93.2/Text-Regex-Base-Context.html -- re-exported by TDFA --- https://www.stackage.org/haddock/lts-13.9/regex-tdfa-1.2.3.1/Text-Regex-TDFA.html -import Text.Regex.TDFA qualified as RE -import Unison.HashQualified qualified as HQ -import Unison.HashQualifiedPrime qualified as HQ' -import Unison.Name (Name) -import Unison.Name qualified as Name -import Unison.Names (Names) -import Unison.Names qualified as Names import Unison.Prelude -import Unison.Reference qualified as Reference -import Unison.Referent qualified as Referent -import Unison.Server.SearchResult (SearchResult) -import Unison.Server.SearchResult qualified as SR -import Unison.ShortHash qualified as SH -import Unison.Syntax.Name qualified as Name (toText) -import Unison.Syntax.NamePrinter (prettyHashQualified) -import Unison.Util.Monoid (intercalateMap) -import Unison.Util.Pretty qualified as P -import Unison.Util.Relation qualified as R - -fuzzyFinder :: - forall a. - String -> - [a] -> - (a -> String) -> - [(a, P.Pretty P.ColorText)] -fuzzyFinder query items render = - sortAndCleanup $ fuzzyFindMatchArray query items render - where - sortAndCleanup = List.map snd . List.sortOn fst - -simpleFuzzyFinder :: - forall a. - Text -> - [a] -> - (a -> Text) -> - [(a, P.Pretty P.ColorText)] -simpleFuzzyFinder query items render = - sortAndCleanup do - a <- items - let s = render a - score <- toList (simpleFuzzyScore query s) - pure ((a, hi (Text.unpack s)), score) - where - hi = highlightSimple query - sortAndCleanup = List.map fst . List.sortOn snd - --- highlights `query` if it is a prefix of `s`, or if it --- appears in the final segement of s (after the final `.`) -highlightSimple :: Text -> String -> P.Pretty P.ColorText -highlightSimple query - | Text.null query = P.string - | otherwise = go - where - go [] = mempty - go s@(h : t) - | query `Text.isPrefixOf` (Text.pack s) = hiQuery <> go (drop len s) - | otherwise = P.string [h] <> go t - len = Text.length query - hiQuery = P.hiBlack (P.text query) simpleFuzzyScore :: Text -> Text -> Maybe Int simpleFuzzyScore query s @@ -85,138 +18,3 @@ simpleFuzzyScore query s bonus s n = if Text.take 1 s == "." then n * 10 else n lowerquery = Text.toLower query lowers = Text.toLower s - --- This logic was split out of fuzzyFinder because the `RE.MatchArray` has an --- `Ord` instance that helps us sort the fuzzy matches in a nice way. (see --- comment below.) `Editor.fuzzyNameDistance` uses this `Ord` instance. -fuzzyFindMatchArray :: - forall a. - String -> - [a] -> - (a -> String) -> - [(RE.MatchArray, (a, P.Pretty P.ColorText))] -fuzzyFindMatchArray query items render = - scoreAndHighlight $ items - where - scoreAndHighlight = catMaybes . List.map go - go :: a -> Maybe (RE.MatchArray, (a, P.Pretty P.ColorText)) - go a = - let string = render a - text = Text.pack string - matches = RE.matchOnce regex string - addContext matches = - let highlighted = highlight P.bold text . tail . toList $ matches - in (matches, (a, highlighted)) - in addContext <$> matches - -- regex "Foo" = "(\\F).*(\\o).*(\\o)" - regex :: RE.Regex - regex = - let s = - if null query - then ".*" - else intercalateMap ".*" esc query - where - esc c = "(\\" <> [c] <> ")" - in RE.makeRegexOpts - RE.defaultCompOpt - { RE.caseSensitive = False, - -- newSyntax = False, otherwise "\<" and "\>" - -- matches word boundaries instead of literal < and > - RE.newSyntax = False - } - RE.defaultExecOpt - s - --- Sort on: --- a. length of match group to find the most compact match --- b. start position of the match group to find the earliest match --- c. the item itself for alphabetical ranking --- Ord MatchArray already provides a. and b. todo: c. - -prefixFindInBranch :: - Names -> HQ'.HashQualified Name -> [(SearchResult, P.Pretty P.ColorText)] -prefixFindInBranch b hq = - fmap getName $ - -- query string includes a name component, so do a prefix find on that - filter (filterName (HQ'.toName hq)) (candidates b hq) - where - filterName :: Name -> SearchResult -> Bool - filterName n1 sr = - fromMaybe False do - n2 <- HQ.toName (SR.name sr) - pure (n1 `Name.isPrefixOf` n2) - --- only search before the # before the # and after the # after the # -fuzzyFindInBranch :: - (HasCallStack) => - Names -> - HQ'.HashQualified Name -> - [(SearchResult, P.Pretty P.ColorText)] -fuzzyFindInBranch b hq = - simpleFuzzyFinder - (Name.toText (HQ'.toName hq)) - (candidates b hq) - ( \sr -> - case HQ.toName (SR.name sr) of - -- see invariant on `candidates` below. - Nothing -> error "search result without name" - Just name -> Name.toText name - ) - -getName :: SearchResult -> (SearchResult, P.Pretty P.ColorText) -getName sr = (sr, P.syntaxToColor $ prettyHashQualified (SR.name sr)) - --- Invariant: all `SearchResult` in the output will have names, even though the type allows them to have only hashes -candidates :: Names.Names -> HQ'.HashQualified Name -> [SearchResult] -candidates b hq = typeCandidates <> termCandidates - where - -- filter branch by hash - typeCandidates = - fmap typeResult . filterTypes . R.toList . Names.types $ b - termCandidates = - fmap termResult . filterTerms . R.toList . Names.terms $ b - filterTerms = case HQ'.toHash hq of - Just sh -> List.filter $ SH.isPrefixOf sh . Referent.toShortHash . snd - Nothing -> id - filterTypes = case HQ'.toHash hq of - Just sh -> List.filter $ SH.isPrefixOf sh . Reference.toShortHash . snd - Nothing -> id - typeResult (n, r) = SR.typeSearchResult b n r - termResult (n, r) = SR.termSearchResult b n r - -type Pos = Int - -type Len = Int - --- This [(Pos, Len)] type is the same as `tail . toList` of a regex MatchArray -highlight :: - (P.Pretty P.ColorText -> P.Pretty P.ColorText) -> - Text -> - [(Pos, Len)] -> - P.Pretty P.ColorText -highlight on = highlight' on id - -highlight' :: - (P.Pretty P.ColorText -> P.Pretty P.ColorText) -> - (P.Pretty P.ColorText -> P.Pretty P.ColorText) -> - Text -> - [(Pos, Len)] -> - P.Pretty P.ColorText -highlight' on off t groups = case groups of - [] -> (off . P.text) t - (0, _) : _ -> go groups - (start, _) : _ -> (off . P.text . Text.take start) t <> go groups - where - go = \case - [] -> error "unpossible I think" - (start, len) : (start2, len2) : groups - | start + len == start2 -> - -- avoid an on/off since there's no gap between groups - go ((start, len + len2) : groups) - (start, len) : groups -> - let (selected, remaining) = Text.splitAt len . Text.drop start $ t - in (on . P.text) selected <> case groups of - [] -> (off . P.text) remaining - (start2, _) : _ -> - (off . P.text . Text.drop (start + len) . Text.take start2 $ t) - <> go groups diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index 2e42b8ac70..1921a0f25b 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -87,7 +87,6 @@ library , aeson >=2.0.0.0 , async , base - , binary , bytes , bytestring , containers @@ -105,7 +104,6 @@ library , mtl , nonempty-containers , openapi3 - , regex-tdfa , servant , servant-docs , servant-openapi3 diff --git a/unison-share-projects-api/package.yaml b/unison-share-projects-api/package.yaml index 10694036b6..31064d130c 100644 --- a/unison-share-projects-api/package.yaml +++ b/unison-share-projects-api/package.yaml @@ -11,11 +11,8 @@ library: dependencies: - aeson - base - - jose - jwt - - lens - servant - - servant-auth - text - unison-hash - unison-hash-orphans-aeson @@ -53,4 +50,3 @@ default-extensions: - TypeApplications - TypeOperators - ViewPatterns - diff --git a/unison-share-projects-api/src/Unison/Share/API/Hash.hs b/unison-share-projects-api/src/Unison/Share/API/Hash.hs index dfa1d1f44c..bef5b97d5b 100644 --- a/unison-share-projects-api/src/Unison/Share/API/Hash.hs +++ b/unison-share-projects-api/src/Unison/Share/API/Hash.hs @@ -18,12 +18,9 @@ module Unison.Share.API.Hash ) where -import Control.Lens (folding, ix, (^?)) -import Crypto.JWT qualified as Jose import Data.Aeson import Data.Aeson qualified as Aeson import Data.Aeson.KeyMap qualified as Aeson.KeyMap -import Servant.Auth.JWT qualified as Servant.Auth import Unison.Hash32 (Hash32) import Unison.Hash32.Orphans.Aeson () import Unison.Prelude @@ -45,27 +42,6 @@ data HashJWTClaims = HashJWTClaims } 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 Servant.Auth.ToJWT HashJWTClaims where - encodeJWT (HashJWTClaims h u) = - Jose.emptyClaimsSet - & Jose.addClaim "h" (toJSON h) - & Jose.addClaim "u" (toJSON u) - & Jose.addClaim "t" (toJSON hashJWTType) - -instance Servant.Auth.FromJWT HashJWTClaims where - 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 userId) = object diff --git a/unison-share-projects-api/unison-share-projects-api.cabal b/unison-share-projects-api/unison-share-projects-api.cabal index 1ed58ed848..b85ccd89c9 100644 --- a/unison-share-projects-api/unison-share-projects-api.cabal +++ b/unison-share-projects-api/unison-share-projects-api.cabal @@ -54,11 +54,8 @@ library build-depends: aeson , base - , jose , jwt - , lens , servant - , servant-auth , text , unison-hash , unison-hash-orphans-aeson diff --git a/unison-syntax/src/Unison/Parser/Ann.hs b/unison-syntax/src/Unison/Parser/Ann.hs index 1b73adeaf6..4ac31aea2b 100644 --- a/unison-syntax/src/Unison/Parser/Ann.hs +++ b/unison-syntax/src/Unison/Parser/Ann.hs @@ -4,11 +4,8 @@ module Unison.Parser.Ann where -import Control.Comonad.Cofree (Cofree ((:<))) import Data.List.NonEmpty (NonEmpty) -import Data.Void (absurd) import Unison.Lexer.Pos qualified as L -import Unison.Prelude data Ann = -- Used for things like Builtins which don't have a source position. @@ -60,31 +57,6 @@ contains External _ = False contains (Ann start end) p = start <= p && p < end contains (GeneratedFrom ann) p = contains ann p --- | Checks whether an annotation contains another annotation. --- --- i.e. pos ∈ [start, end) --- --- >>> Intrinsic `encompasses` Ann (L.Pos 1 1) (L.Pos 2 1) --- Nothing --- --- >>> External `encompasses` Ann (L.Pos 1 1) (L.Pos 2 1) --- Nothing --- --- >>> Ann (L.Pos 0 0) (L.Pos 0 10) `encompasses` Ann (L.Pos 0 1) (L.Pos 0 5) --- Just True --- --- >>> Ann (L.Pos 1 0) (L.Pos 1 10) `encompasses` Ann (L.Pos 0 0) (L.Pos 2 0) --- Just False -encompasses :: Ann -> Ann -> Maybe Bool -encompasses Intrinsic _ = Nothing -encompasses External _ = Nothing -encompasses _ Intrinsic = Nothing -encompasses _ External = Nothing -encompasses (GeneratedFrom ann) other = encompasses ann other -encompasses ann (GeneratedFrom other) = encompasses ann other -encompasses (Ann start1 end1) (Ann start2 end2) = - Just $ start1 <= start2 && end1 >= end2 - class Annotated a where ann :: a -> Ann @@ -96,12 +68,3 @@ instance (Annotated a) => Annotated [a] where instance (Annotated a) => Annotated (NonEmpty a) where ann = foldMap ann - -instance (Annotated a) => Annotated (Maybe a) where - ann = foldMap ann - -instance Annotated Void where - ann = absurd - -instance (Annotated a) => Annotated (Cofree f a) where - ann (a :< _) = ann a diff --git a/unison-syntax/src/Unison/Syntax/HashQualifiedPrime.hs b/unison-syntax/src/Unison/Syntax/HashQualifiedPrime.hs index 406a8eae2f..665a328593 100644 --- a/unison-syntax/src/Unison/Syntax/HashQualifiedPrime.hs +++ b/unison-syntax/src/Unison/Syntax/HashQualifiedPrime.hs @@ -4,7 +4,6 @@ module Unison.Syntax.HashQualifiedPrime ( -- * String conversions parseText, - unsafeParseText, toText, -- * Parsers @@ -34,11 +33,6 @@ parseText text = parser = hashQualifiedP (P.withParsecT (fmap NameSegment.renderParseErr) Name.nameP) <* P.eof -unsafeParseText :: (HasCallStack) => Text -> HQ'.HashQualified Name -unsafeParseText txt = fromMaybe msg (parseText txt) - where - msg = error ("HashQualified.unsafeFromText " <> show txt) - toText :: HQ'.HashQualified Name -> Text toText = HQ'.toTextWith Name.toText diff --git a/unison-syntax/src/Unison/Syntax/Parser.hs b/unison-syntax/src/Unison/Syntax/Parser.hs index 30126c7d8b..fd95b63168 100644 --- a/unison-syntax/src/Unison/Syntax/Parser.hs +++ b/unison-syntax/src/Unison/Syntax/Parser.hs @@ -210,7 +210,7 @@ tokenToPair t = (ann t, L.payload t) newtype Input = Input {inputStream :: [L.Token L.Lexeme]} deriving stock (Eq, Ord, Show) - deriving newtype (P.Stream, P.VisualStream) + deriving newtype (P.Stream) instance (Annotated a) => Annotated (ABT.Term f v a) where ann = ann . ABT.annotation diff --git a/unison-syntax/test/Unison/Test/Unison.hs b/unison-syntax/test/Unison/Test/Unison.hs index 5468046400..393797cb98 100644 --- a/unison-syntax/test/Unison/Test/Unison.hs +++ b/unison-syntax/test/Unison/Test/Unison.hs @@ -2,8 +2,10 @@ module Unison.Test.Unison (test) where import Data.Text qualified as Text import EasyTest +import Unison.HashQualifiedPrime qualified as HQ' +import Unison.Name (Name) import Unison.Prelude -import Unison.Syntax.HashQualifiedPrime qualified as HQ' (unsafeParseText) +import Unison.Syntax.HashQualifiedPrime qualified as HQ' (parseText) import Unison.Syntax.Lexer.Unison test :: Test () @@ -226,10 +228,15 @@ t s expected = case toList . preParse $ lexer filename s of where filename = "test case" +unsafeParseText :: (HasCallStack) => Text -> HQ'.HashQualified Name +unsafeParseText txt = fromMaybe msg (HQ'.parseText txt) + where + msg = error ("Unison.Test.Unison.unsafeFromText " <> show txt) + simpleSymbolyId :: Text -> Lexeme simpleSymbolyId = - SymbolyId . HQ'.unsafeParseText + SymbolyId . unsafeParseText simpleWordyId :: Text -> Lexeme simpleWordyId = - WordyId . HQ'.unsafeParseText + WordyId . unsafeParseText diff --git a/weeder.dhall b/weeder.dhall deleted file mode 100644 index 6c2fe1de6f..0000000000 --- a/weeder.dhall +++ /dev/null @@ -1 +0,0 @@ -{ roots = [ "^Main.main$", "^Paths_.*" ], type-class-roots = True } diff --git a/weeder.toml b/weeder.toml new file mode 100644 index 0000000000..259c3d86db --- /dev/null +++ b/weeder.toml @@ -0,0 +1,81 @@ +root-instances = [ + # Allow “negative” instances, which are necessarily unused. + { instance = '''^\((.* )?TypeError .*\) => .*''' }, + # Principled classes – even if we’re not using them, they have a single reasaonable implementation, and many of them + # can be derived. + # + # NB: These classes aren’t always in the module you might expect, but it’s the canonical one. + { class = '''^Data\.Bifoldable\.Bifoldable$''' }, + { class = '''^Data\.Bifunctor\.Bifunctor$''' }, + { class = '''^Data\.Bitraversable\.Bitraversable$''' }, + { class = '''^Data\.Foldable\.Foldable$''' }, + { class = '''^Data\.Functor\.Classes\.Eq1$''' }, + { class = '''^Data\.Functor\.Classes\.Eq2$''' }, + { class = '''^Data\.Functor\.Classes\.Ord1$''' }, + { class = '''^Data\.Functor\.Classes\.Ord2$''' }, + { class = '''^Data\.Functor\.Classes\.Read1$''' }, + { class = '''^Data\.Functor\.Classes\.Read2$''' }, + { class = '''^Data\.Functor\.Classes\.Show1$''' }, + { class = '''^Data\.Functor\.Classes\.Show2$''' }, + { class = '''^Data\.Traversable\.Traversable$''' }, + { class = '''^GHC\.Base\.Functor$''' }, + { class = '''^GHC\.Base\.Monoid$''' }, + { class = '''^GHC\.Classes\.Eq$''' }, + { class = '''^GHC\.Classes\.Ord$''' }, + { class = '''^GHC\.Generics\.Generic$''' }, + { class = '''^GHC\.Generics\.Generic1$''' }, + { class = '''^GHC\.Read\.Read$''' }, + { class = '''^GHC\.Show\.Show$''' }, + { class = '''^GHC\Base\.Semigroup$''' }, + # Not great classes, and we generally only use one of the pair, but since they should form a `Prism` or split + # epi/mono, it makes sense to define both when you define one (adding a generic round-tripping test for these + # instances should mean we can remove them from here, though). + { class = '''^Data\.Aeson\.Types\.FromJSON\.FromJSON$''' }, + { class = '''^Data\.Aeson\.Types\.ToJSON\.ToJSON$''' }, + # Avoid gaps in patterns of instances + { module = '''Unison.Runtime.Builtin''', instance = '''^Var v => Fresh \(v, v, v, v, v, v\)$''' }, + { module = '''Unison.Runtime.Builtin''', instance = '''^Var v => Fresh \(v, v, v, v, v, v, v, v, v, v, v, v, v\)$''' }, + # Usage hidden by syntax (e.g., Weeder can’t identify implicit usage of `Enum` from `..`, `IsString` from + # `OverloadedStrings`, or `Num` from numeric literals). + { module = "Suite", instance = '''^IsString ProjectBranchName$''' }, + { module = "Suite", instance = '''^IsString ProjectName$''' }, + { module = "U.Codebase.Sqlite.DbId", instance = '''^Num HashVersion$''' }, + { module = "Unison.Runtime.ANF", instance = '''^Enum POp$''' }, +] +roots = [ + '''^Main\.main$''', + '''^Paths_[^\.]+\.[^\.]+$''', + # Modules that have “independent” APIs (but should probably get tests and/or extracted to independent repos). + # It would be good to list these in `root-modules` instead, but it seems like that doesn’t currently work + # (ocharles/weeder#177). + '''^EasyTest\.[^\.]+$''', + '''^System\.Path\.[^\.]+$''', + '''^Unison\.Util\.Alphabetical\.[^\.]+$''', + '''^Unison\.Util\.BiMultimap\.[^\.]+$''', + '''^Unison\.Util\.Bytes\.[^\.]+$''', + '''^Unison\.Util\.ColorText\.[^\.]+$''', + '''^Unison\.Util\.EnumContainers\.[^\.]+$''', + '''^Unison\.Util\.Lens\.[^\.]+$''', + '''^Unison\.Util\.List\.[^\.]+$''', + '''^Unison\.Util\.Logger\.[^\.]+$''', + '''^Unison\.Util\.Map\.[^\.]+$''', + '''^Unison\.Util\.Monoid\.[^\.]+$''', + '''^Unison\.Util\.Pretty\.[^\.]+$''', + '''^Unison\.Util\.Range\.[^\.]+$''', + '''^Unison\.Util\.Recursion\.[^\.]+$''', + '''^Unison\.Util\.Relation\.[^\.]+$''', + '''^Unison\.Util\.Relation3\.[^\.]+$''', + '''^Unison\.Util\.Relation4\.[^\.]+$''', + '''^Unison\.Util\.Rope\.[^\.]+$''', + # Template Haskell (which Weeder can’t identify usage of) + '''^Unison\.Sqlite\.Sql.sql$''', + # Debugging tools – not used in production, but often enabled during development. + '''^Unison\.Debug\.[^\.]+$''', + '''^Unison\.Prelude\.wundefined$''', + '''^Unison\.Runtime\.Debug\.[^\.]+$''', + '''^Unison\.Syntax\.Lexer\.Unison\.debugFilePreParse$''', + # Only used in instance roots + '''^Unison\.Share\.API\.Projects\.toSumType$''', +] +type-class-roots = false +unused-types = true