unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-11 10:35:57 +03:00
Code Issues Projects Releases Wiki Activity

Merge branch 'trunk' into better-CLI-error-messages

Browse Source
This commit is contained in:
Greg Pfeil 2024-06-26 16:24:57 -06:00 committed by GitHub
commit f14fca03a0
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
169 changed files with 3002 additions and 4551 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
.github/workflows/ci.yaml vendored
View File

@ -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
View File

@ -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
View File

@ -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:

2
.mergify.yml
View File

@ -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)

1
CONTRIBUTORS.markdown
View File

@ -86,3 +86,4 @@ The format for this list: name, GitHub handle
* Upendra Upadhyay (@upendra1997)
* Dan Doel (@dolio)
* Eric Torreborre (@etorreborre)
* Eduard Nicodei (@neduard)

2
README.md
View File

@ -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

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs
View File

@ -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

70
codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs
View File

@ -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)

6
codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TermEdit.hs
View File

@ -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

2
codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/TypeEdit.hs
View File

@ -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

344
codebase2/codebase-sqlite/U/Codebase/Sqlite/Queries.hs
View File

@ -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 =

8
codebase2/codebase-sqlite/U/Codebase/Sqlite/Reference.hs
View File

@ -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

2
codebase2/codebase-sqlite/package.yaml
View File

@ -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

2
codebase2/codebase-sqlite/unison-codebase-sqlite.cabal
View File

@ -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

2
codebase2/codebase/U/Codebase/Referent.hs
View File

@ -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

1
codebase2/codebase/U/Codebase/Reflog.hs
View File

@ -13,6 +13,7 @@ data Entry causal text = Entry
toRootCausalHash :: causal,
reason :: text
}
deriving (Functor)
instance Bifunctor Entry where
bimap = bimapDefault

2
codebase2/core/U/Codebase/Reference.hs
View File

@ -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

2
codebase2/core/Unison/Core/Project.hs
View File

@ -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)

6
codebase2/util-term/U/Util/Type.hs
View File

@ -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)

164
docs/m1-mac-setup-tips.markdown
View File

@ -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
lib/unison-prelude/src/Unison/Util/Tuple.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE TypeOperators #-}
-- | Tuple utils.
module Unison.Util.Tuple

2
lib/unison-util-nametree/src/Unison/Util/Defns.hs
View File

@ -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

2
parser-typechecker/src/Unison/Builtin.hs
View File

@ -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

2
parser-typechecker/src/Unison/Builtin/Decls.hs
View File

@ -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

14
parser-typechecker/src/Unison/Codebase/Branch.hs
View File

@ -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

3
parser-typechecker/src/Unison/Codebase/Execute.hs
View File

@ -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

2
parser-typechecker/src/Unison/Codebase/MainTerm.hs
View File

@ -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

47
parser-typechecker/src/Unison/Codebase/Path.hs
View File

@ -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

1
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs
View File

@ -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

15
parser-typechecker/src/Unison/Codebase/SqliteCodebase/Operations.hs
View File

@ -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

3
parser-typechecker/src/Unison/KindInference/Solve/Monad.hs
View File

@ -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)
)

7
parser-typechecker/src/Unison/PatternMatchCoverage/Solve.hs
View File

@ -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

60
parser-typechecker/src/Unison/PrintError.hs
View File

@ -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

10
parser-typechecker/src/Unison/Runtime/Builtin.hs
View File

@ -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

15
parser-typechecker/src/Unison/Syntax/TermParser.hs
View File

@ -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

4
parser-typechecker/src/Unison/Syntax/TermPrinter.hs
View File

@ -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

6
parser-typechecker/src/Unison/Syntax/TypeParser.hs
View File

@ -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 "."

11
parser-typechecker/src/Unison/Typechecker/Context.hs
View File

@ -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

20
parser-typechecker/src/Unison/Util/Text.hs
View File

@ -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.
--

8
parser-typechecker/tests/Unison/Test/DataDeclaration.hs
View File

@ -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

4
parser-typechecker/tests/Unison/Test/Term.hs
View File

@ -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

4
parser-typechecker/tests/Unison/Test/Type.hs
View File

@ -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
]

4
parser-typechecker/tests/Unison/Test/Typechecker.hs
View File

@ -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]]

23
parser-typechecker/tests/Unison/Test/Util/Text.hs
View File

@ -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

1
scripts/check.sh
View File

@ -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

4
unison-cli/src/Unison/Cli/MonadUtils.hs
View File

@ -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

18
unison-cli/src/Unison/Cli/ProjectUtils.hs
View File

@ -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

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

@ -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)

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

@ -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)

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

@ -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

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

@ -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
View 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

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

@ -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

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

@ -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 ()

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

@ -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 ()

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

@ -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
--
-- [

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

@ -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
View 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
}

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

@ -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

7
unison-cli/src/Unison/Codebase/Editor/Input.hs
View File

@ -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.

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

@ -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

70
unison-cli/src/Unison/Codebase/Editor/TodoOutput.hs
View File

@ -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

28
unison-cli/src/Unison/Codebase/TranscriptParser.hs
View File

@ -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

4
unison-cli/src/Unison/CommandLine/BranchRelativePath.hs
View File

@ -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

12
unison-cli/src/Unison/CommandLine/Completion.hs
View File

@ -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)

126
unison-cli/src/Unison/CommandLine/InputPatterns.hs
View File

@ -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)

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

@ -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

1
unison-cli/src/Unison/LSP/CodeLens.hs
View File

@ -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

5
unison-cli/src/Unison/LSP/UCMWorker.hs
View File

@ -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

6
unison-cli/unison-cli.cabal
View File

@ -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

13
unison-core/src/Unison/HashQualified'.hs
View File

@ -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

8
unison-core/src/Unison/HashQualified.hs
View File

@ -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

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

@ -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

25
unison-core/src/Unison/Name/Internal.hs
View File

@ -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

2
unison-core/src/Unison/NamesWithHistory.hs
View File

@ -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 =

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

@ -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

26
unison-core/src/Unison/Type.hs
View File

@ -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

3
unison-core/src/Unison/Type/Names.hs
View File

@ -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)

6
unison-hashing-v2/src/Unison/Hashing/V2/Type.hs
View File

@ -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)

38
unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs
View File

@ -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)

122
unison-merge/src/Unison/Merge/Diff.hs
View File

@ -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
View 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)

48
unison-merge/src/Unison/Merge/Synhash.hs
View File

@ -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

1
unison-merge/unison-merge.cabal
View File

@ -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

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

@ -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

1
unison-share-api/src/Unison/Server/Local/Endpoints/Current.hs
View File

@ -3,7 +3,6 @@
module Unison.Server.Local.Endpoints.Current where
import Control.Monad.Except
import Data.Aeson
import Data.OpenApi (ToSchema (..))
import Servant ((:>))

1
unison-share-api/src/Unison/Server/Local/Endpoints/FuzzyFind.hs
View File

@ -4,7 +4,6 @@
module Unison.Server.Local.Endpoints.FuzzyFind where
import Control.Monad.Except
import Data.Aeson
import Data.OpenApi (ToSchema)
import Servant

1
unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceDetails.hs
View File

@ -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 (..))

1
unison-share-api/src/Unison/Server/Local/Endpoints/NamespaceListing.hs
View File

@ -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

2
unison-share-api/src/Unison/Server/Types.hs
View File

@ -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 _ =

8
unison-share-api/src/Unison/Sync/Types.hs
View File

@ -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
View 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
View 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
```

1
unison-src/transcripts-manual/docs.to-html/direct/doc.html Normal file
View File

@ -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>

1
unison-src/transcripts-manual/docs.to-html/pretty/deeply/nested/doc.html Normal file
View File

@ -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>

1
unison-src/transcripts-manual/gen-racket-libs.md
View File

@ -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
```

4
unison-src/transcripts-manual/rewrites.output.md
View File

@ -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
```

103
unison-src/transcripts-round-trip/main.output.md
View File

@ -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

125
unison-src/transcripts-round-trip/reparses-with-same-hash.u
View File

@ -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
View 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