unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-10-05 06:07:21 +03:00
Code Issues Projects Releases Wiki Activity

wip

Browse Source
This commit is contained in:
Paul Chiusano 2023-05-15 12:47:48 -05:00
parent d5f0f0ec76
commit 18634e4cca
6 changed files with 65 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
parser-typechecker/src/U/Codebase/Projects.hs
View File

@ -9,13 +9,10 @@ import U.Codebase.Branch
import qualified U.Codebase.Causal as Causal
import Unison.Codebase.Path
import qualified Unison.Codebase.Path as Path
import Unison.NameSegment (NameSegment (..))
import Unison.Name (libSegment)
import Unison.Prelude
import qualified Unison.Sqlite as Sqlite
libSegment :: NameSegment
libSegment = NameSegment "lib"
-- | Infers path to use for loading names.
-- Currently this means finding the closest parent with a "lib" child.
inferNamesRoot :: Path -> Branch Sqlite.Transaction -> Sqlite.Transaction (Maybe Path)

50
unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -77,6 +77,7 @@ import qualified Unison.Codebase.BranchUtil as BranchUtil
import qualified Unison.Codebase.Causal as Causal
import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..))
import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo
import qualified Unison.LabeledDependency as LabeledDependency
import Unison.Codebase.Editor.DisplayObject
import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin)
import Unison.Codebase.Editor.HandleInput.Branch (handleBranch)
@ -1273,38 +1274,38 @@ loop e = do
ListDependentsI hq -> handleDependents hq
ListDependenciesI hq -> do
Cli.Env {codebase} <- ask
hqLength <- Cli.runTransaction Codebase.hashLength
-- todo: add flag to handle transitive efficiently
lds <- resolveHQToLabeledDependencies hq
when (null lds) do
Cli.returnEarly (LabeledReferenceNotFound hq)
rootBranch <- Cli.getRootBranch
for_ lds \ld -> do
dependencies :: Set Reference <-
dependencies :: Set LabeledDependency <-
Cli.runTransaction do
let tp r@(Reference.DerivedId i) =
Codebase.getTypeDeclaration codebase i <&> \case
Nothing -> error $ "What happened to " ++ show i ++ "?"
Just decl -> Set.delete r . DD.dependencies $ DD.asDataDecl decl
Just decl -> Set.map LabeledDependency.TypeReference . Set.delete r . DD.dependencies
$ DD.asDataDecl decl
tp _ = pure mempty
tm (Referent.Ref r@(Reference.DerivedId i)) =
tm r@(Referent.Ref (Reference.DerivedId i)) =
Codebase.getTerm codebase i <&> \case
Nothing -> error $ "What happened to " ++ show i ++ "?"
Just tm -> Set.delete r $ Term.dependencies tm
Just tm -> Set.delete (LabeledDependency.TermReferent r) (Term.labeledDependencies tm)
tm con@(Referent.Con (ConstructorReference (Reference.DerivedId i) cid) _ct) =
Codebase.getTypeDeclaration codebase i <&> \case
Nothing -> error $ "What happened to " ++ show i ++ "?"
Just decl -> case DD.typeOfConstructor (DD.asDataDecl decl) cid of
Nothing -> error $ "What happened to " ++ show con ++ "?"
Just tp -> Type.dependencies tp
Just tp -> Type.labeledDependencies tp
tm _ = pure mempty
in LD.fold tp tm ld
(missing, names0) <- liftIO (Branch.findHistoricalRefs' dependencies rootBranch)
let types = R.toList $ Names.types names0
let terms = fmap (second Referent.toReference) $ R.toList $ Names.terms names0
ppe <- PPE.suffixifiedPPE <$> currentPrettyPrintEnvDecl Backend.WithinStrict
let types = List.sort [ PPE.typeName ppe r | LabeledDependency.TypeReference r <- toList dependencies ]
let terms = List.sort [ PPE.termName ppe r | LabeledDependency.TermReferent r <- toList dependencies ]
let names = types <> terms
#numberedArgs .= fmap (Text.unpack . Reference.toText) ((fmap snd names) <> toList missing)
Cli.respond $ ListDependencies hqLength ld names missing
#numberedArgs .= map HQ.toString names
Cli.respond $ ListDependencies hq types terms
NamespaceDependenciesI namespacePath' -> do
Cli.Env {codebase} <- ask
path <- maybe Cli.getCurrentPath Cli.resolvePath' namespacePath'
@ -1760,9 +1761,13 @@ handleDependents hq = do
hqLength <- Cli.runTransaction Codebase.hashLength
-- todo: add flag to handle transitive efficiently
lds <- resolveHQToLabeledDependencies hq
-- Use an unsuffixified PPE here, so we display full names (relative to the current path),
-- rather than the shortest possible unambiguous name.
ppe <- PPE.unsuffixifiedPPE <$> currentPrettyPrintEnvDecl Backend.WithinStrict
when (null lds) do
Cli.returnEarly (LabeledReferenceNotFound hq)
when (length lds > 1) do
Cli.returnEarly (LabeledReferenceAmbiguous hqLength hq lds)
for_ lds \ld -> do
-- The full set of dependent references, any number of which may not have names in the current namespace.
@ -1773,25 +1778,22 @@ handleDependents hq = do
Referent.Con (ConstructorReference r _cid) _ct ->
Codebase.dependents Queries.ExcludeOwnComponent r
in Cli.runTransaction (LD.fold tp tm ld)
-- Use an unsuffixified PPE here, so we display full names (relative to the current path), rather than the shortest possible
-- unambiguous name.
ppe <- PPE.unsuffixifiedPPE <$> currentPrettyPrintEnvDecl Backend.Within
let results :: [(Reference, Maybe Name)]
results =
-- Currently we only retain dependents that are named in the current namespace (hence `mapMaybe`). In the future, we could
-- take a flag to control whether we want to show all dependents
mapMaybe f (Set.toList dependents)
-- Currently we only retain dependents that are named in the current namespace
[ p | Just p <- map f (Set.toList dependents) ]
where
f :: Reference -> Maybe (Reference, Maybe Name)
f reference =
asum
[ g <$> PPE.terms ppe (Referent.Ref reference),
g <$> PPE.types ppe reference
[ g =<< PPE.terms ppe (Referent.Ref reference),
g =<< PPE.types ppe reference
]
where
g :: HQ'.HashQualified Name -> (Reference, Maybe Name)
g hqName =
(reference, Just (HQ'.toName hqName))
g :: HQ'.HashQualified Name -> Maybe (Reference, Maybe Name)
g hqName = case HQ'.toName hqName of
name | Name.beginsWithSegment name Name.libSegment -> Nothing
| otherwise -> Just (reference, Just (HQ'.toName hqName))
#numberedArgs .= map (Text.unpack . Reference.toText . fst) results
Cli.respond (ListDependents hqLength ld results)

2
unison-cli/src/Unison/Codebase/Editor/Output.hs
View File

@ -272,7 +272,7 @@ data Output
NoConflictsOrEdits
| NotImplemented
| NoBranchWithHash ShortCausalHash
| ListDependencies Int LabeledDependency [(Name, Reference)] (Set Reference)
| ListDependencies (HQ.HashQualified Name) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms
| -- | List dependents of a type or term.
ListDependents Int LabeledDependency [(Reference, Maybe Name)]
| -- | List all direct dependencies which don't have any names in the current branch

40
unison-cli/src/Unison/CommandLine/OutputMessages.hs
View File

@ -1672,28 +1672,28 @@ notifyUser dir = \case
Just name -> prettyName name,
prettyShortHash (SH.take hqLength (Reference.toShortHash reference))
)
-- this definition is identical to the previous one, apart from the word
-- "Dependencies", but undecided about whether or how to refactor
ListDependencies hqLength ld names missing ->
ListDependencies hq [] [] ->
pure $ P.syntaxToColor $ prettyHashQualified hq <> " doesn't have any dependencies."
ListDependencies _hq types terms ->
pure $
if names == mempty && missing == mempty
then c (prettyLabeledDependency hqLength ld) <> " doesn't have any dependencies."
else
"Dependencies of "
<> c (prettyLabeledDependency hqLength ld)
<> ":\n\n"
<> (P.indentN 2 (P.numberedColumn2Header num pairs))
P.lines . join $
[ [ P.bold "Types:",
"",
P.indentN 2 $ P.numbered (numFrom 0) $ c . prettyHashQualified <$> types
],
if null terms
then []
else
[ "",
P.bold "Terms:",
"",
P.indentN 2 $ P.numbered (numFrom $ length types) $ c . prettyHashQualified <$> terms
],
[""],
[tip ("Use " <> IP.makeExample IP.view ["1"] <> " to view one of these definitions.")]
]
where
num n = P.hiBlack $ P.shown n <> "."
header = (P.hiBlack "Reference", P.hiBlack "Name")
pairs =
header
: ( fmap (first c . second c) $
[(p $ Reference.toShortHash r, prettyName n) | (n, r) <- names]
++ [(p $ Reference.toShortHash r, "(no name available)") | r <- toList missing]
)
p = prettyShortHash . SH.take hqLength
numFrom k n = P.hiBlack $ P.shown (k + n) <> "."
c = P.syntaxToColor
ListNamespaceDependencies _ppe _path Empty -> pure $ "This namespace has no external dependencies."
ListNamespaceDependencies ppe path' externalDependencies -> do

7
unison-core/src/Unison/Name.hs
View File

@ -32,6 +32,7 @@ module Unison.Name
unqualified,
-- * To organize later
libSegment,
sortNames,
sortNamed,
sortByText,
@ -315,12 +316,14 @@ searchByRankedSuffix suffix rel = case searchBySuffix suffix rel of
| r <- toList rs,
ns <- [filter ok (toList (R.lookupRan r rel))]
]
lib = NameSegment "lib"
libCount = length . filter (== lib) . toList . reverseSegments
libCount = length . filter (== libSegment) . toList . reverseSegments
minLibs [] = 0
minLibs ns = minimum (map libCount ns)
ok name = compareSuffix suffix name == EQ
libSegment :: NameSegment
libSegment = NameSegment "lib"
sortByText :: (a -> Text) -> [a] -> [a]
sortByText by as =
let as' = [(a, by a) | a <- as]

15
unison-share-api/src/Unison/Server/Backend.hs
View File

@ -269,6 +269,7 @@ namesForBranch root scope =
(path, includeAllNames) = case scope of
AllNames path -> (path, True)
Within path -> (path, False)
WithinStrict path -> (path, False)
root0 = Branch.head root
currentBranch = fromMaybe Branch.empty $ Branch.getAt path root
absoluteRootNames = Names.makeAbsolute (Branch.toNames root0)
@ -689,18 +690,26 @@ data NameScoping
AllNames Path
| -- | Filter returned names to only include names within this path.
Within Path
| -- | Like `Within`, but does not include a fallback
WithinStrict Path
toAllNames :: NameScoping -> NameScoping
toAllNames (AllNames p) = AllNames p
toAllNames (Within p) = AllNames p
toAllNames (WithinStrict p) = AllNames p
getCurrentPrettyNames :: Int -> NameScoping -> Branch m -> PPED.PrettyPrintEnvDecl
getCurrentPrettyNames hashLen scope root =
let primary = PPED.fromNamesDecl hashLen $ NamesWithHistory (parseNamesForBranch root scope) mempty
backup = PPED.fromNamesDecl hashLen $ NamesWithHistory (parseNamesForBranch root (AllNames mempty)) mempty
in PPED.PrettyPrintEnvDecl
case scope of
WithinStrict _ -> primary
_ ->
PPED.PrettyPrintEnvDecl
(PPED.unsuffixifiedPPE primary `PPE.addFallback` PPED.unsuffixifiedPPE backup)
(PPED.suffixifiedPPE primary `PPE.addFallback` PPED.suffixifiedPPE backup)
where
backup = PPED.fromNamesDecl hashLen $ NamesWithHistory (parseNamesForBranch root (AllNames mempty)) mempty
where
primary = PPED.fromNamesDecl hashLen $ NamesWithHistory (parseNamesForBranch root scope) mempty
getCurrentParseNames :: NameScoping -> Branch m -> NamesWithHistory
getCurrentParseNames scope root =