From 8373e2b447f2197edab83961500e97264394ec14 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 25 Nov 2023 13:32:30 -0500 Subject: [PATCH 1/2] don't use deepTermMetadata for `test` --- .../U/Codebase/Sqlite/Operations.hs | 20 +++ .../U/Codebase/Sqlite/Queries.hs | 72 ++++++++++ codebase2/core/U/Codebase/Reference.hs | 16 ++- parser-typechecker/src/Unison/Codebase.hs | 26 +++- .../src/Unison/Codebase/SqliteCodebase.hs | 12 +- .../Codebase/SqliteCodebase/Conversions.hs | 17 +-- .../Codebase/SqliteCodebase/Operations.hs | 17 +++ .../src/Unison/Codebase/Type.hs | 6 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 125 +++++++++--------- .../src/Unison/Codebase/Editor/Output.hs | 30 ++--- .../src/Unison/CommandLine/OutputMessages.hs | 17 +-- unison-core/src/Unison/Referent.hs | 20 +++ 12 files changed, 279 insertions(+), 99 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 03329901bc..723f760334 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -70,6 +70,8 @@ module U.Codebase.Sqlite.Operations -- ** type index Q.addTypeToIndexForTerm, termsHavingType, + filterTermsByReferenceHavingType, + filterTermsByReferentHavingType, -- ** type mentions index Q.addTypeMentionsToIndexForTerm, @@ -1048,6 +1050,24 @@ termsHavingType cTypeRef = set <- traverse s2cReferentId sIds pure (Set.fromList set) +filterTermsByReferenceHavingType :: C.TypeReference -> [C.Reference.Id] -> Transaction [C.Reference.Id] +filterTermsByReferenceHavingType cTypeRef cTermRefIds = + runMaybeT (c2hReference cTypeRef) >>= \case + Nothing -> pure [] + Just sTypeRef -> do + sTermRefIds <- traverse c2sReferenceId cTermRefIds + matches <- Q.filterTermsByReferenceHavingType sTypeRef sTermRefIds + traverse s2cReferenceId matches + +filterTermsByReferentHavingType :: C.TypeReference -> [C.Referent.Id] -> Transaction [C.Referent.Id] +filterTermsByReferentHavingType cTypeRef cTermRefIds = + runMaybeT (c2hReference cTypeRef) >>= \case + Nothing -> pure [] + Just sTypeRef -> do + sTermRefIds <- traverse c2sReferentId cTermRefIds + matches <- Q.filterTermsByReferentHavingType sTypeRef sTermRefIds + traverse s2cReferentId matches + typeReferenceForTerm :: S.Reference.Id -> Transaction S.ReferenceH typeReferenceForTerm = Q.getTypeReferenceForReferent . C.Referent.RefId diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs index 06af52f05f..98e645b367 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs @@ -167,6 +167,8 @@ module U.Codebase.Sqlite.Queries getReferentsByType, getTypeReferenceForReferent, getTypeReferencesForComponent, + filterTermsByReferenceHavingType, + filterTermsByReferentHavingType, -- ** type mentions index addToTypeMentionsIndex, @@ -1460,6 +1462,76 @@ getTypeReferencesForComponent oId = 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 + select = queryListRow [sql| + SELECT + q.term_referent_object_id, + q.term_referent_component_index, + q.term_referent_constructor_index + FROM filter_query q, find_type_index t + WHERE t.type_reference_builtin IS :typeBuiltin + AND t.type_reference_hash_id IS :typeHashId + AND t.type_reference_component_index IS :typeComponentIndex + AND t.term_referent_object_id = q.term_referent_object_id + AND t.term_referent_component_index = q.term_referent_component_index + AND t.term_referent_constructor_index IS q.term_referent_constructor_index + |] + insert r = execute [sql| + INSERT INTO filter_query ( + term_referent_object_id, + term_referent_component_index, + term_referent_constructor_index + ) VALUES (@r, @, @) + |] + typeBuiltin :: Maybe TextId = Lens.preview C.Reference.t_ typ + typeHashId :: Maybe HashId = Lens.preview (C.Reference._ReferenceDerived . C.Reference.idH) typ + typeComponentIndex :: Maybe C.Reference.Pos = Lens.preview (C.Reference._ReferenceDerived . C.Reference.idPos) typ + create = execute + [sql| + CREATE TEMPORARY TABLE filter_query ( + term_referent_object_id INTEGER NOT NULL, + term_referent_component_index INTEGER NOT NULL, + term_referent_constructor_index INTEGER NULL + ) + |] + drop = execute [sql|DROP TABLE filter_query|] + +filterTermsByReferenceHavingType :: S.ReferenceH -> [S.Reference.Id] -> Transaction [S.Reference.Id] +filterTermsByReferenceHavingType typ terms = create *> for_ terms insert *> select <* drop + where + select = queryListRow [sql| + SELECT + q.term_reference_object_id, + q.term_reference_component_index + FROM filter_query q, find_type_index t + WHERE t.type_reference_builtin IS :typeBuiltin + AND t.type_reference_hash_id IS :typeHashId + AND t.type_reference_component_index IS :typeComponentIndex + AND t.term_referent_object_id = q.term_reference_object_id + AND t.term_referent_component_index = q.term_reference_component_index + AND t.term_referent_constructor_index IS NULL + |] + insert r = execute [sql| + INSERT INTO filter_query ( + term_reference_object_id, + term_reference_component_index + ) VALUES (@r, @) + |] + typeBuiltin :: Maybe TextId = Lens.preview C.Reference.t_ typ + typeHashId :: Maybe HashId = Lens.preview (C.Reference._ReferenceDerived . C.Reference.idH) typ + typeComponentIndex :: Maybe C.Reference.Pos = Lens.preview (C.Reference._ReferenceDerived . C.Reference.idPos) typ + create = execute + [sql| + CREATE TEMPORARY TABLE filter_query ( + term_reference_object_id INTEGER NOT NULL, + term_reference_component_index INTEGER NOT NULL + ) + |] + drop = execute [sql|DROP TABLE filter_query|] + + addToTypeMentionsIndex :: Reference' TextId HashId -> Referent.Id -> Transaction () addToTypeMentionsIndex tp tm = execute diff --git a/codebase2/core/U/Codebase/Reference.hs b/codebase2/core/U/Codebase/Reference.hs index e2809903de..1146ca8aa1 100644 --- a/codebase2/core/U/Codebase/Reference.hs +++ b/codebase2/core/U/Codebase/Reference.hs @@ -10,7 +10,7 @@ module U.Codebase.Reference Reference' (..), TermReference', TypeReference', - ReferenceType(..), + ReferenceType (..), pattern Derived, Id, Id' (..), @@ -20,6 +20,7 @@ module U.Codebase.Reference t_, h_, idH, + idPos, idToHash, idToShortHash, isBuiltin, @@ -30,7 +31,7 @@ module U.Codebase.Reference ) where -import Control.Lens (Lens, Prism, Prism', Traversal, lens, preview, prism) +import Control.Lens (Lens, Lens', Prism, Prism', Traversal, lens, preview, prism) import Data.Bifoldable (Bifoldable (..)) import Data.Bitraversable (Bitraversable (..)) import Data.Text qualified as Text @@ -112,16 +113,19 @@ type Pos = Word64 data Id' h = Id h Pos deriving stock (Eq, Ord, Show, Functor, Foldable, Traversable) -t_ :: Traversal (Reference' t h) (Reference' t' h) t t' -t_ f = \case - ReferenceBuiltin t -> ReferenceBuiltin <$> f t - ReferenceDerived id -> pure (ReferenceDerived id) +t_ :: Prism (Reference' t h) (Reference' t' h) t t' +t_ = prism ReferenceBuiltin \case + ReferenceBuiltin t -> Right t + ReferenceDerived id -> Left (ReferenceDerived id) h_ :: Traversal (Reference' t h) (Reference' t h') h h' h_ f = \case ReferenceBuiltin t -> pure (ReferenceBuiltin t) Derived h i -> Derived <$> f h <*> pure i +idPos :: Lens' (Id' h) Pos +idPos = lens (\(Id _h w) -> w) (\(Id h _w) w -> Id h w) + idH :: Lens (Id' h) (Id' h') h h' idH = lens (\(Id h _w) -> h) (\(Id _h w) h -> Id h w) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 7bcab19221..b9b6883e8a 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -20,6 +20,8 @@ module Unison.Codebase -- ** Search termsOfType, + filterTermsByReferenceIdHavingType, + filterTermsByReferentHavingType, termsMentioningType, SqliteCodebase.Operations.termReferencesByPrefix, termReferentsByPrefix, @@ -155,7 +157,7 @@ import Unison.NameSegment qualified as NameSegment import Unison.Parser.Ann (Ann) import Unison.Parser.Ann qualified as Parser import Unison.Prelude -import Unison.Reference (Reference) +import Unison.Reference (Reference, TermReferenceId, TypeReference) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.Runtime.IOSource qualified as IOSource @@ -461,6 +463,28 @@ 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/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 4417595fef..90755b4496 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -71,7 +71,7 @@ import Unison.DataDeclaration (Decl) import Unison.Hash (Hash) import Unison.Parser.Ann (Ann) import Unison.Prelude -import Unison.Reference (Reference) +import Unison.Reference (Reference, TermReferenceId) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.ShortHash (ShortHash) @@ -352,6 +352,14 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action termsOfTypeImpl = CodebaseOps.termsOfTypeImpl getDeclType + filterTermsByReferentIdHavingTypeImpl :: Reference -> Set Referent.Id -> Sqlite.Transaction (Set Referent.Id) + filterTermsByReferentIdHavingTypeImpl = + CodebaseOps.filterReferentsHavingTypeImpl getDeclType + + filterTermsByReferenceIdHavingTypeImpl :: Reference -> Set TermReferenceId -> Sqlite.Transaction (Set TermReferenceId) + filterTermsByReferenceIdHavingTypeImpl = + CodebaseOps.filterReferencesHavingTypeImpl + termsMentioningTypeImpl :: Reference -> Sqlite.Transaction (Set Referent.Id) termsMentioningTypeImpl = CodebaseOps.termsMentioningTypeImpl getDeclType @@ -382,6 +390,8 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action getWatch, termsOfTypeImpl, termsMentioningTypeImpl, + filterTermsByReferenceIdHavingTypeImpl, + filterTermsByReferentIdHavingTypeImpl, termReferentsByPrefix = referentsByPrefix, withConnection = withConn, withConnectionIO = withConnection debugName root diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs index 3b6e91a1a9..ce34d72f1d 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Conversions.hs @@ -273,20 +273,16 @@ branchHash2to1 :: forall m. BranchHash -> V1.Branch.NamespaceHash m branchHash2to1 = V1.HashFor . unBranchHash reference2to1 :: V2.Reference -> V1.Reference -reference2to1 = \case - V2.ReferenceBuiltin t -> V1.Reference.Builtin t - V2.ReferenceDerived i -> V1.Reference.DerivedId $ referenceid2to1 i +reference2to1 = id reference1to2 :: V1.Reference -> V2.Reference -reference1to2 = \case - V1.Reference.Builtin t -> V2.ReferenceBuiltin t - V1.Reference.DerivedId i -> V2.ReferenceDerived (referenceid1to2 i) +reference1to2 = id referenceid1to2 :: V1.Reference.Id -> V2.Reference.Id -referenceid1to2 (V1.Reference.Id h i) = V2.Reference.Id h i +referenceid1to2 = id referenceid2to1 :: V2.Reference.Id -> V1.Reference.Id -referenceid2to1 (V2.Reference.Id h i) = V1.Reference.Id h i +referenceid2to1 = id rreferent2to1 :: (Applicative m) => Hash -> (V2.Reference -> m CT.ConstructorType) -> V2.ReferentH -> m V1.Referent rreferent2to1 h lookupCT = \case @@ -314,6 +310,11 @@ referent1to2 = \case V1.Ref r -> V2.Ref $ reference1to2 r V1.Con (V1.ConstructorReference r i) _ct -> V2.Con (reference1to2 r) (fromIntegral i) +referentid1to2 :: V1.Referent.Id -> V2.Referent.Id +referentid1to2 = \case + V1.RefId r -> V2.RefId (referenceid1to2 r) + V1.ConId (V1.ConstructorReference r i) _ct -> V2.ConId (referenceid1to2 r) i + referentid2to1 :: (Applicative m) => (V2.Reference -> m CT.ConstructorType) -> V2.Referent.Id -> m V1.Referent.Id referentid2to1 lookupCT = \case V2.RefId r -> pure $ V1.RefId (referenceid2to1 r) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs index 133c47fe85..9cc0964de3 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs @@ -503,6 +503,23 @@ termsMentioningTypeImpl doGetDeclType r = Ops.termsMentioningType (Cv.reference1to2 r) >>= Set.traverse (Cv.referentid2to1 doGetDeclType) +filterReferencesHavingTypeImpl :: Reference -> Set Reference.Id -> Transaction (Set Reference.Id) +filterReferencesHavingTypeImpl typRef termRefs = + Ops.filterTermsByReferenceHavingType (Cv.reference1to2 typRef) (Cv.referenceid1to2 <$> toList termRefs) + <&> fmap Cv.referenceid2to1 + <&> Set.fromList + +filterReferentsHavingTypeImpl :: + -- | A 'getDeclType'-like lookup, possibly backed by a cache. + (C.Reference.Reference -> Transaction CT.ConstructorType) -> + Reference -> + Set Referent.Id -> + Transaction (Set Referent.Id) +filterReferentsHavingTypeImpl doGetDeclType typRef termRefs = + Ops.filterTermsByReferentHavingType (Cv.reference1to2 typRef) (Cv.referentid1to2 <$> toList termRefs) + >>= traverse (Cv.referentid2to1 doGetDeclType) + <&> Set.fromList + -- | The number of base32 characters needed to distinguish any two references in the codebase. hashLength :: Transaction Int hashLength = pure 10 diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 9a6385240e..fe2cb52458 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -27,7 +27,7 @@ import Unison.ConstructorType qualified as CT import Unison.DataDeclaration (Decl) import Unison.Hash (Hash) import Unison.Prelude -import Unison.Reference (Reference) +import Unison.Reference (Reference, TypeReference) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.ShortHash (ShortHash) @@ -98,6 +98,10 @@ data Codebase m v a = Codebase termsOfTypeImpl :: Reference -> Sqlite.Transaction (Set Referent.Id), -- | Get the set of user-defined terms-or-constructors mention the given type anywhere in their signature. termsMentioningTypeImpl :: Reference -> Sqlite.Transaction (Set Referent.Id), + -- | Return the subset of the given set that has the given type. + filterTermsByReferenceIdHavingTypeImpl :: TypeReference -> Set Reference.Id -> Sqlite.Transaction (Set Reference.Id), + -- | Return the subset of the given set that has the given type. + filterTermsByReferentIdHavingTypeImpl :: TypeReference -> Set Referent.Id -> Sqlite.Transaction (Set Referent.Id), -- | Get the set of user-defined terms-or-constructors whose hash matches the given prefix. termReferentsByPrefix :: ShortHash -> Sqlite.Transaction (Set Referent.Id), -- | Acquire a new connection to the same underlying database file this codebase object connects to. diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 547cd1ed22..e0e8d849ab 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -26,6 +26,7 @@ import Data.Set.NonEmpty qualified as NESet import Data.Text qualified as Text import Data.These (These (..)) import Data.Time (UTCTime) +import Data.Tuple qualified as Tuple import Data.Tuple.Extra (uncurry3) import System.Directory (XdgDirectory (..), createDirectoryIfMissing, doesFileExist, getXdgDirectory) import System.Environment (withArgs) @@ -1860,7 +1861,7 @@ handleDependencies hq = do let terms = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ snd <$> results) #numberedArgs .= map (Text.unpack . Reference.toText . snd) types - <> map (Text.unpack . Reference.toText . Referent.toReference . snd) terms + <> map (Text.unpack . Reference.toText . Referent.toReference . snd) terms Cli.respond $ ListDependencies ppe lds (fst <$> types) (fst <$> terms) handleDependents :: HQ.HashQualified Name -> Cli () @@ -1994,14 +1995,14 @@ handleIOTest main = do whenJustM Cli.getLatestTypecheckedFile \typecheckedFile -> do whenJust (HQ.toName main) \mainName -> whenJust (Map.lookup (Name.toVar mainName) (UF.hashTermsId typecheckedFile)) \(_, ref, _wk, _term, typ) -> - returnMatches [(Reference.fromId ref, typ)] + returnMatches [(ref, typ)] -- Then, if we get here (because nothing in the scratch file matched), look at the terms in the codebase. Cli.runTransaction do forMaybe (Set.toList (NamesWithHistory.lookupHQTerm main parseNames)) \ref0 -> runMaybeT do - ref <- MaybeT (pure (Referent.toTermReference ref0)) - typ <- MaybeT (loadTypeOfTerm codebase (Referent.Ref ref)) + ref <- MaybeT (pure (Referent.toTermReferenceId ref0)) + typ <- MaybeT (loadTypeOfTerm codebase (Referent.fromTermReferenceId ref)) pure (ref, typ) ref <- @@ -2015,12 +2016,12 @@ handleIOTest main = do hashLength <- Cli.runTransaction Codebase.hashLength let labeledDependencies = matches - & map (\(ref, _typ) -> LD.termRef ref) + & map (\(ref, _typ) -> LD.derivedTerm ref) & Set.fromList Cli.returnEarly (LabeledReferenceAmbiguous hashLength main labeledDependencies) let a = ABT.annotation tm - tm = DD.forceTerm a a (Term.ref a ref) + tm = DD.forceTerm a a (Term.refId a ref) -- Don't cache IO tests tm' <- evalUnisonTerm False ppe False tm Cli.respond $ TestResults Output.NewlyComputed ppe True True (oks [(ref, tm')]) (fails [(ref, tm')]) @@ -2070,10 +2071,10 @@ handleShowDefinition outputLoc showDefinitionScope inputQuery = do -- information from the database instead, once it's efficient to do so. isTest <- do branch <- Cli.getCurrentBranch0 - pure \ref -> - branch - & Branch.deepTermMetadata - & Metadata.hasMetadataWithType' (Referent.fromTermReference ref) IOSource.isTestReference + let branchRefs = branch & Branch.deepTerms & Relation.dom & Set.mapMaybe Referent.toTermReferenceId + tests <- Cli.runTransaction (Codebase.filterTermsByReferenceIdHavingType codebase (DD.testResultType mempty) branchRefs) + pure \r -> Set.member r tests + Cli.respond $ DisplayDefinitions DisplayDefinitionsOutput @@ -2110,40 +2111,48 @@ handleShowDefinition outputLoc showDefinitionScope inputQuery = do Just (path, _) -> Just path -- | Handle a @test@ command. +-- Run pure tests in the current subnamespace. handleTest :: TestInput -> Cli () handleTest TestInput {includeLibNamespace, showFailures, showSuccesses} = do Cli.Env {codebase} <- ask - testTerms <- do - branch <- Cli.getCurrentBranch0 - branch - & Branch.deepTermMetadata - & R4.restrict34d12 IOSource.isTest - & (if includeLibNamespace then id else R.filterRan (not . isInLibNamespace)) - & R.dom - & pure - let testRefs = Set.mapMaybe Referent.toTermReference testTerms - oks results = - [ (r, msg) - | (r, Term.List' ts) <- Map.toList results, - Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts, - cid == DD.okConstructorId && ref == DD.testResultRef - ] - fails results = - [ (r, msg) - | (r, Term.List' ts) <- Map.toList results, - Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) <- toList ts, - cid == DD.failConstructorId && ref == DD.testResultRef - ] - cachedTests <- do - fmap Map.fromList do + testRefs <- + do + branch <- Cli.getCurrentBranch0 + let queryTerms = + branch + & Branch.deepTerms + & (if includeLibNamespace then id else R.filterRan (not . isInLibNamespace)) + & R.dom + & Set.mapMaybe Referent.toTermReferenceId + Cli.runTransaction (Codebase.filterTermsByReferenceIdHavingType codebase (DD.testResultType mempty) queryTerms) + + cachedTests <- + Map.fromList <$> Cli.runTransaction do Set.toList testRefs & wither \case - Reference.Builtin _ -> pure Nothing - r@(Reference.DerivedId rid) -> fmap (r,) <$> Cli.runTransaction (Codebase.getWatch codebase WK.TestWatch rid) + rid -> fmap (rid,) <$> Codebase.getWatch codebase WK.TestWatch rid + let (oks, fails) = passFails cachedTests + passFails :: (Ord r) => Map r (Term v a) -> ([(r, Text)], [(r, Text)]) + passFails = Tuple.swap . partitionEithers . concat . map p . Map.toList + where + p :: (r, Term v a) -> [Either (r, Text) (r, Text)] + p (r, tm) = case tm of + Term.List' ts -> mapMaybe (q r) (toList ts) + _ -> [] + q r = \case + Term.App' (Term.Constructor' (ConstructorReference ref cid)) (Term.Text' msg) -> + if + | ref == DD.testResultRef -> + if + | cid == DD.okConstructorId -> Just (Right (r, msg)) + | cid == DD.failConstructorId -> Just (Left (r, msg)) + | otherwise -> Nothing + | otherwise -> Nothing + _ -> Nothing let stats = Output.CachedTests (Set.size testRefs) (Map.size cachedTests) names <- makePrintNamesFromLabeled' $ - LD.referents testTerms + LD.referents (Set.mapMonotonic Referent.fromTermReferenceId testRefs) <> LD.referents [DD.okConstructorReferent, DD.failConstructorReferent] ppe <- fqnPPE names Cli.respond $ @@ -2152,36 +2161,34 @@ handleTest TestInput {includeLibNamespace, showFailures, showSuccesses} = do ppe showSuccesses showFailures - (oks cachedTests) - (fails cachedTests) + oks + fails let toCompute = Set.difference testRefs (Map.keysSet cachedTests) when (not (Set.null toCompute)) do let total = Set.size toCompute computedTests <- fmap join . for (toList toCompute `zip` [1 ..]) $ \(r, n) -> - case r of - Reference.DerivedId rid -> - Cli.runTransaction (Codebase.getTerm codebase rid) >>= \case - Nothing -> do - hqLength <- Cli.runTransaction Codebase.hashLength - Cli.respond (TermNotFound' . SH.shortenTo hqLength . Reference.toShortHash $ Reference.DerivedId rid) + Cli.runTransaction (Codebase.getTerm codebase r) >>= \case + Nothing -> do + hqLength <- Cli.runTransaction Codebase.hashLength + Cli.respond (TermNotFound' . SH.shortenTo hqLength . Reference.toShortHash $ Reference.DerivedId r) + pure [] + Just tm -> do + Cli.respond $ TestIncrementalOutputStart ppe (n, total) r tm + -- v don't cache; test cache populated below + tm' <- evalPureUnison ppe False tm + case tm' of + Left e -> do + Cli.respond (EvaluationFailure e) pure [] - Just tm -> do - Cli.respond $ TestIncrementalOutputStart ppe (n, total) r tm - -- v don't cache; test cache populated below - tm' <- evalPureUnison ppe False tm - case tm' of - Left e -> do - Cli.respond (EvaluationFailure e) - pure [] - Right tm' -> do - -- After evaluation, cache the result of the test - Cli.runTransaction (Codebase.putWatch WK.TestWatch rid tm') - Cli.respond $ TestIncrementalOutputEnd ppe (n, total) r tm' - pure [(r, tm')] - r -> error $ "unpossible, tests can't be builtins: " <> show r + Right tm' -> do + -- After evaluation, cache the result of the test + Cli.runTransaction (Codebase.putWatch WK.TestWatch r tm') + Cli.respond $ TestIncrementalOutputEnd ppe (n, total) r tm' + pure [(r, tm')] let m = Map.fromList computedTests - Cli.respond $ TestResults Output.NewlyComputed ppe showSuccesses showFailures (oks m) (fails m) + (mOks, mFails) = passFails m + Cli.respond $ TestResults Output.NewlyComputed ppe showSuccesses showFailures mOks mFails where isInLibNamespace :: Name -> Bool isInLibNamespace name = diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 5f1e485468..7020c39b37 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -63,7 +63,7 @@ import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPE import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName, Semver) -import Unison.Reference (Reference, TermReference) +import Unison.Reference (Reference, TermReferenceId) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Server.Backend (ShallowListEntry (..)) @@ -159,15 +159,15 @@ data Output | -- | Function found, but has improper type -- Note: the constructor name is misleading here; we weren't necessarily looking for a "main". BadMainFunction + -- | what we were trying to do (e.g. "run", "io.test") String - -- ^ what we were trying to do (e.g. "run", "io.test") + -- | name of function String - -- ^ name of function + -- | bad type of function (Type Symbol Ann) - -- ^ bad type of function PPE.PrettyPrintEnv + -- | acceptable type(s) of function [Type Symbol Ann] - -- ^ acceptable type(s) of function | BranchEmpty WhichBranchEmpty | LoadPullRequest (ReadRemoteNamespace Void) (ReadRemoteNamespace Void) Path' Path' Path' Path' | CreatedNewBranch Path.Absolute @@ -206,12 +206,12 @@ data Output -- for terms. This additional info is used to provide an enhanced -- error message. SearchTermsNotFoundDetailed + -- | @True@ if we are searching for a term, @False@ if we are searching for a type Bool - -- ^ @True@ if we are searching for a term, @False@ if we are searching for a type + -- | Misses (search terms that returned no hits for terms or types) [HQ.HashQualified Name] - -- ^ Misses (search terms that returned no hits for terms or types) + -- | Hits for types if we are searching for terms or terms if we are searching for types [HQ.HashQualified Name] - -- ^ Hits for types if we are searching for terms or terms if we are searching for types | -- ask confirmation before deleting the last branch that contains some defns -- `Path` is one of the paths the user has requested to delete, and is paired -- with whatever named definitions would not have any remaining names if @@ -253,16 +253,16 @@ data Output | -- "display" definitions, possibly to a FilePath on disk (e.g. editing) DisplayDefinitions DisplayDefinitionsOutput | -- Like `DisplayDefinitions`, but the definitions are already rendered. `Nothing` means put to the terminal. - DisplayDefinitionsString !(Maybe FilePath) !(P.Pretty P.ColorText) {- rendered definitions -} - | TestIncrementalOutputStart PPE.PrettyPrintEnv (Int, Int) Reference (Term Symbol Ann) - | TestIncrementalOutputEnd PPE.PrettyPrintEnv (Int, Int) Reference (Term Symbol Ann) + DisplayDefinitionsString !(Maybe FilePath) !(P.Pretty P.ColorText {- rendered definitions -}) + | TestIncrementalOutputStart PPE.PrettyPrintEnv (Int, Int) TermReferenceId (Term Symbol Ann) + | TestIncrementalOutputEnd PPE.PrettyPrintEnv (Int, Int) TermReferenceId (Term Symbol Ann) | TestResults TestReportStats PPE.PrettyPrintEnv ShowSuccesses ShowFailures - [(Reference, Text)] -- oks - [(Reference, Text)] -- fails + [(TermReferenceId, Text)] -- oks + [(TermReferenceId, Text)] -- fails | CantUndo UndoFailureReason | -- new/unrepresented references followed by old/removed -- todo: eventually replace these sets with [SearchResult' v Ann] @@ -370,8 +370,8 @@ data Output | CalculatingDiff | -- | The `local` in a `clone remote local` is ambiguous AmbiguousCloneLocal + -- | Treating `local` as a project. We may know the branch name, if it was provided in `remote`. (ProjectAndBranch ProjectName ProjectBranchName) - -- ^ Treating `local` as a project. We may know the branch name, if it was provided in `remote`. (ProjectAndBranch ProjectName ProjectBranchName) | -- | The `remote` in a `clone remote local` is ambiguous AmbiguousCloneRemote ProjectName (ProjectAndBranch ProjectName ProjectBranchName) @@ -407,7 +407,7 @@ data CreatedProjectBranchFrom | CreatedProjectBranchFrom'ParentBranch ProjectBranchName data DisplayDefinitionsOutput = DisplayDefinitionsOutput - { isTest :: TermReference -> Bool, + { isTest :: TermReferenceId -> Bool, outputFile :: Maybe FilePath, prettyPrintEnv :: PPE.PrettyPrintEnvDecl, terms :: Map Reference (DisplayObject (Type Symbol Ann) (Term Symbol Ann)), diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index c65c53bf68..961da1e565 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -38,6 +38,7 @@ import System.IO.Error (isDoesNotExistError) import U.Codebase.Branch (NamespaceStats (..)) import U.Codebase.Branch.Diff (NameChanges (..)) import U.Codebase.HashTags (CausalHash (..)) +import U.Codebase.Reference qualified as Reference import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) import Unison.ABT qualified as ABT import Unison.Auth.Types qualified as Auth @@ -119,7 +120,7 @@ import Unison.PrintError renderCompilerBug, ) import Unison.Project (ProjectAndBranch (..)) -import Unison.Reference (Reference, TermReference) +import Unison.Reference (Reference, TermReferenceId) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent @@ -798,7 +799,7 @@ notifyUser dir = \case putPretty' $ P.shown (total - n) <> " tests left to run, current test: " - <> P.syntaxToColor (prettyHashQualified (PPE.termName ppe $ Referent.Ref r)) + <> P.syntaxToColor (prettyHashQualified (PPE.termName ppe $ Referent.fromTermReferenceId r)) pure mempty TestIncrementalOutputEnd _ppe (_n, _total) _r result -> do clearCurrentLine @@ -2645,7 +2646,7 @@ displayDefinitions DisplayDefinitionsOutput {isTest, outputFile, prettyPrintEnv <> "to replace the definitions currently in this namespace." ] - code :: (TermReference -> Bool) -> Pretty + code :: (TermReferenceId -> Bool) -> Pretty code isTest = P.syntaxToColor $ P.sep "\n\n" (prettyTypes <> prettyTerms isTest) @@ -2657,13 +2658,13 @@ displayDefinitions DisplayDefinitionsOutput {isTest, outputFile, prettyPrintEnv & List.sortBy (\(n0, _, _) (n1, _, _) -> Name.compareAlphabetical n0 n1) & map prettyType - prettyTerms :: (TermReference -> Bool) -> [P.Pretty SyntaxText] + prettyTerms :: (TermReferenceId -> Bool) -> [P.Pretty SyntaxText] prettyTerms isTest = terms & Map.toList & map (\(ref, dt) -> (PPE.termName ppeDecl (Referent.Ref ref), ref, dt)) & List.sortBy (\(n0, _, _) (n1, _, _) -> Name.compareAlphabetical n0 n1) - & map (\t -> prettyTerm (isTest (t ^. _2)) t) + & map (\t -> prettyTerm (fromMaybe False . fmap isTest . Reference.toId $ (t ^. _2)) t) prettyTerm :: Bool -> @@ -2735,13 +2736,13 @@ displayDefinitionsString maybePath definitions = displayTestResults :: Bool -> -- whether to show the tip PPE.PrettyPrintEnv -> - [(Reference, Text)] -> - [(Reference, Text)] -> + [(TermReferenceId, Text)] -> + [(TermReferenceId, Text)] -> Pretty displayTestResults showTip ppe oksUnsorted failsUnsorted = let oks = Name.sortByText fst [(name r, msg) | (r, msg) <- oksUnsorted] fails = Name.sortByText fst [(name r, msg) | (r, msg) <- failsUnsorted] - name r = HQ.toText $ PPE.termName ppe (Referent.Ref r) + name r = HQ.toText $ PPE.termName ppe (Referent.fromTermReferenceId r) okMsg = if null oks then mempty diff --git a/unison-core/src/Unison/Referent.hs b/unison-core/src/Unison/Referent.hs index 398732443e..d04454ea17 100644 --- a/unison-core/src/Unison/Referent.hs +++ b/unison-core/src/Unison/Referent.hs @@ -9,9 +9,12 @@ module Unison.Referent pattern RefId, pattern ConId, fold, + toId, toReference, toReferenceId, toTermReference, + toTermReferenceId, + fromId, fromTermReference, fromTermReferenceId, fromText, @@ -72,6 +75,20 @@ 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 @@ -107,6 +124,9 @@ toTermReference = \case Con' _ _ -> Nothing Ref' reference -> Just reference +toTermReferenceId :: Referent -> Maybe TermReferenceId +toTermReferenceId r = toTermReference r >>= Reference.toId + -- | Inject a Term Reference into a Referent fromTermReference :: TermReference -> Referent fromTermReference r = Ref r From b14ec9983889210261763f8febee73ec40c178c7 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 25 Nov 2023 13:43:17 -0500 Subject: [PATCH 2/2] transcript showing test without metadata --- unison-src/transcripts/test-command.md | 2 +- unison-src/transcripts/test-command.output.md | 9 ++++++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/unison-src/transcripts/test-command.md b/unison-src/transcripts/test-command.md index 3d8bde394a..da8effa92e 100644 --- a/unison-src/transcripts/test-command.md +++ b/unison-src/transcripts/test-command.md @@ -32,7 +32,6 @@ test2 = [Ok "test2"] ```ucm:hide .lib> add -.lib> link .builtin.metadata.isTest test2 ``` ```ucm @@ -45,6 +44,7 @@ test2 = [Ok "test2"] ```unison test3 : [Result] test3 = [Ok "test3"] +test4 = [Ok "test4"] ``` ```ucm:hide diff --git a/unison-src/transcripts/test-command.output.md b/unison-src/transcripts/test-command.output.md index 0dbc2e8391..e3ae2f815b 100644 --- a/unison-src/transcripts/test-command.output.md +++ b/unison-src/transcripts/test-command.output.md @@ -97,6 +97,7 @@ test2 = [Ok "test2"] ```unison test3 : [Result] test3 = [Ok "test3"] +test4 = [Ok "test4"] ``` ```ucm @@ -108,6 +109,7 @@ test3 = [Ok "test3"] ⍟ These new definitions are ok to `add`: test3 : [Result] + test4 : [Result] ``` ```ucm @@ -126,11 +128,16 @@ test3 = [Ok "test3"] + + + + New test results: ◉ hello.lib.test3 test3 + ◉ hello.lib.test4 test4 - ✅ 1 test(s) passing + ✅ 2 test(s) passing Tip: Use view hello.lib.test3 to view the source of a test.