mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
Merge pull request #5068 from unisonweb/24-05-30-edit-namespace-no-record-accessors
This commit is contained in:
commit
433be000b2
@ -32,11 +32,15 @@ import Unison.Referent (Referent)
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Namer
|
||||
|
||||
-- | A "namer" associates a set of (possibly hash-qualified) names with a referent / type reference.
|
||||
data Namer = Namer
|
||||
{ nameTerm :: Referent -> Set (HQ'.HashQualified Name),
|
||||
nameType :: TypeReference -> Set (HQ'.HashQualified Name)
|
||||
}
|
||||
|
||||
-- | Make a "namer" out of a collection of names, ignoring conflicted names. That is, if references #foo and #bar are
|
||||
-- both associated with name "baz", then the returned namer maps #foo too "baz" (not "baz"#foo) and #bar to "baz" (not
|
||||
-- "baz"#bar).
|
||||
namer :: Names -> Namer
|
||||
namer names =
|
||||
Namer
|
||||
@ -44,6 +48,9 @@ namer names =
|
||||
nameType = Set.map HQ'.fromName . Names.namesForReference names
|
||||
}
|
||||
|
||||
-- | Make a "namer" out of a collection of names, respecting conflicted names. That is, if references #foo and #bar are
|
||||
-- both associated with name "baz", then the returned namer maps #foo too "baz"#foo and #bar to "baz"#bar, but otherwise
|
||||
-- if a reference #qux has a single name "qux", then the returned namer maps #qux to "qux" (not "qux"#qux).
|
||||
hqNamer :: Int -> Names -> Namer
|
||||
hqNamer hashLen names =
|
||||
Namer
|
||||
|
@ -3,6 +3,7 @@ module Unison.Syntax.DeclPrinter
|
||||
prettyDeclW,
|
||||
prettyDeclHeader,
|
||||
prettyDeclOrBuiltinHeader,
|
||||
getFieldAndAccessorNames,
|
||||
AccessorName,
|
||||
)
|
||||
where
|
||||
@ -26,7 +27,7 @@ import Unison.PrettyPrintEnv (PrettyPrintEnv)
|
||||
import Unison.PrettyPrintEnv qualified as PPE
|
||||
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
import Unison.Reference (Reference, Reference' (DerivedId), TypeReference)
|
||||
import Unison.Reference (Reference, TypeReference)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Syntax.HashQualified qualified as HQ (toText)
|
||||
import Unison.Syntax.Name qualified as Name
|
||||
@ -125,20 +126,20 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
|
||||
constructor (n, (_, _, t)) = constructor' n t
|
||||
constructor' n t = case Type.unArrows t of
|
||||
Nothing -> pure $ prettyPattern unsuffixifiedPPE CT.Data name (ConstructorReference r n)
|
||||
Just ts -> case fieldNames unsuffixifiedPPE r name dd of
|
||||
Just ts -> case getFieldAndAccessorNames unsuffixifiedPPE r name dd of
|
||||
Nothing ->
|
||||
pure
|
||||
. P.group
|
||||
. P.hang' (prettyPattern unsuffixifiedPPE CT.Data name (ConstructorReference r n)) " "
|
||||
$ P.spaced (runPretty suffixifiedPPE (traverse (TypePrinter.prettyRaw Map.empty 10) (init ts)))
|
||||
Just fs -> do
|
||||
Just (fieldNames, _) -> do
|
||||
tell $
|
||||
Set.fromList $
|
||||
[ case accessor of
|
||||
Nothing -> declName `Name.joinDot` fieldName
|
||||
Just accessor -> declName `Name.joinDot` fieldName `Name.joinDot` accessor
|
||||
| HQ.NameOnly declName <- [name],
|
||||
fieldName <- fs,
|
||||
fieldName <- fieldNames,
|
||||
accessor <-
|
||||
[ Nothing,
|
||||
Just (Name.fromSegment NameSegment.setSegment),
|
||||
@ -149,7 +150,7 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
|
||||
fmt S.DelimiterChar "{ "
|
||||
<> P.sep
|
||||
(fmt S.DelimiterChar "," <> " " `P.orElse` "\n ")
|
||||
(field <$> zip fs (init ts))
|
||||
(field <$> zip fieldNames (init ts))
|
||||
<> fmt S.DelimiterChar " }"
|
||||
field (fname, typ) =
|
||||
P.group $
|
||||
@ -158,28 +159,31 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
|
||||
`P.hang` runPretty suffixifiedPPE (TypePrinter.prettyRaw Map.empty (-1) typ)
|
||||
header = prettyDataHeader name dd <> fmt S.DelimiterChar (" = " `P.orElse` "\n = ")
|
||||
|
||||
-- Comes up with field names for a data declaration which has the form of a
|
||||
-- record, like `type Pt = { x : Int, y : Int }`. Works by generating the
|
||||
-- record accessor terms for the data type, hashing these terms, and then
|
||||
-- checking the `PrettyPrintEnv` for the names of those hashes. If the names for
|
||||
-- these hashes are:
|
||||
-- This function determines if a data declaration "looks like a record", and if so, returns both its auto-generated
|
||||
-- accessor names (such as "Pt.x.set") and field names (such as "x"). Because we generate three accessors per field,
|
||||
-- there will always be three times as many accessors as there are fields.
|
||||
--
|
||||
-- It works by works by generating the record accessor terms for the data type, hashing these terms, and then checking
|
||||
-- the `PrettyPrintEnv` for the names of those hashes.
|
||||
--
|
||||
-- For example, for a type named "Pt", if the names of its accessors are
|
||||
--
|
||||
-- `Pt.x`, `Pt.x.set`, `Pt.x.modify`, `Pt.y`, `Pt.y.set`, `Pt.y.modify`
|
||||
--
|
||||
-- then this matches the naming convention generated by the parser, and we
|
||||
-- return `x` and `y` as the field names.
|
||||
-- then we will return those accessors along with the field names
|
||||
--
|
||||
-- This function bails with `Nothing` if the names aren't an exact match for
|
||||
-- the expected record naming convention.
|
||||
fieldNames ::
|
||||
-- `x`, `y`
|
||||
--
|
||||
-- This function returns `Nothing` if the given data declaration does not "look like a record".
|
||||
getFieldAndAccessorNames ::
|
||||
forall v a.
|
||||
(Var v) =>
|
||||
PrettyPrintEnv ->
|
||||
TypeReference ->
|
||||
HQ.HashQualified Name ->
|
||||
DataDeclaration v a ->
|
||||
Maybe [Name]
|
||||
fieldNames env r hqTypename dd = do
|
||||
Maybe ([Name], [Name]) -- field names, accessor names
|
||||
getFieldAndAccessorNames env r hqTypename dd = do
|
||||
-- If we only have a hash for the decl, then we can't know where in the namespace to look for the generated accessors,
|
||||
-- so we just give up trying to infer whether this was a record (even if it was one).
|
||||
typename <- HQ.toName hqTypename
|
||||
@ -212,10 +216,11 @@ fieldNames env r hqTypename dd = do
|
||||
-- ( #sety , "Pt.y.set" )
|
||||
-- ( #modifyy , "Pt.y.modify" )
|
||||
-- ]
|
||||
let names =
|
||||
[ (r, HQ.toText . PPE.termName env . Referent.Ref $ DerivedId r)
|
||||
| r <- (\(refId, _trm, _typ) -> refId) <$> Map.elems hashes
|
||||
]
|
||||
let accessorNamesByHash =
|
||||
hashes
|
||||
& Map.elems
|
||||
& map \(refId, _term, _typ) ->
|
||||
(refId, HQ.toText (PPE.termName env (Referent.fromTermReferenceId refId)))
|
||||
|
||||
-- {
|
||||
-- #getx => "x"
|
||||
@ -225,10 +230,10 @@ fieldNames env r hqTypename dd = do
|
||||
-- #sety => "y"
|
||||
-- #modifyy => "y"
|
||||
-- }
|
||||
let fieldNames =
|
||||
let fieldNamesByHash =
|
||||
Map.fromList
|
||||
[ (r, f)
|
||||
| (r, n) <- names,
|
||||
| (r, n) <- accessorNamesByHash,
|
||||
let typenameText = Name.toText typename,
|
||||
typenameText `Text.isPrefixOf` n,
|
||||
let rest = Text.drop (Text.length typenameText + 1) n,
|
||||
@ -236,17 +241,19 @@ fieldNames env r hqTypename dd = do
|
||||
rest `elem` ["", ".set", ".modify"]
|
||||
]
|
||||
|
||||
if Map.size fieldNames == length names
|
||||
if Map.size fieldNamesByHash == length accessorNamesByHash
|
||||
then
|
||||
Just
|
||||
[ Name.unsafeParseText name
|
||||
| -- "_0"
|
||||
v <- vars,
|
||||
-- #getx
|
||||
Just (ref, _, _) <- [Map.lookup (Var.namespaced (Name.toVar typename :| [v])) hashes],
|
||||
-- "x"
|
||||
Just name <- [Map.lookup ref fieldNames]
|
||||
]
|
||||
( [ Name.unsafeParseText name
|
||||
| -- "_0"
|
||||
v <- vars,
|
||||
-- #getx
|
||||
Just (ref, _, _) <- [Map.lookup (Var.namespaced (Name.toVar typename :| [v])) hashes],
|
||||
-- "x"
|
||||
Just name <- [Map.lookup ref fieldNamesByHash]
|
||||
],
|
||||
map (Name.unsafeParseText . snd) accessorNamesByHash
|
||||
)
|
||||
else Nothing
|
||||
|
||||
prettyModifier :: DD.Modifier -> Pretty SyntaxText
|
||||
|
@ -1,8 +1,11 @@
|
||||
module Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace) where
|
||||
|
||||
import Control.Monad.Reader
|
||||
import Data.Foldable qualified as Foldable
|
||||
import Data.List.Extra qualified as List
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import U.Codebase.Reference (Reference' (..))
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
@ -10,58 +13,87 @@ import Unison.Cli.PrettyPrintUtils qualified as NamesUtils
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Branch.Names qualified as Branch
|
||||
import Unison.Codebase.Editor.DisplayObject qualified as DisplayObject
|
||||
import Unison.Codebase.Editor.HandleInput.ShowDefinition (showDefinitions)
|
||||
import Unison.Codebase.Editor.Input (OutputLocation (..))
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.Name (Name)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Server.Backend qualified as Backend
|
||||
import Unison.Syntax.DeclPrinter qualified as DeclPrinter
|
||||
import Unison.Util.Monoid (foldMapM)
|
||||
|
||||
handleEditNamespace :: OutputLocation -> [Path] -> Cli ()
|
||||
handleEditNamespace outputLoc inputPaths = do
|
||||
handleEditNamespace outputLoc paths0 = do
|
||||
Cli.Env {codebase} <- ask
|
||||
currentBranch <- Cli.getCurrentBranch0
|
||||
ppe <- NamesUtils.currentPrettyPrintEnvDecl
|
||||
|
||||
-- Adjust the requested list of paths slightly: if it's missing (i.e. `edit.namespace` without arguments), then behave
|
||||
-- as if the empty path (which there is no syntax for, heh) was supplied.
|
||||
let paths =
|
||||
if null inputPaths
|
||||
if null paths0
|
||||
then [Path.empty]
|
||||
else inputPaths
|
||||
else paths0
|
||||
|
||||
-- Make a names object that contains the union of all names in the supplied paths (each prefixed with the associated
|
||||
-- path of course). Special case: if the path is the empty path, then ignore `lib`.
|
||||
let allNamesToEdit =
|
||||
(List.nubOrd paths) & foldMap \path ->
|
||||
let b = Branch.withoutLib $ Branch.getAt0 path currentBranch
|
||||
names = (Branch.toNames b)
|
||||
prefixedNames = case Path.toName path of
|
||||
List.nubOrd paths & foldMap \path ->
|
||||
let branch = (if path == Path.empty then Branch.withoutLib else id) (Branch.getAt0 path currentBranch)
|
||||
names = Branch.toNames branch
|
||||
in -- PPED.makePPED (PPE.hqNamer hashLen ns) (PPE.suffixifyByHash ns)
|
||||
|
||||
case Path.toName path of
|
||||
Nothing -> names
|
||||
Just pathPrefix -> Names.prefix0 pathPrefix names
|
||||
in prefixedNames
|
||||
|
||||
let termRefs = Names.termReferences allNamesToEdit
|
||||
-- We only need to (optionally) include cycles for type references, not term references,
|
||||
-- because 'update' is smart enough to patch-up cycles as expected for terms.
|
||||
let typeRefsWithoutCycles = Names.typeReferences allNamesToEdit
|
||||
typeRefs <- Cli.runTransaction $
|
||||
case includeCycles of
|
||||
Backend.IncludeCycles -> foldMapM Codebase.componentReferencesForReference typeRefsWithoutCycles
|
||||
Backend.DontIncludeCycles -> pure typeRefsWithoutCycles
|
||||
let typeRefs = Names.typeReferences allNamesToEdit
|
||||
|
||||
terms <-
|
||||
termRefs
|
||||
& foldMapM \ref ->
|
||||
Map.singleton ref <$> Backend.displayTerm codebase ref
|
||||
& Cli.runTransaction
|
||||
(types, terms) <-
|
||||
Cli.runTransaction do
|
||||
(types, accessorNames) <-
|
||||
Foldable.foldlM
|
||||
( \(types, accessorNames) ref ->
|
||||
case ref of
|
||||
ReferenceBuiltin _ -> do
|
||||
let !types1 = Map.insert ref (DisplayObject.BuiltinObject ()) types
|
||||
pure (types1, accessorNames)
|
||||
ReferenceDerived refId -> do
|
||||
decl <- Codebase.unsafeGetTypeDeclaration codebase refId
|
||||
let !types1 = Map.insert ref (DisplayObject.UserObject decl) types
|
||||
let !accessorNames1 =
|
||||
accessorNames <> case decl of
|
||||
Left _effectDecl -> Set.empty
|
||||
Right dataDecl ->
|
||||
let declAccessorNames :: Name -> Set Name
|
||||
declAccessorNames declName =
|
||||
case DeclPrinter.getFieldAndAccessorNames
|
||||
ppe.unsuffixifiedPPE
|
||||
ref
|
||||
(HQ.fromName declName)
|
||||
dataDecl of
|
||||
Nothing -> Set.empty
|
||||
Just (_fieldNames, theAccessorNames) -> Set.fromList theAccessorNames
|
||||
in foldMap declAccessorNames (Names.namesForReference allNamesToEdit ref)
|
||||
pure (types1, accessorNames1)
|
||||
)
|
||||
(Map.empty, Set.empty)
|
||||
typeRefs
|
||||
terms <-
|
||||
termRefs & foldMapM \ref ->
|
||||
let isRecordAccessor =
|
||||
not (Set.disjoint (Names.namesForReferent allNamesToEdit (Referent.fromTermReference ref)) accessorNames)
|
||||
in if isRecordAccessor
|
||||
then pure Map.empty
|
||||
else Map.singleton ref <$> Backend.displayTerm codebase ref
|
||||
pure (types, terms)
|
||||
|
||||
types <-
|
||||
typeRefs
|
||||
& foldMapM \ref ->
|
||||
Map.singleton ref <$> Backend.displayType codebase ref
|
||||
& Cli.runTransaction
|
||||
let misses = []
|
||||
showDefinitions outputLoc ppe terms types misses
|
||||
where
|
||||
-- `view`: don't include cycles; `edit`: include cycles
|
||||
includeCycles =
|
||||
case outputLoc of
|
||||
ConsoleLocation -> Backend.DontIncludeCycles
|
||||
FileLocation _ -> Backend.IncludeCycles
|
||||
LatestFileLocation -> Backend.IncludeCycles
|
||||
|
@ -1,8 +1,9 @@
|
||||
```ucm:hide
|
||||
.> builtins.mergeio lib.builtin
|
||||
.> project.create-empty project
|
||||
project/main> builtins.mergeio lib.builtin
|
||||
```
|
||||
|
||||
```unison:hide
|
||||
```unison
|
||||
{{ ping doc }}
|
||||
nested.cycle.ping n = n Nat.+ pong n
|
||||
|
||||
@ -16,26 +17,23 @@ simple.y = 20
|
||||
|
||||
-- Shouldn't edit things in lib
|
||||
lib.project.ignoreMe = 30
|
||||
```
|
||||
|
||||
```ucm:hide
|
||||
.> add
|
||||
-- Shouldn't render record accessors
|
||||
unique type Foo = { bar : Nat, baz : Nat }
|
||||
```
|
||||
|
||||
Edit current namespace
|
||||
|
||||
```ucm
|
||||
.simple> edit.namespace
|
||||
project/main> add
|
||||
```
|
||||
|
||||
Edit should hit things recursively
|
||||
`edit.namespace` edits the whole namespace (minus the top-level `lib`).
|
||||
|
||||
```ucm
|
||||
.> edit.namespace
|
||||
project/main> edit.namespace
|
||||
```
|
||||
|
||||
Edit should handle multiple explicit paths at once.
|
||||
`edit.namespace` can also accept explicit paths
|
||||
|
||||
```ucm
|
||||
.> edit.namespace nested.cycle simple
|
||||
project/main> edit.namespace nested simple
|
||||
```
|
||||
|
@ -12,43 +12,76 @@ simple.y = 20
|
||||
|
||||
-- Shouldn't edit things in lib
|
||||
lib.project.ignoreMe = 30
|
||||
|
||||
-- Shouldn't render record accessors
|
||||
unique type Foo = { bar : Nat, baz : Nat }
|
||||
```
|
||||
|
||||
Edit current namespace
|
||||
```ucm
|
||||
|
||||
Loading changes detected in scratch.u.
|
||||
|
||||
I found and typechecked these definitions in scratch.u. If you
|
||||
do an `add` or `update`, here's how your codebase would
|
||||
change:
|
||||
|
||||
⍟ These new definitions are ok to `add`:
|
||||
|
||||
type Foo
|
||||
Foo.bar : Foo -> Nat
|
||||
Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo
|
||||
Foo.bar.set : Nat -> Foo -> Foo
|
||||
Foo.baz : Foo -> Nat
|
||||
Foo.baz.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo
|
||||
Foo.baz.set : Nat -> Foo -> Foo
|
||||
lib.project.ignoreMe : Nat
|
||||
nested.cycle.ping : Nat -> Nat
|
||||
nested.cycle.ping.doc : Doc2
|
||||
nested.cycle.pong : Nat -> Nat
|
||||
nested.cycle.pong.doc : Doc2
|
||||
simple.x : Nat
|
||||
simple.y : Nat
|
||||
toplevel : Text
|
||||
|
||||
```
|
||||
```ucm
|
||||
project/main> add
|
||||
|
||||
⍟ I've added these definitions:
|
||||
|
||||
type Foo
|
||||
Foo.bar : Foo -> Nat
|
||||
Foo.bar.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo
|
||||
Foo.bar.set : Nat -> Foo -> Foo
|
||||
Foo.baz : Foo -> Nat
|
||||
Foo.baz.modify : (Nat ->{g} Nat) -> Foo ->{g} Foo
|
||||
Foo.baz.set : Nat -> Foo -> Foo
|
||||
lib.project.ignoreMe : Nat
|
||||
nested.cycle.ping : Nat -> Nat
|
||||
nested.cycle.ping.doc : Doc2
|
||||
nested.cycle.pong : Nat -> Nat
|
||||
nested.cycle.pong.doc : Doc2
|
||||
simple.x : Nat
|
||||
simple.y : Nat
|
||||
toplevel : Text
|
||||
|
||||
```
|
||||
`edit.namespace` edits the whole namespace (minus the top-level `lib`).
|
||||
|
||||
```ucm
|
||||
.simple> edit.namespace
|
||||
project/main> edit.namespace
|
||||
|
||||
☝️
|
||||
|
||||
I added 2 definitions to the top of scratch.u
|
||||
I added 8 definitions to the top of scratch.u
|
||||
|
||||
You can edit them there, then run `update` to replace the
|
||||
definitions currently in this namespace.
|
||||
|
||||
```
|
||||
```unison:added-by-ucm scratch.u
|
||||
x : ##Nat
|
||||
x = 10
|
||||
type Foo = { bar : Nat, baz : Nat }
|
||||
|
||||
y : ##Nat
|
||||
y = 20
|
||||
```
|
||||
|
||||
Edit should hit things recursively
|
||||
|
||||
```ucm
|
||||
.> edit.namespace
|
||||
|
||||
☝️
|
||||
|
||||
I added 7 definitions to the top of scratch.u
|
||||
|
||||
You can edit them there, then run `update` to replace the
|
||||
definitions currently in this namespace.
|
||||
|
||||
```
|
||||
```unison:added-by-ucm scratch.u
|
||||
nested.cycle.ping : Nat -> Nat
|
||||
nested.cycle.ping n =
|
||||
use Nat +
|
||||
@ -75,10 +108,10 @@ toplevel : Text
|
||||
toplevel = "hi"
|
||||
```
|
||||
|
||||
Edit should handle multiple explicit paths at once.
|
||||
`edit.namespace` can also accept explicit paths
|
||||
|
||||
```ucm
|
||||
.> edit.namespace nested.cycle simple
|
||||
project/main> edit.namespace nested simple
|
||||
|
||||
☝️
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user