mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
Merge branch 'trunk' into better-CLI-error-messages
This commit is contained in:
commit
f14fca03a0
22
.github/workflows/ci.yaml
vendored
22
.github/workflows/ci.yaml
vendored
@ -5,16 +5,10 @@ defaults:
|
||||
shell: bash
|
||||
|
||||
on:
|
||||
# Build on every pull request (and new PR commit)
|
||||
# Run on the post-merge result of every PR commit
|
||||
pull_request:
|
||||
# Build on new pushes to trunk (E.g. Merge commits)
|
||||
# Without the branch filter, each commit on a branch with a PR is triggered twice.
|
||||
# See: https://github.community/t/how-to-trigger-an-action-on-push-or-pull-request-but-not-both/16662
|
||||
# Build on the pre-merge result of every branch commit
|
||||
push:
|
||||
branches:
|
||||
- trunk
|
||||
tags:
|
||||
- release/*
|
||||
workflow_dispatch:
|
||||
|
||||
env:
|
||||
@ -38,7 +32,7 @@ jobs:
|
||||
- uses: actions/checkout@v4
|
||||
- name: Get changed files
|
||||
id: changed-files
|
||||
uses: tj-actions/changed-files@v41
|
||||
uses: tj-actions/changed-files@v44
|
||||
with:
|
||||
# globs copied from default settings for run-ormolu
|
||||
files: |
|
||||
@ -270,6 +264,14 @@ jobs:
|
||||
${{env.transcripts}}
|
||||
# Fail if any transcripts cause git diffs.
|
||||
git diff --ignore-cr-at-eol --exit-code unison-src/transcripts
|
||||
- name: docs.to-html
|
||||
if: steps.cache-transcript-test-results.outputs.cache-hit != 'true'
|
||||
run: |
|
||||
${{env.ucm}} transcript unison-src/transcripts-manual/docs.to-html.md
|
||||
# Fail if the output or generated docs differ.
|
||||
git diff --ignore-cr-at-eol --exit-code \
|
||||
unison-src/transcripts-manual/docs.to-html.output.md \
|
||||
unison-src/transcripts-manual/docs.to-html
|
||||
- name: mark transcripts as passing
|
||||
if: steps.cache-transcript-test-results.outputs.cache-hit != 'true'
|
||||
run: |
|
||||
@ -417,7 +419,7 @@ jobs:
|
||||
build-jit-binary:
|
||||
name: build jit binary
|
||||
needs: generate-jit-source
|
||||
uses: ./.github/workflows/ci-build-jit-binary.yaml
|
||||
uses: ./.github/workflows/ci-build-jit-binary.yaml
|
||||
|
||||
test-jit:
|
||||
name: test jit
|
||||
|
4
.github/workflows/ormolu.yaml
vendored
4
.github/workflows/ormolu.yaml
vendored
@ -21,7 +21,7 @@ jobs:
|
||||
- name: create pull request with formatting changes
|
||||
uses: peter-evans/create-pull-request@v6
|
||||
with:
|
||||
commit_message: automatically run ormolu
|
||||
commit-message: automatically run ormolu
|
||||
branch: autoformat/${{github.ref_name}}
|
||||
# branch_suffix: random
|
||||
branch-suffix: short-commit-hash
|
||||
title: format `${{github.ref_name}}` with ormolu ${{env.ormolu_version}}
|
||||
|
3
.github/workflows/update-transcripts.yaml
vendored
3
.github/workflows/update-transcripts.yaml
vendored
@ -36,6 +36,9 @@ jobs:
|
||||
stack exec unison transcript unison-src/transcripts-manual/rewrites.md
|
||||
- name: transcripts
|
||||
run: stack exec transcripts
|
||||
- name: docs.to-html
|
||||
run: |
|
||||
stack exec unison transcript unison-src/transcripts-manual/docs.to-html.md
|
||||
- name: save transcript changes
|
||||
uses: stefanzweifel/git-auto-commit-action@v5
|
||||
with:
|
||||
|
@ -1,7 +1,7 @@
|
||||
pull_request_rules:
|
||||
- name: automatic merge on CI success and review
|
||||
conditions:
|
||||
- check-success=Contributor signed CONTRIBUTORS.markdown
|
||||
- check-success=check-contributor
|
||||
- check-success=build ucm (ubuntu-20.04)
|
||||
- check-success=build ucm (macOS-12)
|
||||
- check-success=build ucm (windows-2019)
|
||||
|
@ -86,3 +86,4 @@ The format for this list: name, GitHub handle
|
||||
* Upendra Upadhyay (@upendra1997)
|
||||
* Dan Doel (@dolio)
|
||||
* Eric Torreborre (@etorreborre)
|
||||
* Eduard Nicodei (@neduard)
|
||||
|
@ -43,8 +43,6 @@ If these instructions don't work for you or are incomplete, please file an issue
|
||||
|
||||
The build uses [Stack](http://docs.haskellstack.org/). If you don't already have it installed, [follow the install instructions](http://docs.haskellstack.org/en/stable/README.html#how-to-install) for your platform. (Hint: `brew update && brew install stack`)
|
||||
|
||||
If you have not set up the Haskell toolchain before and are trying to contribute to Unison on an M1 Mac, we have [some tips specifically for you](docs/m1-mac-setup-tips.markdown).
|
||||
|
||||
```sh
|
||||
$ git clone https://github.com/unisonweb/unison.git
|
||||
$ cd unison
|
||||
|
@ -15,7 +15,7 @@ data LocalIds' t h = LocalIds
|
||||
{ textLookup :: Vector t,
|
||||
defnLookup :: Vector h
|
||||
}
|
||||
deriving (Show)
|
||||
deriving (Functor, Show)
|
||||
|
||||
type LocalIds = LocalIds' TextId ObjectId
|
||||
|
||||
|
@ -63,9 +63,11 @@ module U.Codebase.Sqlite.Operations
|
||||
causalHashesByPrefix,
|
||||
|
||||
-- ** dependents index
|
||||
directDependenciesOfScope,
|
||||
dependents,
|
||||
dependentsOfComponent,
|
||||
dependentsWithinScope,
|
||||
directDependentsWithinScope,
|
||||
transitiveDependentsWithinScope,
|
||||
|
||||
-- ** type index
|
||||
Q.addTypeToIndexForTerm,
|
||||
@ -205,6 +207,7 @@ import Unison.NameSegment.Internal qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.ShortHash (ShortCausalHash (..), ShortNamespaceHash (..))
|
||||
import Unison.Sqlite
|
||||
import Unison.Util.Defns (DefnsF)
|
||||
import Unison.Util.List qualified as List
|
||||
import Unison.Util.Map qualified as Map
|
||||
import Unison.Util.Monoid (foldMapM)
|
||||
@ -1121,6 +1124,21 @@ causalHashesByPrefix (ShortCausalHash b32prefix) = do
|
||||
hashes <- traverse (Q.expectHash . Db.unCausalHashId) hashIds
|
||||
pure $ Set.fromList . map CausalHash $ hashes
|
||||
|
||||
directDependenciesOfScope ::
|
||||
DefnsF Set C.TermReferenceId C.TypeReferenceId ->
|
||||
Transaction (DefnsF Set C.TermReference C.TypeReference)
|
||||
directDependenciesOfScope scope0 = do
|
||||
-- Convert C -> S
|
||||
scope1 <- bitraverse (Set.traverse c2sReferenceId) (Set.traverse c2sReferenceId) scope0
|
||||
|
||||
-- Do the query
|
||||
dependencies0 <- Q.getDirectDependenciesOfScope scope1
|
||||
|
||||
-- Convert S -> C
|
||||
dependencies1 <- bitraverse (Set.traverse s2cReference) (Set.traverse s2cReference) dependencies0
|
||||
|
||||
pure dependencies1
|
||||
|
||||
-- | returns a list of known definitions referencing `r`
|
||||
dependents :: Q.DependentsSelector -> C.Reference -> Transaction (Set C.Reference.Id)
|
||||
dependents selector r = do
|
||||
@ -1137,19 +1155,43 @@ dependents selector r = do
|
||||
sIds <- Q.getDependentsForDependency selector r'
|
||||
Set.traverse s2cReferenceId sIds
|
||||
|
||||
-- | `dependentsWithinScope scope query` returns all of transitive dependents of `query` that are in `scope` (not
|
||||
-- including `query` itself). Each dependent is also tagged with whether it is a term or decl.
|
||||
dependentsWithinScope :: Set C.Reference.Id -> Set C.Reference -> Transaction (Map C.Reference.Id C.ReferenceType)
|
||||
dependentsWithinScope scope query = do
|
||||
scope' <- Set.traverse c2sReferenceId scope
|
||||
query' <- Set.traverse c2sReference query
|
||||
Q.getDependentsWithinScope scope' query'
|
||||
>>= Map.bitraverse s2cReferenceId (pure . objectTypeToReferenceType)
|
||||
where
|
||||
objectTypeToReferenceType = \case
|
||||
ObjectType.TermComponent -> C.RtTerm
|
||||
ObjectType.DeclComponent -> C.RtType
|
||||
_ -> error "Q.getDependentsWithinScope shouldn't return any other types"
|
||||
-- | `directDependentsWithinScope scope query` returns all direct dependents of `query` that are in `scope` (not
|
||||
-- including `query` itself).
|
||||
directDependentsWithinScope ::
|
||||
Set C.Reference.Id ->
|
||||
Set C.Reference ->
|
||||
Transaction (DefnsF Set C.TermReferenceId C.TypeReferenceId)
|
||||
directDependentsWithinScope scope0 query0 = do
|
||||
-- Convert C -> S
|
||||
scope1 <- Set.traverse c2sReferenceId scope0
|
||||
query1 <- Set.traverse c2sReference query0
|
||||
|
||||
-- Do the query
|
||||
dependents0 <- Q.getDirectDependentsWithinScope scope1 query1
|
||||
|
||||
-- Convert S -> C
|
||||
dependents1 <- bitraverse (Set.traverse s2cReferenceId) (Set.traverse s2cReferenceId) dependents0
|
||||
|
||||
pure dependents1
|
||||
|
||||
-- | `transitiveDependentsWithinScope scope query` returns all transitive dependents of `query` that are in `scope` (not
|
||||
-- including `query` itself).
|
||||
transitiveDependentsWithinScope ::
|
||||
Set C.Reference.Id ->
|
||||
Set C.Reference ->
|
||||
Transaction (DefnsF Set C.TermReferenceId C.TypeReferenceId)
|
||||
transitiveDependentsWithinScope scope0 query0 = do
|
||||
-- Convert C -> S
|
||||
scope1 <- Set.traverse c2sReferenceId scope0
|
||||
query1 <- Set.traverse c2sReference query0
|
||||
|
||||
-- Do the query
|
||||
dependents0 <- Q.getTransitiveDependentsWithinScope scope1 query1
|
||||
|
||||
-- Convert S -> C
|
||||
dependents1 <- bitraverse (Set.traverse s2cReferenceId) (Set.traverse s2cReferenceId) dependents0
|
||||
|
||||
pure dependents1
|
||||
|
||||
-- | returns a list of known definitions referencing `h`
|
||||
dependentsOfComponent :: H.Hash -> Transaction (Set C.Reference.Id)
|
||||
|
@ -22,6 +22,12 @@ type Referent' t h = Referent.Referent' (Reference' t h) (Reference' t h)
|
||||
data TermEdit' t h = Replace (Referent' t h) Typing | Deprecate
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
instance Functor (TermEdit' t) where
|
||||
fmap :: (a -> b) -> TermEdit' t a -> TermEdit' t b
|
||||
fmap f (Replace (Referent.Ref termRef) typing) = Replace (Referent.Ref (fmap f termRef)) typing
|
||||
fmap f (Replace (Referent.Con typeRef consId) typing) = Replace (Referent.Con (fmap f typeRef) consId) typing
|
||||
fmap _ Deprecate = Deprecate
|
||||
|
||||
_Replace :: Prism (TermEdit' t h) (TermEdit' t' h') (Referent' t h, Typing) (Referent' t' h', Typing)
|
||||
_Replace = prism embed project
|
||||
where
|
||||
|
@ -17,7 +17,7 @@ type TypeEdit = TypeEdit' Db.TextId Db.ObjectId
|
||||
type HashTypeEdit = TypeEdit' Text ComponentHash
|
||||
|
||||
data TypeEdit' t h = Replace (Reference' t h) | Deprecate
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving (Eq, Functor, Ord, Show)
|
||||
|
||||
_Replace :: Prism (TypeEdit' t h) (TypeEdit' t' h') (Reference' t h) (Reference' t' h')
|
||||
_Replace = prism Replace project
|
||||
|
@ -165,7 +165,9 @@ module U.Codebase.Sqlite.Queries
|
||||
getDependenciesForDependent,
|
||||
getDependencyIdsForDependent,
|
||||
getDependenciesBetweenTerms,
|
||||
getDependentsWithinScope,
|
||||
getDirectDependenciesOfScope,
|
||||
getDirectDependentsWithinScope,
|
||||
getTransitiveDependentsWithinScope,
|
||||
|
||||
-- ** type index
|
||||
addToTypeIndex,
|
||||
@ -321,7 +323,7 @@ import U.Codebase.Decl qualified as C
|
||||
import U.Codebase.Decl qualified as C.Decl
|
||||
import U.Codebase.HashTags (BranchHash (..), CausalHash (..), PatchHash (..))
|
||||
import U.Codebase.Reference (Reference' (..))
|
||||
import U.Codebase.Reference qualified as C
|
||||
import U.Codebase.Reference qualified as C (Reference)
|
||||
import U.Codebase.Reference qualified as C.Reference
|
||||
import U.Codebase.Referent qualified as C.Referent
|
||||
import U.Codebase.Reflog qualified as Reflog
|
||||
@ -365,10 +367,9 @@ import U.Codebase.Sqlite.Orphans ()
|
||||
import U.Codebase.Sqlite.Patch.Format qualified as PatchFormat
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Reference qualified as Reference
|
||||
import U.Codebase.Sqlite.Reference qualified as S
|
||||
import U.Codebase.Sqlite.Reference qualified as S (Reference, ReferenceH, TermReference, TermReferenceId, TextReference, TypeReference, TypeReferenceId)
|
||||
import U.Codebase.Sqlite.Reference qualified as S.Reference
|
||||
import U.Codebase.Sqlite.Referent qualified as Referent
|
||||
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)
|
||||
@ -399,6 +400,7 @@ import Unison.NameSegment.Internal qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Sqlite
|
||||
import Unison.Util.Alternative qualified as Alternative
|
||||
import Unison.Util.Defns (Defns (..), DefnsF)
|
||||
import Unison.Util.FileEmbed (embedProjectStringFile)
|
||||
import Unison.Util.Lens qualified as Lens
|
||||
import Unison.Util.Map qualified as Map
|
||||
@ -1361,7 +1363,7 @@ setNamespaceRoot id =
|
||||
False -> execute [sql| INSERT INTO namespace_root VALUES (:id) |]
|
||||
True -> execute [sql| UPDATE namespace_root SET causal_id = :id |]
|
||||
|
||||
saveWatch :: WatchKind -> Reference.IdH -> ByteString -> Transaction ()
|
||||
saveWatch :: WatchKind -> S.Reference.IdH -> ByteString -> Transaction ()
|
||||
saveWatch k r blob = do
|
||||
execute
|
||||
[sql|
|
||||
@ -1379,7 +1381,7 @@ saveWatch k r blob = do
|
||||
loadWatch ::
|
||||
SqliteExceptionReason e =>
|
||||
WatchKind ->
|
||||
Reference.IdH ->
|
||||
S.Reference.IdH ->
|
||||
(ByteString -> Either e a) ->
|
||||
Transaction (Maybe a)
|
||||
loadWatch k r check =
|
||||
@ -1395,7 +1397,7 @@ loadWatch k r check =
|
||||
|]
|
||||
check
|
||||
|
||||
loadWatchKindsByReference :: Reference.IdH -> Transaction [WatchKind]
|
||||
loadWatchKindsByReference :: S.Reference.IdH -> Transaction [WatchKind]
|
||||
loadWatchKindsByReference r =
|
||||
queryListCol
|
||||
[sql|
|
||||
@ -1407,7 +1409,7 @@ loadWatchKindsByReference r =
|
||||
AND watch.component_index = @
|
||||
|]
|
||||
|
||||
loadWatchesByWatchKind :: WatchKind -> Transaction [Reference.IdH]
|
||||
loadWatchesByWatchKind :: WatchKind -> Transaction [S.Reference.IdH]
|
||||
loadWatchesByWatchKind k =
|
||||
queryListRow
|
||||
[sql|
|
||||
@ -1423,7 +1425,7 @@ clearWatches = do
|
||||
execute [sql| DELETE FROM watch |]
|
||||
|
||||
-- * Index-building
|
||||
addToTypeIndex :: Reference' TextId HashId -> Referent.Id -> Transaction ()
|
||||
addToTypeIndex :: S.ReferenceH -> S.Referent.Id -> Transaction ()
|
||||
addToTypeIndex tp tm =
|
||||
execute
|
||||
[sql|
|
||||
@ -1438,7 +1440,7 @@ addToTypeIndex tp tm =
|
||||
ON CONFLICT DO NOTHING
|
||||
|]
|
||||
|
||||
getReferentsByType :: Reference' TextId HashId -> Transaction [Referent.Id]
|
||||
getReferentsByType :: S.ReferenceH -> Transaction [S.Referent.Id]
|
||||
getReferentsByType r =
|
||||
queryListRow
|
||||
[sql|
|
||||
@ -1452,7 +1454,7 @@ getReferentsByType r =
|
||||
AND type_reference_component_index IS @
|
||||
|]
|
||||
|
||||
getTypeReferenceForReferent :: Referent.Id -> Transaction (Reference' TextId HashId)
|
||||
getTypeReferenceForReferent :: S.Referent.Id -> Transaction S.ReferenceH
|
||||
getTypeReferenceForReferent r =
|
||||
queryOneRow
|
||||
[sql|
|
||||
@ -1467,7 +1469,7 @@ getTypeReferenceForReferent r =
|
||||
|]
|
||||
|
||||
-- todo: error if no results
|
||||
getTypeReferencesForComponent :: ObjectId -> Transaction [(Reference' TextId HashId, Referent.Id)]
|
||||
getTypeReferencesForComponent :: ObjectId -> Transaction [(S.ReferenceH, S.Referent.Id)]
|
||||
getTypeReferencesForComponent oId =
|
||||
fmap (map fixupTypeIndexRow) $
|
||||
queryListRow
|
||||
@ -1553,7 +1555,7 @@ filterTermsByReferenceHavingType typ terms = create *> for_ terms insert *> sele
|
||||
drop = execute [sql|DROP TABLE filter_query|]
|
||||
|
||||
|
||||
addToTypeMentionsIndex :: Reference' TextId HashId -> Referent.Id -> Transaction ()
|
||||
addToTypeMentionsIndex :: S.ReferenceH -> S.Referent.Id -> Transaction ()
|
||||
addToTypeMentionsIndex tp tm =
|
||||
execute
|
||||
[sql|
|
||||
@ -1568,7 +1570,7 @@ addToTypeMentionsIndex tp tm =
|
||||
ON CONFLICT DO NOTHING
|
||||
|]
|
||||
|
||||
getReferentsByTypeMention :: Reference' TextId HashId -> Transaction [Referent.Id]
|
||||
getReferentsByTypeMention :: S.ReferenceH -> Transaction [S.Referent.Id]
|
||||
getReferentsByTypeMention r =
|
||||
queryListRow
|
||||
[sql|
|
||||
@ -1583,7 +1585,7 @@ getReferentsByTypeMention r =
|
||||
|]
|
||||
|
||||
-- todo: error if no results
|
||||
getTypeMentionsReferencesForComponent :: ObjectId -> Transaction [(Reference' TextId HashId, Referent.Id)]
|
||||
getTypeMentionsReferencesForComponent :: ObjectId -> Transaction [(S.ReferenceH, S.Referent.Id)]
|
||||
getTypeMentionsReferencesForComponent r =
|
||||
fmap (map fixupTypeIndexRow) $
|
||||
queryListRow
|
||||
@ -1599,7 +1601,7 @@ getTypeMentionsReferencesForComponent r =
|
||||
WHERE term_referent_object_id IS :r
|
||||
|]
|
||||
|
||||
fixupTypeIndexRow :: Reference' TextId HashId :. Referent.Id -> (Reference' TextId HashId, Referent.Id)
|
||||
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
|
||||
@ -1653,7 +1655,7 @@ garbageCollectWatchesWithoutObjects = do
|
||||
(SELECT hash_object.hash_id FROM hash_object)
|
||||
|]
|
||||
|
||||
addToDependentsIndex :: [Reference.Reference] -> Reference.Id -> Transaction ()
|
||||
addToDependentsIndex :: [S.Reference] -> S.Reference.Id -> Transaction ()
|
||||
addToDependentsIndex dependencies dependent =
|
||||
for_ dependencies \dependency ->
|
||||
execute
|
||||
@ -1682,7 +1684,7 @@ data DependentsSelector
|
||||
| ExcludeOwnComponent
|
||||
|
||||
-- | Get dependents of a dependency.
|
||||
getDependentsForDependency :: DependentsSelector -> Reference.Reference -> Transaction (Set Reference.Id)
|
||||
getDependentsForDependency :: DependentsSelector -> S.Reference -> Transaction (Set S.Reference.Id)
|
||||
getDependentsForDependency selector dependency = do
|
||||
dependents <-
|
||||
queryListRow
|
||||
@ -1699,19 +1701,19 @@ getDependentsForDependency selector dependency = do
|
||||
ExcludeSelf -> filter isNotSelfReference dependents
|
||||
ExcludeOwnComponent -> filter isNotReferenceFromOwnComponent dependents
|
||||
where
|
||||
isNotReferenceFromOwnComponent :: Reference.Id -> Bool
|
||||
isNotReferenceFromOwnComponent :: S.Reference.Id -> Bool
|
||||
isNotReferenceFromOwnComponent =
|
||||
case dependency of
|
||||
ReferenceBuiltin _ -> const True
|
||||
ReferenceDerived (C.Reference.Id oid0 _pos0) -> \(C.Reference.Id oid1 _pos1) -> oid0 /= oid1
|
||||
|
||||
isNotSelfReference :: Reference.Id -> Bool
|
||||
isNotSelfReference :: S.Reference.Id -> Bool
|
||||
isNotSelfReference =
|
||||
case dependency of
|
||||
ReferenceBuiltin _ -> const True
|
||||
ReferenceDerived ref -> (ref /=)
|
||||
|
||||
getDependentsForDependencyComponent :: ObjectId -> Transaction [Reference.Id]
|
||||
getDependentsForDependencyComponent :: ObjectId -> Transaction [S.Reference.Id]
|
||||
getDependentsForDependencyComponent dependency =
|
||||
filter isNotSelfReference <$>
|
||||
queryListRow
|
||||
@ -1722,12 +1724,12 @@ getDependentsForDependencyComponent dependency =
|
||||
AND dependency_object_id IS :dependency
|
||||
|]
|
||||
where
|
||||
isNotSelfReference :: Reference.Id -> Bool
|
||||
isNotSelfReference :: S.Reference.Id -> Bool
|
||||
isNotSelfReference = \case
|
||||
(C.Reference.Id oid1 _pos1) -> dependency /= oid1
|
||||
|
||||
-- | Get non-self dependencies of a user-defined dependent.
|
||||
getDependenciesForDependent :: Reference.Id -> Transaction [Reference.Reference]
|
||||
getDependenciesForDependent :: S.Reference.Id -> Transaction [S.Reference]
|
||||
getDependenciesForDependent dependent@(C.Reference.Id oid0 _) =
|
||||
fmap (filter isNotSelfReference) $
|
||||
queryListRow
|
||||
@ -1738,13 +1740,13 @@ getDependenciesForDependent dependent@(C.Reference.Id oid0 _) =
|
||||
AND dependent_component_index IS @
|
||||
|]
|
||||
where
|
||||
isNotSelfReference :: Reference.Reference -> Bool
|
||||
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 :: Reference.Id -> Transaction [Reference.Id]
|
||||
getDependencyIdsForDependent :: S.Reference.Id -> Transaction [S.Reference.Id]
|
||||
getDependencyIdsForDependent dependent@(C.Reference.Id oid0 _) =
|
||||
fmap (filter isNotSelfReference) $
|
||||
queryListRow
|
||||
@ -1756,7 +1758,7 @@ getDependencyIdsForDependent dependent@(C.Reference.Id oid0 _) =
|
||||
AND dependent_component_index = @
|
||||
|]
|
||||
where
|
||||
isNotSelfReference :: Reference.Id -> Bool
|
||||
isNotSelfReference :: S.Reference.Id -> Bool
|
||||
isNotSelfReference (C.Reference.Id oid1 _) =
|
||||
oid0 /= oid1
|
||||
|
||||
@ -1869,35 +1871,111 @@ getDependenciesBetweenTerms oid1 oid2 =
|
||||
WHERE path_elem IS NOT null
|
||||
|]
|
||||
|
||||
-- | `getDependentsWithinScope scope query` returns all of transitive dependents of `query` that are in `scope` (not
|
||||
-- including `query` itself). Each dependent is also tagged with whether it is a term or decl.
|
||||
getDependentsWithinScope :: Set Reference.Id -> Set S.Reference -> Transaction (Map Reference.Id ObjectType)
|
||||
getDependentsWithinScope scope query = do
|
||||
-- Mitchell says: why are we enabling and disabling ormolu all over this file? Let's just enable. But right now I'm only
|
||||
-- adding this one query and don't want a big diff in my PR.
|
||||
|
||||
{- ORMOLU_ENABLE -}
|
||||
|
||||
getDirectDependenciesOfScope ::
|
||||
DefnsF Set S.TermReferenceId S.TypeReferenceId ->
|
||||
Transaction (DefnsF Set S.TermReference S.TypeReference)
|
||||
getDirectDependenciesOfScope scope = do
|
||||
let tempTableName = [sql| temp_dependents |]
|
||||
|
||||
-- Populate a temporary table with all of the references in `scope`
|
||||
execute
|
||||
[sql|
|
||||
CREATE TEMPORARY TABLE dependents_search_scope (
|
||||
dependent_object_id INTEGER NOT NULL,
|
||||
dependent_component_index INTEGER NOT NULL,
|
||||
PRIMARY KEY (dependent_object_id, dependent_component_index)
|
||||
)
|
||||
|]
|
||||
for_ scope \r ->
|
||||
execute [sql|INSERT INTO dependents_search_scope VALUES (@r, @)|]
|
||||
createTemporaryTableOfReferenceIds tempTableName (Set.union scope.terms scope.types)
|
||||
|
||||
-- Get their direct dependencies (tagged with object type)
|
||||
dependencies0 <-
|
||||
queryListRow @(S.Reference :. Only ObjectType)
|
||||
[sql|
|
||||
SELECT d.dependency_builtin, d.dependency_object_id, d.dependency_component_index, o.type_id
|
||||
FROM dependents_index d
|
||||
JOIN object o ON d.dependency_object_id = o.id
|
||||
WHERE (d.dependent_object_id, d.dependent_component_index) IN (
|
||||
SELECT object_id, component_index
|
||||
FROM $tempTableName
|
||||
)
|
||||
|]
|
||||
|
||||
-- Drop the temporary table
|
||||
execute [sql| DROP TABLE $tempTableName |]
|
||||
|
||||
-- Post-process the query result
|
||||
let dependencies1 =
|
||||
List.foldl'
|
||||
( \deps -> \case
|
||||
dep :. Only TermComponent -> Defns (Set.insert dep deps.terms) deps.types
|
||||
dep :. Only DeclComponent -> Defns deps.terms (Set.insert dep deps.types)
|
||||
_ -> deps -- impossible; could error here
|
||||
)
|
||||
(Defns Set.empty Set.empty)
|
||||
dependencies0
|
||||
|
||||
pure dependencies1
|
||||
|
||||
-- | `getDirectDependentsWithinScope scope query` returns all direct dependents of `query` that are in `scope` (not
|
||||
-- including `query` itself).
|
||||
getDirectDependentsWithinScope ::
|
||||
Set S.Reference.Id ->
|
||||
Set S.Reference ->
|
||||
Transaction (DefnsF Set S.TermReferenceId S.TypeReferenceId)
|
||||
getDirectDependentsWithinScope scope query = do
|
||||
-- Populate a temporary table with all of the references in `scope`
|
||||
let scopeTableName = [sql| dependents_search_scope |]
|
||||
createTemporaryTableOfReferenceIds scopeTableName scope
|
||||
|
||||
-- Populate a temporary table with all of the references in `query`
|
||||
execute
|
||||
[sql|
|
||||
CREATE TEMPORARY TABLE dependencies_query (
|
||||
dependency_builtin INTEGER NULL,
|
||||
dependency_object_id INTEGER NULL,
|
||||
dependency_component_index INTEGER NULL,
|
||||
CHECK ((dependency_builtin IS NULL) = (dependency_object_id IS NOT NULL)),
|
||||
CHECK ((dependency_object_id IS NULL) = (dependency_component_index IS NULL))
|
||||
)
|
||||
|]
|
||||
for_ query \r ->
|
||||
execute [sql|INSERT INTO dependencies_query VALUES (@r, @, @)|]
|
||||
let queryTableName = [sql| dependencies_query |]
|
||||
createTemporaryTableOfReferences queryTableName query
|
||||
|
||||
-- Get their direct dependents (tagged with object type)
|
||||
dependents0 <-
|
||||
queryListRow @(S.Reference.Id :. Only ObjectType)
|
||||
[sql|
|
||||
SELECT s.object_id, s.component_index, o.type_id
|
||||
FROM $queryTableName q
|
||||
JOIN dependents_index d
|
||||
ON q.builtin IS d.dependency_builtin
|
||||
AND q.object_id IS d.dependency_object_id
|
||||
AND q.component_index IS d.dependency_component_index
|
||||
JOIN $scopeTableName s
|
||||
ON d.dependent_object_id = s.object_id
|
||||
AND d.dependent_component_index = s.component_index
|
||||
JOIN object o ON s.object_id = o.id
|
||||
|]
|
||||
|
||||
-- Drop the temporary tables
|
||||
execute [sql| DROP TABLE $scopeTableName |]
|
||||
execute [sql| DROP TABLE $queryTableName |]
|
||||
|
||||
-- Post-process the query result
|
||||
let dependents1 =
|
||||
List.foldl'
|
||||
( \deps -> \case
|
||||
dep :. Only TermComponent -> Defns (Set.insert dep deps.terms) deps.types
|
||||
dep :. Only DeclComponent -> Defns deps.terms (Set.insert dep deps.types)
|
||||
_ -> deps -- impossible; could error here
|
||||
)
|
||||
(Defns Set.empty Set.empty)
|
||||
dependents0
|
||||
|
||||
pure dependents1
|
||||
|
||||
-- | `getTransitiveDependentsWithinScope scope query` returns all transitive dependents of `query` that are in `scope`
|
||||
-- (not including `query` itself).
|
||||
getTransitiveDependentsWithinScope ::
|
||||
Set S.Reference.Id ->
|
||||
Set S.Reference ->
|
||||
Transaction (DefnsF Set S.TermReferenceId S.TypeReferenceId)
|
||||
getTransitiveDependentsWithinScope scope query = do
|
||||
-- Populate a temporary table with all of the references in `scope`
|
||||
let scopeTableName = [sql| dependents_search_scope |]
|
||||
createTemporaryTableOfReferenceIds scopeTableName scope
|
||||
|
||||
-- Populate a temporary table with all of the references in `query`
|
||||
let queryTableName = [sql| dependencies_query |]
|
||||
createTemporaryTableOfReferences queryTableName query
|
||||
|
||||
-- Say the query set is { #foo, #bar }, and the scope set is { #foo, #bar, #baz, #qux, #honk }.
|
||||
--
|
||||
@ -1917,34 +1995,80 @@ getDependentsWithinScope scope query = do
|
||||
-- We use `UNION` rather than `UNION ALL` so as to not track down the transitive dependents of any particular
|
||||
-- reference more than once.
|
||||
|
||||
result :: [Reference.Id :. Only ObjectType] <- queryListRow [sql|
|
||||
WITH RECURSIVE transitive_dependents (dependent_object_id, dependent_component_index, type_id) AS (
|
||||
SELECT d.dependent_object_id, d.dependent_component_index, object.type_id
|
||||
FROM dependents_index d
|
||||
JOIN object ON d.dependent_object_id = object.id
|
||||
JOIN dependencies_query q
|
||||
ON q.dependency_builtin IS d.dependency_builtin
|
||||
AND q.dependency_object_id IS d.dependency_object_id
|
||||
AND q.dependency_component_index IS d.dependency_component_index
|
||||
JOIN dependents_search_scope s
|
||||
ON s.dependent_object_id = d.dependent_object_id
|
||||
AND s.dependent_component_index = d.dependent_component_index
|
||||
result0 :: [S.Reference.Id :. Only ObjectType] <-
|
||||
queryListRow
|
||||
[sql|
|
||||
WITH RECURSIVE transitive_dependents (dependent_object_id, dependent_component_index, type_id) AS (
|
||||
SELECT d.dependent_object_id, d.dependent_component_index, object.type_id
|
||||
FROM dependents_index d
|
||||
JOIN object ON d.dependent_object_id = object.id
|
||||
JOIN $queryTableName q
|
||||
ON q.builtin IS d.dependency_builtin
|
||||
AND q.object_id IS d.dependency_object_id
|
||||
AND q.component_index IS d.dependency_component_index
|
||||
JOIN $scopeTableName s
|
||||
ON s.object_id = d.dependent_object_id
|
||||
AND s.component_index = d.dependent_component_index
|
||||
|
||||
UNION SELECT d.dependent_object_id, d.dependent_component_index, object.type_id
|
||||
FROM dependents_index d
|
||||
JOIN object ON d.dependent_object_id = object.id
|
||||
JOIN transitive_dependents t
|
||||
ON t.dependent_object_id = d.dependency_object_id
|
||||
AND t.dependent_component_index = d.dependency_component_index
|
||||
JOIN dependents_search_scope s
|
||||
ON s.dependent_object_id = d.dependent_object_id
|
||||
AND s.dependent_component_index = d.dependent_component_index
|
||||
)
|
||||
SELECT * FROM transitive_dependents
|
||||
|]
|
||||
execute [sql|DROP TABLE dependents_search_scope|]
|
||||
execute [sql|DROP TABLE dependencies_query|]
|
||||
pure . Map.fromList $ [(r, t) | r :. Only t <- result]
|
||||
UNION SELECT d.dependent_object_id, d.dependent_component_index, object.type_id
|
||||
FROM dependents_index d
|
||||
JOIN object ON d.dependent_object_id = object.id
|
||||
JOIN transitive_dependents t
|
||||
ON t.dependent_object_id = d.dependency_object_id
|
||||
AND t.dependent_component_index = d.dependency_component_index
|
||||
JOIN $scopeTableName s
|
||||
ON s.object_id = d.dependent_object_id
|
||||
AND s.component_index = d.dependent_component_index
|
||||
)
|
||||
SELECT * FROM transitive_dependents
|
||||
|]
|
||||
|
||||
execute [sql| DROP TABLE $scopeTableName |]
|
||||
execute [sql| DROP TABLE $queryTableName |]
|
||||
|
||||
-- Post-process the query result
|
||||
let result1 =
|
||||
List.foldl'
|
||||
( \deps -> \case
|
||||
dep :. Only TermComponent -> Defns (Set.insert dep deps.terms) deps.types
|
||||
dep :. Only DeclComponent -> Defns deps.terms (Set.insert dep deps.types)
|
||||
_ -> deps -- impossible; could error here
|
||||
)
|
||||
(Defns Set.empty Set.empty)
|
||||
result0
|
||||
|
||||
pure result1
|
||||
|
||||
createTemporaryTableOfReferences :: Sql -> Set S.Reference -> Transaction ()
|
||||
createTemporaryTableOfReferences tableName refs = do
|
||||
execute
|
||||
[sql|
|
||||
CREATE TEMPORARY TABLE $tableName (
|
||||
builtin INTEGER NULL,
|
||||
object_id INTEGER NULL,
|
||||
component_index INTEGER NULL
|
||||
CHECK ((builtin IS NULL) = (object_id IS NOT NULL)),
|
||||
CHECK ((object_id IS NULL) = (component_index IS NULL))
|
||||
)
|
||||
|]
|
||||
|
||||
for_ refs \ref ->
|
||||
execute [sql| INSERT INTO $tableName VALUES (@ref, @, @) |]
|
||||
|
||||
createTemporaryTableOfReferenceIds :: Sql -> Set S.Reference.Id -> Transaction ()
|
||||
createTemporaryTableOfReferenceIds tableName refs = do
|
||||
execute
|
||||
[sql|
|
||||
CREATE TEMPORARY TABLE $tableName (
|
||||
object_id INTEGER NOT NULL,
|
||||
component_index INTEGER NOT NULL,
|
||||
PRIMARY KEY (object_id, component_index)
|
||||
)
|
||||
|]
|
||||
for_ refs \ref ->
|
||||
execute [sql| INSERT INTO $tableName VALUES (@ref, @) |]
|
||||
|
||||
{- ORMOLU_DISABLE -}
|
||||
|
||||
objectIdByBase32Prefix :: ObjectType -> Text -> Transaction [ObjectId]
|
||||
objectIdByBase32Prefix objType prefix =
|
||||
@ -2086,7 +2210,7 @@ deleteNameLookupsExceptFor hashIds = do
|
||||
|]
|
||||
|
||||
-- | Insert the given set of term names into the name lookup table
|
||||
insertScopedTermNames :: BranchHashId -> [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)] -> Transaction ()
|
||||
insertScopedTermNames :: BranchHashId -> [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)] -> Transaction ()
|
||||
insertScopedTermNames bhId = do
|
||||
traverse_ \name0 -> do
|
||||
let name = NamedRef.ScopedRow (refToRow <$> name0)
|
||||
@ -2106,11 +2230,11 @@ insertScopedTermNames bhId = do
|
||||
VALUES (:bhId, @name, @, @, @, @, @, @, @)
|
||||
|]
|
||||
where
|
||||
refToRow :: (Referent.TextReferent, Maybe NamedRef.ConstructorType) -> (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))
|
||||
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 Reference.TextReference] -> Transaction ()
|
||||
insertScopedTypeNames :: BranchHashId -> [NamedRef S.TextReference] -> Transaction ()
|
||||
insertScopedTypeNames bhId =
|
||||
traverse_ \name0 -> do
|
||||
let name = NamedRef.ScopedRow name0
|
||||
@ -2129,7 +2253,7 @@ insertScopedTypeNames bhId =
|
||||
|]
|
||||
|
||||
-- | Remove the given set of term names into the name lookup table
|
||||
removeScopedTermNames :: BranchHashId -> [NamedRef Referent.TextReferent] -> Transaction ()
|
||||
removeScopedTermNames :: BranchHashId -> [NamedRef S.TextReferent] -> Transaction ()
|
||||
removeScopedTermNames bhId names = do
|
||||
for_ names \name ->
|
||||
execute
|
||||
@ -2144,7 +2268,7 @@ removeScopedTermNames bhId names = do
|
||||
|]
|
||||
|
||||
-- | Remove the given set of term names into the name lookup table
|
||||
removeScopedTypeNames :: BranchHashId -> [NamedRef Reference.TextReference] -> Transaction ()
|
||||
removeScopedTypeNames :: BranchHashId -> [NamedRef S.TextReference] -> Transaction ()
|
||||
removeScopedTypeNames bhId names = do
|
||||
for_ names \name ->
|
||||
execute
|
||||
@ -2203,9 +2327,9 @@ likeEscape escapeChar pat =
|
||||
--
|
||||
-- Get the list of a term names in the provided name lookup and relative namespace.
|
||||
-- Includes dependencies, but not transitive dependencies.
|
||||
termNamesWithinNamespace :: BranchHashId -> PathSegments -> Transaction [NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)]
|
||||
termNamesWithinNamespace :: BranchHashId -> PathSegments -> Transaction [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)]
|
||||
termNamesWithinNamespace bhId namespace = do
|
||||
results :: [NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <-
|
||||
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
|
||||
@ -2236,7 +2360,7 @@ termNamesWithinNamespace bhId namespace = do
|
||||
--
|
||||
-- Get the list of a type names in the provided name lookup and relative namespace.
|
||||
-- Includes dependencies, but not transitive dependencies.
|
||||
typeNamesWithinNamespace :: BranchHashId -> PathSegments -> Transaction [NamedRef Reference.TextReference]
|
||||
typeNamesWithinNamespace :: BranchHashId -> PathSegments -> Transaction [NamedRef S.TextReference]
|
||||
typeNamesWithinNamespace bhId namespace =
|
||||
queryListRow
|
||||
[sql|
|
||||
@ -2265,13 +2389,13 @@ typeNamesWithinNamespace bhId namespace =
|
||||
-- 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 (Referent.TextReferent, Maybe NamedRef.ConstructorType)]
|
||||
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 (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <-
|
||||
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
|
||||
@ -2304,7 +2428,7 @@ termNamesBySuffix bhId namespaceRoot suffix = do
|
||||
-- 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 Reference.TextReference]
|
||||
typeNamesBySuffix :: BranchHashId -> PathSegments -> ReversedName -> Transaction [NamedRef S.TextReference]
|
||||
typeNamesBySuffix bhId namespaceRoot suffix = do
|
||||
Debug.debugM Debug.Server "typeNamesBySuffix" (namespaceRoot, suffix)
|
||||
let namespaceGlob = toNamespaceGlob namespaceRoot
|
||||
@ -2343,10 +2467,10 @@ typeNamesBySuffix bhId namespaceRoot suffix = do
|
||||
-- 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 (Referent.TextReferent, Maybe NamedRef.ConstructorType)]
|
||||
termRefsForExactName :: BranchHashId -> ReversedName -> Transaction [NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)]
|
||||
termRefsForExactName bhId reversedSegments = do
|
||||
let reversedName = toReversedName reversedSegments
|
||||
results :: [NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))] <-
|
||||
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
|
||||
@ -2366,7 +2490,7 @@ termRefsForExactName bhId reversedSegments = do
|
||||
-- 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 Reference.TextReference]
|
||||
typeRefsForExactName :: BranchHashId -> ReversedName -> Transaction [NamedRef S.TextReference]
|
||||
typeRefsForExactName bhId reversedSegments = do
|
||||
let reversedName = toReversedName reversedSegments
|
||||
queryListRow
|
||||
@ -2382,7 +2506,7 @@ typeRefsForExactName bhId reversedSegments = do
|
||||
--
|
||||
-- Get the list of term names for a given Referent within a given namespace.
|
||||
-- Considers one level of dependencies, but not transitive dependencies.
|
||||
termNamesForRefWithinNamespace :: BranchHashId -> PathSegments -> Referent.TextReferent -> Maybe ReversedName -> Transaction [ReversedName]
|
||||
termNamesForRefWithinNamespace :: BranchHashId -> PathSegments -> S.TextReferent -> Maybe ReversedName -> Transaction [ReversedName]
|
||||
termNamesForRefWithinNamespace bhId namespaceRoot ref maySuffix = do
|
||||
let namespaceGlob = toNamespaceGlob namespaceRoot
|
||||
let suffixGlob = case maySuffix of
|
||||
@ -2431,7 +2555,7 @@ termNamesForRefWithinNamespace bhId namespaceRoot ref maySuffix = do
|
||||
--
|
||||
-- Get the list of type names for a given Reference within a given namespace.
|
||||
-- Considers one level of dependencies, but not transitive dependencies.
|
||||
typeNamesForRefWithinNamespace :: BranchHashId -> PathSegments -> Reference.TextReference -> Maybe ReversedName -> Transaction [ReversedName]
|
||||
typeNamesForRefWithinNamespace :: BranchHashId -> PathSegments -> S.TextReference -> Maybe ReversedName -> Transaction [ReversedName]
|
||||
typeNamesForRefWithinNamespace bhId namespaceRoot ref maySuffix = do
|
||||
let namespaceGlob = toNamespaceGlob namespaceRoot
|
||||
let suffixGlob = case maySuffix of
|
||||
@ -2511,7 +2635,7 @@ transitiveDependenciesSql rootBranchHashId =
|
||||
-- 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 -> Referent.TextReferent -> Transaction (Maybe ReversedName)
|
||||
recursiveTermNameSearch :: BranchHashId -> S.TextReferent -> Transaction (Maybe ReversedName)
|
||||
recursiveTermNameSearch bhId ref = do
|
||||
queryMaybeColCheck
|
||||
[sql|
|
||||
@ -2548,7 +2672,7 @@ recursiveTermNameSearch bhId ref = do
|
||||
-- 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 -> Reference.TextReference -> Transaction (Maybe ReversedName)
|
||||
recursiveTypeNameSearch :: BranchHashId -> S.TextReference -> Transaction (Maybe ReversedName)
|
||||
recursiveTypeNameSearch bhId ref = do
|
||||
queryMaybeColCheck
|
||||
[sql|
|
||||
@ -2589,13 +2713,13 @@ recursiveTypeNameSearch bhId ref = do
|
||||
-- the longest matching suffix.
|
||||
--
|
||||
-- Considers one level of dependencies, but not transitive dependencies.
|
||||
longestMatchingTermNameForSuffixification :: BranchHashId -> PathSegments -> NamedRef Referent.TextReferent -> Transaction (Maybe (NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)))
|
||||
longestMatchingTermNameForSuffixification :: BranchHashId -> PathSegments -> NamedRef S.TextReferent -> Transaction (Maybe (NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType)))
|
||||
longestMatchingTermNameForSuffixification bhId namespaceRoot (NamedRef.NamedRef {reversedSegments = revSuffix@(ReversedName (lastSegment NonEmpty.:| _)), ref}) = do
|
||||
let namespaceGlob = toNamespaceGlob namespaceRoot <> ".*"
|
||||
let loop :: [Text] -> MaybeT Transaction (NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType))
|
||||
let loop :: [Text] -> MaybeT Transaction (NamedRef (S.TextReferent, Maybe NamedRef.ConstructorType))
|
||||
loop [] = empty
|
||||
loop (suffGlob : rest) = do
|
||||
result :: Maybe (NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType))) <-
|
||||
result :: Maybe (NamedRef (S.TextReferent :. Only (Maybe NamedRef.ConstructorType))) <-
|
||||
lift $
|
||||
queryMaybeRow
|
||||
-- Note: It may seem strange that we do a last_name_segment constraint AND a reversed_name
|
||||
@ -2664,13 +2788,13 @@ longestMatchingTermNameForSuffixification bhId namespaceRoot (NamedRef.NamedRef
|
||||
-- the longest matching suffix.
|
||||
--
|
||||
-- Considers one level of dependencies, but not transitive dependencies.
|
||||
longestMatchingTypeNameForSuffixification :: BranchHashId -> PathSegments -> NamedRef Reference.TextReference -> Transaction (Maybe (NamedRef Reference.TextReference))
|
||||
longestMatchingTypeNameForSuffixification :: BranchHashId -> PathSegments -> NamedRef S.TextReference -> Transaction (Maybe (NamedRef S.TextReference))
|
||||
longestMatchingTypeNameForSuffixification bhId namespaceRoot (NamedRef.NamedRef {reversedSegments = revSuffix@(ReversedName (lastSegment NonEmpty.:| _)), ref}) = do
|
||||
let namespaceGlob = toNamespaceGlob namespaceRoot <> ".*"
|
||||
let loop :: [Text] -> MaybeT Transaction (NamedRef Reference.TextReference)
|
||||
let loop :: [Text] -> MaybeT Transaction (NamedRef S.TextReference)
|
||||
loop [] = empty
|
||||
loop (suffGlob : rest) = do
|
||||
result :: Maybe (NamedRef (Reference.TextReference)) <-
|
||||
result :: Maybe (NamedRef (S.TextReference)) <-
|
||||
lift $
|
||||
queryMaybeRow
|
||||
-- Note: It may seem strange that we do a last_name_segment constraint AND a reversed_name
|
||||
@ -3036,12 +3160,12 @@ saveTermComponent hh@HashHandle {toReference, toReferenceMentions} maybeEncodedT
|
||||
tpRefs' = Foldable.toList $ C.Type.dependencies tp
|
||||
getTermSRef :: S.Term.TermRef -> S.Reference
|
||||
getTermSRef = \case
|
||||
C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
|
||||
ReferenceBuiltin t -> ReferenceBuiltin (tIds Vector.! fromIntegral t)
|
||||
C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references
|
||||
C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
|
||||
getTypeSRef :: S.Term.TypeRef -> S.Reference
|
||||
getTypeSRef = \case
|
||||
C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
|
||||
ReferenceBuiltin t -> ReferenceBuiltin (tIds Vector.! fromIntegral t)
|
||||
C.Reference.Derived h i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
|
||||
getSTypeLink = getTypeSRef
|
||||
getSTermLink :: S.Term.TermLink -> S.Reference
|
||||
@ -3096,7 +3220,7 @@ saveDeclComponent hh@HashHandle {toReferenceDecl, toReferenceDeclMentions} maybe
|
||||
dependencies :: Set S.Decl.TypeRef = C.Decl.dependencies decl
|
||||
getSRef :: C.Reference.Reference' LocalTextId (Maybe LocalDefnId) -> S.Reference.Reference
|
||||
getSRef = \case
|
||||
C.ReferenceBuiltin t -> C.ReferenceBuiltin (tIds Vector.! fromIntegral t)
|
||||
ReferenceBuiltin t -> ReferenceBuiltin (tIds Vector.! fromIntegral t)
|
||||
C.Reference.Derived Nothing i -> C.Reference.Derived oId i -- index self-references
|
||||
C.Reference.Derived (Just h) i -> C.Reference.Derived (oIds Vector.! fromIntegral h) i
|
||||
in (Set.map getSRef dependencies, self)
|
||||
@ -4144,7 +4268,7 @@ loadMostRecentBranch 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 (Referent.TextReferent, Maybe NamedRef.ConstructorType))]
|
||||
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 =
|
||||
@ -4179,14 +4303,14 @@ fuzzySearchTerms includeDependencies bhId limit namespace querySegments = do
|
||||
where
|
||||
namespaceGlob = toNamespaceGlob namespace
|
||||
preparedQuery = prepareFuzzyQuery '\\' querySegments
|
||||
unRow :: NamedRef (Referent.TextReferent :. Only (Maybe NamedRef.ConstructorType)) -> NamedRef (Referent.TextReferent, Maybe NamedRef.ConstructorType)
|
||||
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 Reference.TextReference)]
|
||||
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 =
|
||||
|
@ -14,12 +14,20 @@ import Unison.Sqlite (FromField, FromRow (fromRow), Only (..), RowParser, SQLDat
|
||||
|
||||
type Reference = Reference' TextId ObjectId
|
||||
|
||||
type TermReference = Reference
|
||||
|
||||
type TypeReference = Reference
|
||||
|
||||
-- | The name lookup table uses this because normalizing/denormalizing hashes to ids is slower
|
||||
-- than we'd like when writing/reading the entire name lookup table.
|
||||
type TextReference = Reference' Text Base32Hex
|
||||
|
||||
type Id = Id' ObjectId
|
||||
|
||||
type TermReferenceId = Id
|
||||
|
||||
type TypeReferenceId = Id
|
||||
|
||||
type LocalReferenceH = Reference' LocalTextId LocalHashId
|
||||
|
||||
type LocalReference = Reference' LocalTextId LocalDefnId
|
||||
|
@ -39,6 +39,7 @@ dependencies:
|
||||
- unison-util-base32hex
|
||||
- unison-util-cache
|
||||
- unison-util-file-embed
|
||||
- unison-util-nametree
|
||||
- unison-util-serialization
|
||||
- unison-util-term
|
||||
- unliftio
|
||||
@ -71,6 +72,7 @@ default-extensions:
|
||||
- MultiParamTypeClasses
|
||||
- NamedFieldPuns
|
||||
- OverloadedLabels
|
||||
- OverloadedRecordDot
|
||||
- OverloadedStrings
|
||||
- PatternSynonyms
|
||||
- QuasiQuotes
|
||||
|
@ -91,6 +91,7 @@ library
|
||||
MultiParamTypeClasses
|
||||
NamedFieldPuns
|
||||
OverloadedLabels
|
||||
OverloadedRecordDot
|
||||
OverloadedStrings
|
||||
PatternSynonyms
|
||||
QuasiQuotes
|
||||
@ -132,6 +133,7 @@ library
|
||||
, unison-util-base32hex
|
||||
, unison-util-cache
|
||||
, unison-util-file-embed
|
||||
, unison-util-nametree
|
||||
, unison-util-serialization
|
||||
, unison-util-term
|
||||
, unliftio
|
||||
|
@ -63,7 +63,7 @@ type Id = Id' Hash Hash
|
||||
data Id' hTm hTp
|
||||
= RefId (Reference.Id' hTm)
|
||||
| ConId (Reference.Id' hTp) ConstructorId
|
||||
deriving (Eq, Ord, Show)
|
||||
deriving (Eq, Functor, Ord, Show)
|
||||
|
||||
instance Bifunctor Referent' where
|
||||
bimap f g = \case
|
||||
|
@ -13,6 +13,7 @@ data Entry causal text = Entry
|
||||
toRootCausalHash :: causal,
|
||||
reason :: text
|
||||
}
|
||||
deriving (Functor)
|
||||
|
||||
instance Bifunctor Entry where
|
||||
bimap = bimapDefault
|
||||
|
@ -74,7 +74,7 @@ data ReferenceType = RtTerm | RtType deriving (Eq, Ord, Show)
|
||||
data Reference' t h
|
||||
= ReferenceBuiltin t
|
||||
| ReferenceDerived (Id' h)
|
||||
deriving stock (Eq, Generic, Ord, Show)
|
||||
deriving stock (Eq, Generic, Functor, Ord, Show)
|
||||
|
||||
-- | A type declaration reference.
|
||||
type TermReference' t h = Reference' t h
|
||||
|
@ -29,7 +29,7 @@ data ProjectAndBranch a b = ProjectAndBranch
|
||||
{ project :: a,
|
||||
branch :: b
|
||||
}
|
||||
deriving stock (Eq, Generic, Show)
|
||||
deriving stock (Eq, Generic, Show, Functor)
|
||||
|
||||
instance Bifunctor ProjectAndBranch where
|
||||
bimap f g (ProjectAndBranch a b) = ProjectAndBranch (f a) (g b)
|
||||
|
@ -61,7 +61,7 @@ flattenEffects es = [es]
|
||||
generalize :: (Ord v) => [v] -> TypeR r v -> TypeR r v
|
||||
generalize vs t = foldr f t vs
|
||||
where
|
||||
f v t = if Set.member v (ABT.freeVars t) then forall v t else t
|
||||
f v t = if Set.member v (ABT.freeVars t) then forAll v t else t
|
||||
|
||||
-- * Patterns
|
||||
|
||||
@ -80,8 +80,8 @@ pattern Effect1' e t <- ABT.Tm' (Effect e t)
|
||||
pattern Ref' :: r -> TypeR r v
|
||||
pattern Ref' r <- ABT.Tm' (Ref r)
|
||||
|
||||
forall :: (Ord v) => v -> TypeR r v -> TypeR r v
|
||||
forall v body = ABT.tm () (Forall (ABT.abs () v body))
|
||||
forAll :: (Ord v) => v -> TypeR r v -> TypeR r v
|
||||
forAll v body = ABT.tm () (Forall (ABT.abs () v body))
|
||||
|
||||
unforall' :: TypeR r v -> ([v], TypeR r v)
|
||||
unforall' (ForallsNamed' vs t) = (vs, t)
|
||||
|
@ -1,164 +0,0 @@
|
||||
|
||||
# M1 Mac Haskell toolchain setup
|
||||
|
||||
If you are a newcomer to the Haskell ecosystem trying to set up your dev environment on a Mac M1 computer, welcome, you can do this! The tips in this document provide one way to get a working development setup, but are not the only path forward. If you haven't downloaded the Haskell toolchain before, our recommendation is to use GHCup. We've found that issues can arise if you mix ARM native binaries with x86 binaries to be run with Rosetta. If you're a veteran Haskell developer, much of this won't apply to you as it's likely you already have a working development environment.
|
||||
|
||||
Here is a working set of versions you can use to build the Unison executable:
|
||||
|
||||
- GHC version: 8.10.7
|
||||
- Stack version: 2.9.1
|
||||
- Cabal version 3.6.2.0
|
||||
- Haskell language server version: 1.7.0.0
|
||||
|
||||
The GHC version for the project can be confirmed by looking at the `resolver` key in this project's `stack.yaml`.
|
||||
|
||||
## Newcomer setup tips
|
||||
|
||||
[Install GHCup using the instructions on their website.](https://www.haskell.org/ghcup/) Once it's installed make sure `ghcup` is on your path.
|
||||
|
||||
```
|
||||
export PATH="$HOME/.ghcup/bin:$PATH"
|
||||
```
|
||||
|
||||
GHCup has a nice ui for setting Haskell toolchain versions for the project. Enter `ghcup tui` to open it up and follow the instructions for installing and setting the versions there. GHCup will try to download M1 native binaries for the versions given.
|
||||
|
||||
Check your clang version. For [hand-wavey reasons](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/301) we recommend you use llvm version 12. See troubleshooting note below about changing your LLVM if your version is different.
|
||||
|
||||
```shell
|
||||
$ clang --version
|
||||
Homebrew clang version 12.0.1
|
||||
Target: arm64-apple-darwin20.2.0
|
||||
Thread model: posix
|
||||
InstalledDir: /opt/homebrew/opt/llvm@12/bin
|
||||
```
|
||||
|
||||
At the end of the process you should see something like the following for executable locations and versions.
|
||||
|
||||
```shell
|
||||
$ which ghcup
|
||||
~/.ghcup/bin/ghcup
|
||||
$ ghcup --version
|
||||
The GHCup Haskell installer, version 0.1.19.0
|
||||
```
|
||||
|
||||
```bash
|
||||
$ which stack
|
||||
~/.ghcup/bin/stack
|
||||
$ stack --version
|
||||
Version 2.9.1, Git revision 13c9c8772a6dce093dbeacc08bb5877bdb6cfc2e (dirty) (155 commits) aarch64
|
||||
```
|
||||
|
||||
```shell
|
||||
$ which ghc
|
||||
~/.ghcup/bin/ghc
|
||||
$ ghc --version
|
||||
The Glorious Glasgow Haskell Compilation System, version 8.10.7
|
||||
```
|
||||
|
||||
Check which GHC version Stack thinks it's using too, for good measure:
|
||||
|
||||
```shell
|
||||
$ stack ghc -- --version
|
||||
The Glorious Glasgow Haskell Compilation System, version 8.10.7
|
||||
$ stack exec -- which ghc
|
||||
~/.ghcup/ghc/8.10.7/bin/ghc
|
||||
```
|
||||
|
||||
```shell
|
||||
$ which haskell-language-server-wrapper
|
||||
~/.ghcup/bin/haskell-language-server-wrapper
|
||||
$ haskell-language-server-wrapper
|
||||
|
||||
Found "...unison/hie.yaml" for "...unison/a"
|
||||
Run entered for haskell-language-server-wrapper(haskell-language-server-wrapper) Version 1.7.0.0 aarch64 ghc-9.2.2
|
||||
Current directory: ...unison
|
||||
Operating system: darwin
|
||||
Arguments: []
|
||||
Cradle directory: ...unison
|
||||
Cradle type: Stack
|
||||
|
||||
Tool versions found on the $PATH
|
||||
cabal: 3.6.2.0
|
||||
stack: 2.9.1
|
||||
ghc: 8.10.7
|
||||
```
|
||||
|
||||
If you're a VS Code user, you can download the Haskell extension for IDE support. You may need to configure it in `settings.json`.
|
||||
|
||||
```json
|
||||
"haskell.manageHLS": "GHCup",
|
||||
"haskell.toolchain": {
|
||||
"stack": "2.9.1",
|
||||
"ghc": "8.10.7",
|
||||
"cabal": "recommended",
|
||||
"hls": "1.7.0.0"
|
||||
}
|
||||
```
|
||||
|
||||
These setting blocks say that the VS Code extension will use GHCup for your Haskell language server distribution, and sets the versions for elements in the toolchain.
|
||||
|
||||
## Troubleshooting:
|
||||
|
||||
The VS Code extension has compiled a helpful list of troubleshooting steps here: https://github.com/haskell/vscode-haskell#troubleshooting
|
||||
|
||||
### "Couldn't figure out LLVM version" or "failed to compile a sanity check" errors
|
||||
|
||||
```
|
||||
<no location info>: error:
|
||||
Warning: Couldn't figure out LLVM version!
|
||||
Make sure you have installed LLVM between [9 and 13)
|
||||
ghc: could not execute: opt
|
||||
```
|
||||
|
||||
Or
|
||||
|
||||
```
|
||||
ld: symbol(s) not found for architecture x86_64
|
||||
clang: error: linker command failed with exit code 1 (use -v to see invocation)
|
||||
`gcc' failed in phase `Linker'. (Exit code: 1)
|
||||
```
|
||||
|
||||
Try installing llvm version 12
|
||||
`brew install llvm@12`
|
||||
|
||||
and prepend it to your path
|
||||
```
|
||||
export PATH="$(brew --prefix)/opt/llvm@12/bin:$PATH"
|
||||
```
|
||||
|
||||
(The GHC version 8.10.7 mentions it supports LLVM versions up to 12. https://www.haskell.org/ghc/download_ghc_8_10_7.html)
|
||||
|
||||
### "GHC ABIs don't match!"
|
||||
|
||||
Follow the steps here:
|
||||
|
||||
https://github.com/haskell/vscode-haskell#ghc-abis-dont-match
|
||||
|
||||
We found some success telling Stack to use the system's GHC instead of managing its own version of GHC. You can try this by setting the following two configuration flags in ~/.stack/config.yaml
|
||||
|
||||
```
|
||||
system-ghc: true
|
||||
install-ghc: false
|
||||
```
|
||||
|
||||
This is telling Stack to use the GHC executable that it finds on your $PATH. Make sure the ghc being provided is the proper version, 8.10.7, from ghcup.
|
||||
|
||||
Note that you may need to clean the cache for the project after this failure with `stack clean --full` if you have previously built things with a different stack distribution.
|
||||
|
||||
### "stack" commands like "stack build" cause a segfault:
|
||||
|
||||
1. Make sure your stack state is clean. `stack clean --full` removes the project's stack work directories (things in .stack-work).
|
||||
2. [Wait for this bug to be fixed (or help fix this bug!)](https://github.com/commercialhaskell/stack/issues/5607)
|
||||
3. Or subshell out your stack commands `$(stack commandHere)`
|
||||
4. Or use bash instead of zsh
|
||||
|
||||
### Help! Everything is broken and I want to start over
|
||||
|
||||
Warning, the following will remove ghcup, configuration files, cached packages, and versions of the toolchain.
|
||||
|
||||
```
|
||||
ghcup nuke
|
||||
rm -rf ~/.ghcup
|
||||
rm -rf ~/.stack
|
||||
rm -rf ~/.cabal
|
||||
```
|
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
-- | Tuple utils.
|
||||
module Unison.Util.Tuple
|
||||
|
@ -28,7 +28,7 @@ data Defns terms types = Defns
|
||||
{ terms :: terms,
|
||||
types :: types
|
||||
}
|
||||
deriving stock (Generic, Show)
|
||||
deriving stock (Generic, Functor, Show)
|
||||
deriving (Monoid, Semigroup) via GenericSemigroupMonoid (Defns terms types)
|
||||
|
||||
instance Bifoldable Defns where
|
||||
|
@ -985,7 +985,7 @@ refPromiseBuiltins =
|
||||
forall1 :: Text -> (Type -> Type) -> Type
|
||||
forall1 name body =
|
||||
let a = Var.named name
|
||||
in Type.forall () a (body $ Type.var () a)
|
||||
in Type.forAll () a (body $ Type.var () a)
|
||||
|
||||
forall2 ::
|
||||
Text -> Text -> (Type -> Type -> Type) -> Type
|
||||
|
@ -596,7 +596,7 @@ builtinEffectDecls =
|
||||
Structural
|
||||
()
|
||||
[]
|
||||
[ ((), v "Exception.raise", Type.forall () (v "x") (failureType () `arr` self (var "x")))
|
||||
[ ((), v "Exception.raise", Type.forAll () (v "x") (failureType () `arr` self (var "x")))
|
||||
]
|
||||
|
||||
pattern UnitRef :: Reference
|
||||
|
@ -90,7 +90,9 @@ module Unison.Codebase.Branch
|
||||
deepPaths,
|
||||
deepReferents,
|
||||
deepTermReferences,
|
||||
deepTermReferenceIds,
|
||||
deepTypeReferences,
|
||||
deepTypeReferenceIds,
|
||||
consBranchSnapshot,
|
||||
)
|
||||
where
|
||||
@ -136,7 +138,7 @@ import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude hiding (empty)
|
||||
import Unison.Reference (TermReference, TypeReference)
|
||||
import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Util.List qualified as List
|
||||
@ -146,6 +148,7 @@ import Unison.Util.Set qualified as Set
|
||||
import Unison.Util.Star2 qualified as Star2
|
||||
import Witherable (FilterableWithIndex (imapMaybe))
|
||||
import Prelude hiding (head, read, subtract)
|
||||
import qualified Unison.Reference as Reference
|
||||
|
||||
instance AsEmpty (Branch m) where
|
||||
_Empty = prism' (const empty) matchEmpty
|
||||
@ -201,9 +204,18 @@ deepTermReferences :: Branch0 m -> Set TermReference
|
||||
deepTermReferences =
|
||||
Set.mapMaybe Referent.toTermReference . deepReferents
|
||||
|
||||
deepTermReferenceIds :: Branch0 m -> Set TermReferenceId
|
||||
deepTermReferenceIds =
|
||||
Set.mapMaybe Referent.toTermReferenceId . deepReferents
|
||||
|
||||
deepTypeReferences :: Branch0 m -> Set TypeReference
|
||||
deepTypeReferences = R.dom . deepTypes
|
||||
|
||||
deepTypeReferenceIds :: Branch0 m -> Set TypeReferenceId
|
||||
deepTypeReferenceIds =
|
||||
Set.mapMaybe Reference.toId . deepTypeReferences
|
||||
|
||||
|
||||
namespaceStats :: Branch0 m -> NamespaceStats
|
||||
namespaceStats b =
|
||||
NamespaceStats
|
||||
|
@ -6,7 +6,8 @@
|
||||
module Unison.Codebase.Execute where
|
||||
|
||||
import Control.Exception (finally)
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Except (throwError, runExceptT)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Branch.Names qualified as Branch
|
||||
|
@ -57,7 +57,7 @@ getMainTerm loadTypeOfTerm parseNames mainName mainType = do
|
||||
builtinMain :: (Var v) => a -> Type.Type v a
|
||||
builtinMain a =
|
||||
let result = Var.named "result"
|
||||
in Type.forall a result (builtinMainWithResultType a (Type.var a result))
|
||||
in Type.forAll a result (builtinMainWithResultType a (Type.var a result))
|
||||
|
||||
-- '{io2.IO, Exception} res
|
||||
builtinMainWithResultType :: (Var v) => a -> Type.Type v a -> Type.Type v a
|
||||
|
@ -43,7 +43,7 @@ module Unison.Codebase.Path
|
||||
isRoot,
|
||||
isRoot',
|
||||
|
||||
-- * things that could be replaced with `Convert` instances
|
||||
-- * conversions
|
||||
absoluteToPath',
|
||||
fromList,
|
||||
fromName,
|
||||
@ -76,8 +76,6 @@ module Unison.Codebase.Path
|
||||
-- * things that could be replaced with `Snoc` instances
|
||||
snoc,
|
||||
unsnoc,
|
||||
-- This should be moved to a common util module, or we could use the 'witch' package.
|
||||
Convert (..),
|
||||
)
|
||||
where
|
||||
|
||||
@ -93,14 +91,19 @@ import Data.Sequence qualified as Seq
|
||||
import Data.Text qualified as Text
|
||||
import GHC.Exts qualified as GHC
|
||||
import Unison.HashQualified' qualified as HQ'
|
||||
import Unison.Name (Convert (..), Name)
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude hiding (empty, toList)
|
||||
import Unison.Syntax.Name qualified as Name (toText, unsafeParseText)
|
||||
import Unison.Util.List qualified as List
|
||||
|
||||
-- `Foo.Bar.baz` becomes ["Foo", "Bar", "baz"]
|
||||
-- | A `Path` is an internal structure representing some namespace in the codebase.
|
||||
--
|
||||
-- @Foo.Bar.baz@ becomes @["Foo", "Bar", "baz"]@.
|
||||
--
|
||||
-- __NB__: This shouldn’t be exposed outside of this module (prefer`Path'`, `Absolute`, or `Relative`), but it’s
|
||||
-- currently used pretty widely. Such usage should be replaced when encountered.
|
||||
newtype Path = Path {toSeq :: Seq NameSegment}
|
||||
deriving stock (Eq, Ord)
|
||||
deriving newtype (Semigroup, Monoid)
|
||||
@ -112,10 +115,13 @@ instance GHC.IsList Path where
|
||||
toList (Path segs) = Foldable.toList segs
|
||||
fromList = Path . Seq.fromList
|
||||
|
||||
-- | A namespace path that starts from the root.
|
||||
newtype Absolute = Absolute {unabsolute :: Path} deriving (Eq, Ord)
|
||||
|
||||
-- | A namespace path that doesn’t necessarily start from the root.
|
||||
newtype Relative = Relative {unrelative :: Path} deriving (Eq, Ord)
|
||||
|
||||
-- | 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)
|
||||
|
||||
@ -534,34 +540,3 @@ instance Resolve Absolute HQSplit HQSplitAbsolute where
|
||||
instance Resolve Absolute Path' Absolute where
|
||||
resolve _ (AbsolutePath' a) = a
|
||||
resolve a (RelativePath' r) = resolve a r
|
||||
|
||||
instance Convert Absolute Path where convert = unabsolute
|
||||
|
||||
instance Convert Absolute Path' where convert = absoluteToPath'
|
||||
|
||||
instance Convert Absolute Text where convert = toText' . absoluteToPath'
|
||||
|
||||
instance Convert Relative Text where convert = toText . unrelative
|
||||
|
||||
instance Convert Absolute String where convert = Text.unpack . convert
|
||||
|
||||
instance Convert Relative String where convert = Text.unpack . convert
|
||||
|
||||
instance Convert [NameSegment] Path where convert = fromList
|
||||
|
||||
instance Convert Path [NameSegment] where convert = toList
|
||||
|
||||
instance Convert HQSplit (HQ'.HashQualified Path) where convert = unsplitHQ
|
||||
|
||||
instance Convert HQSplit' (HQ'.HashQualified Path') where convert = unsplitHQ'
|
||||
|
||||
instance Convert Name Split where
|
||||
convert = splitFromName
|
||||
|
||||
instance Convert (path, NameSegment) (path, HQ'.HQSegment) where
|
||||
convert (path, name) =
|
||||
(path, HQ'.fromName name)
|
||||
|
||||
instance (Convert path0 path1) => Convert (path0, name) (path1, name) where
|
||||
convert =
|
||||
over _1 convert
|
||||
|
@ -4,7 +4,6 @@
|
||||
|
||||
module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema6To7 (migrateSchema6To7) where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.State
|
||||
import U.Codebase.Branch.Type (NamespaceStats)
|
||||
import U.Codebase.Sqlite.DbId qualified as DB
|
||||
|
@ -24,11 +24,13 @@ import U.Codebase.Projects qualified as Projects
|
||||
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
|
||||
import U.Codebase.Sqlite.ObjectType qualified as OT
|
||||
import U.Codebase.Sqlite.Operations (NamesInPerspective (..))
|
||||
import U.Codebase.Sqlite.Operations qualified as Ops
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
|
||||
import Unison.Builtin qualified as Builtins
|
||||
@ -41,6 +43,7 @@ import Unison.Codebase.SqliteCodebase.Branch.Cache (BranchCache)
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
import Unison.ConstructorType qualified as CT
|
||||
import Unison.Core.Project (ProjectBranchName, ProjectName)
|
||||
import Unison.DataDeclaration (Decl)
|
||||
import Unison.DataDeclaration qualified as Decl
|
||||
import Unison.Hash (Hash)
|
||||
@ -731,3 +734,15 @@ makeMaybeCachedTransaction size action = do
|
||||
pure \x -> do
|
||||
conn <- Sqlite.unsafeGetConnection
|
||||
Sqlite.unsafeIO (Cache.applyDefined cache (\x -> Sqlite.unsafeUnTransaction (action x) conn) x)
|
||||
|
||||
insertProjectAndBranch :: Db.ProjectId -> ProjectName -> Db.ProjectBranchId -> ProjectBranchName -> Sqlite.Transaction ()
|
||||
insertProjectAndBranch projectId projectName branchId branchName = do
|
||||
Q.insertProject projectId projectName
|
||||
Q.insertProjectBranch
|
||||
ProjectBranch
|
||||
{ projectId,
|
||||
branchId,
|
||||
name = branchName,
|
||||
parentBranchId = Nothing
|
||||
}
|
||||
Q.setMostRecentBranch projectId branchId
|
||||
|
@ -14,6 +14,7 @@ module Unison.KindInference.Solve.Monad
|
||||
where
|
||||
|
||||
import Control.Lens (Lens', (%%~))
|
||||
import Control.Monad.Fix (MonadFix (..))
|
||||
import Control.Monad.Reader qualified as M
|
||||
import Control.Monad.State.Strict qualified as M
|
||||
import Data.Functor.Identity
|
||||
@ -64,7 +65,7 @@ newtype Solve v loc a = Solve {unSolve :: Env -> SolveState v loc -> (a, SolveSt
|
||||
( Functor,
|
||||
Applicative,
|
||||
Monad,
|
||||
M.MonadFix,
|
||||
MonadFix,
|
||||
M.MonadReader Env,
|
||||
M.MonadState (SolveState v loc)
|
||||
)
|
||||
|
@ -518,12 +518,9 @@ addConstraint con0 nc = do
|
||||
C.PosLit var pmlit ->
|
||||
let updateLiteral pos neg lit
|
||||
| Just lit1 <- pos,
|
||||
lit1 == lit = case lit1 == lit of
|
||||
lit1 == lit =
|
||||
-- we already have this positive constraint
|
||||
True -> (pure (), Ignore)
|
||||
-- contradicts positive info
|
||||
False -> (contradiction, Ignore)
|
||||
-- the constraint contradicts negative info
|
||||
(pure (), Ignore)
|
||||
| Set.member lit neg = (contradiction, Ignore)
|
||||
| otherwise = (pure (), Update (Just lit, neg))
|
||||
in modifyLiteralC var pmlit updateLiteral nc
|
||||
|
@ -75,6 +75,7 @@ import Unison.Util.Monoid (intercalateMap)
|
||||
import Unison.Util.Pretty (ColorText, Pretty)
|
||||
import Unison.Util.Pretty qualified as Pr
|
||||
import Unison.Util.Range (Range (..), startingLine)
|
||||
import Unison.Util.Text (ordinal)
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
|
||||
@ -126,6 +127,10 @@ styleAnnotated sty a = (,sty) <$> rangeForAnnotated a
|
||||
style :: s -> String -> Pretty (AnnotatedText s)
|
||||
style sty str = Pr.lit . AT.annotate sty $ fromString str
|
||||
|
||||
-- | Applies the color highlighting for `Code`, but also quotes the code, to separate it from the containing context.
|
||||
quoteCode :: String -> Pretty ColorText
|
||||
quoteCode = Pr.backticked . style Code
|
||||
|
||||
stylePretty :: Color -> Pretty ColorText -> Pretty ColorText
|
||||
stylePretty = Pr.map . AT.annotate
|
||||
|
||||
@ -827,14 +832,6 @@ renderTypeError e env src = case e of
|
||||
let sz = length wrongs
|
||||
pl a b = if sz == 1 then a else b
|
||||
in mconcat [txt pl, intercalateMap "\n" (renderSuggestion env) wrongs]
|
||||
ordinal :: (IsString s) => Int -> s
|
||||
ordinal n =
|
||||
fromString $
|
||||
show n ++ case last (show n) of
|
||||
'1' -> "st"
|
||||
'2' -> "nd"
|
||||
'3' -> "rd"
|
||||
_ -> "th"
|
||||
debugNoteLoc a = if Settings.debugNoteLoc then a else mempty
|
||||
debugSummary :: C.ErrorNote v loc -> Pretty ColorText
|
||||
debugSummary note =
|
||||
@ -1366,31 +1363,31 @@ renderParseErrors s = \case
|
||||
<> style ErrorSite (fromString open)
|
||||
<> ".\n\n"
|
||||
<> excerpt
|
||||
L.InvalidWordyId _id ->
|
||||
L.ReservedWordyId id ->
|
||||
Pr.lines
|
||||
[ "This identifier isn't valid syntax: ",
|
||||
[ "The identifier " <> quoteCode id <> " used here is a reserved keyword: ",
|
||||
"",
|
||||
excerpt,
|
||||
"Here's a few examples of valid syntax: "
|
||||
<> style Code "abba1', snake_case, Foo.zoink!, 🌻"
|
||||
Pr.wrap $
|
||||
"You can avoid this problem either by renaming the identifier or wrapping it in backticks (like "
|
||||
<> style Code ("`" <> id <> "`")
|
||||
<> ")."
|
||||
]
|
||||
L.ReservedWordyId _id ->
|
||||
L.InvalidSymbolyId id ->
|
||||
Pr.lines
|
||||
[ "The identifier used here isn't allowed to be a reserved keyword: ",
|
||||
"",
|
||||
excerpt
|
||||
]
|
||||
L.InvalidSymbolyId _id ->
|
||||
Pr.lines
|
||||
[ "This infix identifier isn't valid syntax: ",
|
||||
[ "The infix identifier " <> quoteCode id <> " isn’t valid syntax: ",
|
||||
"",
|
||||
excerpt,
|
||||
"Here's a few valid examples: "
|
||||
<> style Code "++, Float./, `List.map`"
|
||||
"Here are a few valid examples: "
|
||||
<> quoteCode "++"
|
||||
<> ", "
|
||||
<> quoteCode "Float./"
|
||||
<> ", and "
|
||||
<> quoteCode "List.map"
|
||||
]
|
||||
L.ReservedSymbolyId _id ->
|
||||
L.ReservedSymbolyId id ->
|
||||
Pr.lines
|
||||
[ "This identifier is reserved by Unison and can't be used as an operator: ",
|
||||
[ "The identifier " <> quoteCode id <> " is reserved by Unison and can't be used as an operator: ",
|
||||
"",
|
||||
excerpt
|
||||
]
|
||||
@ -1444,11 +1441,12 @@ renderParseErrors s = \case
|
||||
"",
|
||||
excerpt,
|
||||
Pr.wrap $
|
||||
"I was expecting some digits after the '.',"
|
||||
<> "for example: "
|
||||
<> style Code (n <> "0")
|
||||
"I was expecting some digits after the "
|
||||
<> quoteCode "."
|
||||
<> ", for example: "
|
||||
<> quoteCode (n <> "0")
|
||||
<> "or"
|
||||
<> Pr.group (style Code (n <> "1e37") <> ".")
|
||||
<> Pr.group (quoteCode (n <> "1e37") <> ".")
|
||||
]
|
||||
L.MissingExponent n ->
|
||||
Pr.lines
|
||||
@ -1458,7 +1456,7 @@ renderParseErrors s = \case
|
||||
Pr.wrap $
|
||||
"I was expecting some digits for the exponent,"
|
||||
<> "for example: "
|
||||
<> Pr.group (style Code (n <> "37") <> ".")
|
||||
<> Pr.group (quoteCode (n <> "37") <> ".")
|
||||
]
|
||||
L.TextLiteralMissingClosingQuote _txt ->
|
||||
Pr.lines
|
||||
@ -1474,7 +1472,7 @@ renderParseErrors s = \case
|
||||
"",
|
||||
"I only know about the following escape characters:",
|
||||
"",
|
||||
let s ch = style Code (fromString $ "\\" <> [ch])
|
||||
let s ch = quoteCode (fromString $ "\\" <> [ch])
|
||||
in Pr.indentN 2 $ intercalateMap "," s (fst <$> L.escapeChars)
|
||||
]
|
||||
L.LayoutError ->
|
||||
@ -1705,7 +1703,7 @@ renderParseErrors s = \case
|
||||
let msg =
|
||||
mconcat
|
||||
[ "This looks like the start of an expression here but I was expecting a binding.",
|
||||
"\nDid you mean to use a single " <> style Code ":",
|
||||
"\nDid you mean to use a single " <> quoteCode ":",
|
||||
" here for a type signature?",
|
||||
"\n\n",
|
||||
tokenAsErrorSite s t
|
||||
|
@ -2599,8 +2599,16 @@ declareForeigns = do
|
||||
|
||||
declareForeign Tracked "IO.kill.impl.v3" boxToEF0 $ mkForeignIOF killThread
|
||||
|
||||
let mx :: Word64
|
||||
mx = fromIntegral (maxBound :: Int)
|
||||
|
||||
customDelay :: Word64 -> IO ()
|
||||
customDelay n
|
||||
| n < mx = threadDelay (fromIntegral n)
|
||||
| otherwise = threadDelay maxBound >> customDelay (n - mx)
|
||||
|
||||
declareForeign Tracked "IO.delay.impl.v3" natToEFUnit $
|
||||
mkForeignIOF threadDelay
|
||||
mkForeignIOF customDelay
|
||||
|
||||
declareForeign Tracked "IO.stdHandle" standard'handle
|
||||
. mkForeign
|
||||
|
@ -38,6 +38,7 @@ import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Names (Names)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.NamesWithHistory qualified as Names
|
||||
import Unison.Parser.Ann qualified as Ann
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Pattern (Pattern)
|
||||
import Unison.Pattern qualified as Pattern
|
||||
@ -439,7 +440,8 @@ resolveHashQualified tok = do
|
||||
termLeaf :: forall m v. (Monad m, Var v) => TermP v m
|
||||
termLeaf =
|
||||
asum
|
||||
[ hashQualifiedPrefixTerm,
|
||||
[ force,
|
||||
hashQualifiedPrefixTerm,
|
||||
text,
|
||||
char,
|
||||
number,
|
||||
@ -991,6 +993,17 @@ bang = P.label "bang" do
|
||||
e <- termLeaf
|
||||
pure $ DD.forceTerm (ann start <> ann e) (ann start) e
|
||||
|
||||
force :: forall m v . (Monad m, Var v) => TermP v m
|
||||
force = P.label "force" $ P.try do
|
||||
-- `forkAt pool() blah` parses as `forkAt (pool ()) blah`
|
||||
-- That is, empty parens immediately (no space) following a symbol
|
||||
-- is treated as high precedence function application of `Unit`
|
||||
fn <- hashQualifiedPrefixTerm
|
||||
tok <- ann <$> openBlockWith "("
|
||||
guard (L.column (Ann.start tok) == L.column (Ann.end (ann fn)))
|
||||
close <- closeBlock
|
||||
pure $ DD.forceTerm (ann fn <> ann close) (tok <> ann close) fn
|
||||
|
||||
seqOp :: (Ord v) => P v m Pattern.SeqOp
|
||||
seqOp =
|
||||
Pattern.Snoc
|
||||
|
@ -459,7 +459,7 @@ pretty0
|
||||
go tm = goNormal 10 tm
|
||||
PP.hang kw <$> fmap PP.lines (traverse go rs)
|
||||
(Bytes' bs, _) ->
|
||||
pure $ fmt S.BytesLiteral "0xs" <> PP.shown (Bytes.fromWord8s (map fromIntegral bs))
|
||||
pure $ PP.group $ fmt S.BytesLiteral "0xs" <> PP.shown (Bytes.fromWord8s (map fromIntegral bs))
|
||||
BinaryAppsPred' apps lastArg -> do
|
||||
prettyLast <- pretty0 (ac 3 Normal im doc) lastArg
|
||||
prettyApps <- binaryApps apps prettyLast
|
||||
@ -490,7 +490,7 @@ pretty0
|
||||
(App' x (Constructor' (ConstructorReference DD.UnitRef 0)), _) | isLeaf x -> do
|
||||
px <- pretty0 (ac (if isBlock x then 0 else 9) Normal im doc) x
|
||||
pure . paren (p >= 11 || isBlock x && p >= 3) $
|
||||
fmt S.DelayForceChar (l "!") <> PP.indentNAfterNewline 1 px
|
||||
px <> fmt S.DelayForceChar (l "()")
|
||||
(Apps' f (unsnoc -> Just (args, lastArg)), _)
|
||||
| isSoftHangable lastArg -> do
|
||||
fun <- goNormal 9 f
|
||||
|
@ -31,7 +31,7 @@ type TypeP v m = P v m (Type v Ann)
|
||||
-- the right of a function arrow:
|
||||
-- valueType ::= Int | Text | App valueType valueType | Arrow valueType computationType
|
||||
valueType :: (Monad m, Var v) => TypeP v m
|
||||
valueType = forall type1 <|> type1
|
||||
valueType = forAll type1 <|> type1
|
||||
|
||||
-- Computation
|
||||
-- computationType ::= [{effect*}] valueType
|
||||
@ -119,8 +119,8 @@ arrow rec =
|
||||
in chainr1 (effect <|> rec) (reserved "->" *> eff)
|
||||
|
||||
-- "forall a b . List a -> List b -> Maybe Text"
|
||||
forall :: (Var v) => TypeP v m -> TypeP v m
|
||||
forall rec = do
|
||||
forAll :: (Var v) => TypeP v m -> TypeP v m
|
||||
forAll rec = do
|
||||
kw <- reserved "forall" <|> reserved "∀"
|
||||
vars <- fmap (fmap L.payload) . some $ prefixDefinitionName
|
||||
_ <- reserved "."
|
||||
|
@ -963,7 +963,7 @@ apply' solvedExistentials t = go t
|
||||
Type.Ann' v k -> Type.ann a (go v) k
|
||||
Type.Effect1' e t -> Type.effect1 a (go e) (go t)
|
||||
Type.Effects' es -> Type.effects a (map go es)
|
||||
Type.ForallNamed' v t' -> Type.forall a v (go t')
|
||||
Type.ForallNamed' v t' -> Type.forAll a v (go t')
|
||||
Type.IntroOuterNamed' v t' -> Type.introOuter a v (go t')
|
||||
_ -> error $ "Match error in Context.apply': " ++ show t
|
||||
where
|
||||
@ -1059,7 +1059,7 @@ vectorConstructorOfArity loc arity = do
|
||||
let elementVar = Var.named "elem"
|
||||
args = replicate arity (loc, Type.var loc elementVar)
|
||||
resultType = Type.app loc (Type.list loc) (Type.var loc elementVar)
|
||||
vt = Type.forall loc elementVar (Type.arrows args resultType)
|
||||
vt = Type.forAll loc elementVar (Type.arrows args resultType)
|
||||
pure vt
|
||||
|
||||
generalizeAndUnTypeVar :: (Var v) => Type v a -> Type.Type v a
|
||||
@ -1984,7 +1984,7 @@ tweakEffects v0 t0
|
||||
rewrite p ty
|
||||
| Type.ForallNamed' v t <- ty,
|
||||
v0 /= v =
|
||||
second (Type.forall a v) <$> rewrite p t
|
||||
second (Type.forAll a v) <$> rewrite p t
|
||||
| Type.Arrow' i o <- ty = do
|
||||
(vis, i) <- rewrite (not <$> p) i
|
||||
(vos, o) <- rewrite p o
|
||||
@ -2097,7 +2097,7 @@ generalizeP p ctx0 ty = foldr gen (applyCtx ctx0 ty) ctx
|
||||
-- location of the forall is just the location of the input type
|
||||
-- and the location of each quantified variable is just inherited
|
||||
-- from its source location
|
||||
Type.forall
|
||||
Type.forAll
|
||||
(loc t)
|
||||
(TypeVar.Universal v)
|
||||
(ABT.substInheritAnnotation tv (universal' () v) t)
|
||||
@ -2561,8 +2561,7 @@ subtype tx ty = scope (InSubtype tx ty) $ do
|
||||
go ctx (Type.Var' (TypeVar.Existential b v)) t -- `InstantiateL`
|
||||
| Set.member v (existentials ctx)
|
||||
&& notMember v (Type.freeVars t) = do
|
||||
e <- extendExistential Var.inferAbility
|
||||
instantiateL b v (relax' False e t)
|
||||
instantiateL b v t
|
||||
go ctx t (Type.Var' (TypeVar.Existential b v)) -- `InstantiateR`
|
||||
| Set.member v (existentials ctx)
|
||||
&& notMember v (Type.freeVars t) = do
|
||||
|
@ -6,6 +6,7 @@ module Unison.Util.Text where
|
||||
|
||||
import Data.Foldable (toList)
|
||||
import Data.List (foldl', unfoldr)
|
||||
import Data.List qualified as L
|
||||
import Data.String (IsString (..))
|
||||
import Data.Text qualified as T
|
||||
import Data.Text.Encoding qualified as T
|
||||
@ -131,6 +132,25 @@ indexOf needle haystack =
|
||||
needle' = toLazyText needle
|
||||
haystack' = toLazyText haystack
|
||||
|
||||
-- | Return the ordinal representation of a number in English.
|
||||
-- A number ending with '1' must finish with 'st'
|
||||
-- A number ending with '2' must finish with 'nd'
|
||||
-- A number ending with '3' must finish with 'rd'
|
||||
-- _except_ for 11, 12, and 13 which must finish with 'th'
|
||||
ordinal :: (IsString s) => Int -> s
|
||||
ordinal n = do
|
||||
let s = show n
|
||||
fromString $ s ++
|
||||
case L.drop (L.length s - 2) s of
|
||||
['1', '1'] -> "th"
|
||||
['1', '2'] -> "th"
|
||||
['1', '3'] -> "th"
|
||||
_ -> case last s of
|
||||
'1' -> "st"
|
||||
'2' -> "nd"
|
||||
'3' -> "rd"
|
||||
_ -> "th"
|
||||
|
||||
-- Drop with both a maximum size and a predicate. Yields actual number of
|
||||
-- dropped characters.
|
||||
--
|
||||
|
@ -88,7 +88,7 @@ unhashComponentTest =
|
||||
inventedVarsFreshnessTest =
|
||||
let var = Type.var ()
|
||||
app = Type.app ()
|
||||
forall = Type.forall ()
|
||||
forAll = Type.forAll ()
|
||||
(-->) = Type.arrow ()
|
||||
h = Hash.fromByteString (encodeUtf8 "abcd")
|
||||
ref = R.Id h 0
|
||||
@ -104,8 +104,8 @@ unhashComponentTest =
|
||||
annotation = (),
|
||||
bound = [],
|
||||
constructors' =
|
||||
[ ((), nil, forall a (listType `app` var a)),
|
||||
((), cons, forall b (var b --> listType `app` var b --> listType `app` var b))
|
||||
[ ((), nil, forAll a (listType `app` var a)),
|
||||
((), cons, forAll b (var b --> listType `app` var b --> listType `app` var b))
|
||||
]
|
||||
}
|
||||
component :: Map R.Id (Decl Symbol ())
|
||||
@ -120,7 +120,7 @@ unhashComponentTest =
|
||||
in tests
|
||||
[ -- check that `nil` constructor's type did not collapse to `forall a. a a`,
|
||||
-- which would happen if the var invented for `listRef` was simply `Var.refNamed listRef`
|
||||
expectEqual (forall z (listType' `app` var z)) nilType',
|
||||
expectEqual (forAll z (listType' `app` var z)) nilType',
|
||||
-- check that the variable assigned to `listRef` is different from `cons`,
|
||||
-- which would happen if the var invented for `listRef` was simply `Var.refNamed listRef`
|
||||
expectNotEqual cons listVar
|
||||
|
@ -33,7 +33,7 @@ test =
|
||||
Type.arrow () (tv "a") (tv "x")
|
||||
)
|
||||
)
|
||||
(Type.forall () (v "a") (tv "a"))
|
||||
(Type.forAll () (v "a") (tv "a"))
|
||||
tm' = Term.substTypeVar (v "x") (tv "a") tm
|
||||
expected =
|
||||
Term.ann
|
||||
@ -45,7 +45,7 @@ test =
|
||||
Type.arrow () (Type.var () $ v1 "a") (tv "a")
|
||||
)
|
||||
)
|
||||
(Type.forall () (v1 "a") (Type.var () $ v1 "a"))
|
||||
(Type.forAll () (v1 "a") (Type.var () $ v1 "a"))
|
||||
note $ show tm'
|
||||
note $ show expected
|
||||
expect $ tm == tm
|
||||
|
@ -28,7 +28,7 @@ test =
|
||||
v2 = Var.named "b"
|
||||
vt = var () v
|
||||
vt2 = var () v2
|
||||
x = forall () v (nat () --> effect () [vt, builtin () "eff"] (nat ())) :: Type Symbol ()
|
||||
y = forall () v2 (nat () --> effect () [vt2] (nat ())) :: Type Symbol ()
|
||||
x = forAll () v (nat () --> effect () [vt, builtin () "eff"] (nat ())) :: Type Symbol ()
|
||||
y = forAll () v2 (nat () --> effect () [vt2] (nat ())) :: Type Symbol ()
|
||||
expect . not $ Typechecker.isSubtype x y
|
||||
]
|
||||
|
@ -18,12 +18,12 @@ test =
|
||||
isSubtypeTest :: Test ()
|
||||
isSubtypeTest =
|
||||
let symbol i n = Symbol i (Var.User n)
|
||||
forall v t = Type.forall () v t
|
||||
forAll v t = Type.forAll () v t
|
||||
var v = Type.var () v
|
||||
|
||||
a = symbol 0 "a"
|
||||
a_ i = symbol i "a"
|
||||
lhs = forall a (var a) -- ∀a. a
|
||||
lhs = forAll a (var a) -- ∀a. a
|
||||
rhs_ i = var (a_ i) -- a_i
|
||||
in -- check that `∀a. a <: a_i` (used to fail for i = 2, 3)
|
||||
tests [expectSubtype lhs (rhs_ i) | i <- [0 .. 5]]
|
||||
|
@ -178,7 +178,28 @@ test =
|
||||
)
|
||||
(P.Join [P.Capture (P.Literal "zzzaaa"), P.Capture (P.Literal "!")])
|
||||
in P.run p "zzzaaa!!!"
|
||||
ok
|
||||
ok,
|
||||
scope "ordinal" do
|
||||
expectEqual (Text.ordinal 1) ("1st" :: String)
|
||||
expectEqual (Text.ordinal 2) ("2nd" :: String)
|
||||
expectEqual (Text.ordinal 3) ("3rd" :: String)
|
||||
expectEqual (Text.ordinal 4) ("4th" :: String)
|
||||
expectEqual (Text.ordinal 5) ("5th" :: String)
|
||||
expectEqual (Text.ordinal 10) ("10th" :: String)
|
||||
expectEqual (Text.ordinal 11) ("11th" :: String)
|
||||
expectEqual (Text.ordinal 12) ("12th" :: String)
|
||||
expectEqual (Text.ordinal 13) ("13th" :: String)
|
||||
expectEqual (Text.ordinal 14) ("14th" :: String)
|
||||
expectEqual (Text.ordinal 21) ("21st" :: String)
|
||||
expectEqual (Text.ordinal 22) ("22nd" :: String)
|
||||
expectEqual (Text.ordinal 23) ("23rd" :: String)
|
||||
expectEqual (Text.ordinal 24) ("24th" :: String)
|
||||
expectEqual (Text.ordinal 111) ("111th" :: String)
|
||||
expectEqual (Text.ordinal 112) ("112th" :: String)
|
||||
expectEqual (Text.ordinal 113) ("113th" :: String)
|
||||
expectEqual (Text.ordinal 121) ("121st" :: String)
|
||||
expectEqual (Text.ordinal 122) ("122nd" :: String)
|
||||
expectEqual (Text.ordinal 123) ("123rd" :: String)
|
||||
]
|
||||
where
|
||||
log2 :: Int -> Int
|
||||
|
@ -6,4 +6,5 @@ true \
|
||||
&& stack exec transcripts \
|
||||
&& stack exec unison transcript unison-src/transcripts-round-trip/main.md \
|
||||
&& stack exec unison transcript unison-src/transcripts-manual/rewrites.md \
|
||||
&& stack exec unison transcript unison-src/transcripts-manual/docs.to-html.md \
|
||||
&& stack exec cli-integration-tests
|
||||
|
@ -481,7 +481,7 @@ updateRoot new reason =
|
||||
getTermsAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set Referent)
|
||||
getTermsAt path = do
|
||||
rootBranch0 <- getRootBranch0
|
||||
pure (BranchUtil.getTerm (Path.convert path) rootBranch0)
|
||||
pure (BranchUtil.getTerm (first Path.unabsolute path) rootBranch0)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Getting types
|
||||
@ -489,7 +489,7 @@ getTermsAt path = do
|
||||
getTypesAt :: (Path.Absolute, HQ'.HQSegment) -> Cli (Set TypeReference)
|
||||
getTypesAt path = do
|
||||
rootBranch0 <- getRootBranch0
|
||||
pure (BranchUtil.getType (Path.convert path) rootBranch0)
|
||||
pure (BranchUtil.getType (first Path.unabsolute path) rootBranch0)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Getting patches
|
||||
|
@ -47,7 +47,8 @@ module Unison.Cli.ProjectUtils
|
||||
findTemporaryBranchName,
|
||||
expectLatestReleaseBranchName,
|
||||
|
||||
-- * Upgrade branch utils
|
||||
-- * Merge/upgrade branch utils
|
||||
getMergeBranchParent,
|
||||
getUpgradeBranchParent,
|
||||
)
|
||||
where
|
||||
@ -123,8 +124,8 @@ justTheIds x =
|
||||
ProjectAndBranch x.project.projectId x.branch.branchId
|
||||
|
||||
justTheIds' :: Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId
|
||||
justTheIds' x =
|
||||
ProjectAndBranch x.projectId x.branchId
|
||||
justTheIds' branch =
|
||||
ProjectAndBranch branch.projectId branch.branchId
|
||||
|
||||
justTheNames :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectName ProjectBranchName
|
||||
justTheNames x =
|
||||
@ -411,6 +412,17 @@ expectLatestReleaseBranchName remoteProject =
|
||||
Nothing -> Cli.returnEarly (Output.ProjectHasNoReleases remoteProject.projectName)
|
||||
Just semver -> pure (UnsafeProjectBranchName ("releases/" <> into @Text semver))
|
||||
|
||||
-- | @getMergeBranchParent branch@ returns the parent branch of a "merge" branch.
|
||||
--
|
||||
-- When a merge fails, we put you on a branch called `merge-<source>-into-<target>`. That's a "merge" branch. It's not
|
||||
-- currently distinguished in the database, so we first just switch on whether its name begins with "merge-". If it
|
||||
-- does, then we get the branch's parent, which should exist, but perhaps wouldn't if the user had manually made a
|
||||
-- parentless branch called "merge-whatever" for whatever reason.
|
||||
getMergeBranchParent :: Sqlite.ProjectBranch -> Maybe ProjectBranchId
|
||||
getMergeBranchParent branch = do
|
||||
guard ("merge-" `Text.isPrefixOf` into @Text branch.name)
|
||||
branch.parentBranchId
|
||||
|
||||
-- | @getUpgradeBranchParent branch@ returns the parent branch of an "upgrade" branch.
|
||||
--
|
||||
-- When an upgrade fails, we put you on a branch called `upgrade-<old>-to-<new>`. That's an "upgrade" branch. It's not
|
||||
|
@ -41,7 +41,6 @@ import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.NamesUtils qualified as Cli
|
||||
import Unison.Cli.PrettyPrintUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch (..), Branch0)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
@ -51,12 +50,12 @@ import Unison.Codebase.BranchUtil qualified as BranchUtil
|
||||
import Unison.Codebase.Causal qualified as Causal
|
||||
import Unison.Codebase.Editor.AuthorInfo (AuthorInfo (..))
|
||||
import Unison.Codebase.Editor.AuthorInfo qualified as AuthorInfo
|
||||
import Unison.Codebase.Editor.DisplayObject
|
||||
import Unison.Codebase.Editor.HandleInput.AddRun (handleAddRun)
|
||||
import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin)
|
||||
import Unison.Codebase.Editor.HandleInput.Branch (handleBranch)
|
||||
import Unison.Codebase.Editor.HandleInput.BranchRename (handleBranchRename)
|
||||
import Unison.Codebase.Editor.HandleInput.Branches (handleBranches)
|
||||
import Unison.Codebase.Editor.HandleInput.CommitMerge (handleCommitMerge)
|
||||
import Unison.Codebase.Editor.HandleInput.CommitUpgrade (handleCommitUpgrade)
|
||||
import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition
|
||||
import Unison.Codebase.Editor.HandleInput.DebugFoldRanges qualified as DebugFoldRanges
|
||||
@ -67,6 +66,7 @@ import Unison.Codebase.Editor.HandleInput.FindAndReplace (handleStructuredFindI,
|
||||
import Unison.Codebase.Editor.HandleInput.FormatFile qualified as Format
|
||||
import Unison.Codebase.Editor.HandleInput.InstallLib (handleInstallLib)
|
||||
import Unison.Codebase.Editor.HandleInput.Load (EvalMode (Sandboxed), evalUnisonFile, handleLoad, loadUnisonFile)
|
||||
import Unison.Codebase.Editor.HandleInput.Ls (handleLs)
|
||||
import Unison.Codebase.Editor.HandleInput.Merge2 (handleMerge)
|
||||
import Unison.Codebase.Editor.HandleInput.MoveAll (handleMoveAll)
|
||||
import Unison.Codebase.Editor.HandleInput.MoveBranch (doMoveBranch)
|
||||
@ -77,6 +77,7 @@ import Unison.Codebase.Editor.HandleInput.NamespaceDiffUtils (diffHelper)
|
||||
import Unison.Codebase.Editor.HandleInput.ProjectClone (handleClone)
|
||||
import Unison.Codebase.Editor.HandleInput.ProjectCreate (projectCreate)
|
||||
import Unison.Codebase.Editor.HandleInput.ProjectRename (handleProjectRename)
|
||||
import Unison.Codebase.Editor.HandleInput.Todo (handleTodo)
|
||||
import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch)
|
||||
import Unison.Codebase.Editor.HandleInput.Projects (handleProjects)
|
||||
import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch)
|
||||
@ -100,11 +101,8 @@ import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||
import Unison.Codebase.Editor.Slurp qualified as Slurp
|
||||
import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult
|
||||
import Unison.Codebase.Editor.StructuredArgument qualified as SA
|
||||
import Unison.Codebase.Editor.TodoOutput qualified as TO
|
||||
import Unison.Codebase.IntegrityCheck qualified as IntegrityCheck (integrityCheckFullCodebase)
|
||||
import Unison.Codebase.Metadata qualified as Metadata
|
||||
import Unison.Codebase.Patch (Patch (..))
|
||||
import Unison.Codebase.Patch qualified as Patch
|
||||
import Unison.Codebase.Path (Path, Path' (..))
|
||||
import Unison.Codebase.Path qualified as HQSplit'
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
@ -181,7 +179,6 @@ 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 Unison.Util.TransitiveClosure (transitiveClosure)
|
||||
import Unison.Var (Var)
|
||||
import Unison.Var qualified as Var
|
||||
import Unison.WatchKind qualified as WK
|
||||
@ -351,7 +348,7 @@ loop e = do
|
||||
Left hash -> (,WhichBranchEmptyHash hash) <$> Cli.resolveShortCausalHash hash
|
||||
Right path' -> do
|
||||
absPath <- ProjectUtils.branchRelativePathToAbsolute path'
|
||||
let srcp = Path.convert absPath
|
||||
let srcp = Path.AbsolutePath' absPath
|
||||
srcb <- Cli.expectBranchAtPath' srcp
|
||||
pure (srcb, WhichBranchEmptyPath srcp)
|
||||
description <- inputDescription input
|
||||
@ -362,6 +359,7 @@ loop e = do
|
||||
then Success
|
||||
else BranchEmpty branchEmpty
|
||||
MergeI branch -> handleMerge branch
|
||||
MergeCommitI -> handleCommitMerge
|
||||
MergeLocalBranchI src0 dest0 mergeMode -> do
|
||||
description <- inputDescription input
|
||||
src0 <- ProjectUtils.expectLooseCodeOrProjectBranch src0
|
||||
@ -468,11 +466,11 @@ loop e = do
|
||||
Cli.respond $ Output.MarkdownOut (Text.intercalate "\n---\n" mdText)
|
||||
DocsToHtmlI namespacePath' sourceDirectory -> do
|
||||
Cli.Env {codebase, sandboxedRuntime} <- ask
|
||||
absPath <- Cli.resolvePath' namespacePath'
|
||||
absPath <- ProjectUtils.branchRelativePathToAbsolute namespacePath'
|
||||
branch <- liftIO $ Codebase.getBranchAtPath codebase absPath
|
||||
_evalErrs <- liftIO $ (Backend.docsInBranchToHtmlFiles sandboxedRuntime codebase branch sourceDirectory)
|
||||
pure ()
|
||||
AliasTermI src' dest' -> do
|
||||
AliasTermI force src' dest' -> do
|
||||
Cli.Env {codebase} <- ask
|
||||
src <- traverseOf _Right Cli.resolveSplit' src'
|
||||
srcTerms <-
|
||||
@ -490,11 +488,11 @@ loop e = do
|
||||
hqLength <- Cli.runTransaction Codebase.hashLength
|
||||
pure (DeleteNameAmbiguous hqLength name srcTerms Set.empty)
|
||||
dest <- Cli.resolveSplit' dest'
|
||||
destTerms <- Cli.getTermsAt (Path.convert dest)
|
||||
when (not (Set.null destTerms)) do
|
||||
destTerms <- Cli.getTermsAt (HQ'.NameOnly <$> dest)
|
||||
when (not force && not (Set.null destTerms)) do
|
||||
Cli.returnEarly (TermAlreadyExists dest' destTerms)
|
||||
description <- inputDescription input
|
||||
Cli.stepAt description (BranchUtil.makeAddTermName (Path.convert dest) srcTerm)
|
||||
Cli.stepAt description (BranchUtil.makeAddTermName (first Path.unabsolute dest) srcTerm)
|
||||
Cli.respond Success
|
||||
AliasTypeI src' dest' -> do
|
||||
src <- traverseOf _Right Cli.resolveSplit' src'
|
||||
@ -513,11 +511,11 @@ loop e = do
|
||||
hqLength <- Cli.runTransaction Codebase.hashLength
|
||||
pure (DeleteNameAmbiguous hqLength name Set.empty srcTypes)
|
||||
dest <- Cli.resolveSplit' dest'
|
||||
destTypes <- Cli.getTypesAt (Path.convert dest)
|
||||
destTypes <- Cli.getTypesAt (HQ'.NameOnly <$> dest)
|
||||
when (not (Set.null destTypes)) do
|
||||
Cli.returnEarly (TypeAlreadyExists dest' destTypes)
|
||||
description <- inputDescription input
|
||||
Cli.stepAt description (BranchUtil.makeAddTypeName (Path.convert dest) srcType)
|
||||
Cli.stepAt description (BranchUtil.makeAddTypeName (first Path.unabsolute dest) srcType)
|
||||
Cli.respond Success
|
||||
|
||||
-- this implementation will happily produce name conflicts,
|
||||
@ -619,9 +617,9 @@ loop e = do
|
||||
guidPath <- Cli.resolveSplit' (authorPath' |> NameSegment.guidSegment)
|
||||
Cli.stepManyAt
|
||||
description
|
||||
[ BranchUtil.makeAddTermName (Path.convert authorPath) (d authorRef),
|
||||
BranchUtil.makeAddTermName (Path.convert copyrightHolderPath) (d copyrightHolderRef),
|
||||
BranchUtil.makeAddTermName (Path.convert guidPath) (d guidRef)
|
||||
[ BranchUtil.makeAddTermName (first Path.unabsolute authorPath) (d authorRef),
|
||||
BranchUtil.makeAddTermName (first Path.unabsolute copyrightHolderPath) (d copyrightHolderRef),
|
||||
BranchUtil.makeAddTermName (first Path.unabsolute guidPath) (d guidRef)
|
||||
]
|
||||
currentPath <- Cli.getCurrentPath
|
||||
finalBranch <- Cli.getCurrentBranch0
|
||||
@ -690,21 +688,7 @@ loop e = do
|
||||
traverse_ (displayI outputLoc) namesToDisplay
|
||||
ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query
|
||||
EditNamespaceI paths -> handleEditNamespace LatestFileLocation paths
|
||||
FindShallowI pathArg -> do
|
||||
Cli.Env {codebase} <- ask
|
||||
|
||||
pathArgAbs <- Cli.resolvePath' pathArg
|
||||
entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs)
|
||||
Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries
|
||||
pped <- Cli.currentPrettyPrintEnvDecl
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
-- This used to be a delayed action which only forced the loading of the root
|
||||
-- branch when it was necessary for printing the results, but that got wiped out
|
||||
-- when we ported to the new Cli monad.
|
||||
-- It would be nice to restore it, but it's pretty rare that it actually results
|
||||
-- in an improvement, so perhaps it's not worth the effort.
|
||||
let buildPPE = pure suffixifiedPPE
|
||||
Cli.respond $ ListShallow buildPPE entries
|
||||
FindShallowI pathArg -> handleLs pathArg
|
||||
FindI isVerbose fscope ws -> handleFindI isVerbose fscope ws input
|
||||
StructuredFindI _fscope ws -> handleStructuredFindI ws
|
||||
StructuredFindReplaceI ws -> handleStructuredFindReplaceI ws
|
||||
@ -742,10 +726,7 @@ loop e = do
|
||||
currentNames <- Branch.toNames <$> Cli.getCurrentBranch0
|
||||
let sr = Slurp.slurpFile uf vars Slurp.UpdateOp currentNames
|
||||
previewResponse sourceName sr uf
|
||||
TodoI patchPath branchPath' -> do
|
||||
patch <- Cli.getPatchAt (fromMaybe Cli.defaultPatchPath patchPath)
|
||||
branchPath <- Cli.resolvePath' branchPath'
|
||||
doShowTodoOutput patch branchPath
|
||||
TodoI -> handleTodo
|
||||
TestI testInput -> Tests.handleTest testInput
|
||||
ExecuteI main args -> handleRun False main args
|
||||
MakeStandaloneI output main -> doCompile False output main
|
||||
@ -996,10 +977,10 @@ inputDescription input =
|
||||
ResetRootI src0 -> do
|
||||
src <- hp' src0
|
||||
pure ("reset-root " <> src)
|
||||
AliasTermI src0 dest0 -> do
|
||||
AliasTermI force src0 dest0 -> do
|
||||
src <- hhqs' src0
|
||||
dest <- ps' dest0
|
||||
pure ("alias.term " <> src <> " " <> dest)
|
||||
pure ((if force then "alias.term.force " else "alias.term ") <> src <> " " <> dest)
|
||||
AliasTypeI src0 dest0 -> do
|
||||
src <- hhqs' src0
|
||||
dest <- ps' dest0
|
||||
@ -1115,6 +1096,7 @@ inputDescription input =
|
||||
ListDependentsI {} -> wat
|
||||
LoadI {} -> wat
|
||||
MergeI {} -> wat
|
||||
MergeCommitI {} -> wat
|
||||
NamesI {} -> wat
|
||||
NamespaceDependenciesI {} -> wat
|
||||
PopBranchI {} -> wat
|
||||
@ -1430,58 +1412,6 @@ doDisplay outputLoc names tm = do
|
||||
else do
|
||||
writeUtf8 filePath txt
|
||||
|
||||
-- | Show todo output if there are any conflicts or edits.
|
||||
doShowTodoOutput :: Patch -> Path.Absolute -> Cli ()
|
||||
doShowTodoOutput patch scopePath = do
|
||||
Cli.Env {codebase} <- ask
|
||||
names0 <- Branch.toNames <$> Cli.getBranch0At scopePath
|
||||
todo <- Cli.runTransaction (checkTodo codebase patch names0)
|
||||
if TO.noConflicts todo && TO.noEdits todo
|
||||
then Cli.respond NoConflictsOrEdits
|
||||
else do
|
||||
Cli.setNumberedArgs $
|
||||
SA.HashQualified . HQ.HashOnly . Reference.toShortHash . view _2
|
||||
<$> fst (TO.todoFrontierDependents todo)
|
||||
pped <- Cli.currentPrettyPrintEnvDecl
|
||||
Cli.respondNumbered $ TodoOutput pped todo
|
||||
|
||||
checkTodo :: Codebase m Symbol Ann -> Patch -> Names -> Sqlite.Transaction (TO.TodoOutput Symbol Ann)
|
||||
checkTodo codebase patch names0 = do
|
||||
let -- Get the dependents of a reference which:
|
||||
-- 1. Don't appear on the LHS of this patch
|
||||
-- 2. Have a name in this namespace
|
||||
getDependents :: Reference -> Sqlite.Transaction (Set Reference)
|
||||
getDependents ref = do
|
||||
dependents <- Codebase.dependents Queries.ExcludeSelf ref
|
||||
pure (dependents & removeEditedThings & removeNamelessThings)
|
||||
-- (r,r2) ∈ dependsOn if r depends on r2, excluding self-references (i.e. (r,r))
|
||||
dependsOn <- Monoid.foldMapM (\ref -> R.fromManyDom <$> getDependents ref <*> pure ref) edited
|
||||
let dirty = R.dom dependsOn
|
||||
transitiveDirty <- transitiveClosure getDependents dirty
|
||||
(frontierTerms, frontierTypes) <- loadDisplayInfo codebase (R.ran dependsOn)
|
||||
(dirtyTerms, dirtyTypes) <- loadDisplayInfo codebase dirty
|
||||
pure $
|
||||
TO.TodoOutput
|
||||
(Set.size transitiveDirty)
|
||||
(frontierTerms, frontierTypes)
|
||||
(score dirtyTerms, score dirtyTypes)
|
||||
(Names.conflicts names0)
|
||||
(Patch.conflicts patch)
|
||||
where
|
||||
-- Remove from a all references that were edited, i.e. appear on the LHS of this patch.
|
||||
removeEditedThings :: Set Reference -> Set Reference
|
||||
removeEditedThings =
|
||||
(`Set.difference` edited)
|
||||
-- Remove all references that don't have a name in the given namespace
|
||||
removeNamelessThings :: Set Reference -> Set Reference
|
||||
removeNamelessThings =
|
||||
Set.filter (Names.contains names0)
|
||||
-- todo: something more intelligent here?
|
||||
score :: [(a, b)] -> [(TO.Score, a, b)]
|
||||
score = map (\(x, y) -> (1, x, y))
|
||||
edited :: Set Reference
|
||||
edited = R.dom (Patch._termEdits patch) <> R.dom (Patch._typeEdits patch)
|
||||
|
||||
confirmedCommand :: Input -> Cli Bool
|
||||
confirmedCommand i = do
|
||||
loopState <- State.get
|
||||
@ -1621,7 +1551,7 @@ checkDeletes typesTermsTuples doutput inputs = do
|
||||
(Path.HQSplit', Set Reference, Set Referent) ->
|
||||
Cli (Path.Split, Name, Set Reference, Set Referent)
|
||||
toSplitName hq = do
|
||||
resolvedPath <- Path.convert <$> Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
|
||||
resolvedPath <- first Path.unabsolute <$> Cli.resolveSplit' (HQ'.toName <$> hq ^. _1)
|
||||
return (resolvedPath, Path.unsafeToName (Path.unsplit resolvedPath), hq ^. _2, hq ^. _3)
|
||||
-- get the splits and names with terms and types
|
||||
splitsNames <- traverse toSplitName typesTermsTuples
|
||||
@ -1768,7 +1698,7 @@ docsI src = do
|
||||
(codebaseByName) Lastly check for `foo.doc` in the codebase and if found do `display foo.doc`
|
||||
-}
|
||||
dotDoc :: HQ.HashQualified Name
|
||||
dotDoc = Name.convert . Name.joinDot src $ Name.fromSegment NameSegment.docSegment
|
||||
dotDoc = HQ.NameOnly . Name.joinDot src $ Name.fromSegment NameSegment.docSegment
|
||||
|
||||
findInScratchfileByName :: Cli ()
|
||||
findInScratchfileByName = do
|
||||
@ -1780,27 +1710,6 @@ docsI src = do
|
||||
displayI ConsoleLocation (Names.longestTermName 10 (Set.findMin s) namesInFile)
|
||||
_ -> displayI ConsoleLocation dotDoc
|
||||
|
||||
loadDisplayInfo ::
|
||||
Codebase m Symbol Ann ->
|
||||
Set Reference ->
|
||||
Sqlite.Transaction
|
||||
( [(Reference, Maybe (Type Symbol Ann))],
|
||||
[(Reference, DisplayObject () (DD.Decl Symbol Ann))]
|
||||
)
|
||||
loadDisplayInfo codebase refs = do
|
||||
termRefs <- filterM (Codebase.isTerm codebase) (toList refs)
|
||||
typeRefs <- filterM (Codebase.isType codebase) (toList refs)
|
||||
terms <- forM termRefs $ \r -> (r,) <$> Codebase.getTypeOfTerm codebase r
|
||||
types <- forM typeRefs $ \r -> (r,) <$> loadTypeDisplayObject codebase r
|
||||
pure (terms, types)
|
||||
|
||||
loadTypeDisplayObject :: Codebase m Symbol Ann -> Reference -> Sqlite.Transaction (DisplayObject () (DD.Decl Symbol Ann))
|
||||
loadTypeDisplayObject codebase = \case
|
||||
Reference.Builtin _ -> pure (BuiltinObject ())
|
||||
Reference.DerivedId id ->
|
||||
maybe (MissingObject $ Reference.idToShortHash id) UserObject
|
||||
<$> Codebase.getTypeDeclaration codebase id
|
||||
|
||||
lexedSource :: Text -> Text -> Cli (Text, [L.Token L.Lexeme])
|
||||
lexedSource name src = do
|
||||
let tokens = L.lexer (Text.unpack name) (Text.unpack src)
|
||||
|
@ -124,7 +124,8 @@ doCreateBranch createFrom project newBranchName description = do
|
||||
CreateFrom'Branch (ProjectAndBranch _ sourceBranch)
|
||||
| sourceBranch.projectId == project.projectId -> Just sourceBranch.branchId
|
||||
_ -> Nothing
|
||||
doCreateBranch' sourceNamespaceObject parentBranchId project (pure newBranchName) description
|
||||
(newBranchId, _) <- doCreateBranch' sourceNamespaceObject parentBranchId project (pure newBranchName) description
|
||||
pure newBranchId
|
||||
|
||||
doCreateBranch' ::
|
||||
Branch IO ->
|
||||
@ -132,10 +133,10 @@ doCreateBranch' ::
|
||||
Sqlite.Project ->
|
||||
Sqlite.Transaction ProjectBranchName ->
|
||||
Text ->
|
||||
Cli ProjectBranchId
|
||||
Cli (ProjectBranchId, ProjectBranchName)
|
||||
doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName description = do
|
||||
let projectId = project ^. #projectId
|
||||
newBranchId <-
|
||||
(newBranchId, newBranchName) <-
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
newBranchName <- getNewBranchName
|
||||
Queries.projectBranchExistsByName projectId newBranchName >>= \case
|
||||
@ -152,9 +153,9 @@ doCreateBranch' sourceNamespaceObject parentBranchId project getNewBranchName de
|
||||
parentBranchId = parentBranchId
|
||||
}
|
||||
Queries.setMostRecentBranch projectId newBranchId
|
||||
pure newBranchId
|
||||
pure (newBranchId, newBranchName)
|
||||
|
||||
let newBranchPath = ProjectUtils.projectBranchPath (ProjectAndBranch projectId newBranchId)
|
||||
_ <- Cli.updateAt description newBranchPath (const sourceNamespaceObject)
|
||||
Cli.cd newBranchPath
|
||||
pure newBranchId
|
||||
pure (newBranchId, newBranchName)
|
||||
|
@ -0,0 +1,50 @@
|
||||
-- | @merge.commit@ handler.
|
||||
module Unison.Codebase.Editor.HandleInput.CommitMerge
|
||||
( handleCommitMerge,
|
||||
)
|
||||
where
|
||||
|
||||
import U.Codebase.Sqlite.Project qualified
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch
|
||||
import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Merge.TwoWay (TwoWay (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..))
|
||||
|
||||
-- Note: this implementation is similar to `upgrade.commit`.
|
||||
|
||||
handleCommitMerge :: Cli ()
|
||||
handleCommitMerge = do
|
||||
(mergeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
|
||||
|
||||
-- Assert that this is a "merge" branch, get its parent (which is the branch we were on when we ran `merge`),
|
||||
-- and switch to the parent.
|
||||
|
||||
parentBranchId <-
|
||||
ProjectUtils.getMergeBranchParent mergeProjectAndBranch.branch
|
||||
& onNothing (Cli.returnEarly Output.NoMergeInProgress)
|
||||
|
||||
parentBranch <-
|
||||
Cli.runTransaction do
|
||||
parentBranch <- Queries.expectProjectBranch mergeProjectAndBranch.project.projectId parentBranchId
|
||||
Queries.setMostRecentBranch parentBranch.projectId parentBranch.branchId
|
||||
pure parentBranch
|
||||
Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch parentBranch.projectId parentBranch.branchId))
|
||||
|
||||
-- Merge the merge branch into the parent
|
||||
|
||||
Merge.doMergeLocalBranch
|
||||
TwoWay
|
||||
{ alice = ProjectAndBranch mergeProjectAndBranch.project parentBranch,
|
||||
bob = mergeProjectAndBranch
|
||||
}
|
||||
|
||||
-- Delete the merge branch
|
||||
|
||||
DeleteBranch.doDeleteProjectBranch mergeProjectAndBranch
|
@ -5,43 +5,43 @@ module Unison.Codebase.Editor.HandleInput.CommitUpgrade
|
||||
where
|
||||
|
||||
import U.Codebase.Sqlite.Project qualified
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch
|
||||
import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge
|
||||
import Unison.Codebase.Editor.HandleInput.ProjectSwitch qualified as ProjectSwitch
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Merge.TwoWay (TwoWay (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..))
|
||||
|
||||
-- Note: this implementation is similar to `merge.commit`.
|
||||
|
||||
handleCommitUpgrade :: Cli ()
|
||||
handleCommitUpgrade = do
|
||||
(upgradeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch
|
||||
|
||||
-- Assert that this is an "upgrade" branch and get its parent, which is the branch we were on when we ran `upgrade`.
|
||||
-- Assert that this is an "upgrade" branch, get its parent (which is the branch we were on when we ran `upgrade`),
|
||||
-- and switch to the parent.
|
||||
|
||||
parentBranchId <-
|
||||
ProjectUtils.getUpgradeBranchParent upgradeProjectAndBranch.branch
|
||||
& onNothing (Cli.returnEarly Output.NoUpgradeInProgress)
|
||||
|
||||
parentBranch <-
|
||||
Cli.runTransaction do
|
||||
Queries.expectProjectBranch upgradeProjectAndBranch.project.projectId parentBranchId
|
||||
|
||||
let parentProjectAndBranch =
|
||||
ProjectAndBranch upgradeProjectAndBranch.project parentBranch
|
||||
|
||||
-- Switch to the parent
|
||||
|
||||
ProjectSwitch.switchToProjectBranch (ProjectUtils.justTheIds parentProjectAndBranch)
|
||||
parentBranch <- Queries.expectProjectBranch upgradeProjectAndBranch.project.projectId parentBranchId
|
||||
Queries.setMostRecentBranch parentBranch.projectId parentBranch.branchId
|
||||
pure parentBranch
|
||||
Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch parentBranch.projectId parentBranch.branchId))
|
||||
|
||||
-- Merge the upgrade branch into the parent
|
||||
|
||||
Merge.doMergeLocalBranch
|
||||
TwoWay
|
||||
{ alice = parentProjectAndBranch,
|
||||
{ alice = ProjectAndBranch upgradeProjectAndBranch.project parentBranch,
|
||||
bob = upgradeProjectAndBranch
|
||||
}
|
||||
|
||||
|
33
unison-cli/src/Unison/Codebase/Editor/HandleInput/Ls.hs
Normal file
33
unison-cli/src/Unison/Codebase/Editor/HandleInput/Ls.hs
Normal file
@ -0,0 +1,33 @@
|
||||
module Unison.Codebase.Editor.HandleInput.Ls
|
||||
( handleLs,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Monad.Reader (ask)
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.PrettyPrintUtils qualified as Cli
|
||||
import Unison.Codebase.Editor.Output
|
||||
import Unison.Codebase.Editor.StructuredArgument qualified as SA
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPED
|
||||
import Unison.Server.Backend qualified as Backend
|
||||
|
||||
handleLs :: Path' -> Cli ()
|
||||
handleLs pathArg = do
|
||||
Cli.Env {codebase} <- ask
|
||||
|
||||
pathArgAbs <- Cli.resolvePath' pathArg
|
||||
entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs)
|
||||
Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries
|
||||
pped <- Cli.currentPrettyPrintEnvDecl
|
||||
let suffixifiedPPE = PPED.suffixifiedPPE pped
|
||||
-- This used to be a delayed action which only forced the loading of the root
|
||||
-- branch when it was necessary for printing the results, but that got wiped out
|
||||
-- when we ported to the new Cli monad.
|
||||
-- It would be nice to restore it, but it's pretty rare that it actually results
|
||||
-- in an improvement, so perhaps it's not worth the effort.
|
||||
let buildPPE = pure suffixifiedPPE
|
||||
Cli.respond $ ListShallow buildPPE entries
|
@ -138,6 +138,7 @@ import Unison.Util.SyntaxText (SyntaxText')
|
||||
import Unison.Var (Var)
|
||||
import Witch (unsafeFrom)
|
||||
import Prelude hiding (unzip, zip, zipWith)
|
||||
import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup)
|
||||
|
||||
handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli ()
|
||||
handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do
|
||||
@ -200,235 +201,236 @@ doMerge info = do
|
||||
|
||||
Cli.Env {codebase} <- ask
|
||||
|
||||
Cli.label \done -> do
|
||||
-- If alice == bob, or LCA == bob (so alice is ahead of bob), then we are done.
|
||||
when (info.alice.causalHash == info.bob.causalHash || info.lca.causalHash == Just info.bob.causalHash) do
|
||||
Cli.respond (Output.MergeAlreadyUpToDate2 mergeSourceAndTarget)
|
||||
done ()
|
||||
finalOutput <-
|
||||
Cli.label \done -> do
|
||||
-- If alice == bob, or LCA == bob (so alice is ahead of bob), then we are done.
|
||||
when (info.alice.causalHash == info.bob.causalHash || info.lca.causalHash == Just info.bob.causalHash) do
|
||||
done (Output.MergeAlreadyUpToDate2 mergeSourceAndTarget)
|
||||
|
||||
-- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done.
|
||||
when (info.lca.causalHash == Just info.alice.causalHash) do
|
||||
bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash)
|
||||
_ <- Cli.updateAt info.description alicePath (\_aliceBranch -> bobBranch)
|
||||
Cli.respond (Output.MergeSuccessFastForward mergeSourceAndTarget)
|
||||
done ()
|
||||
-- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done.
|
||||
when (info.lca.causalHash == Just info.alice.causalHash) do
|
||||
bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash)
|
||||
_ <- Cli.updateAt info.description alicePath (\_aliceBranch -> bobBranch)
|
||||
done (Output.MergeSuccessFastForward mergeSourceAndTarget)
|
||||
|
||||
-- Create a bunch of cached database lookup functions
|
||||
db <- makeMergeDatabase codebase
|
||||
-- Create a bunch of cached database lookup functions
|
||||
db <- makeMergeDatabase codebase
|
||||
|
||||
-- Load Alice/Bob/LCA causals
|
||||
causals <- Cli.runTransaction do
|
||||
traverse
|
||||
Operations.expectCausalBranchByCausalHash
|
||||
TwoOrThreeWay
|
||||
{ alice = info.alice.causalHash,
|
||||
bob = info.bob.causalHash,
|
||||
lca = info.lca.causalHash
|
||||
}
|
||||
-- Load Alice/Bob/LCA causals
|
||||
causals <- Cli.runTransaction do
|
||||
traverse
|
||||
Operations.expectCausalBranchByCausalHash
|
||||
TwoOrThreeWay
|
||||
{ alice = info.alice.causalHash,
|
||||
bob = info.bob.causalHash,
|
||||
lca = info.lca.causalHash
|
||||
}
|
||||
|
||||
liftIO (debugFunctions.debugCausals causals)
|
||||
liftIO (debugFunctions.debugCausals causals)
|
||||
|
||||
-- Load Alice/Bob/LCA branches
|
||||
branches <-
|
||||
Cli.runTransaction do
|
||||
alice <- causals.alice.value
|
||||
bob <- causals.bob.value
|
||||
lca <- for causals.lca \causal -> causal.value
|
||||
pure TwoOrThreeWay {lca, alice, bob}
|
||||
-- Load Alice/Bob/LCA branches
|
||||
branches <-
|
||||
Cli.runTransaction do
|
||||
alice <- causals.alice.value
|
||||
bob <- causals.bob.value
|
||||
lca <- for causals.lca \causal -> causal.value
|
||||
pure TwoOrThreeWay {lca, alice, bob}
|
||||
|
||||
-- Assert that neither Alice nor Bob have defns in lib
|
||||
for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do
|
||||
libdeps <-
|
||||
case Map.lookup NameSegment.libSegment branch.children of
|
||||
Nothing -> pure V2.Branch.empty
|
||||
Just libdeps -> Cli.runTransaction libdeps.value
|
||||
when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do
|
||||
Cli.returnEarly (Output.MergeDefnsInLib who)
|
||||
-- Assert that neither Alice nor Bob have defns in lib
|
||||
for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do
|
||||
libdeps <-
|
||||
case Map.lookup NameSegment.libSegment branch.children of
|
||||
Nothing -> pure V2.Branch.empty
|
||||
Just libdeps -> Cli.runTransaction libdeps.value
|
||||
when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do
|
||||
done (Output.MergeDefnsInLib who)
|
||||
|
||||
-- Load Alice/Bob/LCA definitions and decl name lookups
|
||||
(defns3, declNameLookups, lcaDeclToConstructors) <- do
|
||||
let emptyNametree = Nametree {value = Defns Map.empty Map.empty, children = Map.empty}
|
||||
let loadDefns branch =
|
||||
Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName ->
|
||||
Cli.returnEarly case conflictedName of
|
||||
ConflictedName'Term name refs -> Output.MergeConflictedTermName name refs
|
||||
ConflictedName'Type name refs -> Output.MergeConflictedTypeName name refs
|
||||
let load = \case
|
||||
Nothing -> pure (emptyNametree, DeclNameLookup Map.empty Map.empty)
|
||||
Just (who, branch) -> do
|
||||
defns <- loadDefns branch
|
||||
declNameLookup <-
|
||||
Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err ->
|
||||
Cli.returnEarly case err of
|
||||
IncoherentDeclReason'ConstructorAlias typeName conName1 conName2 ->
|
||||
Output.MergeConstructorAlias who typeName conName1 conName2
|
||||
IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName who name
|
||||
IncoherentDeclReason'NestedDeclAlias shorterName longerName ->
|
||||
Output.MergeNestedDeclAlias who shorterName longerName
|
||||
IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor who name
|
||||
pure (defns, declNameLookup)
|
||||
-- Load Alice/Bob/LCA definitions and decl name lookups
|
||||
(defns3, declNameLookups, lcaDeclNameLookup) <- do
|
||||
let emptyNametree = Nametree {value = Defns Map.empty Map.empty, children = Map.empty}
|
||||
let loadDefns branch =
|
||||
Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName ->
|
||||
done case conflictedName of
|
||||
ConflictedName'Term name refs -> Output.MergeConflictedTermName name refs
|
||||
ConflictedName'Type name refs -> Output.MergeConflictedTypeName name refs
|
||||
let load = \case
|
||||
Nothing -> pure (emptyNametree, DeclNameLookup Map.empty Map.empty)
|
||||
Just (who, branch) -> do
|
||||
defns <- loadDefns branch
|
||||
declNameLookup <-
|
||||
Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err ->
|
||||
done case err of
|
||||
IncoherentDeclReason'ConstructorAlias typeName conName1 conName2 ->
|
||||
Output.MergeConstructorAlias who typeName conName1 conName2
|
||||
IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName who name
|
||||
IncoherentDeclReason'NestedDeclAlias shorterName longerName ->
|
||||
Output.MergeNestedDeclAlias who shorterName longerName
|
||||
IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor who name
|
||||
pure (defns, declNameLookup)
|
||||
|
||||
(aliceDefns0, aliceDeclNameLookup) <- load (Just (mergeTarget, branches.alice))
|
||||
(bobDefns0, bobDeclNameLookup) <- load (Just (mergeSource, branches.bob))
|
||||
lcaDefns0 <- maybe (pure emptyNametree) loadDefns branches.lca
|
||||
lcaDeclToConstructors <- Cli.runTransaction (lenientCheckDeclCoherency db.loadDeclNumConstructors lcaDefns0)
|
||||
(aliceDefns0, aliceDeclNameLookup) <- load (Just (mergeTarget, branches.alice))
|
||||
(bobDefns0, bobDeclNameLookup) <- load (Just (mergeSource, branches.bob))
|
||||
lcaDefns0 <- maybe (pure emptyNametree) loadDefns branches.lca
|
||||
lcaDeclNameLookup <- Cli.runTransaction (lenientCheckDeclCoherency db.loadDeclNumConstructors lcaDefns0)
|
||||
|
||||
let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns)
|
||||
let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0}
|
||||
let declNameLookups = TwoWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup}
|
||||
let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns)
|
||||
let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0}
|
||||
let declNameLookups = TwoWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup}
|
||||
|
||||
pure (defns3, declNameLookups, lcaDeclToConstructors)
|
||||
pure (defns3, declNameLookups, lcaDeclNameLookup)
|
||||
|
||||
let defns = ThreeWay.forgetLca defns3
|
||||
let defns = ThreeWay.forgetLca defns3
|
||||
|
||||
liftIO (debugFunctions.debugDefns defns3 declNameLookups lcaDeclToConstructors)
|
||||
liftIO (debugFunctions.debugDefns defns3 declNameLookups lcaDeclNameLookup)
|
||||
|
||||
-- Diff LCA->Alice and LCA->Bob
|
||||
diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns3)
|
||||
-- Diff LCA->Alice and LCA->Bob
|
||||
diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups lcaDeclNameLookup defns3)
|
||||
|
||||
liftIO (debugFunctions.debugDiffs diffs)
|
||||
liftIO (debugFunctions.debugDiffs diffs)
|
||||
|
||||
-- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias
|
||||
for_ ((,) <$> TwoWay mergeTarget mergeSource <*> diffs) \(who, diff) ->
|
||||
whenJust (findConflictedAlias defns3.lca diff) \(name1, name2) ->
|
||||
Cli.returnEarly (Output.MergeConflictedAliases who name1 name2)
|
||||
-- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias
|
||||
for_ ((,) <$> TwoWay mergeTarget mergeSource <*> diffs) \(who, diff) ->
|
||||
whenJust (findConflictedAlias defns3.lca diff) \(name1, name2) ->
|
||||
done (Output.MergeConflictedAliases who name1 name2)
|
||||
|
||||
-- Combine the LCA->Alice and LCA->Bob diffs together
|
||||
let diff = combineDiffs diffs
|
||||
-- Combine the LCA->Alice and LCA->Bob diffs together
|
||||
let diff = combineDiffs diffs
|
||||
|
||||
liftIO (debugFunctions.debugCombinedDiff diff)
|
||||
liftIO (debugFunctions.debugCombinedDiff diff)
|
||||
|
||||
-- Partition the combined diff into the conflicted things and the unconflicted things
|
||||
(conflicts, unconflicts) <-
|
||||
partitionCombinedDiffs defns declNameLookups diff & onLeft \name ->
|
||||
Cli.returnEarly (Output.MergeConflictInvolvingBuiltin name)
|
||||
-- Partition the combined diff into the conflicted things and the unconflicted things
|
||||
(conflicts, unconflicts) <-
|
||||
partitionCombinedDiffs defns declNameLookups diff & onLeft \name ->
|
||||
done (Output.MergeConflictInvolvingBuiltin name)
|
||||
|
||||
liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts)
|
||||
liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts)
|
||||
|
||||
-- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there
|
||||
-- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are)
|
||||
dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts)
|
||||
-- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there
|
||||
-- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are)
|
||||
dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts)
|
||||
|
||||
liftIO (debugFunctions.debugDependents dependents)
|
||||
liftIO (debugFunctions.debugDependents dependents)
|
||||
|
||||
let stageOne :: DefnsF (Map Name) Referent TypeReference
|
||||
stageOne =
|
||||
makeStageOne
|
||||
declNameLookups
|
||||
conflicts
|
||||
unconflicts
|
||||
dependents
|
||||
(bimap BiMultimap.range BiMultimap.range defns3.lca)
|
||||
let stageOne :: DefnsF (Map Name) Referent TypeReference
|
||||
stageOne =
|
||||
makeStageOne
|
||||
declNameLookups
|
||||
conflicts
|
||||
unconflicts
|
||||
dependents
|
||||
(bimap BiMultimap.range BiMultimap.range defns3.lca)
|
||||
|
||||
liftIO (debugFunctions.debugStageOne stageOne)
|
||||
liftIO (debugFunctions.debugStageOne stageOne)
|
||||
|
||||
-- Load and merge Alice's and Bob's libdeps
|
||||
mergedLibdeps <-
|
||||
Cli.runTransaction do
|
||||
libdeps <- loadLibdeps branches
|
||||
libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps)
|
||||
-- Load and merge Alice's and Bob's libdeps
|
||||
mergedLibdeps <-
|
||||
Cli.runTransaction do
|
||||
libdeps <- loadLibdeps branches
|
||||
libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps)
|
||||
|
||||
-- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names
|
||||
let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl
|
||||
mkPpes defnsNames libdepsNames =
|
||||
defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier
|
||||
where
|
||||
suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames)
|
||||
let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps)
|
||||
-- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names
|
||||
let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl
|
||||
mkPpes defnsNames libdepsNames =
|
||||
defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier
|
||||
where
|
||||
suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames)
|
||||
let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps)
|
||||
|
||||
hydratedThings <- do
|
||||
Cli.runTransaction do
|
||||
for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) ->
|
||||
let hydrate = hydrateDefns (Codebase.unsafeGetTermComponent codebase) Operations.expectDeclComponent
|
||||
in (,) <$> hydrate conflicts1 <*> hydrate dependents1
|
||||
hydratedThings <- do
|
||||
Cli.runTransaction do
|
||||
for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) ->
|
||||
let hydrate = hydrateDefns (Codebase.unsafeGetTermComponent codebase) Operations.expectDeclComponent
|
||||
in (,) <$> hydrate conflicts1 <*> hydrate dependents1
|
||||
|
||||
let (renderedConflicts, renderedDependents) =
|
||||
let honk declNameLookup ppe defns =
|
||||
let (types, accessorNames) =
|
||||
Writer.runWriter $
|
||||
defns.types & Map.traverseWithKey \name (ref, typ) ->
|
||||
renderTypeBinding
|
||||
-- Sort of a hack; since the decl printer looks in the PPE for names of constructors,
|
||||
-- we just delete all term names out and add back the constructors...
|
||||
-- probably no need to wipe out the suffixified side but we do it anyway
|
||||
(setPpedToConstructorNames declNameLookup name ref ppe)
|
||||
name
|
||||
ref
|
||||
typ
|
||||
terms =
|
||||
defns.terms & Map.mapMaybeWithKey \name (term, typ) ->
|
||||
if Set.member name accessorNames
|
||||
then Nothing
|
||||
else Just (renderTermBinding ppe.suffixifiedPPE name term typ)
|
||||
in Defns {terms, types}
|
||||
in unzip $
|
||||
( \declNameLookup (conflicts, dependents) ppe ->
|
||||
let honk1 = honk declNameLookup ppe
|
||||
in (honk1 conflicts, honk1 dependents)
|
||||
)
|
||||
<$> declNameLookups
|
||||
<*> hydratedThings
|
||||
<*> ppes
|
||||
let (renderedConflicts, renderedDependents) =
|
||||
let honk declNameLookup ppe defns =
|
||||
let (types, accessorNames) =
|
||||
Writer.runWriter $
|
||||
defns.types & Map.traverseWithKey \name (ref, typ) ->
|
||||
renderTypeBinding
|
||||
-- Sort of a hack; since the decl printer looks in the PPE for names of constructors,
|
||||
-- we just delete all term names out and add back the constructors...
|
||||
-- probably no need to wipe out the suffixified side but we do it anyway
|
||||
(setPpedToConstructorNames declNameLookup name ref ppe)
|
||||
name
|
||||
ref
|
||||
typ
|
||||
terms =
|
||||
defns.terms & Map.mapMaybeWithKey \name (term, typ) ->
|
||||
if Set.member name accessorNames
|
||||
then Nothing
|
||||
else Just (renderTermBinding ppe.suffixifiedPPE name term typ)
|
||||
in Defns {terms, types}
|
||||
in unzip $
|
||||
( \declNameLookup (conflicts, dependents) ppe ->
|
||||
let honk1 = honk declNameLookup ppe
|
||||
in (honk1 conflicts, honk1 dependents)
|
||||
)
|
||||
<$> declNameLookups
|
||||
<*> hydratedThings
|
||||
<*> ppes
|
||||
|
||||
let prettyUnisonFile =
|
||||
makePrettyUnisonFile
|
||||
TwoWay
|
||||
{ alice = into @Text aliceBranchNames,
|
||||
bob =
|
||||
case info.bob.source of
|
||||
MergeSource'LocalProjectBranch bobBranchNames -> into @Text bobBranchNames
|
||||
MergeSource'RemoteProjectBranch bobBranchNames
|
||||
| aliceBranchNames == bobBranchNames -> "remote " <> into @Text bobBranchNames
|
||||
| otherwise -> into @Text bobBranchNames
|
||||
MergeSource'RemoteLooseCode info ->
|
||||
case Path.toName info.path of
|
||||
Nothing -> "<root>"
|
||||
Just name -> Name.toText name
|
||||
}
|
||||
renderedConflicts
|
||||
renderedDependents
|
||||
let prettyUnisonFile =
|
||||
makePrettyUnisonFile
|
||||
TwoWay
|
||||
{ alice = into @Text aliceBranchNames,
|
||||
bob =
|
||||
case info.bob.source of
|
||||
MergeSource'LocalProjectBranch bobBranchNames -> into @Text bobBranchNames
|
||||
MergeSource'RemoteProjectBranch bobBranchNames
|
||||
| aliceBranchNames == bobBranchNames -> "remote " <> into @Text bobBranchNames
|
||||
| otherwise -> into @Text bobBranchNames
|
||||
MergeSource'RemoteLooseCode info ->
|
||||
case Path.toName info.path of
|
||||
Nothing -> "<root>"
|
||||
Just name -> Name.toText name
|
||||
}
|
||||
renderedConflicts
|
||||
renderedDependents
|
||||
|
||||
let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps
|
||||
let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps
|
||||
|
||||
maybeTypecheckedUnisonFile <-
|
||||
let thisMergeHasConflicts =
|
||||
-- Eh, they'd either both be null, or neither, but just check both maps anyway
|
||||
not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob)
|
||||
in if thisMergeHasConflicts
|
||||
then pure Nothing
|
||||
else do
|
||||
currentPath <- Cli.getCurrentPath
|
||||
parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch)
|
||||
prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe
|
||||
maybeTypecheckedUnisonFile <-
|
||||
let thisMergeHasConflicts =
|
||||
-- Eh, they'd either both be null, or neither, but just check both maps anyway
|
||||
not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob)
|
||||
in if thisMergeHasConflicts
|
||||
then pure Nothing
|
||||
else do
|
||||
currentPath <- Cli.getCurrentPath
|
||||
parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch)
|
||||
prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe
|
||||
|
||||
let parents =
|
||||
(\causal -> (causal.causalHash, Codebase.expectBranchForHash codebase causal.causalHash)) <$> causals
|
||||
let parents =
|
||||
(\causal -> (causal.causalHash, Codebase.expectBranchForHash codebase causal.causalHash)) <$> causals
|
||||
|
||||
case maybeTypecheckedUnisonFile of
|
||||
Nothing -> do
|
||||
Cli.Env {writeSource} <- ask
|
||||
_temporaryBranchId <-
|
||||
HandleInput.Branch.doCreateBranch'
|
||||
(Branch.mergeNode stageOneBranch parents.alice parents.bob)
|
||||
Nothing
|
||||
info.alice.projectAndBranch.project
|
||||
(findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget)
|
||||
info.description
|
||||
scratchFilePath <-
|
||||
Cli.getLatestFile <&> \case
|
||||
Nothing -> "scratch.u"
|
||||
Just (file, _) -> file
|
||||
liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile)
|
||||
Cli.respond (Output.MergeFailure scratchFilePath mergeSourceAndTarget)
|
||||
Just tuf -> do
|
||||
Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf)
|
||||
let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch
|
||||
_ <-
|
||||
Cli.updateAt
|
||||
info.description
|
||||
alicePath
|
||||
(\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
|
||||
Cli.respond (Output.MergeSuccess mergeSourceAndTarget)
|
||||
case maybeTypecheckedUnisonFile of
|
||||
Nothing -> do
|
||||
Cli.Env {writeSource} <- ask
|
||||
(_temporaryBranchId, temporaryBranchName) <-
|
||||
HandleInput.Branch.doCreateBranch'
|
||||
(Branch.mergeNode stageOneBranch parents.alice parents.bob)
|
||||
(Just info.alice.projectAndBranch.branch.branchId)
|
||||
info.alice.projectAndBranch.project
|
||||
(findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget)
|
||||
info.description
|
||||
scratchFilePath <-
|
||||
Cli.getLatestFile <&> \case
|
||||
Nothing -> "scratch.u"
|
||||
Just (file, _) -> file
|
||||
liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile)
|
||||
pure (Output.MergeFailure scratchFilePath mergeSourceAndTarget temporaryBranchName)
|
||||
Just tuf -> do
|
||||
Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf)
|
||||
let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch
|
||||
_ <-
|
||||
Cli.updateAt
|
||||
info.description
|
||||
alicePath
|
||||
(\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob)
|
||||
pure (Output.MergeSuccess mergeSourceAndTarget)
|
||||
|
||||
Cli.respond finalOutput
|
||||
|
||||
doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli ()
|
||||
doMergeLocalBranch branches = do
|
||||
@ -886,7 +888,7 @@ findTemporaryBranchName projectId mergeSourceAndTarget = do
|
||||
-- Fails if there is a conflicted name.
|
||||
loadNamespaceDefinitions ::
|
||||
forall m.
|
||||
Monad m =>
|
||||
(Monad m) =>
|
||||
(V2.Referent -> m Referent) ->
|
||||
V2.Branch m ->
|
||||
m (Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference)))
|
||||
@ -1037,7 +1039,7 @@ data DebugFunctions = DebugFunctions
|
||||
debugDefns ::
|
||||
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
TwoWay DeclNameLookup ->
|
||||
Map Name [Maybe Name] ->
|
||||
PartialDeclNameLookup ->
|
||||
IO (),
|
||||
debugDiffs :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> IO (),
|
||||
debugCombinedDiff :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO (),
|
||||
@ -1079,7 +1081,7 @@ realDebugCausals causals = do
|
||||
realDebugDefns ::
|
||||
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
TwoWay DeclNameLookup ->
|
||||
Map Name [Maybe Name] ->
|
||||
PartialDeclNameLookup ->
|
||||
IO ()
|
||||
realDebugDefns defns declNameLookups _lcaDeclNameLookup = do
|
||||
Text.putStrLn (Text.bold "\n=== Alice definitions ===")
|
||||
@ -1199,28 +1201,28 @@ realDebugPartitionedDiff conflicts unconflicts = do
|
||||
renderConflicts "typeid" conflicts.bob.types (Bob ())
|
||||
|
||||
Text.putStrLn (Text.bold "\n=== Alice unconflicts ===")
|
||||
renderUnconflicts Text.green "+" referentLabel Referent.toText unconflicts.terms.adds.alice (OnlyAlice ())
|
||||
renderUnconflicts Text.green "+" (const "type") Reference.toText unconflicts.types.adds.alice (OnlyAlice ())
|
||||
renderUnconflicts Text.red "-" referentLabel Referent.toText unconflicts.terms.deletes.alice (OnlyAlice ())
|
||||
renderUnconflicts Text.red "-" (const "type") Reference.toText unconflicts.types.deletes.alice (OnlyAlice ())
|
||||
renderUnconflicts Text.yellow "%" referentLabel Referent.toText unconflicts.terms.updates.alice (OnlyAlice ())
|
||||
renderUnconflicts Text.yellow "%" (const "type") Reference.toText unconflicts.types.updates.alice (OnlyAlice ())
|
||||
renderUnconflicts Text.green "+" referentLabel Referent.toText unconflicts.terms.adds.alice
|
||||
renderUnconflicts Text.green "+" (const "type") Reference.toText unconflicts.types.adds.alice
|
||||
renderUnconflicts Text.red "-" referentLabel Referent.toText unconflicts.terms.deletes.alice
|
||||
renderUnconflicts Text.red "-" (const "type") Reference.toText unconflicts.types.deletes.alice
|
||||
renderUnconflicts Text.yellow "%" referentLabel Referent.toText unconflicts.terms.updates.alice
|
||||
renderUnconflicts Text.yellow "%" (const "type") Reference.toText unconflicts.types.updates.alice
|
||||
|
||||
Text.putStrLn (Text.bold "\n=== Bob unconflicts ===")
|
||||
renderUnconflicts Text.green "+" referentLabel Referent.toText unconflicts.terms.adds.bob (OnlyBob ())
|
||||
renderUnconflicts Text.green "+" (const "type") Reference.toText unconflicts.types.adds.bob (OnlyBob ())
|
||||
renderUnconflicts Text.red "-" referentLabel Referent.toText unconflicts.terms.deletes.bob (OnlyBob ())
|
||||
renderUnconflicts Text.red "-" (const "type") Reference.toText unconflicts.types.deletes.bob (OnlyBob ())
|
||||
renderUnconflicts Text.yellow "%" referentLabel Referent.toText unconflicts.terms.updates.bob (OnlyBob ())
|
||||
renderUnconflicts Text.yellow "%" (const "type") Reference.toText unconflicts.types.updates.bob (OnlyBob ())
|
||||
renderUnconflicts Text.green "+" referentLabel Referent.toText unconflicts.terms.adds.bob
|
||||
renderUnconflicts Text.green "+" (const "type") Reference.toText unconflicts.types.adds.bob
|
||||
renderUnconflicts Text.red "-" referentLabel Referent.toText unconflicts.terms.deletes.bob
|
||||
renderUnconflicts Text.red "-" (const "type") Reference.toText unconflicts.types.deletes.bob
|
||||
renderUnconflicts Text.yellow "%" referentLabel Referent.toText unconflicts.terms.updates.bob
|
||||
renderUnconflicts Text.yellow "%" (const "type") Reference.toText unconflicts.types.updates.bob
|
||||
|
||||
Text.putStrLn (Text.bold "\n=== Alice-and-Bob unconflicts ===")
|
||||
renderUnconflicts Text.green "+" referentLabel Referent.toText unconflicts.terms.adds.both (AliceAndBob ())
|
||||
renderUnconflicts Text.green "+" (const "type") Reference.toText unconflicts.types.adds.both (AliceAndBob ())
|
||||
renderUnconflicts Text.red "-" referentLabel Referent.toText unconflicts.terms.deletes.both (AliceAndBob ())
|
||||
renderUnconflicts Text.red "-" (const "type") Reference.toText unconflicts.types.deletes.both (AliceAndBob ())
|
||||
renderUnconflicts Text.yellow "%" referentLabel Referent.toText unconflicts.terms.updates.both (AliceAndBob ())
|
||||
renderUnconflicts Text.yellow "%" (const "type") Reference.toText unconflicts.types.updates.both (AliceAndBob ())
|
||||
renderUnconflicts Text.green "+" referentLabel Referent.toText unconflicts.terms.adds.both
|
||||
renderUnconflicts Text.green "+" (const "type") Reference.toText unconflicts.types.adds.both
|
||||
renderUnconflicts Text.red "-" referentLabel Referent.toText unconflicts.terms.deletes.both
|
||||
renderUnconflicts Text.red "-" (const "type") Reference.toText unconflicts.types.deletes.both
|
||||
renderUnconflicts Text.yellow "%" referentLabel Referent.toText unconflicts.terms.updates.both
|
||||
renderUnconflicts Text.yellow "%" (const "type") Reference.toText unconflicts.types.updates.both
|
||||
where
|
||||
renderConflicts :: Text -> Map Name Reference.Id -> EitherWay () -> IO ()
|
||||
renderConflicts label conflicts who =
|
||||
@ -1243,9 +1245,8 @@ realDebugPartitionedDiff conflicts unconflicts = do
|
||||
(ref -> Text) ->
|
||||
(ref -> Text) ->
|
||||
Map Name ref ->
|
||||
EitherWayI () ->
|
||||
IO ()
|
||||
renderUnconflicts color action label renderRef unconflicts who =
|
||||
renderUnconflicts color action label renderRef unconflicts =
|
||||
for_ (Map.toList unconflicts) \(name, ref) ->
|
||||
Text.putStrLn $
|
||||
color $
|
||||
@ -1256,9 +1257,6 @@ realDebugPartitionedDiff conflicts unconflicts = do
|
||||
<> Name.toText name
|
||||
<> " "
|
||||
<> renderRef ref
|
||||
<> " ("
|
||||
<> (case who of OnlyAlice () -> "Alice"; OnlyBob () -> "Bob"; AliceAndBob () -> "Alice and Bob")
|
||||
<> ")"
|
||||
|
||||
realDebugDependents :: TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) -> IO ()
|
||||
realDebugDependents dependents = do
|
||||
|
@ -26,14 +26,14 @@ moveTermSteps src' dest' = do
|
||||
Cli.returnEarly (Output.DeleteNameAmbiguous hqLength src' srcTerms Set.empty)
|
||||
[srcTerm] -> do
|
||||
dest <- Cli.resolveSplit' dest'
|
||||
destTerms <- Cli.getTermsAt (Path.convert dest)
|
||||
destTerms <- Cli.getTermsAt (HQ'.NameOnly <$> dest)
|
||||
when (not (Set.null destTerms)) do
|
||||
Cli.returnEarly (Output.TermAlreadyExists dest' destTerms)
|
||||
let p = Path.convert src
|
||||
let p = first Path.unabsolute src
|
||||
pure
|
||||
[ -- Mitchell: throwing away any hash-qualification here seems wrong!
|
||||
BranchUtil.makeDeleteTermName (over _2 HQ'.toName p) srcTerm,
|
||||
BranchUtil.makeAddTermName (Path.convert dest) srcTerm
|
||||
BranchUtil.makeAddTermName (first Path.unabsolute dest) srcTerm
|
||||
]
|
||||
|
||||
doMoveTerm :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli ()
|
||||
|
@ -26,14 +26,14 @@ moveTypeSteps src' dest' = do
|
||||
Cli.returnEarly (Output.DeleteNameAmbiguous hqLength src' Set.empty srcTypes)
|
||||
[srcType] -> do
|
||||
dest <- Cli.resolveSplit' dest'
|
||||
destTypes <- Cli.getTypesAt (Path.convert dest)
|
||||
destTypes <- Cli.getTypesAt (HQ'.NameOnly <$> dest)
|
||||
when (not (Set.null destTypes)) do
|
||||
Cli.returnEarly (Output.TypeAlreadyExists dest' destTypes)
|
||||
let p = Path.convert src
|
||||
let p = first Path.unabsolute src
|
||||
pure
|
||||
[ -- Mitchell: throwing away any hash-qualification here seems wrong!
|
||||
BranchUtil.makeDeleteTypeName (over _2 HQ'.toName p) srcType,
|
||||
BranchUtil.makeAddTypeName (Path.convert dest) srcType
|
||||
BranchUtil.makeAddTypeName (first Path.unabsolute dest) srcType
|
||||
]
|
||||
|
||||
doMoveType :: (Path', HQ'.HQSegment) -> (Path', NameSegment) -> Text -> Cli ()
|
||||
|
@ -10,7 +10,6 @@ import Data.Text qualified as Text
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import System.Random.Shuffle qualified as RandomShuffle
|
||||
import U.Codebase.Sqlite.DbId
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare)
|
||||
import Unison.Cli.Monad (Cli)
|
||||
@ -22,11 +21,11 @@ import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as Ops
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectName)
|
||||
import Unison.Share.API.Hash qualified as Share.API
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Sync.Common qualified as Sync.Common
|
||||
import Witch (unsafeFrom)
|
||||
|
||||
@ -73,7 +72,7 @@ projectCreate tryDownloadingBase maybeProjectName = do
|
||||
projectName : projectNames ->
|
||||
Queries.projectExistsByName projectName >>= \case
|
||||
False -> do
|
||||
insertProjectAndBranch projectId projectName branchId branchName
|
||||
Ops.insertProjectAndBranch projectId projectName branchId branchName
|
||||
pure projectName
|
||||
True -> loop projectNames
|
||||
loop randomProjectNames
|
||||
@ -81,7 +80,7 @@ projectCreate tryDownloadingBase maybeProjectName = do
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
Queries.projectExistsByName projectName >>= \case
|
||||
False -> do
|
||||
insertProjectAndBranch projectId projectName branchId branchName
|
||||
Ops.insertProjectAndBranch projectId projectName branchId branchName
|
||||
pure projectName
|
||||
True -> rollback (Output.ProjectNameAlreadyExists projectName)
|
||||
|
||||
@ -152,18 +151,6 @@ projectCreate tryDownloadingBase maybeProjectName = do
|
||||
Nothing -> "project.create"
|
||||
Just projectName -> "project.create " <> into @Text projectName
|
||||
|
||||
insertProjectAndBranch :: ProjectId -> ProjectName -> ProjectBranchId -> ProjectBranchName -> Sqlite.Transaction ()
|
||||
insertProjectAndBranch projectId projectName branchId branchName = do
|
||||
Queries.insertProject projectId projectName
|
||||
Queries.insertProjectBranch
|
||||
Sqlite.ProjectBranch
|
||||
{ projectId,
|
||||
branchId,
|
||||
name = branchName,
|
||||
parentBranchId = Nothing
|
||||
}
|
||||
Queries.setMostRecentBranch projectId branchId
|
||||
|
||||
-- An infinite list of random project names that looks like
|
||||
--
|
||||
-- [
|
||||
|
@ -1,13 +1,12 @@
|
||||
-- | @switch@ input handler
|
||||
module Unison.Codebase.Editor.HandleInput.ProjectSwitch
|
||||
( projectSwitch,
|
||||
switchToProjectBranch,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.These (These (..))
|
||||
import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId)
|
||||
import U.Codebase.Sqlite.Project qualified
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
@ -59,21 +58,21 @@ switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do
|
||||
project <-
|
||||
Queries.loadProjectByName projectName & onNothingM do
|
||||
rollback (Output.LocalProjectDoesntExist projectName)
|
||||
let branchName = unsafeFrom @Text "main"
|
||||
Queries.loadProjectBranchByName project.projectId branchName & onNothingM do
|
||||
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
|
||||
Queries.loadMostRecentBranch project.projectId >>= \case
|
||||
Nothing -> do
|
||||
let branchName = unsafeFrom @Text "main"
|
||||
branch <-
|
||||
Queries.loadProjectBranchByName project.projectId branchName & onNothingM do
|
||||
rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName))
|
||||
Queries.setMostRecentBranch branch.projectId branch.branchId
|
||||
pure branch
|
||||
Just branchId -> Queries.expectProjectBranch project.projectId branchId
|
||||
_ -> do
|
||||
projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0
|
||||
projectAndBranchNames <- ProjectUtils.hydrateNames projectAndBranchNames0
|
||||
Cli.runTransactionWithRollback \rollback -> do
|
||||
Queries.loadProjectBranchByNames projectName branchName & onNothingM do
|
||||
rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
|
||||
switchToProjectBranch (ProjectUtils.justTheIds' branch)
|
||||
|
||||
-- | Switch to a branch:
|
||||
--
|
||||
-- * Record it as the most-recent branch (so it's restored when ucm starts).
|
||||
-- * Change the current path in the in-memory loop state.
|
||||
switchToProjectBranch :: ProjectAndBranch ProjectId ProjectBranchId -> Cli ()
|
||||
switchToProjectBranch x = do
|
||||
Cli.runTransaction (Queries.setMostRecentBranch x.project x.branch)
|
||||
Cli.cd (ProjectUtils.projectBranchPath x)
|
||||
branch <-
|
||||
Queries.loadProjectBranchByNames projectAndBranchNames.project projectAndBranchNames.branch & onNothingM do
|
||||
rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)
|
||||
Queries.setMostRecentBranch branch.projectId branch.branchId
|
||||
pure branch
|
||||
Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch branch.projectId branch.branchId))
|
||||
|
70
unison-cli/src/Unison/Codebase/Editor/HandleInput/Todo.hs
Normal file
70
unison-cli/src/Unison/Codebase/Editor/HandleInput/Todo.hs
Normal file
@ -0,0 +1,70 @@
|
||||
-- | @todo@ input handler
|
||||
module Unison.Codebase.Editor.HandleInput.Todo
|
||||
( handleTodo,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Set qualified as Set
|
||||
import U.Codebase.Sqlite.Operations qualified as Operations
|
||||
import Unison.Builtin qualified as Builtin
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.PrettyPrintUtils qualified as Cli
|
||||
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.Output
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (TermReference)
|
||||
import Unison.Syntax.Name qualified as Name
|
||||
import Unison.Util.Defns (Defns (..))
|
||||
import Unison.Util.Set qualified as Set
|
||||
|
||||
handleTodo :: Cli ()
|
||||
handleTodo = do
|
||||
-- For now, we don't go through any great trouble to seek out the root of the project branch. Just assume the current
|
||||
-- namespace is the root, which will be the case unless the user uses `deprecated.cd`.
|
||||
currentNamespace <- Cli.getCurrentBranch0
|
||||
let currentNamespaceWithoutLibdeps = Branch.deleteLibdeps currentNamespace
|
||||
|
||||
(dependentsOfTodo, directDependencies, hashLen) <-
|
||||
Cli.runTransaction do
|
||||
let todoReference :: TermReference
|
||||
todoReference =
|
||||
Set.asSingleton (Names.refTermsNamed Builtin.names (Name.unsafeParseText "todo"))
|
||||
& fromMaybe (error (reportBug "E260496" "No reference for builtin named 'todo'"))
|
||||
|
||||
-- All type-and-term dependents of the `todo` builtin, but we know they're all terms.
|
||||
dependentsOfTodo <-
|
||||
Operations.directDependentsWithinScope
|
||||
(Branch.deepTermReferenceIds currentNamespaceWithoutLibdeps)
|
||||
(Set.singleton todoReference)
|
||||
|
||||
directDependencies <-
|
||||
Operations.directDependenciesOfScope
|
||||
Defns
|
||||
{ terms = Branch.deepTermReferenceIds currentNamespaceWithoutLibdeps,
|
||||
types = Branch.deepTypeReferenceIds currentNamespaceWithoutLibdeps
|
||||
}
|
||||
|
||||
hashLen <- Codebase.hashLength
|
||||
|
||||
pure (dependentsOfTodo.terms, directDependencies, hashLen)
|
||||
|
||||
ppe <- Cli.currentPrettyPrintEnvDecl
|
||||
|
||||
Cli.respondNumbered $
|
||||
Output'Todo
|
||||
TodoOutput
|
||||
{ hashLen,
|
||||
dependentsOfTodo,
|
||||
directDependenciesWithoutNames =
|
||||
Defns
|
||||
{ terms = Set.difference directDependencies.terms (Branch.deepTermReferences currentNamespace),
|
||||
types = Set.difference directDependencies.types (Branch.deepTypeReferences currentNamespace)
|
||||
},
|
||||
nameConflicts = Names.conflicts (Branch.toNames currentNamespaceWithoutLibdeps),
|
||||
ppe
|
||||
}
|
@ -511,17 +511,8 @@ getNamespaceDependentsOf ::
|
||||
Set Reference ->
|
||||
Transaction (DefnsF (Relation Name) TermReferenceId TypeReferenceId)
|
||||
getNamespaceDependentsOf names dependencies = do
|
||||
dependents <- Ops.dependentsWithinScope (Names.referenceIds names) dependencies
|
||||
let dependents1 :: DefnsF Set TermReferenceId TypeReferenceId
|
||||
dependents1 =
|
||||
Map.foldlWithKey'
|
||||
( \defns refId -> \case
|
||||
Reference.RtTerm -> let !terms1 = Set.insert refId defns.terms in defns & #terms .~ terms1
|
||||
Reference.RtType -> let !types1 = Set.insert refId defns.types in defns & #types .~ types1
|
||||
)
|
||||
(Defns Set.empty Set.empty)
|
||||
dependents
|
||||
pure (bimap (foldMap nameTerm) (foldMap nameType) dependents1)
|
||||
dependents <- Ops.transitiveDependentsWithinScope (Names.referenceIds names) dependencies
|
||||
pure (bimap (foldMap nameTerm) (foldMap nameType) dependents)
|
||||
where
|
||||
nameTerm :: TermReferenceId -> Relation Name TermReferenceId
|
||||
nameTerm ref =
|
||||
@ -542,26 +533,21 @@ getNamespaceDependentsOf2 defns dependencies = do
|
||||
let scope = bifoldMap toTermScope toTypeScope defns
|
||||
|
||||
dependents <-
|
||||
Ops.dependentsWithinScope scope dependencies
|
||||
|
||||
let (termDependentRefs, typeDependentRefs) =
|
||||
dependents & Map.partition \case
|
||||
Reference.RtTerm -> True
|
||||
Reference.RtType -> False
|
||||
Ops.transitiveDependentsWithinScope scope dependencies
|
||||
|
||||
pure
|
||||
Defns
|
||||
{ terms = Map.foldlWithKey' addTerms Map.empty termDependentRefs,
|
||||
types = Map.foldlWithKey' addTypes Map.empty typeDependentRefs
|
||||
{ terms = Set.foldl' addTerms Map.empty dependents.terms,
|
||||
types = Set.foldl' addTypes Map.empty dependents.types
|
||||
}
|
||||
where
|
||||
addTerms :: Map Name TermReferenceId -> TermReferenceId -> ignored -> Map Name TermReferenceId
|
||||
addTerms acc0 ref _ =
|
||||
addTerms :: Map Name TermReferenceId -> TermReferenceId -> Map Name TermReferenceId
|
||||
addTerms acc0 ref =
|
||||
let names = BiMultimap.lookupDom (Referent.fromTermReferenceId ref) defns.terms
|
||||
in Set.foldl' (\acc name -> Map.insert name ref acc) acc0 names
|
||||
|
||||
addTypes :: Map Name TypeReferenceId -> TypeReferenceId -> ignored -> Map Name TypeReferenceId
|
||||
addTypes acc0 ref _ =
|
||||
addTypes :: Map Name TypeReferenceId -> TypeReferenceId -> Map Name TypeReferenceId
|
||||
addTypes acc0 ref =
|
||||
let names = BiMultimap.lookupDom (Reference.fromId ref) defns.types
|
||||
in Set.foldl' (\acc name -> Map.insert name ref acc) acc0 names
|
||||
|
||||
|
@ -132,7 +132,7 @@ data Input
|
||||
-- > names .foo.bar#asdflkjsdf
|
||||
-- > names #sdflkjsdfhsdf
|
||||
NamesI IsGlobal (HQ.HashQualified Name)
|
||||
| AliasTermI HashOrHQSplit' Path.Split'
|
||||
| AliasTermI !Bool HashOrHQSplit' Path.Split' -- bool = force?
|
||||
| AliasTypeI HashOrHQSplit' Path.Split'
|
||||
| AliasManyI [Path.HQSplit] Path'
|
||||
| MoveAllI Path.Path' Path.Path'
|
||||
@ -150,7 +150,7 @@ data Input
|
||||
| UpdateI OptionalPatch (Set Name)
|
||||
| Update2I
|
||||
| PreviewUpdateI (Set Name)
|
||||
| TodoI (Maybe PatchPath) Path'
|
||||
| TodoI
|
||||
| UndoI
|
||||
| -- First `Maybe Int` is cap on number of results, if any
|
||||
-- Second `Maybe Int` is cap on diff elements shown, if any
|
||||
@ -208,7 +208,7 @@ data Input
|
||||
| ApiI
|
||||
| UiI Path'
|
||||
| DocToMarkdownI Name
|
||||
| DocsToHtmlI Path' FilePath
|
||||
| DocsToHtmlI BranchRelativePath FilePath
|
||||
| AuthLoginI
|
||||
| VersionI
|
||||
| ProjectCreateI Bool {- try downloading base? -} (Maybe ProjectName)
|
||||
@ -228,6 +228,7 @@ data Input
|
||||
!Bool -- Remind the user to use `lib.install` next time, not `pull`?
|
||||
!(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease))
|
||||
| UpgradeCommitI
|
||||
| MergeCommitI
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | The source of a `branch` command: what to make the new branch from.
|
||||
|
@ -8,6 +8,7 @@ module Unison.Codebase.Editor.Output
|
||||
ListDetailed,
|
||||
HistoryTail (..),
|
||||
TestReportStats (..),
|
||||
TodoOutput (..),
|
||||
UndoFailureReason (..),
|
||||
ShareError (..),
|
||||
UpdateOrUpgrade (..),
|
||||
@ -37,7 +38,6 @@ import Unison.Codebase.Editor.RemoteRepo
|
||||
import Unison.Codebase.Editor.SlurpResult (SlurpResult (..))
|
||||
import Unison.Codebase.Editor.SlurpResult qualified as SR
|
||||
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
|
||||
import Unison.Codebase.Editor.TodoOutput qualified as TO
|
||||
import Unison.Codebase.IntegrityCheck (IntegrityResult (..))
|
||||
import Unison.Codebase.Path (Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
@ -59,9 +59,10 @@ import Unison.NamesWithHistory qualified as Names
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.PrettyPrintEnv qualified as PPE
|
||||
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl)
|
||||
import Unison.PrettyPrintEnvDecl qualified as PPE
|
||||
import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName, Semver)
|
||||
import Unison.Reference (Reference, TermReferenceId, TypeReference)
|
||||
import Unison.Reference (Reference, TermReference, TermReferenceId, TypeReference)
|
||||
import Unison.Reference qualified as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Server.Backend (ShallowListEntry (..))
|
||||
@ -75,6 +76,7 @@ import Unison.Term (Term)
|
||||
import Unison.Type (Type)
|
||||
import Unison.Typechecker.Context qualified as Context
|
||||
import Unison.UnisonFile qualified as UF
|
||||
import Unison.Util.Defns (DefnsF)
|
||||
import Unison.Util.Pretty qualified as P
|
||||
import Unison.Util.Relation (Relation)
|
||||
import Unison.WatchKind qualified as WK
|
||||
@ -117,8 +119,7 @@ data NumberedOutput
|
||||
| ShowDiffAfterPull Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
|
||||
| -- <authorIdentifier> <authorPath> <relativeBase>
|
||||
ShowDiffAfterCreateAuthor NameSegment Path.Path' Path.Absolute PPE.PrettyPrintEnv (BranchDiffOutput Symbol Ann)
|
||||
| -- | Invariant: there's at least one conflict or edit in the TodoOutput.
|
||||
TodoOutput PPE.PrettyPrintEnvDecl (TO.TodoOutput Symbol Ann)
|
||||
| Output'Todo !TodoOutput
|
||||
| -- | CantDeleteDefinitions ppe couldntDelete becauseTheseStillReferenceThem
|
||||
CantDeleteDefinitions PPE.PrettyPrintEnvDecl (Map LabeledDependency (NESet LabeledDependency))
|
||||
| -- | CantDeleteNamespace ppe couldntDelete becauseTheseStillReferenceThem
|
||||
@ -141,6 +142,14 @@ data NumberedOutput
|
||||
Path.Absolute -- The namespace we're checking dependencies for.
|
||||
(Map LabeledDependency (Set Name)) -- Mapping of external dependencies to their local dependents.
|
||||
|
||||
data TodoOutput = TodoOutput
|
||||
{ dependentsOfTodo :: !(Set TermReferenceId),
|
||||
directDependenciesWithoutNames :: !(DefnsF Set TermReference TypeReference),
|
||||
hashLen :: !Int,
|
||||
nameConflicts :: !Names,
|
||||
ppe :: !PrettyPrintEnvDecl
|
||||
}
|
||||
|
||||
data AmbiguousReset'Argument
|
||||
= AmbiguousReset'Hash
|
||||
| AmbiguousReset'Target
|
||||
@ -293,8 +302,6 @@ data Output
|
||||
| PreviewMergeAlreadyUpToDate
|
||||
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
(Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch))
|
||||
| -- | No conflicts or edits remain for the current patch.
|
||||
NoConflictsOrEdits
|
||||
| NotImplemented
|
||||
| NoBranchWithHash ShortCausalHash
|
||||
| ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms
|
||||
@ -392,7 +399,7 @@ data Output
|
||||
| UpgradeFailure !ProjectBranchName !ProjectBranchName !FilePath !NameSegment !NameSegment
|
||||
| UpgradeSuccess !NameSegment !NameSegment
|
||||
| LooseCodePushDeprecated
|
||||
| MergeFailure !FilePath !MergeSourceAndTarget
|
||||
| MergeFailure !FilePath !MergeSourceAndTarget !ProjectBranchName
|
||||
| MergeSuccess !MergeSourceAndTarget
|
||||
| MergeSuccessFastForward !MergeSourceAndTarget
|
||||
| MergeConflictedAliases !MergeSourceOrTarget !Name !Name
|
||||
@ -408,6 +415,7 @@ data Output
|
||||
| NoUpgradeInProgress
|
||||
| UseLibInstallNotPull !(ProjectAndBranch ProjectName ProjectBranchName)
|
||||
| PullIntoMissingBranch !(ReadRemoteNamespace Share.RemoteProjectBranch) !(ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
|
||||
| NoMergeInProgress
|
||||
|
||||
data UpdateOrUpgrade = UOUUpdate | UOUUpgrade
|
||||
|
||||
@ -554,7 +562,6 @@ isFailure o = case o of
|
||||
MergeAlreadyUpToDate {} -> False
|
||||
MergeAlreadyUpToDate2 {} -> False
|
||||
PreviewMergeAlreadyUpToDate {} -> False
|
||||
NoConflictsOrEdits {} -> False
|
||||
ListShallow _ es -> null es
|
||||
HashAmbiguous {} -> True
|
||||
ShowReflog {} -> False
|
||||
@ -647,6 +654,7 @@ isFailure o = case o of
|
||||
NoUpgradeInProgress {} -> True
|
||||
UseLibInstallNotPull {} -> False
|
||||
PullIntoMissingBranch {} -> True
|
||||
NoMergeInProgress {} -> True
|
||||
|
||||
isNumberedFailure :: NumberedOutput -> Bool
|
||||
isNumberedFailure = \case
|
||||
@ -669,4 +677,4 @@ isNumberedFailure = \case
|
||||
ShowDiffAfterUndo {} -> False
|
||||
ShowDiffNamespace _ _ _ bd -> BD.isEmpty bd
|
||||
ListNamespaceDependencies {} -> False
|
||||
TodoOutput _ todo -> TO.todoScore todo > 0 || not (TO.noConflicts todo)
|
||||
Output'Todo {} -> False
|
||||
|
@ -1,70 +0,0 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Unison.Codebase.Editor.TodoOutput where
|
||||
|
||||
import Data.Set qualified as Set
|
||||
import Unison.Codebase.Editor.DisplayObject (DisplayObject (UserObject))
|
||||
import Unison.Codebase.Patch (Patch)
|
||||
import Unison.Codebase.Patch qualified as Patch
|
||||
import Unison.DataDeclaration (Decl)
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
import Unison.LabeledDependency qualified as LD
|
||||
import Unison.Names (Names)
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Type (Type)
|
||||
import Unison.Type qualified as Type
|
||||
import Unison.Util.Relation qualified as R
|
||||
|
||||
type Score = Int
|
||||
|
||||
data TodoOutput v a = TodoOutput
|
||||
{ todoScore :: Score,
|
||||
todoFrontier ::
|
||||
( [(Reference, Maybe (Type v a))],
|
||||
[(Reference, DisplayObject () (Decl v a))]
|
||||
),
|
||||
todoFrontierDependents ::
|
||||
( [(Score, Reference, Maybe (Type v a))],
|
||||
[(Score, Reference, DisplayObject () (Decl v a))]
|
||||
),
|
||||
nameConflicts :: Names,
|
||||
editConflicts :: Patch
|
||||
}
|
||||
|
||||
labeledDependencies :: (Ord v) => TodoOutput v a -> Set LabeledDependency
|
||||
labeledDependencies TodoOutput {..} =
|
||||
Set.fromList
|
||||
( -- term refs
|
||||
[LD.termRef r | (r, _) <- fst todoFrontier]
|
||||
<> [LD.termRef r | (_, r, _) <- fst todoFrontierDependents]
|
||||
<> [LD.typeRef r | (r, _) <- snd todoFrontier]
|
||||
<> [LD.typeRef r | (_, r, _) <- snd todoFrontierDependents]
|
||||
<>
|
||||
-- types of term refs
|
||||
[ LD.typeRef r | (_, Just t) <- fst todoFrontier, r <- toList (Type.dependencies t)
|
||||
]
|
||||
<> [ LD.typeRef r | (_, _, Just t) <- fst todoFrontierDependents, r <- toList (Type.dependencies t)
|
||||
]
|
||||
<>
|
||||
-- and decls of type refs
|
||||
[ labeledDep | (declRef, UserObject d) <- snd todoFrontier, labeledDep <- toList (DD.labeledDeclDependenciesIncludingSelf declRef d)
|
||||
]
|
||||
<> [ labeledDep | (_, declRef, UserObject d) <- snd todoFrontierDependents, labeledDep <- toList (DD.labeledDeclDependenciesIncludingSelf declRef d)
|
||||
]
|
||||
)
|
||||
<>
|
||||
-- name conflicts
|
||||
Set.map LD.referent (R.ran (Names.terms nameConflicts))
|
||||
<> Set.map LD.typeRef (R.ran (Names.types nameConflicts))
|
||||
<> Patch.labeledDependencies editConflicts
|
||||
|
||||
noConflicts :: TodoOutput v a -> Bool
|
||||
noConflicts todo =
|
||||
nameConflicts todo == mempty && editConflicts todo == Patch.empty
|
||||
|
||||
noEdits :: TodoOutput v a -> Bool
|
||||
noEdits todo =
|
||||
todoScore todo == 0
|
@ -31,6 +31,7 @@ import Data.List (isSubsequenceOf)
|
||||
import Data.Map qualified as Map
|
||||
import Data.Text qualified as Text
|
||||
import Data.These (These (..))
|
||||
import Data.UUID.V4 qualified as UUID
|
||||
import Ki qualified
|
||||
import Network.HTTP.Client qualified as HTTP
|
||||
import System.Directory (doesFileExist)
|
||||
@ -39,7 +40,11 @@ import System.Exit (die)
|
||||
import System.IO qualified as IO
|
||||
import System.IO.Error (catchIOError)
|
||||
import Text.Megaparsec qualified as P
|
||||
import U.Codebase.Sqlite.DbId qualified as Db
|
||||
import U.Codebase.Sqlite.Operations qualified as Operations
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Q
|
||||
import Unison.Auth.CredentialManager qualified as AuthN
|
||||
import Unison.Auth.HTTPClient qualified as AuthN
|
||||
import Unison.Auth.Tokens qualified as AuthN
|
||||
@ -70,6 +75,7 @@ import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (ProjectAndB
|
||||
import Unison.Runtime.Interface qualified as RTI
|
||||
import Unison.Server.Backend qualified as Backend
|
||||
import Unison.Server.CodebaseServer qualified as Server
|
||||
import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.Parser qualified as Parser
|
||||
import Unison.Util.Pretty qualified as Pretty
|
||||
@ -349,10 +355,24 @@ run verbosity dir stanzas codebase runtime sbRuntime nRuntime config ucmVersion
|
||||
if curPath == path
|
||||
then pure Nothing
|
||||
else pure $ Just (SwitchBranchI (Path.absoluteToPath' path))
|
||||
UcmContextProject (ProjectAndBranch projectName branchName) -> do
|
||||
ProjectAndBranch project branch <-
|
||||
ProjectUtils.expectProjectAndBranchByTheseNames (These projectName branchName)
|
||||
let projectAndBranchIds = ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)
|
||||
UcmContextProject (ProjectAndBranch projectName branchName) -> Cli.runTransaction do
|
||||
Project {projectId, name = projectName} <-
|
||||
Q.loadProjectByName projectName
|
||||
>>= \case
|
||||
Nothing -> do
|
||||
projectId <- Sqlite.unsafeIO (Db.ProjectId <$> UUID.nextRandom)
|
||||
Q.insertProject projectId projectName
|
||||
pure $ Project {projectId, name = projectName}
|
||||
Just project -> pure project
|
||||
projectBranch <-
|
||||
Q.loadProjectBranchByName projectId branchName >>= \case
|
||||
Nothing -> do
|
||||
branchId <- Sqlite.unsafeIO (Db.ProjectBranchId <$> UUID.nextRandom)
|
||||
let projectBranch = ProjectBranch {projectId, parentBranchId = Nothing, branchId, name = branchName}
|
||||
Q.insertProjectBranch projectBranch
|
||||
pure projectBranch
|
||||
Just projBranch -> pure projBranch
|
||||
let projectAndBranchIds = ProjectAndBranch projectBranch.projectId projectBranch.branchId
|
||||
pure
|
||||
if curPath == ProjectUtils.projectBranchPath projectAndBranchIds
|
||||
then Nothing
|
||||
|
@ -63,13 +63,13 @@ instance From BranchRelativePath Text where
|
||||
That path ->
|
||||
Text.Builder.run
|
||||
( Text.Builder.char ':'
|
||||
<> Text.Builder.text (Path.convert path)
|
||||
<> Text.Builder.text (Path.toText' $ Path.RelativePath' path)
|
||||
)
|
||||
These eitherProj path ->
|
||||
Text.Builder.run
|
||||
( Text.Builder.text (eitherProjToText eitherProj)
|
||||
<> Text.Builder.char ':'
|
||||
<> Text.Builder.text (Path.convert path)
|
||||
<> Text.Builder.text (Path.toText' $ Path.RelativePath' path)
|
||||
)
|
||||
LoosePath path -> Path.toText' path
|
||||
where
|
||||
|
@ -196,12 +196,6 @@ completeWithinNamespace compTypes query currentPath = do
|
||||
namesInBranch :: Int -> V2Branch.Branch Sqlite.Transaction -> Sqlite.Transaction [(CompletionType, Bool, Text)]
|
||||
namesInBranch hashLen b = do
|
||||
nonEmptyChildren <- V2Branch.nonEmptyChildren b
|
||||
let textifyHQ :: (NameSegment -> r -> HQ'.HashQualified NameSegment) -> Map NameSegment (Map r metadata) -> [(Bool, Text)]
|
||||
textifyHQ f xs =
|
||||
xs
|
||||
& hashQualifyCompletions f
|
||||
& fmap (HQ'.toTextWith NameSegment.toEscapedText)
|
||||
& fmap (True,)
|
||||
pure $
|
||||
concat
|
||||
[ (NamespaceCompletion,False,) <$> (fmap NameSegment.toEscapedText . Map.keys $ nonEmptyChildren),
|
||||
@ -216,6 +210,12 @@ completeWithinNamespace compTypes query currentPath = do
|
||||
(fmap ((PatchCompletion,True,) . NameSegment.toEscapedText) . Map.keys $ V2Branch.patches b)
|
||||
]
|
||||
|
||||
textifyHQ :: (NameSegment -> r -> HQ'.HashQualified NameSegment) -> Map NameSegment (Map r metadata) -> [(Bool, Text)]
|
||||
textifyHQ f xs =
|
||||
xs
|
||||
& hashQualifyCompletions f
|
||||
& fmap (HQ'.toTextWith NameSegment.toEscapedText)
|
||||
& fmap (True,)
|
||||
-- Regrettably there'shqFromNamedV2Referencenot a great spot to combinators for V2 references and shorthashes right now.
|
||||
hqFromNamedV2Referent :: Int -> NameSegment -> Referent.Referent -> HQ'.HashQualified NameSegment
|
||||
hqFromNamedV2Referent hashLen n r = HQ'.HashQualified n (Cv.referent2toshorthash1 (Just hashLen) r)
|
||||
|
@ -70,6 +70,7 @@ module Unison.CommandLine.InputPatterns
|
||||
load,
|
||||
makeStandalone,
|
||||
mergeBuiltins,
|
||||
mergeCommitInputPattern,
|
||||
mergeIOBuiltins,
|
||||
mergeInputPattern,
|
||||
mergeOldInputPattern,
|
||||
@ -763,30 +764,15 @@ todo =
|
||||
"todo"
|
||||
[]
|
||||
I.Visible
|
||||
[("patch", Optional, patchArg), ("namespace", Optional, namespaceArg)]
|
||||
( P.wrapColumn2
|
||||
[ ( makeExample' todo,
|
||||
"lists the refactor work remaining in the default patch for the current"
|
||||
<> " namespace."
|
||||
),
|
||||
( makeExample todo ["<patch>"],
|
||||
"lists the refactor work remaining in the given patch in the current "
|
||||
<> "namespace."
|
||||
),
|
||||
( makeExample todo ["<patch>", "[path]"],
|
||||
"lists the refactor work remaining in the given patch in given namespace."
|
||||
)
|
||||
]
|
||||
[]
|
||||
( P.wrap $
|
||||
makeExample' todo
|
||||
<> "lists the current namespace's outstanding issues, including conflicted names, dependencies with missing"
|
||||
<> "names, and merge precondition violations."
|
||||
)
|
||||
\case
|
||||
patchStr : ws -> first warn $ do
|
||||
patch <- handleSplit'Arg patchStr
|
||||
branch <- case ws of
|
||||
[] -> pure Path.relativeEmpty'
|
||||
[pathStr] -> handlePath'Arg pathStr
|
||||
_ -> Left "`todo` just takes a patch and one optional namespace"
|
||||
Right $ Input.TodoI (Just patch) branch
|
||||
[] -> Right $ Input.TodoI Nothing Path.relativeEmpty'
|
||||
[] -> Right Input.TodoI
|
||||
_ -> Left (I.help todo)
|
||||
|
||||
load :: InputPattern
|
||||
load =
|
||||
@ -1404,14 +1390,30 @@ deleteBranch =
|
||||
aliasTerm :: InputPattern
|
||||
aliasTerm =
|
||||
InputPattern
|
||||
"alias.term"
|
||||
[]
|
||||
I.Visible
|
||||
[("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)]
|
||||
"`alias.term foo bar` introduces `bar` with the same definition as `foo`."
|
||||
$ \case
|
||||
[oldName, newName] -> Input.AliasTermI <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName
|
||||
_ -> Left . warn $ P.wrap "`alias.term` takes two arguments, like `alias.term oldname newname`."
|
||||
{ patternName = "alias.term",
|
||||
aliases = [],
|
||||
visibility = I.Visible,
|
||||
args = [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)],
|
||||
help = "`alias.term foo bar` introduces `bar` with the same definition as `foo`.",
|
||||
parse = \case
|
||||
[oldName, newName] -> Input.AliasTermI False <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName
|
||||
_ -> Left . warn $ P.wrap "`alias.term` takes two arguments, like `alias.term oldname newname`."
|
||||
}
|
||||
|
||||
aliasTermForce :: InputPattern
|
||||
aliasTermForce =
|
||||
InputPattern
|
||||
{ patternName = "debug.alias.term.force",
|
||||
aliases = [],
|
||||
visibility = I.Hidden,
|
||||
args = [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)],
|
||||
help = "`debug.alias.term.force foo bar` introduces `bar` with the same definition as `foo`.",
|
||||
parse = \case
|
||||
[oldName, newName] -> Input.AliasTermI True <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName
|
||||
_ ->
|
||||
Left . warn $
|
||||
P.wrap "`debug.alias.term.force` takes two arguments, like `debug.alias.term.force oldname newname`."
|
||||
}
|
||||
|
||||
aliasType :: InputPattern
|
||||
aliasType =
|
||||
@ -2128,6 +2130,48 @@ mergeInputPattern =
|
||||
args -> wrongArgsLength "exactly one argument" args
|
||||
}
|
||||
|
||||
mergeCommitInputPattern :: InputPattern
|
||||
mergeCommitInputPattern =
|
||||
InputPattern
|
||||
{ patternName = "merge.commit",
|
||||
aliases = ["commit.merge"],
|
||||
visibility = I.Visible,
|
||||
args = [],
|
||||
help =
|
||||
let mainBranch = UnsafeProjectBranchName "main"
|
||||
tempBranch = UnsafeProjectBranchName "merge-topic-into-main"
|
||||
in P.wrap
|
||||
( makeExample' mergeCommitInputPattern
|
||||
<> "merges a temporary branch created by the"
|
||||
<> makeExample' mergeInputPattern
|
||||
<> "command back into its parent branch, and removes the temporary branch."
|
||||
)
|
||||
<> P.newline
|
||||
<> P.newline
|
||||
<> P.wrap
|
||||
( "For example, if you've done"
|
||||
<> makeExample mergeInputPattern ["topic"]
|
||||
<> "from"
|
||||
<> P.group (prettyProjectBranchName mainBranch <> ",")
|
||||
<> "then"
|
||||
<> makeExample' mergeCommitInputPattern
|
||||
<> "is equivalent to doing"
|
||||
)
|
||||
<> P.newline
|
||||
<> P.newline
|
||||
<> P.indentN
|
||||
2
|
||||
( P.bulleted
|
||||
[ makeExampleNoBackticks projectSwitch [prettySlashProjectBranchName mainBranch],
|
||||
makeExampleNoBackticks mergeInputPattern [prettySlashProjectBranchName tempBranch],
|
||||
makeExampleNoBackticks deleteBranch [prettySlashProjectBranchName tempBranch]
|
||||
]
|
||||
),
|
||||
parse = \case
|
||||
[] -> Right Input.MergeCommitI
|
||||
_ -> Left (I.help mergeCommitInputPattern)
|
||||
}
|
||||
|
||||
parseLooseCodeOrProject :: String -> Maybe Input.LooseCodeOrProject
|
||||
parseLooseCodeOrProject inputString =
|
||||
case (asLooseCode, asBranch) of
|
||||
@ -2727,18 +2771,20 @@ docsToHtml =
|
||||
"docs.to-html"
|
||||
[]
|
||||
I.Visible
|
||||
[("namespace", Required, namespaceArg), ("", Required, filePathArg)]
|
||||
[("namespace", Required, branchRelativePathArg), ("", Required, filePathArg)]
|
||||
( P.wrapColumn2
|
||||
[ ( "`docs.to-html .path.to.namespace ~/path/to/file/output`",
|
||||
"Render all docs contained within a namespace, no matter how deep,"
|
||||
<> "to html files on a file path"
|
||||
[ ( makeExample docsToHtml [".path.to.ns", "doc-dir"],
|
||||
"Render all docs contained within the namespace `.path.to.ns`, no matter how deep, to html files in `doc-dir` in the directory UCM was run from."
|
||||
),
|
||||
( makeExample docsToHtml ["project0/branch0:a.path", "/tmp/doc-dir"],
|
||||
"Renders all docs anywhere in the namespace `a.path` from `branch0` of `project0` to html in `/tmp/doc-dir`."
|
||||
)
|
||||
]
|
||||
)
|
||||
\case
|
||||
[namespacePath, destinationFilePath] ->
|
||||
Input.DocsToHtmlI
|
||||
<$> handlePath'Arg namespacePath
|
||||
<$> handleBranchRelativePathArg namespacePath
|
||||
<*> unsupportedStructuredArgument "docs.to-html" "a file name" destinationFilePath
|
||||
args -> wrongArgsLength "exactly two arguments" args
|
||||
|
||||
@ -3257,6 +3303,7 @@ validInputs =
|
||||
[ add,
|
||||
aliasMany,
|
||||
aliasTerm,
|
||||
aliasTermForce,
|
||||
aliasType,
|
||||
api,
|
||||
authLogin,
|
||||
@ -3330,6 +3377,7 @@ validInputs =
|
||||
mergeOldPreviewInputPattern,
|
||||
mergeOldSquashInputPattern,
|
||||
mergeInputPattern,
|
||||
mergeCommitInputPattern,
|
||||
names False, -- names
|
||||
names True, -- names.global
|
||||
namespaceDependencies,
|
||||
@ -3797,7 +3845,8 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath =
|
||||
Just projectBranch -> do
|
||||
let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty)
|
||||
projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId)
|
||||
map prefixPathSep <$> prefixCompleteNamespace (Path.convert relPath) branchPath
|
||||
map prefixPathSep
|
||||
<$> prefixCompleteNamespace (Text.unpack . Path.toText' $ Path.RelativePath' relPath) branchPath
|
||||
BranchRelativePath.IncompletePath projStuff mpath -> do
|
||||
Codebase.runTransaction codebase do
|
||||
mprojectBranch <- runMaybeT do
|
||||
@ -3813,7 +3862,10 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath =
|
||||
Just (projectBranch, prefix) -> do
|
||||
let branchPath = review ProjectUtils.projectBranchPathPrism (projectAndBranch, mempty)
|
||||
projectAndBranch = ProjectAndBranch (projectBranch ^. #projectId) (projectBranch ^. #branchId)
|
||||
map (addBranchPrefix prefix) <$> prefixCompleteNamespace (maybe "" Path.convert mpath) branchPath
|
||||
map (addBranchPrefix prefix)
|
||||
<$> prefixCompleteNamespace
|
||||
(maybe "" (Text.unpack . Path.toText' . Path.RelativePath') mpath)
|
||||
branchPath
|
||||
where
|
||||
(mayCurrentProjectId, mayCurrentBranchId) = case projectContextFromPath currentPath of
|
||||
LooseCodePath {} -> (Nothing, Nothing)
|
||||
|
@ -53,6 +53,7 @@ import Unison.Codebase.Editor.Output
|
||||
Output (..),
|
||||
ShareError (..),
|
||||
TestReportStats (CachedTests, NewlyComputed),
|
||||
TodoOutput,
|
||||
UndoFailureReason (CantUndoPastMerge, CantUndoPastStart),
|
||||
)
|
||||
import Unison.Codebase.Editor.Output qualified as E
|
||||
@ -63,9 +64,7 @@ import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||
import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult
|
||||
import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
|
||||
import Unison.Codebase.Editor.StructuredArgument qualified as SA
|
||||
import Unison.Codebase.Editor.TodoOutput qualified as TO
|
||||
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors)
|
||||
import Unison.Codebase.Patch (Patch (..))
|
||||
import Unison.Codebase.Patch qualified as Patch
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.PushBehavior qualified as PushBehavior
|
||||
@ -73,8 +72,6 @@ import Unison.Codebase.Runtime qualified as Runtime
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.Codebase.TermEdit qualified as TermEdit
|
||||
import Unison.Codebase.TypeEdit qualified as TypeEdit
|
||||
import Unison.CommandLine (bigproblem, note, tip)
|
||||
import Unison.CommandLine.FZFResolvers qualified as FZFResolvers
|
||||
import Unison.CommandLine.InputPattern (InputPattern)
|
||||
@ -137,7 +134,6 @@ import Unison.Syntax.NamePrinter
|
||||
prettyReference,
|
||||
prettyReferent,
|
||||
prettyShortHash,
|
||||
styleHashQualified,
|
||||
)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment
|
||||
import Unison.Syntax.TermPrinter qualified as TermPrinter
|
||||
@ -146,6 +142,7 @@ import Unison.Term (Term)
|
||||
import Unison.Term qualified as Term
|
||||
import Unison.Type (Type)
|
||||
import Unison.UnisonFile qualified as UF
|
||||
import Unison.Util.Defns (Defns (..))
|
||||
import Unison.Util.List qualified as List
|
||||
import Unison.Util.Monoid (intercalateMap)
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
@ -310,7 +307,7 @@ notifyNumbered = \case
|
||||
]
|
||||
)
|
||||
(showDiffNamespace ShowNumbers ppe (absPathToBranchId bAbs) (absPathToBranchId bAbs) diff)
|
||||
TodoOutput names todo -> todoOutput names todo
|
||||
Output'Todo todoOutput -> runNumbered (handleTodoOutput todoOutput)
|
||||
CantDeleteDefinitions ppeDecl endangerments ->
|
||||
( P.warnCallout $
|
||||
P.lines
|
||||
@ -1372,7 +1369,9 @@ notifyUser dir = \case
|
||||
<> "or"
|
||||
<> IP.makeExample' IP.delete
|
||||
<> "all but one of the definitions; I'll use the remaining name when propagating updates."
|
||||
<> "(You can `rename` it back after the merge.)"
|
||||
<> "(You can"
|
||||
<> IP.makeExample' IP.moveAll
|
||||
<> "it back after the merge.)"
|
||||
)
|
||||
]
|
||||
)
|
||||
@ -1481,8 +1480,6 @@ notifyUser dir = \case
|
||||
<> P.group (prettyNamespaceKey src <> ".")
|
||||
DumpNumberedArgs schLength args ->
|
||||
pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument (pure schLength)) args
|
||||
NoConflictsOrEdits ->
|
||||
pure (P.okCallout "No conflicts or edits in progress.")
|
||||
HelpMessage pat -> pure $ IP.showPatternHelp pat
|
||||
NoOp -> pure $ P.string "I didn't make any changes."
|
||||
DumpBitBooster head map ->
|
||||
@ -2080,14 +2077,32 @@ notifyUser dir = \case
|
||||
"",
|
||||
"Your non-project code is still available to pull from Share, and you can pull it into a local namespace using `pull myhandle.public`"
|
||||
]
|
||||
MergeFailure path aliceAndBob ->
|
||||
pure . P.wrap $
|
||||
"I couldn't automatically merge"
|
||||
<> prettyMergeSource aliceAndBob.bob
|
||||
<> "into"
|
||||
<> P.group (prettyProjectAndBranchName aliceAndBob.alice <> ".")
|
||||
<> "However, I've added the definitions that need attention to the top of"
|
||||
<> P.group (prettyFilePath path <> ".")
|
||||
MergeFailure path aliceAndBob temp ->
|
||||
pure $
|
||||
P.lines $
|
||||
[ P.wrap $
|
||||
"I couldn't automatically merge"
|
||||
<> prettyMergeSource aliceAndBob.bob
|
||||
<> "into"
|
||||
<> P.group (prettyProjectAndBranchName aliceAndBob.alice <> ".")
|
||||
<> "However, I've added the definitions that need attention to the top of"
|
||||
<> P.group (prettyFilePath path <> "."),
|
||||
"",
|
||||
P.wrap "When you're done, you can run",
|
||||
"",
|
||||
P.indentN 2 (IP.makeExampleNoBackticks IP.mergeCommitInputPattern []),
|
||||
"",
|
||||
P.wrap $
|
||||
"to merge your changes back into"
|
||||
<> prettyProjectBranchName aliceAndBob.alice.branch
|
||||
<> "and delete the temporary branch. Or, if you decide to cancel the merge instead, you can run",
|
||||
"",
|
||||
P.indentN 2 (IP.makeExampleNoBackticks IP.deleteBranch [prettySlashProjectBranchName temp]),
|
||||
"",
|
||||
P.wrap $
|
||||
"to delete the temporary branch and switch back to"
|
||||
<> P.group (prettyProjectBranchName aliceAndBob.alice.branch <> ".")
|
||||
]
|
||||
MergeSuccess aliceAndBob ->
|
||||
pure . P.wrap $
|
||||
"I merged"
|
||||
@ -2131,6 +2146,8 @@ notifyUser dir = \case
|
||||
case maybeTargetProject of
|
||||
Nothing -> prettyProjectBranchName targetBranch
|
||||
Just targetProject -> prettyProjectAndBranchName (ProjectAndBranch targetProject targetBranch)
|
||||
NoMergeInProgress ->
|
||||
pure . P.wrap $ "It doesn't look like there's a merge in progress."
|
||||
|
||||
expectedEmptyPushDest :: WriteRemoteNamespace Void -> Pretty
|
||||
expectedEmptyPushDest namespace =
|
||||
@ -2594,8 +2611,7 @@ renderNameConflicts ppe conflictedNames = do
|
||||
[ prettyConflictedTypes,
|
||||
prettyConflictedTerms,
|
||||
tip $
|
||||
"This occurs when merging branches that both independently introduce the same name."
|
||||
<> "Use "
|
||||
"Use "
|
||||
<> makeExample'
|
||||
( if (not . null) conflictedTypeNames
|
||||
then IP.renameType
|
||||
@ -2613,7 +2629,7 @@ renderNameConflicts ppe conflictedNames = do
|
||||
showConflictedNames :: Pretty -> Map Name [HQ.HashQualified Name] -> Numbered Pretty
|
||||
showConflictedNames thingKind conflictedNames =
|
||||
P.lines <$> do
|
||||
for (Map.toList conflictedNames) $ \(name, hashes) -> do
|
||||
for (Map.toList conflictedNames) \(name, hashes) -> do
|
||||
prettyConflicts <- for hashes \hash -> do
|
||||
n <- addNumberedArg $ SA.HashQualified hash
|
||||
pure $ formatNum n <> (P.blue . P.syntaxToColor . prettyHashQualified $ hash)
|
||||
@ -2624,75 +2640,18 @@ renderNameConflicts ppe conflictedNames = do
|
||||
<> P.green (prettyName name)
|
||||
<> " has conflicting definitions:"
|
||||
)
|
||||
`P.hang` P.lines prettyConflicts
|
||||
|
||||
renderEditConflicts ::
|
||||
PPE.PrettyPrintEnv -> Patch -> Numbered Pretty
|
||||
renderEditConflicts ppe Patch {..} = do
|
||||
formattedConflicts <- for editConflicts formatConflict
|
||||
pure . Monoid.unlessM (null editConflicts) . P.callout "❓" . P.sep "\n\n" $
|
||||
[ P.wrap $
|
||||
"These"
|
||||
<> P.bold "definitions were edited differently"
|
||||
<> "in namespaces that have been merged into this one."
|
||||
<> "You'll have to tell me what to use as the new definition:",
|
||||
P.indentN 2 (P.lines formattedConflicts)
|
||||
-- , tip $ "Use " <> makeExample IP.resolve [name (head editConflicts), " <replacement>"] <> " to pick a replacement." -- todo: eventually something with `edit`
|
||||
]
|
||||
where
|
||||
-- todo: could possibly simplify all of this, but today is a copy/paste day.
|
||||
editConflicts :: [Either (Reference, Set TypeEdit.TypeEdit) (Reference, Set TermEdit.TermEdit)]
|
||||
editConflicts =
|
||||
(fmap Left . Map.toList . R.toMultimap . R.filterManyDom $ _typeEdits)
|
||||
<> (fmap Right . Map.toList . R.toMultimap . R.filterManyDom $ _termEdits)
|
||||
numberedHQName :: HQ.HashQualified Name -> Numbered Pretty
|
||||
numberedHQName hqName = do
|
||||
n <- addNumberedArg $ SA.HashQualified hqName
|
||||
pure $ formatNum n <> styleHashQualified P.bold hqName
|
||||
formatTypeEdits ::
|
||||
(Reference, Set TypeEdit.TypeEdit) ->
|
||||
Numbered Pretty
|
||||
formatTypeEdits (r, toList -> es) = do
|
||||
replacedType <- numberedHQName (PPE.typeName ppe r)
|
||||
replacements <- for [PPE.typeName ppe r | TypeEdit.Replace r <- es] numberedHQName
|
||||
pure . P.wrap $
|
||||
"The type"
|
||||
<> replacedType
|
||||
<> "was"
|
||||
<> ( if TypeEdit.Deprecate `elem` es
|
||||
then "deprecated and also replaced with"
|
||||
else "replaced with"
|
||||
)
|
||||
`P.hang` P.lines replacements
|
||||
formatTermEdits ::
|
||||
(Reference.TermReference, Set TermEdit.TermEdit) ->
|
||||
Numbered Pretty
|
||||
formatTermEdits (r, toList -> es) = do
|
||||
replacedTerm <- numberedHQName (PPE.termName ppe (Referent.Ref r))
|
||||
replacements <- for [PPE.termName ppe (Referent.Ref r) | TermEdit.Replace r _ <- es] numberedHQName
|
||||
pure . P.wrap $
|
||||
"The term"
|
||||
<> replacedTerm
|
||||
<> "was"
|
||||
<> ( if TermEdit.Deprecate `elem` es
|
||||
then "deprecated and also replaced with"
|
||||
else "replaced with"
|
||||
)
|
||||
`P.hang` P.lines replacements
|
||||
formatConflict ::
|
||||
Either
|
||||
(Reference, Set TypeEdit.TypeEdit)
|
||||
(Reference.TermReference, Set TermEdit.TermEdit) ->
|
||||
Numbered Pretty
|
||||
formatConflict = either formatTypeEdits formatTermEdits
|
||||
<> P.newline
|
||||
<> P.newline
|
||||
<> P.indentN 2 (P.lines prettyConflicts)
|
||||
|
||||
type Numbered = State.State (Int, Seq.Seq StructuredArgument)
|
||||
|
||||
addNumberedArg :: StructuredArgument -> Numbered Int
|
||||
addNumberedArg s = do
|
||||
(n, args) <- State.get
|
||||
State.put (n + 1, args Seq.|> s)
|
||||
pure $ (n + 1)
|
||||
let !n' = n + 1
|
||||
State.put (n', args Seq.|> s)
|
||||
pure n'
|
||||
|
||||
formatNum :: Int -> Pretty
|
||||
formatNum n = P.string (show n <> ". ")
|
||||
@ -2702,90 +2661,67 @@ runNumbered m =
|
||||
let (a, (_, args)) = State.runState m (0, mempty)
|
||||
in (a, Foldable.toList args)
|
||||
|
||||
todoOutput :: (Var v) => PPED.PrettyPrintEnvDecl -> TO.TodoOutput v a -> (Pretty, NumberedArgs)
|
||||
todoOutput ppe todo = runNumbered do
|
||||
conflicts <- todoConflicts
|
||||
edits <- todoEdits
|
||||
pure (conflicts <> edits)
|
||||
where
|
||||
ppeu = PPED.unsuffixifiedPPE ppe
|
||||
ppes = PPED.suffixifiedPPE ppe
|
||||
(frontierTerms, frontierTypes) = TO.todoFrontier todo
|
||||
(dirtyTerms, dirtyTypes) = TO.todoFrontierDependents todo
|
||||
corruptTerms =
|
||||
[(PPE.termName ppeu (Referent.Ref r), r) | (r, Nothing) <- frontierTerms]
|
||||
corruptTypes =
|
||||
[(PPE.typeName ppeu r, r) | (r, MissingObject _) <- frontierTypes]
|
||||
goodTerms ts =
|
||||
[(Referent.Ref r, PPE.termName ppeu (Referent.Ref r), typ) | (r, Just typ) <- ts]
|
||||
todoConflicts :: Numbered Pretty
|
||||
todoConflicts = do
|
||||
if TO.noConflicts todo
|
||||
then pure mempty
|
||||
else do
|
||||
editConflicts <- renderEditConflicts ppeu (TO.editConflicts todo)
|
||||
nameConflicts <- renderNameConflicts ppeu conflictedNames
|
||||
pure $ P.lines . P.nonEmpty $ [editConflicts, nameConflicts]
|
||||
where
|
||||
-- If a conflict is both an edit and a name conflict, we show it in the edit
|
||||
-- conflicts section
|
||||
conflictedNames :: Names
|
||||
conflictedNames = removeEditConflicts (TO.editConflicts todo) (TO.nameConflicts todo)
|
||||
-- e.g. `foo#a` has been independently updated to `foo#b` and `foo#c`.
|
||||
-- This means there will be a name conflict:
|
||||
-- foo -> #b
|
||||
-- foo -> #c
|
||||
-- as well as an edit conflict:
|
||||
-- #a -> #b
|
||||
-- #a -> #c
|
||||
-- We want to hide/ignore the name conflicts that are also targets of an
|
||||
-- edit conflict, so that the edit conflict will be dealt with first.
|
||||
-- For example, if hash `h` has multiple edit targets { #x, #y, #z, ...},
|
||||
-- we'll temporarily remove name conflicts pointing to { #x, #y, #z, ...}.
|
||||
removeEditConflicts :: Patch -> Names -> Names
|
||||
removeEditConflicts Patch {..} Names {..} = Names terms' types'
|
||||
where
|
||||
terms' = R.filterRan (`Set.notMember` conflictedTermEditTargets) terms
|
||||
types' = R.filterRan (`Set.notMember` conflictedTypeEditTargets) types
|
||||
conflictedTypeEditTargets :: Set Reference
|
||||
conflictedTypeEditTargets =
|
||||
Set.fromList $ toList (R.ran typeEditConflicts) >>= TypeEdit.references
|
||||
conflictedTermEditTargets :: Set Referent.Referent
|
||||
conflictedTermEditTargets =
|
||||
Set.fromList . fmap Referent.Ref $
|
||||
toList (R.ran termEditConflicts) >>= TermEdit.references
|
||||
typeEditConflicts = R.filterDom (`R.manyDom` _typeEdits) _typeEdits
|
||||
termEditConflicts = R.filterDom (`R.manyDom` _termEdits) _termEdits
|
||||
handleTodoOutput :: TodoOutput -> Numbered Pretty
|
||||
handleTodoOutput todo = do
|
||||
prettyConflicts <-
|
||||
if todo.nameConflicts == mempty
|
||||
then pure mempty
|
||||
else renderNameConflicts todo.ppe.unsuffixifiedPPE todo.nameConflicts
|
||||
|
||||
todoEdits :: Numbered Pretty
|
||||
todoEdits = do
|
||||
numberedTypes <- for (unscore <$> dirtyTypes) \(ref, displayObj) -> do
|
||||
n <- addNumberedArg . SA.HashQualified $ PPE.typeName ppeu ref
|
||||
pure $ formatNum n <> prettyDeclPair ppeu (ref, displayObj)
|
||||
let filteredTerms = goodTerms (unscore <$> dirtyTerms)
|
||||
termNumbers <- for filteredTerms \(ref, _, _) -> do
|
||||
n <- addNumberedArg . SA.HashQualified $ PPE.termName ppeu ref
|
||||
pure $ formatNum n
|
||||
let formattedTerms = TypePrinter.prettySignaturesCT ppes filteredTerms
|
||||
numberedTerms = zipWith (<>) termNumbers formattedTerms
|
||||
pure $
|
||||
Monoid.unlessM (TO.noEdits todo) . P.callout "🚧" . P.sep "\n\n" . P.nonEmpty $
|
||||
[ P.wrap
|
||||
( "The namespace has"
|
||||
<> fromString (show (TO.todoScore todo))
|
||||
<> "transitive dependent(s) left to upgrade."
|
||||
<> "Your edit frontier is the dependents of these definitions:"
|
||||
),
|
||||
P.indentN 2 . P.lines $
|
||||
( (prettyDeclPair ppeu <$> toList frontierTypes)
|
||||
++ TypePrinter.prettySignaturesCT ppes (goodTerms frontierTerms)
|
||||
),
|
||||
P.wrap "I recommend working on them in the following order:",
|
||||
P.lines $ numberedTypes ++ numberedTerms,
|
||||
formatMissingStuff corruptTerms corruptTypes
|
||||
]
|
||||
unscore :: (a, b, c) -> (b, c)
|
||||
unscore (_score, b, c) = (b, c)
|
||||
prettyDependentsOfTodo <- do
|
||||
if Set.null todo.dependentsOfTodo
|
||||
then pure mempty
|
||||
else do
|
||||
terms <-
|
||||
for (Set.toList todo.dependentsOfTodo) \term -> do
|
||||
n <- addNumberedArg (SA.HashQualified (HQ.HashOnly (Reference.idToShortHash term)))
|
||||
let name =
|
||||
term
|
||||
& Referent.fromTermReferenceId
|
||||
& PPE.termName todo.ppe.suffixifiedPPE
|
||||
& prettyHashQualified
|
||||
& P.syntaxToColor
|
||||
pure (formatNum n <> name)
|
||||
pure $
|
||||
P.wrap "These terms call `todo`:"
|
||||
<> P.newline
|
||||
<> P.newline
|
||||
<> P.indentN 2 (P.lines terms)
|
||||
|
||||
prettyDirectTermDependenciesWithoutNames <- do
|
||||
if Set.null todo.directDependenciesWithoutNames.terms
|
||||
then pure mempty
|
||||
else do
|
||||
terms <-
|
||||
for (Set.toList todo.directDependenciesWithoutNames.terms) \term -> do
|
||||
n <- addNumberedArg (SA.HashQualified (HQ.HashOnly (Reference.toShortHash term)))
|
||||
pure (formatNum n <> P.syntaxToColor (prettyReference todo.hashLen term))
|
||||
pure $
|
||||
P.wrap "These terms do not have any names in the current namespace:"
|
||||
<> P.newline
|
||||
<> P.newline
|
||||
<> P.indentN 2 (P.lines terms)
|
||||
|
||||
prettyDirectTypeDependenciesWithoutNames <- do
|
||||
if Set.null todo.directDependenciesWithoutNames.types
|
||||
then pure mempty
|
||||
else do
|
||||
types <-
|
||||
for (Set.toList todo.directDependenciesWithoutNames.types) \typ -> do
|
||||
n <- addNumberedArg (SA.HashQualified (HQ.HashOnly (Reference.toShortHash typ)))
|
||||
pure (formatNum n <> P.syntaxToColor (prettyReference todo.hashLen typ))
|
||||
pure $
|
||||
P.wrap "These types do not have any names in the current namespace:"
|
||||
<> P.newline
|
||||
<> P.newline
|
||||
<> P.indentN 2 (P.lines types)
|
||||
|
||||
(pure . P.sep "\n\n" . P.nonEmpty)
|
||||
[ prettyDependentsOfTodo,
|
||||
prettyDirectTermDependenciesWithoutNames,
|
||||
prettyDirectTypeDependenciesWithoutNames,
|
||||
prettyConflicts
|
||||
]
|
||||
|
||||
listOfDefinitions ::
|
||||
(Var v) => Input.FindScope -> PPE.PrettyPrintEnv -> E.ListDetailed -> [SR'.SearchResult' v a] -> IO Pretty
|
||||
|
@ -6,7 +6,6 @@
|
||||
module Unison.LSP.CodeLens where
|
||||
|
||||
import Control.Lens hiding (List)
|
||||
import Control.Monad.Except
|
||||
import Data.Aeson qualified as Aeson
|
||||
import Data.Map qualified as Map
|
||||
import Data.Text qualified as Text
|
||||
|
@ -1,6 +1,9 @@
|
||||
module Unison.LSP.UCMWorker where
|
||||
|
||||
import Control.Monad.Reader
|
||||
import Control.Monad (guard)
|
||||
import Control.Monad.State (liftIO)
|
||||
import Control.Monad.Reader.Class (ask)
|
||||
import Data.Functor (void)
|
||||
import U.Codebase.HashTags
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
|
@ -1,6 +1,6 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||
-- This file has been generated from package.yaml by hpack version 0.36.0.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
@ -55,6 +55,7 @@ library
|
||||
Unison.Codebase.Editor.HandleInput.Branch
|
||||
Unison.Codebase.Editor.HandleInput.Branches
|
||||
Unison.Codebase.Editor.HandleInput.BranchRename
|
||||
Unison.Codebase.Editor.HandleInput.CommitMerge
|
||||
Unison.Codebase.Editor.HandleInput.CommitUpgrade
|
||||
Unison.Codebase.Editor.HandleInput.DebugDefinition
|
||||
Unison.Codebase.Editor.HandleInput.DebugFoldRanges
|
||||
@ -65,6 +66,7 @@ library
|
||||
Unison.Codebase.Editor.HandleInput.FormatFile
|
||||
Unison.Codebase.Editor.HandleInput.InstallLib
|
||||
Unison.Codebase.Editor.HandleInput.Load
|
||||
Unison.Codebase.Editor.HandleInput.Ls
|
||||
Unison.Codebase.Editor.HandleInput.Merge2
|
||||
Unison.Codebase.Editor.HandleInput.MoveAll
|
||||
Unison.Codebase.Editor.HandleInput.MoveBranch
|
||||
@ -85,6 +87,7 @@ library
|
||||
Unison.Codebase.Editor.HandleInput.ShowDefinition
|
||||
Unison.Codebase.Editor.HandleInput.TermResolution
|
||||
Unison.Codebase.Editor.HandleInput.Tests
|
||||
Unison.Codebase.Editor.HandleInput.Todo
|
||||
Unison.Codebase.Editor.HandleInput.UI
|
||||
Unison.Codebase.Editor.HandleInput.Update
|
||||
Unison.Codebase.Editor.HandleInput.Update2
|
||||
@ -99,7 +102,6 @@ library
|
||||
Unison.Codebase.Editor.SlurpComponent
|
||||
Unison.Codebase.Editor.SlurpResult
|
||||
Unison.Codebase.Editor.StructuredArgument
|
||||
Unison.Codebase.Editor.TodoOutput
|
||||
Unison.Codebase.Editor.UCMVersion
|
||||
Unison.Codebase.Editor.UriParser
|
||||
Unison.Codebase.TranscriptParser
|
||||
|
@ -2,7 +2,7 @@ module Unison.HashQualified' where
|
||||
|
||||
import Data.Text qualified as Text
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.Name (Convert, Name, Parse)
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.Prelude
|
||||
@ -113,14 +113,3 @@ instance (Name.Alphabetical n) => Name.Alphabetical (HashQualified n) where
|
||||
compareAlphabetical NameOnly {} HashQualified {} = LT
|
||||
compareAlphabetical HashQualified {} NameOnly {} = GT
|
||||
compareAlphabetical (HashQualified n sh) (HashQualified n2 sh2) = Name.compareAlphabetical n n2 <> compare sh sh2
|
||||
|
||||
instance (Convert n n2) => Parse (HashQualified n) n2 where
|
||||
parse = \case
|
||||
NameOnly n -> Just (Name.convert n)
|
||||
_ -> Nothing
|
||||
|
||||
instance Convert (HashQualified n) (HQ.HashQualified n) where
|
||||
convert = toHQ
|
||||
|
||||
instance Parse (HQ.HashQualified n) (HashQualified n) where
|
||||
parse = fromHQ
|
||||
|
@ -3,7 +3,7 @@ module Unison.HashQualified where
|
||||
import Data.Text qualified as Text
|
||||
import Unison.ConstructorReference (ConstructorReference)
|
||||
import Unison.ConstructorReference qualified as ConstructorReference
|
||||
import Unison.Name (Convert, Name)
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.Prelude hiding (fromString)
|
||||
import Unison.Reference (Reference)
|
||||
@ -139,9 +139,3 @@ instance (Name.Alphabetical n) => Name.Alphabetical (HashQualified n) where
|
||||
(Nothing, Just _) -> LT -- prefer NameOnly to HashQualified
|
||||
(Just _, Nothing) -> GT
|
||||
(Just sh, Just sh2) -> compare sh sh2
|
||||
|
||||
instance (Convert n n2) => Convert (HashQualified n) (HashQualified n2) where
|
||||
convert = fmap Name.convert
|
||||
|
||||
instance Convert n (HashQualified n) where
|
||||
convert = NameOnly
|
||||
|
@ -1,7 +1,5 @@
|
||||
module Unison.Name
|
||||
( Name,
|
||||
Convert (..),
|
||||
Parse (..),
|
||||
|
||||
-- * Basic construction
|
||||
cons,
|
||||
@ -570,12 +568,3 @@ commonPrefix x@(Name p1 _) y@(Name p2 _)
|
||||
commonPrefix' (a : as) (b : bs)
|
||||
| a == b = a : commonPrefix' as bs
|
||||
commonPrefix' _ _ = []
|
||||
|
||||
class Convert a b where
|
||||
convert :: a -> b
|
||||
|
||||
class Parse a b where
|
||||
parse :: a -> Maybe b
|
||||
|
||||
instance (Parse a a2, Parse b b2) => Parse (a, b) (a2, b2) where
|
||||
parse (a, b) = (,) <$> parse a <*> parse b
|
||||
|
@ -21,21 +21,22 @@ import Unison.Position (Position (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Util.Alphabetical
|
||||
|
||||
-- | A name is an absolute-or-relative non-empty list of name segments.
|
||||
-- | A name is an absolute-or-relative non-empty list of name segments. It is used to represent the path to a
|
||||
-- definition.
|
||||
--
|
||||
-- A few example names:
|
||||
--
|
||||
-- - "foo.bar" --> Name Relative ("bar" :| ["foo"])
|
||||
-- - ".foo.bar" --> Name Absolute ("bar" :| ["foo"])
|
||||
-- - "|>.<|" --> Name Relative ("<|" :| ["|>"])
|
||||
-- - "." --> Name Relative ("." :| [])
|
||||
-- - ".." --> Name Absolute (".." :| [])
|
||||
data Name
|
||||
= -- A few example names:
|
||||
--
|
||||
-- "foo.bar" --> Name Relative ["bar", "foo"]
|
||||
-- ".foo.bar" --> Name Absolute ["bar", "foo"]
|
||||
-- "|>.<|" --> Name Relative ["<|", "|>"]
|
||||
-- "." --> Name Relative ["."]
|
||||
-- ".." --> Name Absolute ["."]
|
||||
--
|
||||
Name
|
||||
-- whether the name is positioned absolutely (to some arbitrary root namespace), or relatively
|
||||
= Name
|
||||
Position
|
||||
-- the name segments in reverse order
|
||||
-- ^ whether the name is positioned absolutely (to some arbitrary root namespace), or relatively
|
||||
(List.NonEmpty NameSegment)
|
||||
-- ^ the name segments in reverse order
|
||||
deriving stock (Eq, Generic, Show)
|
||||
|
||||
-- | Compare names (kinda) alphabetically: absolute comes before relative, but otherwise compare the name segments
|
||||
|
@ -225,7 +225,7 @@ longestTermName :: Int -> Referent -> Names -> HQ.HashQualified Name
|
||||
longestTermName length r ns =
|
||||
case reverse (termNamesByLength length r ns) of
|
||||
[] -> HQ.take length (HQ.fromReferent r)
|
||||
(h : _) -> Name.convert h
|
||||
(h : _) -> HQ'.toHQ h
|
||||
|
||||
termName :: Int -> Referent -> Names -> Set (HQ'.HashQualified Name)
|
||||
termName length r names =
|
||||
|
@ -19,6 +19,7 @@ import Unison.Blank qualified as B
|
||||
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
|
||||
import Unison.ConstructorType qualified as CT
|
||||
import Unison.DataDeclaration.ConstructorId (ConstructorId)
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
import Unison.LabeledDependency qualified as LD
|
||||
import Unison.Name qualified as Name
|
||||
@ -160,14 +161,14 @@ bindNames unsafeVarToName keepFreeTerms ns e = do
|
||||
-- !_ = trace "bindNames.free type vars: " ()
|
||||
-- !_ = traceShow $ fst <$> freeTyVars
|
||||
okTm :: (v, a) -> Names.ResolutionResult v a (v, Term v a)
|
||||
okTm (v, a) = case Names.lookupHQTerm Names.IncludeSuffixes (Name.convert $ unsafeVarToName v) ns of
|
||||
okTm (v, a) = case Names.lookupHQTerm Names.IncludeSuffixes (HQ.NameOnly $ unsafeVarToName v) ns of
|
||||
rs
|
||||
| Set.size rs == 1 ->
|
||||
pure (v, fromReferent a $ Set.findMin rs)
|
||||
| otherwise -> case NES.nonEmptySet rs of
|
||||
Nothing -> Left (pure (Names.TermResolutionFailure v a Names.NotFound))
|
||||
Just refs -> Left (pure (Names.TermResolutionFailure v a (Names.Ambiguous ns refs)))
|
||||
okTy (v, a) = case Names.lookupHQType Names.IncludeSuffixes (Name.convert $ unsafeVarToName v) ns of
|
||||
okTy (v, a) = case Names.lookupHQType Names.IncludeSuffixes (HQ.NameOnly $ unsafeVarToName v) ns of
|
||||
rs
|
||||
| Set.size rs == 1 -> pure (v, Type.ref a $ Set.findMin rs)
|
||||
| otherwise -> case NES.nonEmptySet rs of
|
||||
@ -396,7 +397,7 @@ substTypeVar vt ty = go Set.empty
|
||||
t2 = ABT.bindInheritAnnotation body (Type.var () v2)
|
||||
in uncapture ((ABT.annotation t, v2) : vs) (renameTypeVar v v2 e) t2
|
||||
uncapture vs e t0 =
|
||||
let t = foldl (\body (loc, v) -> Type.forall loc v body) t0 vs
|
||||
let t = foldl (\body (loc, v) -> Type.forAll loc v body) t0 vs
|
||||
bound' = case Type.unForalls (Type.stripIntroOuters t) of
|
||||
Nothing -> bound
|
||||
Just (vs, _) -> bound <> Set.fromList vs
|
||||
|
@ -451,28 +451,28 @@ arrow' i o = arrow (ABT.annotation i <> ABT.annotation o) i o
|
||||
ann :: (Ord v) => a -> Type v a -> K.Kind -> Type v a
|
||||
ann a e t = ABT.tm' a (Ann e t)
|
||||
|
||||
forall :: (Ord v) => a -> v -> Type v a -> Type v a
|
||||
forall a v body = ABT.tm' a (Forall (ABT.abs' a v body))
|
||||
forAll :: (Ord v) => a -> v -> Type v a -> Type v a
|
||||
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
|
||||
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
|
||||
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
|
||||
iff2 loc = forAll loc aa $ arrows (f <$> [a, a]) a
|
||||
where
|
||||
aa = Var.named "a"
|
||||
a = var loc aa
|
||||
@ -498,11 +498,11 @@ v' s = ABT.var (Var.named s)
|
||||
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)
|
||||
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
|
||||
foralls a vs body = foldr (forAll a) body vs
|
||||
|
||||
-- Note: `a -> b -> c` parses as `a -> (b -> c)`
|
||||
-- the annotation associated with `b` will be the annotation for the `b -> c`
|
||||
@ -545,7 +545,7 @@ 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)
|
||||
flipApply t = forAll () b $ arrow () (arrow () t (var () b)) (var () b)
|
||||
where
|
||||
b = ABT.fresh t (Var.named "b")
|
||||
|
||||
@ -554,12 +554,12 @@ generalize' k t = generalize vsk t
|
||||
where
|
||||
vsk = [v | v <- Set.toList (freeVars t), Var.typeOf v == k]
|
||||
|
||||
-- | Bind the given variables with an outer `forall`, if they are used in `t`.
|
||||
-- | Bind the given variables with an outer `forAll`, if they are used in `t`.
|
||||
generalize :: (Ord v) => [v] -> Type v a -> Type v a
|
||||
generalize vs t = foldr f t vs
|
||||
where
|
||||
f v t =
|
||||
if Set.member v (ABT.freeVars t) then forall (ABT.annotation t) v t else 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
|
||||
@ -755,7 +755,7 @@ functionResult = go False
|
||||
-- `.foo -> .foo` becomes `.foo -> .foo` (not changed)
|
||||
-- `.foo.bar -> blarrg.woot` becomes `.foo.bar -> blarrg.woot` (unchanged)
|
||||
generalizeLowercase :: (Var v) => Set v -> Type v a -> Type v a
|
||||
generalizeLowercase except t = foldr (forall (ABT.annotation t)) t vars
|
||||
generalizeLowercase except t = foldr (forAll (ABT.annotation t)) t vars
|
||||
where
|
||||
vars =
|
||||
[v | v <- Set.toList (ABT.freeVars t `Set.difference` except), Var.universallyQuantifyIfFree v]
|
||||
@ -774,7 +774,7 @@ normalizeForallOrder tm0 =
|
||||
where
|
||||
step :: (a, v) -> Type v a -> Type v a
|
||||
step (a, v) body
|
||||
| Set.member v (ABT.freeVars body) = forall a v body
|
||||
| Set.member v (ABT.freeVars body) = forAll a v body
|
||||
| otherwise = body
|
||||
(body, vs0) = extract tm0
|
||||
vs = sortOn (\(_, v) -> Map.lookup v ind) vs0
|
||||
|
@ -6,6 +6,7 @@ where
|
||||
import Data.Set qualified as Set
|
||||
import Data.Set.NonEmpty qualified as NES
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.HashQualified qualified as HQ
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.Names qualified as Names
|
||||
import Unison.Names.ResolutionResult qualified as Names
|
||||
@ -24,7 +25,7 @@ bindNames ::
|
||||
Names.ResolutionResult v a (Type v a)
|
||||
bindNames unsafeVarToName keepFree ns t =
|
||||
let fvs = ABT.freeVarOccurrences keepFree t
|
||||
rs = [(v, a, Names.lookupHQType Names.IncludeSuffixes (Name.convert $ unsafeVarToName v) ns) | (v, a) <- fvs]
|
||||
rs = [(v, a, Names.lookupHQType Names.IncludeSuffixes (HQ.NameOnly $ unsafeVarToName v) ns) | (v, a) <- fvs]
|
||||
ok (v, a, rs) =
|
||||
if Set.size rs == 1
|
||||
then pure (v, Set.findMin rs)
|
||||
|
@ -103,15 +103,15 @@ 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))
|
||||
forAll :: (Ord v) => a -> v -> Type v a -> Type v a
|
||||
forAll a v body = ABT.tm' a (TypeForall (ABT.abs' a v body))
|
||||
|
||||
-- | Bind the given variables with an outer `forall`, if they are used in `t`.
|
||||
generalize :: (Ord v) => [v] -> Type v a -> Type v a
|
||||
generalize vs t = foldr f t vs
|
||||
where
|
||||
f v t =
|
||||
if Set.member v (ABT.freeVars t) then forall (ABT.annotation t) v t else t
|
||||
if Set.member v (ABT.freeVars t) then forAll (ABT.annotation t) v t else t
|
||||
|
||||
unforall' :: Type v a -> ([v], Type v a)
|
||||
unforall' (ForallsNamed' vs t) = (vs, t)
|
||||
|
@ -104,6 +104,7 @@ import U.Codebase.Reference (Reference' (..), TypeReference, TypeReferenceId)
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
import Unison.DataDeclaration.ConstructorId (ConstructorId)
|
||||
import Unison.Merge.DeclNameLookup (DeclNameLookup (..))
|
||||
import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup (..))
|
||||
import Unison.Name (Name)
|
||||
import Unison.Name qualified as Name
|
||||
import Unison.NameSegment (NameSegment)
|
||||
@ -217,21 +218,21 @@ checkDeclCoherency loadDeclNumConstructors =
|
||||
fullName name =
|
||||
Name.fromReverseSegments (name :| prefix)
|
||||
|
||||
-- | A lenient variant of 'checkDeclCoherency' - so lenient it can't even fail! It returns a mapping from decl name to
|
||||
-- constructor names, where constructor names can be missing.
|
||||
-- | A lenient variant of 'checkDeclCoherency' - so lenient it can't even fail! It returns partial decl name lookup,
|
||||
-- which doesn't require a name for every constructor, and allows a constructor with a nameless decl.
|
||||
--
|
||||
-- This function exists merely to extract a best-effort decl-name-to-constructor-name mapping for the LCA of a merge.
|
||||
-- We require Alice and Bob to have coherent decls, but their LCA is out of the user's control and may have incoherent
|
||||
-- decls, and whether or not it does, we still need to compute *some* syntactic hash for its decls.
|
||||
-- This function exists merely to extract a best-effort name mapping for the LCA of a merge. We require Alice and Bob to
|
||||
-- have coherent decls, but their LCA is out of the user's control and may have incoherent decls, and whether or not it
|
||||
-- does, we still need to compute *some* syntactic hash for its decls.
|
||||
lenientCheckDeclCoherency ::
|
||||
forall m.
|
||||
Monad m =>
|
||||
(TypeReferenceId -> m Int) ->
|
||||
Nametree (DefnsF (Map NameSegment) Referent TypeReference) ->
|
||||
m (Map Name [Maybe Name])
|
||||
m PartialDeclNameLookup
|
||||
lenientCheckDeclCoherency loadDeclNumConstructors =
|
||||
fmap (view #declToConstructors)
|
||||
. (`State.execStateT` LenientDeclCoherencyCheckState Map.empty Map.empty)
|
||||
fmap (view #declNameLookup)
|
||||
. (`State.execStateT` LenientDeclCoherencyCheckState Map.empty (PartialDeclNameLookup Map.empty Map.empty))
|
||||
. go []
|
||||
where
|
||||
go ::
|
||||
@ -259,14 +260,14 @@ lenientCheckDeclCoherency loadDeclNumConstructors =
|
||||
lift (getCompose (Map.upsertF (\_ -> Compose recordNewDecl) typeRef state.expectedConstructors))
|
||||
case whatHappened of
|
||||
UninhabitedDecl -> do
|
||||
#declToConstructors %= Map.insert typeName []
|
||||
#declNameLookup . #declToConstructors %= Map.insert typeName []
|
||||
pure Nothing
|
||||
InhabitedDecl expectedConstructors1 -> do
|
||||
let child = Map.findWithDefault (Nametree (Defns Map.empty Map.empty) Map.empty) name children
|
||||
#expectedConstructors .= expectedConstructors1
|
||||
go (name : prefix) child
|
||||
state <- State.get
|
||||
let (maybeConstructorNames, expectedConstructors) =
|
||||
let (constructorNames0, expectedConstructors) =
|
||||
Map.alterF f typeRef state.expectedConstructors
|
||||
where
|
||||
f ::
|
||||
@ -278,8 +279,21 @@ lenientCheckDeclCoherency loadDeclNumConstructors =
|
||||
fromJust
|
||||
>>> Map.deleteLookupJust typeName
|
||||
>>> over _2 \m -> if Map.null m then Nothing else Just m
|
||||
|
||||
constructorNames :: [Maybe Name]
|
||||
constructorNames =
|
||||
IntMap.elems constructorNames0
|
||||
|
||||
#expectedConstructors .= expectedConstructors
|
||||
#declToConstructors %= Map.insert typeName (IntMap.elems maybeConstructorNames)
|
||||
#declNameLookup . #constructorToDecl %= \constructorToDecl ->
|
||||
List.foldl'
|
||||
( \acc -> \case
|
||||
Nothing -> acc
|
||||
Just constructorName -> Map.insert constructorName typeName acc
|
||||
)
|
||||
constructorToDecl
|
||||
constructorNames
|
||||
#declNameLookup . #declToConstructors %= Map.insert typeName constructorNames
|
||||
pure (Just name)
|
||||
where
|
||||
typeName = fullName name
|
||||
@ -298,7 +312,7 @@ data DeclCoherencyCheckState = DeclCoherencyCheckState
|
||||
|
||||
data LenientDeclCoherencyCheckState = LenientDeclCoherencyCheckState
|
||||
{ expectedConstructors :: !(Map TypeReferenceId (Map Name ConstructorNames)),
|
||||
declToConstructors :: !(Map Name [Maybe Name])
|
||||
declNameLookup :: !PartialDeclNameLookup
|
||||
}
|
||||
deriving stock (Generic)
|
||||
|
||||
|
@ -9,6 +9,7 @@ import Data.Semialign (alignWith)
|
||||
import Data.Set qualified as Set
|
||||
import Data.These (These (..))
|
||||
import U.Codebase.Reference (TypeReference)
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
import Unison.DataDeclaration (Decl)
|
||||
import Unison.DataDeclaration qualified as DataDeclaration
|
||||
import Unison.Hash (Hash (Hash))
|
||||
@ -17,6 +18,7 @@ import Unison.Merge.Database (MergeDatabase (..))
|
||||
import Unison.Merge.DeclNameLookup (DeclNameLookup)
|
||||
import Unison.Merge.DeclNameLookup qualified as DeclNameLookup
|
||||
import Unison.Merge.DiffOp (DiffOp (..))
|
||||
import Unison.Merge.PartialDeclNameLookup (PartialDeclNameLookup (..))
|
||||
import Unison.Merge.Synhash
|
||||
import Unison.Merge.Synhashed (Synhashed (..))
|
||||
import Unison.Merge.ThreeWay (ThreeWay (..))
|
||||
@ -30,6 +32,7 @@ import Unison.PrettyPrintEnv (PrettyPrintEnv (..))
|
||||
import Unison.PrettyPrintEnv qualified as Ppe
|
||||
import Unison.Reference (Reference' (..), TypeReferenceId)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Referent qualified as Referent
|
||||
import Unison.Sqlite (Transaction)
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.Name qualified as Name
|
||||
@ -48,52 +51,14 @@ import Unison.Util.Defns (Defns (..), DefnsF2, DefnsF3, zipDefnsWith)
|
||||
nameBasedNamespaceDiff ::
|
||||
MergeDatabase ->
|
||||
TwoWay DeclNameLookup ->
|
||||
Map Name [Maybe Name] ->
|
||||
PartialDeclNameLookup ->
|
||||
ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) ->
|
||||
Transaction (TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference))
|
||||
nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns = do
|
||||
lcaHashes <-
|
||||
synhashDefnsWith
|
||||
hashTerm
|
||||
( \name -> \case
|
||||
ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin)
|
||||
ReferenceDerived ref ->
|
||||
case sequence (lcaDeclToConstructors Map.! name) of
|
||||
-- If we don't have a name for every constructor, that's okay, just use a dummy syntactic hash here.
|
||||
-- This is safe; Alice/Bob can't have such a decl (it violates a merge precondition), so there's no risk
|
||||
-- that we accidentally get an equal hash and classify a real update as unchanged.
|
||||
Nothing -> pure (Hash mempty)
|
||||
Just names -> do
|
||||
decl <- loadDeclWithGoodConstructorNames names ref
|
||||
pure (synhashDerivedDecl ppe name decl)
|
||||
)
|
||||
defns.lca
|
||||
hashes <- sequence (synhashDefns <$> declNameLookups <*> ThreeWay.forgetLca defns)
|
||||
nameBasedNamespaceDiff db declNameLookups lcaDeclNameLookup defns = do
|
||||
lcaHashes <- synhashLcaDefns db ppe lcaDeclNameLookup defns.lca
|
||||
hashes <- sequence (synhashDefns db ppe <$> declNameLookups <*> ThreeWay.forgetLca defns)
|
||||
pure (diffNamespaceDefns lcaHashes <$> hashes)
|
||||
where
|
||||
synhashDefns ::
|
||||
DeclNameLookup ->
|
||||
Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
|
||||
Transaction (DefnsF2 (Map Name) Synhashed Referent TypeReference)
|
||||
synhashDefns declNameLookup =
|
||||
-- FIXME: use cache so we only synhash each thing once
|
||||
synhashDefnsWith hashTerm hashType
|
||||
where
|
||||
hashType :: Name -> TypeReference -> Transaction Hash
|
||||
hashType name = \case
|
||||
ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin)
|
||||
ReferenceDerived ref -> do
|
||||
decl <- loadDeclWithGoodConstructorNames (DeclNameLookup.expectConstructorNames declNameLookup name) ref
|
||||
pure (synhashDerivedDecl ppe name decl)
|
||||
|
||||
loadDeclWithGoodConstructorNames :: [Name] -> TypeReferenceId -> Transaction (Decl Symbol Ann)
|
||||
loadDeclWithGoodConstructorNames names =
|
||||
fmap (DataDeclaration.setConstructorNames (map Name.toVar names)) . db.loadV1Decl
|
||||
|
||||
hashTerm :: Referent -> Transaction Hash
|
||||
hashTerm =
|
||||
synhashTerm db.loadV1Term ppe
|
||||
|
||||
ppe :: PrettyPrintEnv
|
||||
ppe =
|
||||
-- The order between Alice and Bob isn't important here for syntactic hashing; not sure right now if it matters
|
||||
@ -102,6 +67,71 @@ nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns = do
|
||||
`Ppe.addFallback` deepNamespaceDefinitionsToPpe defns.bob
|
||||
`Ppe.addFallback` deepNamespaceDefinitionsToPpe defns.lca
|
||||
|
||||
synhashLcaDefns ::
|
||||
MergeDatabase ->
|
||||
PrettyPrintEnv ->
|
||||
PartialDeclNameLookup ->
|
||||
Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
|
||||
Transaction (DefnsF2 (Map Name) Synhashed Referent TypeReference)
|
||||
synhashLcaDefns db ppe declNameLookup =
|
||||
synhashDefnsWith hashReferent hashType
|
||||
where
|
||||
-- For the LCA only, if we don't have a name for every constructor, or we don't have a name for a decl, that's okay,
|
||||
-- just use a dummy syntactic hash (e.g. where we return `Hash mempty` below in two places).
|
||||
--
|
||||
-- This is safe and correct; Alice/Bob can't have such a decl (it violates a merge precondition), so there's no risk
|
||||
-- that we accidentally get an equal hash and classify a real update as unchanged.
|
||||
|
||||
hashReferent :: Name -> Referent -> Transaction Hash
|
||||
hashReferent name = \case
|
||||
Referent.Con (ConstructorReference ref _) _ ->
|
||||
case Map.lookup name declNameLookup.constructorToDecl of
|
||||
Nothing -> pure (Hash mempty) -- see note above
|
||||
Just declName -> hashType declName ref
|
||||
Referent.Ref ref -> synhashTerm db.loadV1Term ppe ref
|
||||
|
||||
hashType :: Name -> TypeReference -> Transaction Hash
|
||||
hashType name = \case
|
||||
ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin)
|
||||
ReferenceDerived ref ->
|
||||
case sequence (declNameLookup.declToConstructors Map.! name) of
|
||||
Nothing -> pure (Hash mempty) -- see note above
|
||||
Just names -> do
|
||||
decl <- loadDeclWithGoodConstructorNames db names ref
|
||||
pure (synhashDerivedDecl ppe name decl)
|
||||
|
||||
synhashDefns ::
|
||||
MergeDatabase ->
|
||||
PrettyPrintEnv ->
|
||||
DeclNameLookup ->
|
||||
Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
|
||||
Transaction (DefnsF2 (Map Name) Synhashed Referent TypeReference)
|
||||
synhashDefns db ppe declNameLookup =
|
||||
-- FIXME: use cache so we only synhash each thing once
|
||||
synhashDefnsWith hashReferent hashType
|
||||
where
|
||||
hashReferent :: Name -> Referent -> Transaction Hash
|
||||
hashReferent name = \case
|
||||
-- We say that a referent constructor *in the namespace* (distinct from a referent that is in a term body) has a
|
||||
-- synhash that is simply equal to the synhash of its type declaration. This is because the type declaration and
|
||||
-- constructors are changed in lock-step: it is not possible to change one, but not the other.
|
||||
--
|
||||
-- For example, if Alice updates `type Foo = Bar Nat` to `type Foo = Bar Nat Nat`, we want different synhashes on
|
||||
-- both the type (Foo) and the constructor (Foo.Bar).
|
||||
Referent.Con (ConstructorReference ref _) _ -> hashType (DeclNameLookup.expectDeclName declNameLookup name) ref
|
||||
Referent.Ref ref -> synhashTerm db.loadV1Term ppe ref
|
||||
|
||||
hashType :: Name -> TypeReference -> Transaction Hash
|
||||
hashType name = \case
|
||||
ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin)
|
||||
ReferenceDerived ref -> do
|
||||
decl <- loadDeclWithGoodConstructorNames db (DeclNameLookup.expectConstructorNames declNameLookup name) ref
|
||||
pure (synhashDerivedDecl ppe name decl)
|
||||
|
||||
loadDeclWithGoodConstructorNames :: MergeDatabase -> [Name] -> TypeReferenceId -> Transaction (Decl Symbol Ann)
|
||||
loadDeclWithGoodConstructorNames db names =
|
||||
fmap (DataDeclaration.setConstructorNames (map Name.toVar names)) . db.loadV1Decl
|
||||
|
||||
diffNamespaceDefns ::
|
||||
DefnsF2 (Map Name) Synhashed term typ ->
|
||||
DefnsF2 (Map Name) Synhashed term typ ->
|
||||
@ -139,17 +169,17 @@ deepNamespaceDefinitionsToPpe Defns {terms, types} =
|
||||
|
||||
synhashDefnsWith ::
|
||||
Monad m =>
|
||||
(term -> m Hash) ->
|
||||
(Name -> term -> m Hash) ->
|
||||
(Name -> typ -> m Hash) ->
|
||||
Defns (BiMultimap term Name) (BiMultimap typ Name) ->
|
||||
m (DefnsF2 (Map Name) Synhashed term typ)
|
||||
synhashDefnsWith hashTerm hashType = do
|
||||
bitraverse
|
||||
(traverse hashTerm1 . BiMultimap.range)
|
||||
(Map.traverseWithKey hashTerm1 . BiMultimap.range)
|
||||
(Map.traverseWithKey hashType1 . BiMultimap.range)
|
||||
where
|
||||
hashTerm1 term = do
|
||||
hash <- hashTerm term
|
||||
hashTerm1 name term = do
|
||||
hash <- hashTerm name term
|
||||
pure (Synhashed hash term)
|
||||
|
||||
hashType1 name typ = do
|
||||
|
15
unison-merge/src/Unison/Merge/PartialDeclNameLookup.hs
Normal file
15
unison-merge/src/Unison/Merge/PartialDeclNameLookup.hs
Normal file
@ -0,0 +1,15 @@
|
||||
module Unison.Merge.PartialDeclNameLookup
|
||||
( PartialDeclNameLookup (..),
|
||||
)
|
||||
where
|
||||
|
||||
import Unison.Name (Name)
|
||||
import Unison.Prelude
|
||||
|
||||
-- | Like a @DeclNameLookup@, but "partial" / more lenient - because we don't require the LCA of a merge to have a full
|
||||
-- @DeclNameLookup@.
|
||||
data PartialDeclNameLookup = PartialDeclNameLookup
|
||||
{ constructorToDecl :: !(Map Name Name),
|
||||
declToConstructors :: !(Map Name [Maybe Name])
|
||||
}
|
||||
deriving stock (Generic)
|
@ -1,3 +1,5 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
-- | Utilities for computing the "syntactic hash" of a decl or term, which is a hash that is computed after substituting
|
||||
-- references to other terms and decls with names from a pretty-print environment.
|
||||
--
|
||||
@ -35,7 +37,6 @@ import Data.Char (ord)
|
||||
import Data.Text qualified as Text
|
||||
import U.Codebase.Reference (TypeReference)
|
||||
import Unison.ABT qualified as ABT
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
import Unison.ConstructorType (ConstructorType)
|
||||
import Unison.ConstructorType qualified as CT
|
||||
import Unison.DataDeclaration (DataDeclaration, Decl)
|
||||
@ -51,8 +52,9 @@ import Unison.Prelude
|
||||
import Unison.PrettyPrintEnv (PrettyPrintEnv)
|
||||
import Unison.PrettyPrintEnv qualified as PPE
|
||||
import Unison.Reference (Reference' (..), TypeReferenceId)
|
||||
import Unison.Referent qualified as V1 (Referent)
|
||||
import Unison.Referent qualified as V1.Referent
|
||||
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)
|
||||
import Unison.Term (Term)
|
||||
import Unison.Term qualified as Term
|
||||
@ -107,7 +109,7 @@ hashConstructorNameToken declName conName =
|
||||
|
||||
hashDerivedTerm :: Var v => PrettyPrintEnv -> Term v a -> Hash
|
||||
hashDerivedTerm ppe t =
|
||||
H.accumulate $ isNotBuiltinTag : hashTermTokens ppe t
|
||||
H.accumulate $ isNotBuiltinTag : isTermTag : hashTermTokens ppe t
|
||||
|
||||
hashConstructorType :: ConstructorType -> Token
|
||||
hashConstructorType = \case
|
||||
@ -138,7 +140,7 @@ hashDeclTokens ppe name decl =
|
||||
-- syntactic hashes.
|
||||
synhashDerivedDecl :: Var v => PrettyPrintEnv -> Name -> Decl v a -> Hash
|
||||
synhashDerivedDecl ppe name decl =
|
||||
H.accumulate $ isNotBuiltinTag : hashDeclTokens ppe name decl
|
||||
H.accumulate $ isNotBuiltinTag : isDeclTag : hashDeclTokens ppe name decl
|
||||
|
||||
hashHQNameToken :: HashQualified Name -> Token
|
||||
hashHQNameToken =
|
||||
@ -170,14 +172,14 @@ hashPatternTokens ppe = \case
|
||||
Pattern.Char _ c -> [H.Tag 7, H.Nat (fromIntegral (ord c))]
|
||||
Pattern.Constructor _ cr ps ->
|
||||
H.Tag 8
|
||||
: hashReferentToken ppe (V1.Referent.Con cr CT.Data)
|
||||
: hashReferentToken ppe (Referent.Con cr CT.Data)
|
||||
: hashLengthToken ps
|
||||
: (ps >>= hashPatternTokens ppe)
|
||||
Pattern.As _ p -> H.Tag 9 : hashPatternTokens ppe p
|
||||
Pattern.EffectPure _ p -> H.Tag 10 : hashPatternTokens ppe p
|
||||
Pattern.EffectBind _ cr ps k ->
|
||||
H.Tag 11
|
||||
: hashReferentToken ppe (V1.Referent.Con cr CT.Effect)
|
||||
: hashReferentToken ppe (Referent.Con cr CT.Effect)
|
||||
: hashLengthToken ps
|
||||
: hashPatternTokens ppe k <> (ps >>= hashPatternTokens ppe)
|
||||
Pattern.SequenceLiteral _ ps -> H.Tag 12 : hashLengthToken ps : (ps >>= hashPatternTokens ppe)
|
||||
@ -188,36 +190,20 @@ hashPatternTokens ppe = \case
|
||||
Pattern.Snoc -> H.Tag 1
|
||||
Pattern.Cons -> H.Tag 2
|
||||
|
||||
hashReferentToken :: PrettyPrintEnv -> V1.Referent -> Token
|
||||
hashReferentToken :: PrettyPrintEnv -> Referent -> Token
|
||||
hashReferentToken ppe =
|
||||
H.Hashed . H.accumulate . hashReferentTokens ppe
|
||||
hashHQNameToken . PPE.termNameOrHashOnlyFq ppe
|
||||
|
||||
hashReferentTokens :: PrettyPrintEnv -> V1.Referent -> [Token]
|
||||
hashReferentTokens ppe referent =
|
||||
case referent of
|
||||
-- distinguish constructor name from terms by tumbling in a name (of any alias of) its decl
|
||||
V1.Referent.Con (ConstructorReference ref _i) _ct -> [hashTypeReferenceToken ppe ref, nameTok]
|
||||
V1.Referent.Ref _ -> [nameTok]
|
||||
where
|
||||
nameTok :: Token
|
||||
nameTok =
|
||||
hashHQNameToken (PPE.termNameOrHashOnlyFq ppe referent)
|
||||
|
||||
-- | Syntactically hash a term, using reference names rather than hashes.
|
||||
-- Two terms will have the same syntactic hash if they would
|
||||
-- print the the same way under the given pretty-print env.
|
||||
synhashTerm ::
|
||||
forall m v a.
|
||||
(Monad m, Var v) =>
|
||||
(TypeReferenceId -> m (Term v a)) ->
|
||||
PrettyPrintEnv ->
|
||||
V1.Referent ->
|
||||
V1.TermReference ->
|
||||
m Hash
|
||||
synhashTerm loadTerm ppe = \case
|
||||
V1.Referent.Con ref CT.Data -> pure (hashDerivedTerm ppe (Term.constructor @v () ref))
|
||||
V1.Referent.Con ref CT.Effect -> pure (hashDerivedTerm ppe (Term.request @v () ref))
|
||||
V1.Referent.Ref (ReferenceBuiltin builtin) -> pure (hashBuiltinTerm builtin)
|
||||
V1.Referent.Ref (ReferenceDerived ref) -> hashDerivedTerm ppe <$> loadTerm ref
|
||||
ReferenceBuiltin builtin -> pure (hashBuiltinTerm builtin)
|
||||
ReferenceDerived ref -> hashDerivedTerm ppe <$> loadTerm ref
|
||||
|
||||
hashTermTokens :: forall v a. Var v => PrettyPrintEnv -> Term v a -> [Token]
|
||||
hashTermTokens ppe =
|
||||
@ -242,9 +228,9 @@ hashTermFTokens ppe = \case
|
||||
Term.Char c -> [H.Tag 5, H.Nat (fromIntegral (ord c))]
|
||||
Term.Blank {} -> error "tried to hash a term with blanks, something's very wrong"
|
||||
-- note: these are all hashed the same, just based on the name
|
||||
Term.Ref r -> [H.Tag 7, hashReferentToken ppe (V1.Referent.Ref r)]
|
||||
Term.Constructor cr -> [H.Tag 7, hashReferentToken ppe (V1.Referent.Con cr CT.Data)]
|
||||
Term.Request cr -> [H.Tag 7, hashReferentToken ppe (V1.Referent.Con cr CT.Effect)]
|
||||
Term.Ref r -> [H.Tag 7, hashReferentToken ppe (Referent.Ref r)]
|
||||
Term.Constructor cr -> [H.Tag 7, hashReferentToken ppe (Referent.Con cr CT.Data)]
|
||||
Term.Request cr -> [H.Tag 7, hashReferentToken ppe (Referent.Con cr CT.Effect)]
|
||||
Term.Handle {} -> [H.Tag 8]
|
||||
Term.App {} -> [H.Tag 9]
|
||||
Term.Ann _ ty -> H.Tag 10 : hashTypeTokens ppe ty
|
||||
|
@ -26,6 +26,7 @@ library
|
||||
Unison.Merge.EitherWay
|
||||
Unison.Merge.EitherWayI
|
||||
Unison.Merge.Libdeps
|
||||
Unison.Merge.PartialDeclNameLookup
|
||||
Unison.Merge.PartitionCombinedDiffs
|
||||
Unison.Merge.Synhash
|
||||
Unison.Merge.Synhashed
|
||||
|
@ -579,14 +579,10 @@ lsBranch codebase b0 = do
|
||||
(ns, (h, stats)) <- Map.toList $ childrenWithStats
|
||||
guard $ V2Branch.hasDefinitions stats
|
||||
pure $ ShallowBranchEntry ns (V2Causal.causalHash h) stats
|
||||
patchEntries :: [ShallowListEntry Symbol Ann] = do
|
||||
(ns, _h) <- Map.toList $ V2Branch.patches b0
|
||||
pure $ ShallowPatchEntry ns
|
||||
pure . List.sortOn listEntryName $
|
||||
termEntries
|
||||
++ typeEntries
|
||||
++ branchEntries
|
||||
++ patchEntries
|
||||
|
||||
-- Any absolute names in the input which have `root` as a prefix
|
||||
-- are converted to names relative to current path. All other names are
|
||||
|
@ -3,7 +3,6 @@
|
||||
|
||||
module Unison.Server.Local.Endpoints.Current where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Aeson
|
||||
import Data.OpenApi (ToSchema (..))
|
||||
import Servant ((:>))
|
||||
|
@ -4,7 +4,6 @@
|
||||
|
||||
module Unison.Server.Local.Endpoints.FuzzyFind where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Aeson
|
||||
import Data.OpenApi (ToSchema)
|
||||
import Servant
|
||||
|
@ -4,7 +4,6 @@
|
||||
|
||||
module Unison.Server.Local.Endpoints.NamespaceDetails where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Set qualified as Set
|
||||
import Servant (Capture, QueryParam, (:>))
|
||||
import Servant.Docs (DocCapture (..), ToCapture (..))
|
||||
|
@ -4,7 +4,6 @@
|
||||
|
||||
module Unison.Server.Local.Endpoints.NamespaceListing (serve, NamespaceListingAPI, NamespaceListing (..), NamespaceObject (..), NamedNamespace (..), NamedPatch (..), KindExpression (..)) where
|
||||
|
||||
import Control.Monad.Except
|
||||
import Data.Aeson
|
||||
import Data.OpenApi (ToSchema)
|
||||
import Servant
|
||||
|
@ -104,7 +104,7 @@ data ExactName name ref = ExactName
|
||||
{ name :: name,
|
||||
ref :: ref
|
||||
}
|
||||
deriving stock (Show, Eq, Ord)
|
||||
deriving stock (Show, Eq, Functor, Ord)
|
||||
|
||||
instance ToParamSchema (ExactName Name ShortHash) where
|
||||
toParamSchema _ =
|
||||
|
@ -203,7 +203,7 @@ entityDependencies = \case
|
||||
C Causal {namespaceHash, parents} -> Set.insert namespaceHash parents
|
||||
|
||||
data TermComponent text hash = TermComponent [(LocalIds text hash, ByteString)]
|
||||
deriving stock (Show, Eq, Ord)
|
||||
deriving stock (Show, Eq, Functor, Ord)
|
||||
|
||||
instance Bifoldable TermComponent where
|
||||
bifoldMap = bifoldMapDefault
|
||||
@ -252,7 +252,7 @@ decodeComponentPiece = Aeson.withObject "Component Piece" \obj -> do
|
||||
pure (localIDs, bytes)
|
||||
|
||||
data DeclComponent text hash = DeclComponent [(LocalIds text hash, ByteString)]
|
||||
deriving stock (Show, Eq, Ord)
|
||||
deriving stock (Show, Eq, Functor, Ord)
|
||||
|
||||
instance Bifoldable DeclComponent where
|
||||
bifoldMap = bifoldMapDefault
|
||||
@ -280,7 +280,7 @@ data LocalIds text hash = LocalIds
|
||||
{ texts :: [text],
|
||||
hashes :: [hash]
|
||||
}
|
||||
deriving stock (Show, Eq, Ord)
|
||||
deriving stock (Show, Eq, Functor, Ord)
|
||||
|
||||
instance Bifoldable LocalIds where
|
||||
bifoldMap = bifoldMapDefault
|
||||
@ -381,7 +381,7 @@ data Namespace text hash = Namespace
|
||||
childLookup :: [(hash, hash)], -- (namespace hash, causal hash)
|
||||
bytes :: LocalBranchBytes
|
||||
}
|
||||
deriving stock (Eq, Ord, Show)
|
||||
deriving stock (Eq, Functor, Ord, Show)
|
||||
|
||||
instance Bifoldable Namespace where
|
||||
bifoldMap = bifoldMapDefault
|
||||
|
20
unison-src/transcripts-manual/docs.to-html.md
Normal file
20
unison-src/transcripts-manual/docs.to-html.md
Normal file
@ -0,0 +1,20 @@
|
||||
```ucm
|
||||
.> project.create test-html-docs
|
||||
test-html-docs/main> builtins.merge
|
||||
```
|
||||
|
||||
```unison
|
||||
{{A doc directly in the namespace.}}
|
||||
some.ns.direct = 1
|
||||
|
||||
{{A doc pretty deeply nested in the namespace.}}
|
||||
some.ns.pretty.deeply.nested = 2
|
||||
|
||||
{{A doc outside the namespace.}}
|
||||
some.outside = 3
|
||||
```
|
||||
|
||||
```ucm
|
||||
test-html-docs/main> add
|
||||
test-html-docs/main> docs.to-html some.ns unison-src/transcripts-manual/docs.to-html
|
||||
```
|
75
unison-src/transcripts-manual/docs.to-html.output.md
Normal file
75
unison-src/transcripts-manual/docs.to-html.output.md
Normal file
@ -0,0 +1,75 @@
|
||||
```ucm
|
||||
.> project.create test-html-docs
|
||||
|
||||
🎉 I've created the project test-html-docs.
|
||||
|
||||
I'll now fetch the latest version of the base Unison
|
||||
library...
|
||||
|
||||
Downloaded 14053 entities.
|
||||
|
||||
🎨 Type `ui` to explore this project's code in your browser.
|
||||
🔭 Discover libraries at https://share.unison-lang.org
|
||||
📖 Use `help-topic projects` to learn more about projects.
|
||||
|
||||
Write your first Unison code with UCM:
|
||||
|
||||
1. Open scratch.u.
|
||||
2. Write some Unison code and save the file.
|
||||
3. In UCM, type `add` to save it to your new project.
|
||||
|
||||
🎉 🥳 Happy coding!
|
||||
|
||||
test-html-docs/main> builtins.merge
|
||||
|
||||
Done.
|
||||
|
||||
```
|
||||
```unison
|
||||
{{A doc directly in the namespace.}}
|
||||
some.ns.direct = 1
|
||||
|
||||
{{A doc pretty deeply nested in the namespace.}}
|
||||
some.ns.pretty.deeply.nested = 2
|
||||
|
||||
{{A doc outside the namespace.}}
|
||||
some.outside = 3
|
||||
```
|
||||
|
||||
```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`:
|
||||
|
||||
some.ns.direct : Nat
|
||||
some.ns.direct.doc : Doc
|
||||
some.ns.pretty.deeply.nested : Nat
|
||||
(also named lib.base.data.Map.internal.ratio)
|
||||
some.ns.pretty.deeply.nested.doc : Doc
|
||||
some.outside : Nat
|
||||
(also named lib.base.data.Map.internal.delta)
|
||||
some.outside.doc : Doc
|
||||
|
||||
```
|
||||
```ucm
|
||||
test-html-docs/main> add
|
||||
|
||||
⍟ I've added these definitions:
|
||||
|
||||
some.ns.direct : Nat
|
||||
some.ns.direct.doc : Doc
|
||||
some.ns.pretty.deeply.nested : Nat
|
||||
(also named lib.base.data.Map.internal.ratio)
|
||||
some.ns.pretty.deeply.nested.doc : Doc
|
||||
some.outside : Nat
|
||||
(also named lib.base.data.Map.internal.delta)
|
||||
some.outside.doc : Doc
|
||||
|
||||
test-html-docs/main> docs.to-html some.ns unison-src/transcripts-manual/docs.to-html
|
||||
|
||||
```
|
@ -0,0 +1 @@
|
||||
<article class="unison-doc"><span class="span"><span class="word">A doc directly in the namespace.</span></span><div class="tooltips" style="display: none;"></div></article>
|
@ -0,0 +1 @@
|
||||
<article class="unison-doc"><span class="span"><span class="word">A doc pretty deeply nested in the namespace.</span></span><div class="tooltips" style="display: none;"></div></article>
|
@ -4,7 +4,6 @@ When we start out, `./scheme-libs/racket` contains a bunch of library files that
|
||||
Next, we'll download the jit project and generate a few Racket files from it.
|
||||
|
||||
```ucm
|
||||
.> project.create-empty jit-setup
|
||||
jit-setup/main> lib.install @unison/internal/releases/0.0.17
|
||||
```
|
||||
|
||||
|
@ -183,7 +183,7 @@ woot1to2 x =
|
||||
|
||||
wootEx : Nat ->{Woot2} Nat
|
||||
wootEx a =
|
||||
_ = !Woot2.woot2
|
||||
_ = Woot2.woot2()
|
||||
blah2
|
||||
|
||||
blah = 123
|
||||
@ -198,7 +198,7 @@ After adding the rewritten form to the codebase, here's the rewritten `Woot1` to
|
||||
|
||||
wootEx : Nat ->{Woot2} Nat
|
||||
wootEx a =
|
||||
_ = !woot2
|
||||
_ = woot2()
|
||||
blah2
|
||||
|
||||
```
|
||||
|
@ -24,7 +24,7 @@ So we can see the pretty-printed output:
|
||||
|
||||
☝️
|
||||
|
||||
I added 105 definitions to the top of scratch.u
|
||||
I added 110 definitions to the top of scratch.u
|
||||
|
||||
You can edit them there, then run `update` to replace the
|
||||
definitions currently in this namespace.
|
||||
@ -73,13 +73,13 @@ structural ability Zoink where
|
||||
Abort.toDefault! : a -> '{g, Abort} a ->{g} a
|
||||
Abort.toDefault! default thunk =
|
||||
h x = Abort.toDefault! (handler_1778 default x) thunk
|
||||
handle !thunk with h
|
||||
handle thunk() with h
|
||||
|
||||
Abort.toOptional : '{g, Abort} a -> '{g} Optional a
|
||||
Abort.toOptional thunk = do toOptional! thunk
|
||||
|
||||
Abort.toOptional! : '{g, Abort} a ->{g} Optional a
|
||||
Abort.toOptional! thunk = toDefault! None do Some !thunk
|
||||
Abort.toOptional! thunk = toDefault! None do Some thunk()
|
||||
|
||||
catchAll : x -> Nat
|
||||
catchAll x = 99
|
||||
@ -87,7 +87,7 @@ catchAll x = 99
|
||||
Decode.remainder : '{Ask (Optional Bytes)} Bytes
|
||||
Decode.remainder = do match ask with
|
||||
None -> Bytes.empty
|
||||
Some b -> b Bytes.++ !Decode.remainder
|
||||
Some b -> b Bytes.++ Decode.remainder()
|
||||
|
||||
ex1 : Nat
|
||||
ex1 =
|
||||
@ -168,7 +168,7 @@ fix_2271 =
|
||||
# Full doc body indented
|
||||
|
||||
``` raw
|
||||
myVal1 = 42
|
||||
myVal1 = 42
|
||||
myVal2 = 43
|
||||
myVal4 = 44
|
||||
```
|
||||
@ -194,7 +194,7 @@ fix_2650 =
|
||||
use Nat +
|
||||
y = 12
|
||||
13 + y
|
||||
!addNumbers
|
||||
addNumbers()
|
||||
|
||||
fix_2650a : tvar -> fun -> ()
|
||||
fix_2650a tvar fun = ()
|
||||
@ -331,6 +331,85 @@ fix_4384e =
|
||||
}}
|
||||
}}
|
||||
|
||||
fix_4727 : Doc2
|
||||
fix_4727 = {{ `` 0xs900dc0ffee `` }}
|
||||
|
||||
fix_4729a : Doc2
|
||||
fix_4729a =
|
||||
{{
|
||||
# H1A
|
||||
|
||||
## H2A
|
||||
|
||||
```
|
||||
{{
|
||||
# H1B
|
||||
|
||||
## B2B
|
||||
|
||||
|
||||
}}
|
||||
```
|
||||
|
||||
## H2A
|
||||
|
||||
|
||||
}}
|
||||
|
||||
fix_4729b : Doc2
|
||||
fix_4729b =
|
||||
{{
|
||||
# H1A
|
||||
|
||||
## H2A
|
||||
|
||||
{{ docTable
|
||||
[[{{
|
||||
# HA
|
||||
|
||||
|
||||
}}, {{
|
||||
# HB
|
||||
|
||||
|
||||
}}], [{{
|
||||
# a
|
||||
|
||||
|
||||
}}, {{
|
||||
# b
|
||||
|
||||
|
||||
}}]] }}
|
||||
|
||||
## H2A
|
||||
|
||||
|
||||
}}
|
||||
|
||||
fix_4729c : Doc2
|
||||
fix_4729c =
|
||||
{{
|
||||
# Examples ``
|
||||
docCallout
|
||||
(Some
|
||||
(syntax.docUntitledSection
|
||||
[syntax.docSection (syntax.docParagraph [syntax.docWord "Title"]) []]))
|
||||
(syntax.docUntitledSection
|
||||
[ syntax.docParagraph
|
||||
[ syntax.docWord "This"
|
||||
, syntax.docWord "is"
|
||||
, syntax.docWord "a"
|
||||
, syntax.docWord "callout"
|
||||
, syntax.docWord "with"
|
||||
, syntax.docWord "a"
|
||||
, syntax.docWord "title"
|
||||
]
|
||||
]) ``
|
||||
|
||||
|
||||
}}
|
||||
|
||||
Fix_525.bar.quaffle : Nat
|
||||
Fix_525.bar.quaffle = 32
|
||||
|
||||
@ -342,6 +421,16 @@ fix_525_exampleTerm quaffle =
|
||||
fix_525_exampleType : Id qualifiedName -> Id Fully.qualifiedName
|
||||
fix_525_exampleType z = Id (Dontcare () 19)
|
||||
|
||||
fnApplicationSyntax : Nat
|
||||
fnApplicationSyntax =
|
||||
use Nat +
|
||||
Environment.default = do 1 + 1
|
||||
oog = do 2 + 2
|
||||
blah : Nat -> Float -> Nat
|
||||
blah x y = x + 1
|
||||
_ = blah Environment.default() 1.0
|
||||
blah oog() (max 1.0 2.0)
|
||||
|
||||
Foo.bar.qux1 : Nat
|
||||
Foo.bar.qux1 = 42
|
||||
|
||||
@ -672,7 +761,7 @@ UUID.random = do UUID 0 (0, 0)
|
||||
|
||||
UUID.randomUUIDBytes : 'Bytes
|
||||
UUID.randomUUIDBytes = do
|
||||
(UUID a (b, _)) = !random
|
||||
(UUID a (b, _)) = random()
|
||||
encodeNat64be a Bytes.++ encodeNat64be b
|
||||
|
||||
(|>) : a -> (a ->{e} b) ->{e} b
|
||||
|
@ -1,5 +1,5 @@
|
||||
|
||||
-- A very simple example to start
|
||||
-- A very simple example to start
|
||||
simplestPossibleExample = 1 + 1
|
||||
|
||||
-- Destructuring binds
|
||||
@ -73,7 +73,7 @@ Abort.toDefault! default thunk =
|
||||
h x = Abort.toDefault! (handler_1778 default x) thunk
|
||||
handle (thunk ()) with h
|
||||
|
||||
fix_1778 =
|
||||
fix_1778 =
|
||||
'(let
|
||||
abort
|
||||
0) |> Abort.toOptional
|
||||
@ -91,19 +91,19 @@ fix_1536 = 'let
|
||||
fix_2271 : Doc2
|
||||
fix_2271 =
|
||||
{{ # Full doc body indented
|
||||
|
||||
|
||||
``` raw
|
||||
myVal1 = 42
|
||||
myVal1 = 42
|
||||
myVal2 = 43
|
||||
myVal4 = 44
|
||||
```
|
||||
|
||||
|
||||
``` raw
|
||||
indented1= "hi"
|
||||
indented2="this is two indents"
|
||||
```
|
||||
|
||||
I am two spaces over
|
||||
|
||||
I am two spaces over
|
||||
}}
|
||||
|
||||
|
||||
@ -156,7 +156,7 @@ fix_525_exampleTerm quaffle = Fix_525.bar.quaffle + 1
|
||||
|
||||
-- This demonstrates the same thing for types.
|
||||
-- exampleType's signature locally binds the 'qualifiedName' type parameter,
|
||||
-- so the pretty-printer should use the longer name 'Fully.qualifiedName'
|
||||
-- so the pretty-printer should use the longer name 'Fully.qualifiedName'
|
||||
structural type Fully.qualifiedName = Dontcare () Nat
|
||||
|
||||
structural type Id a = Id a
|
||||
@ -166,10 +166,10 @@ fix_525_exampleType z = Id (Dontcare () 19)
|
||||
|
||||
-- We'd get a type error if `exampleTerm` or `exampleType` didn't round-trip, but it typechecks okay!
|
||||
|
||||
-- Use clauses can't introduce shadowing
|
||||
-- Use clauses can't introduce shadowing
|
||||
|
||||
use_clauses_example : Int -> Text -> Nat
|
||||
use_clauses_example oo quaffle =
|
||||
use_clauses_example oo quaffle =
|
||||
Fix_525.bar.quaffle + Fix_525.bar.quaffle + 1
|
||||
|
||||
use_clauses_example2 : Int -> Nat
|
||||
@ -193,29 +193,29 @@ Foo'.bar.qux2 = "45"
|
||||
Foo.bar.qux3 = 46
|
||||
Foo'.bar.qux3 = "47"
|
||||
|
||||
ex1 =
|
||||
ex1 =
|
||||
a = Foo.bar.qux3 + Foo.bar.qux3
|
||||
Foo.bar.qux1 + Foo.bar.qux1 + Foo.bar.qux2
|
||||
|
||||
ex2 =
|
||||
a =
|
||||
ex2 =
|
||||
a =
|
||||
-- use Foo.bar qux3 will get pushed in here since it's already a multiline block
|
||||
z = 203993
|
||||
Foo.bar.qux3 + Foo.bar.qux3
|
||||
Foo.bar.qux1 + Foo.bar.qux1 + Foo.bar.qux2
|
||||
|
||||
ex3 =
|
||||
ex3 =
|
||||
a = do
|
||||
-- use clause gets pushed in here
|
||||
x = Foo.bar.qux3 + Foo.bar.qux3
|
||||
x + x
|
||||
()
|
||||
|
||||
ex3a =
|
||||
ex3a =
|
||||
a = do Foo.bar.qux3 + Foo.bar.qux3 -- use clause will get pulled up to top level
|
||||
()
|
||||
|
||||
-- Make sure use clauses don't show up before a soft hang
|
||||
-- Make sure use clauses don't show up before a soft hang
|
||||
-- Regression test for https://github.com/unisonweb/unison/issues/3883
|
||||
|
||||
structural type UUID = UUID Nat (Nat, Nat)
|
||||
@ -249,7 +249,7 @@ raw_d = """
|
||||
|
||||
"""
|
||||
|
||||
-- Fix for wonky treatment of abilities with multi-segment constructor names
|
||||
-- Fix for wonky treatment of abilities with multi-segment constructor names
|
||||
-- Regression test for https://github.com/unisonweb/unison/issues/3239
|
||||
|
||||
structural ability Zoink where
|
||||
@ -387,14 +387,14 @@ softhang21a = handle
|
||||
{ a } -> "lskdfjlaksjdf al;ksdjf;lkj sa;sldkfja;sldfkj a;lsdkfj asd;lfkj "
|
||||
{ Abort.abort -> _ } -> "lskdfjlaksjdf al;ksdjf;lkj sa;sldkfja;sldfkj a;lsdkfj asd;lfkj "
|
||||
|
||||
softhang2 x f = 0
|
||||
softhang2 x f = 0
|
||||
|
||||
softhang22 = softhang2 [0,1,2,3,4,5] cases
|
||||
0 -> 0
|
||||
1 -> 1
|
||||
n -> n + 100
|
||||
|
||||
catchAll x =
|
||||
catchAll x =
|
||||
99
|
||||
|
||||
softhang23 = do
|
||||
@ -416,13 +416,13 @@ softhang26 = softhang2 [1,2,3,4] cases
|
||||
0 -> 1
|
||||
n -> n + 1
|
||||
|
||||
forkAt loc c =
|
||||
forkAt loc c =
|
||||
x = 99
|
||||
390439034
|
||||
390439034
|
||||
|
||||
softhang27 somewhere = forkAt somewhere do
|
||||
x = 1
|
||||
y = 2
|
||||
y = 2
|
||||
x + y
|
||||
|
||||
softhang28 = softhang2 [0,1,2,3,4,5] cases
|
||||
@ -432,13 +432,13 @@ softhang28 = softhang2 [0,1,2,3,4,5] cases
|
||||
|
||||
-- Weirdness reported by Stew with super long lines
|
||||
|
||||
longlines x =
|
||||
longlines x =
|
||||
u = 92393
|
||||
x
|
||||
|
||||
longlines_helper x = do x
|
||||
|
||||
longlines1 = do
|
||||
longlines1 = do
|
||||
longlines !(longlines_helper "This has to laksdjf alsdkfj alskdjf asdf be a long enough string to force a line break")
|
||||
|
||||
longlines2 =
|
||||
@ -456,7 +456,7 @@ test3 = do
|
||||
|
||||
-- Regression test for https://github.com/unisonweb/unison/issues/4239
|
||||
-- `n` was replaced by `error` but should not be. Instead, render as if
|
||||
-- a second param, _, had been provided in the definition.
|
||||
-- a second param, _, had been provided in the definition.
|
||||
(>>>>) : Nat -> Nat -> ()
|
||||
(>>>>) n = cases
|
||||
_ -> bug ""
|
||||
@ -472,11 +472,11 @@ fix_4352 = {{``+1``}}
|
||||
-- regression test to make sure we don't use soft hang between a `do` and `match`
|
||||
-- if there's imports that have been inserted there
|
||||
|
||||
structural ability Ask a where
|
||||
ask : a
|
||||
structural ability Ask a where
|
||||
ask : a
|
||||
|
||||
Decode.remainder : '{Ask (Optional Bytes)} Bytes
|
||||
Decode.remainder = do
|
||||
Decode.remainder = do
|
||||
use Bytes ++
|
||||
match ask with
|
||||
None -> Bytes.empty
|
||||
@ -488,7 +488,7 @@ fix_4340 = HandlerWebSocket cases
|
||||
1 -> "hi sdflkj sdlfkjsdflkj sldfkj sldkfj sdf asdlkfjs dlfkj sldfkj sdf"
|
||||
_ -> abort
|
||||
|
||||
fix_4258 x y z =
|
||||
fix_4258 x y z =
|
||||
_ = "fix_4258"
|
||||
()
|
||||
|
||||
@ -497,26 +497,26 @@ fix_4258_example = fix_4258 1 () 2
|
||||
-- previously, lexer was emitting virtual semicolons inside parens, which
|
||||
-- led to some very odd parse errors in cases like these
|
||||
|
||||
stew_issue =
|
||||
stew_issue =
|
||||
error x = ()
|
||||
(++) a b = 0
|
||||
toText a = a
|
||||
Debug : a -> b -> ()
|
||||
Debug a b = ()
|
||||
error
|
||||
(Debug None '(Debug "Failed " -- virtual semicolon here was tripping up parser
|
||||
(Debug None '(Debug "Failed " -- virtual semicolon here was tripping up parser
|
||||
42))
|
||||
stew_issue2 =
|
||||
stew_issue2 =
|
||||
error x = ()
|
||||
(++) a b = 0
|
||||
toText a = a
|
||||
Debug : a -> b -> ()
|
||||
Debug a b = ()
|
||||
error
|
||||
(Debug None '("Failed " ++
|
||||
(Debug None '("Failed " ++
|
||||
toText 42))
|
||||
|
||||
stew_issue3 =
|
||||
stew_issue3 =
|
||||
id x = x
|
||||
error x = ()
|
||||
(++) a b = 0
|
||||
@ -525,7 +525,7 @@ stew_issue3 =
|
||||
configPath = 0
|
||||
Debug a b = ()
|
||||
error
|
||||
(Debug None '("Failed to get timestamp of config file " ++
|
||||
(Debug None '("Failed to get timestamp of config file " ++
|
||||
toText configPath))
|
||||
|
||||
fix_4384 = {{ {{ docExampleBlock 0 do 2 }} }}
|
||||
@ -539,7 +539,58 @@ fix_4384c = {{ {{ docExampleBlock 0 do
|
||||
|
||||
fix_4384d = {{ {{ docExampleBlock 0 '[1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18] }} }}
|
||||
|
||||
fix_4384e =
|
||||
fix_4384e =
|
||||
id : x -> x
|
||||
id x = x
|
||||
{{ {{ docExampleBlock 0 (id id id id id id id id id id id id id id id id id id id id id (x -> 0) }} }}
|
||||
{{ {{ docExampleBlock 0 (id id id id id id id id id id id id id id id id id id id id id (x -> 0) }} }}
|
||||
|
||||
fnApplicationSyntax =
|
||||
Environment.default = do 1 + 1
|
||||
oog = do 2 + 2
|
||||
blah : Nat -> Float -> Nat
|
||||
blah x y = x + 1
|
||||
_ = blah Environment.default() 1.0
|
||||
blah oog() (Float.max 1.0 2.0)
|
||||
|
||||
fix_4727 = {{ `` 0xs900dc0ffee `` }}
|
||||
|
||||
fix_4729a = {{
|
||||
# H1A
|
||||
|
||||
## H2A
|
||||
|
||||
```
|
||||
{{
|
||||
# H1B
|
||||
|
||||
## B2B
|
||||
}}
|
||||
```
|
||||
|
||||
## H2A
|
||||
}}
|
||||
|
||||
fix_4729b = {{
|
||||
# H1A
|
||||
|
||||
## H2A
|
||||
|
||||
{{ docTable [
|
||||
[ {{ # HA }}, {{ # HB }} ],
|
||||
[ {{ ## a }}, {{ ## b }} ]
|
||||
] }}
|
||||
|
||||
## H2A
|
||||
}}
|
||||
|
||||
fix_4729c = {{
|
||||
# Examples
|
||||
```
|
||||
docCallout
|
||||
(Some
|
||||
{{
|
||||
# Title
|
||||
|
||||
}}) {{ This is a callout with a title }}
|
||||
```
|
||||
}}
|
||||
|
45
unison-src/transcripts-using-base/fix5129.md
Normal file
45
unison-src/transcripts-using-base/fix5129.md
Normal file
@ -0,0 +1,45 @@
|
||||
```ucm:hide
|
||||
.> builtins.mergeio
|
||||
```
|
||||
|
||||
Checks for some bad type checking behavior. Some ability subtyping was
|
||||
too lenient when higher-order functions were involved.
|
||||
|
||||
```unison:error
|
||||
foreach : (a ->{g} ()) -> [a] ->{g} ()
|
||||
foreach f = cases
|
||||
[] -> ()
|
||||
x +: xs ->
|
||||
f x
|
||||
foreach f xs
|
||||
|
||||
forkIt : '{IO} () ->{IO} ()
|
||||
forkIt e =
|
||||
_ = IO.forkComp e
|
||||
()
|
||||
|
||||
thunk : '{IO,Exception} ()
|
||||
thunk = do
|
||||
raise (Failure (typeLink MiscFailure) "thunk" (Any ()))
|
||||
|
||||
go = do
|
||||
foreach forkIt [thunk]
|
||||
```
|
||||
|
||||
This comes from issue #3513
|
||||
|
||||
```unison:error
|
||||
(<<) : (b ->{e} c) -> (a ->{e} b) -> a ->{e} c
|
||||
(<<) f g x = f (g x)
|
||||
|
||||
catchAll.impl : '{IO, Exception} a ->{IO} Either Failure a
|
||||
catchAll.impl thunk =
|
||||
handle tryEval do catch thunk
|
||||
with
|
||||
cases
|
||||
{ x } -> x
|
||||
{Exception.raise f -> _} -> Left f
|
||||
|
||||
fancyTryEval : '{g, IO, Exception} a ->{g, IO, Exception} a
|
||||
fancyTryEval = reraise << catchAll.impl
|
||||
```
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user