mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
Merge branch 'trunk' into work/compiler
This commit is contained in:
commit
4e49cc9116
4
.github/workflows/ci.yaml
vendored
4
.github/workflows/ci.yaml
vendored
@ -157,6 +157,10 @@ jobs:
|
||||
run: stack --no-terminal build --fast --test unison-cli
|
||||
- name: unison-parser-typechecker tests
|
||||
run: stack --no-terminal build --fast --test unison-parser-typechecker
|
||||
- name: unison-syntax tests
|
||||
run: stack --no-terminal build --fast --test unison-syntax
|
||||
- name: unison-util-bytes tests
|
||||
run: stack --no-terminal build --fast --test unison-util-bytes
|
||||
- name: unison-util-relation tests
|
||||
run: stack --no-terminal build --fast --test unison-util-relation
|
||||
- name: transcripts
|
||||
|
26
.github/workflows/release.yaml
vendored
26
.github/workflows/release.yaml
vendored
@ -11,6 +11,10 @@ on:
|
||||
description: 'Release Version (E.g. M4 or M4a)'
|
||||
required: true
|
||||
type: string
|
||||
share_base_path:
|
||||
description: 'Path to base version that UCM should pull by default (E.g. `unison.public.base.releases.M4`)'
|
||||
required: true
|
||||
type: string
|
||||
target:
|
||||
description: 'Ref to use for this release, defaults to trunk'
|
||||
required: true
|
||||
@ -57,6 +61,8 @@ jobs:
|
||||
|
||||
name: "build_linux"
|
||||
runs-on: ubuntu-20.04
|
||||
env:
|
||||
UNISON_BASE_PATH: "${{inputs.share_base_path}}"
|
||||
steps:
|
||||
- uses: actions/checkout@v2
|
||||
with:
|
||||
@ -102,7 +108,11 @@ jobs:
|
||||
echo "$PWD/stack-"* >> $GITHUB_PATH
|
||||
|
||||
- name: build
|
||||
run: stack --no-terminal build --flag unison-parser-typechecker:optimized
|
||||
run: |
|
||||
# unison-cli checks env vars for which base version to automatically pull,
|
||||
# so it needs to be forced to rebuild to ensure those are updated.
|
||||
stack clean unison-cli
|
||||
stack --no-terminal build --flag unison-parser-typechecker:optimized
|
||||
|
||||
- name: fetch latest Unison Local UI and package with ucm
|
||||
run: |
|
||||
@ -123,6 +133,8 @@ jobs:
|
||||
build_macos:
|
||||
name: "build_macos"
|
||||
runs-on: macos-11
|
||||
env:
|
||||
UNISON_BASE_PATH: "${{inputs.share_base_path}}"
|
||||
steps:
|
||||
- uses: actions/checkout@v2
|
||||
with:
|
||||
@ -171,7 +183,11 @@ jobs:
|
||||
run: rm -rf ~/.stack/setup-exe-cache
|
||||
|
||||
- name: build
|
||||
run: stack --no-terminal build --flag unison-parser-typechecker:optimized
|
||||
run: |
|
||||
# unison-cli checks env vars for which base version to automatically pull,
|
||||
# so it needs to be forced to rebuild to ensure those are updated.
|
||||
stack clean unison-cli
|
||||
stack --no-terminal build --flag unison-parser-typechecker:optimized
|
||||
|
||||
- name: fetch latest Unison Local UI and package with ucm
|
||||
run: |
|
||||
@ -192,6 +208,8 @@ jobs:
|
||||
build_windows:
|
||||
name: "build_windows"
|
||||
runs-on: windows-2019
|
||||
env:
|
||||
UNISON_BASE_PATH: "${{inputs.share_base_path}}"
|
||||
|
||||
steps:
|
||||
- uses: actions/checkout@v2
|
||||
@ -239,6 +257,10 @@ jobs:
|
||||
|
||||
- name: build
|
||||
run: |
|
||||
# unison-cli checks env vars for which base version to automatically pull,
|
||||
# so it needs to be forced to rebuild to ensure those are updated.
|
||||
stack clean unison-cli
|
||||
|
||||
# Windows will crash on build intermittently because the filesystem
|
||||
# sucks at managing concurrent file access;
|
||||
# Just keep retrying on these failures.
|
||||
|
@ -5,8 +5,9 @@ The Unison language
|
||||
|
||||
* [Overview](#overview)
|
||||
* [Building using Stack](#building-using-stack)
|
||||
* [Language Server Protocol (LSP)](#language-server-protocol-lsp)
|
||||
* [Language Server Protocol (LSP)](docs/language-server.markdown)
|
||||
* [Codebase Server](#codebase-server)
|
||||
* [Configuration](./docs/configuration.md)
|
||||
|
||||
Overview
|
||||
--------
|
||||
@ -67,3 +68,8 @@ connect to the server.
|
||||
|
||||
The port, host and token can all be configured by providing environment
|
||||
variables when starting `ucm`: `UCM_PORT`, `UCM_HOST`, and `UCM_TOKEN`.
|
||||
|
||||
Configuration
|
||||
-------------
|
||||
|
||||
See the documentation for configuration [here](docs/configuration.md)
|
||||
|
@ -4,11 +4,13 @@ module U.Codebase.Sqlite.Operations
|
||||
loadRootCausalHash,
|
||||
expectRootCausalHash,
|
||||
expectRootCausal,
|
||||
expectRootBranchHash,
|
||||
loadCausalHashAtPath,
|
||||
expectCausalHashAtPath,
|
||||
saveBranch,
|
||||
loadCausalBranchByCausalHash,
|
||||
expectCausalBranchByCausalHash,
|
||||
expectBranchByBranchHash,
|
||||
expectNamespaceStatsByHash,
|
||||
expectNamespaceStatsByHashId,
|
||||
|
||||
@ -65,7 +67,7 @@ module U.Codebase.Sqlite.Operations
|
||||
termsMentioningType,
|
||||
|
||||
-- ** name lookup index
|
||||
rebuildNameIndex,
|
||||
updateNameIndex,
|
||||
rootNamesByPath,
|
||||
NamesByPath (..),
|
||||
|
||||
@ -91,7 +93,7 @@ module U.Codebase.Sqlite.Operations
|
||||
Q.s2cTermWithType,
|
||||
Q.s2cDecl,
|
||||
declReferencesByPrefix,
|
||||
branchHashesByPrefix,
|
||||
namespaceHashesByPrefix,
|
||||
derivedDependencies,
|
||||
)
|
||||
where
|
||||
@ -117,7 +119,7 @@ import qualified U.Codebase.Reference as C.Reference
|
||||
import qualified U.Codebase.Referent as C
|
||||
import qualified U.Codebase.Referent as C.Referent
|
||||
import qualified U.Codebase.Reflog as Reflog
|
||||
import U.Codebase.ShortHash (ShortBranchHash (ShortBranchHash))
|
||||
import U.Codebase.ShortHash (ShortCausalHash (..), ShortNamespaceHash (..))
|
||||
import qualified U.Codebase.Sqlite.Branch.Diff as S.Branch
|
||||
import qualified U.Codebase.Sqlite.Branch.Diff as S.Branch.Diff
|
||||
import qualified U.Codebase.Sqlite.Branch.Diff as S.BranchDiff
|
||||
@ -196,6 +198,11 @@ expectValueHashByCausalHashId = loadValueHashById <=< Q.expectCausalValueHashId
|
||||
expectRootCausalHash :: Transaction CausalHash
|
||||
expectRootCausalHash = Q.expectCausalHash =<< Q.expectNamespaceRoot
|
||||
|
||||
expectRootBranchHash :: Transaction BranchHash
|
||||
expectRootBranchHash = do
|
||||
rootCausalHashId <- Q.expectNamespaceRoot
|
||||
expectValueHashByCausalHashId rootCausalHashId
|
||||
|
||||
loadRootCausalHash :: Transaction (Maybe CausalHash)
|
||||
loadRootCausalHash =
|
||||
runMaybeT $
|
||||
@ -631,7 +638,8 @@ saveBranch ::
|
||||
saveBranch hh (C.Causal hc he parents me) = do
|
||||
when debug $ traceM $ "\nOperations.saveBranch \n hc = " ++ show hc ++ ",\n he = " ++ show he ++ ",\n parents = " ++ show (Map.keys parents)
|
||||
|
||||
(chId, bhId) <- flip Monad.fromMaybeM (Q.loadCausalByCausalHash hc) do
|
||||
-- Save the causal
|
||||
(chId, bhId) <- whenNothingM (Q.loadCausalByCausalHash hc) do
|
||||
-- if not exist, create these
|
||||
chId <- Q.saveCausalHash hc
|
||||
bhId <- Q.saveBranchHash he
|
||||
@ -648,7 +656,9 @@ saveBranch hh (C.Causal hc he parents me) = do
|
||||
-- Save these CausalHashIds to the causal_parents table,
|
||||
Q.saveCausal hh chId bhId parentCausalHashIds
|
||||
pure (chId, bhId)
|
||||
boId <- flip Monad.fromMaybeM (Q.loadBranchObjectIdByCausalHashId chId) do
|
||||
|
||||
-- Save the namespace
|
||||
boId <- flip Monad.fromMaybeM (Q.loadBranchObjectIdByBranchHashId bhId) do
|
||||
branch <- me
|
||||
dbBranch <- c2sBranch branch
|
||||
stats <- namespaceStatsForDbBranch dbBranch
|
||||
@ -716,6 +726,16 @@ loadDbBranchByCausalHashId causalHashId =
|
||||
Nothing -> pure Nothing
|
||||
Just branchObjectId -> Just <$> expectDbBranch branchObjectId
|
||||
|
||||
expectBranchByBranchHashId :: Db.BranchHashId -> Transaction (C.Branch.Branch Transaction)
|
||||
expectBranchByBranchHashId bhId = do
|
||||
boId <- Q.expectBranchObjectIdByBranchHashId bhId
|
||||
expectBranch boId
|
||||
|
||||
expectBranchByBranchHash :: BranchHash -> Transaction (C.Branch.Branch Transaction)
|
||||
expectBranchByBranchHash bh = do
|
||||
bhId <- Q.saveBranchHash bh
|
||||
expectBranchByBranchHashId bhId
|
||||
|
||||
-- | Expect a branch value given its causal hash id.
|
||||
expectDbBranchByCausalHashId :: Db.CausalHashId -> Transaction S.DbBranch
|
||||
expectDbBranchByCausalHashId causalHashId = do
|
||||
@ -1003,14 +1023,14 @@ declReferentsByPrefix b32prefix pos cid = do
|
||||
(_localIds, decl) <- Q.expectDeclObject r (decodeDeclElement i)
|
||||
pure (C.Decl.declType decl, length (C.Decl.constructorTypes decl))
|
||||
|
||||
branchHashesByPrefix :: ShortBranchHash -> Transaction (Set BranchHash)
|
||||
branchHashesByPrefix (ShortBranchHash b32prefix) = do
|
||||
namespaceHashesByPrefix :: ShortNamespaceHash -> Transaction (Set BranchHash)
|
||||
namespaceHashesByPrefix (ShortNamespaceHash b32prefix) = do
|
||||
hashIds <- Q.namespaceHashIdByBase32Prefix b32prefix
|
||||
hashes <- traverse (Q.expectHash . Db.unBranchHashId) hashIds
|
||||
pure $ Set.fromList . map BranchHash $ hashes
|
||||
|
||||
causalHashesByPrefix :: ShortBranchHash -> Transaction (Set CausalHash)
|
||||
causalHashesByPrefix (ShortBranchHash b32prefix) = do
|
||||
causalHashesByPrefix :: ShortCausalHash -> Transaction (Set CausalHash)
|
||||
causalHashesByPrefix (ShortCausalHash b32prefix) = do
|
||||
hashIds <- Q.causalHashIdByBase32Prefix b32prefix
|
||||
hashes <- traverse (Q.expectHash . Db.unCausalHashId) hashIds
|
||||
pure $ Set.fromList . map CausalHash $ hashes
|
||||
@ -1018,9 +1038,18 @@ causalHashesByPrefix (ShortBranchHash b32prefix) = do
|
||||
-- | returns a list of known definitions referencing `r`
|
||||
dependents :: Q.DependentsSelector -> C.Reference -> Transaction (Set C.Reference.Id)
|
||||
dependents selector r = do
|
||||
r' <- c2sReference r
|
||||
sIds <- Q.getDependentsForDependency selector r'
|
||||
Set.traverse s2cReferenceId sIds
|
||||
mr <- case r of
|
||||
C.ReferenceBuiltin {} -> pure (Just r)
|
||||
C.ReferenceDerived id_ ->
|
||||
objectExistsForHash (view C.idH id_) <&> \case
|
||||
True -> Just r
|
||||
False -> Nothing
|
||||
case mr of
|
||||
Nothing -> pure mempty
|
||||
Just r -> do
|
||||
r' <- c2sReference r
|
||||
sIds <- Q.getDependentsForDependency selector r'
|
||||
Set.traverse s2cReferenceId sIds
|
||||
|
||||
-- | returns a list of known definitions referencing `h`
|
||||
dependentsOfComponent :: H.Hash -> Transaction (Set C.Reference.Id)
|
||||
@ -1038,13 +1067,19 @@ derivedDependencies cid = do
|
||||
cids <- traverse s2cReferenceId sids
|
||||
pure $ Set.fromList cids
|
||||
|
||||
-- | Given the list of term and type names from the root branch, rebuild the name lookup
|
||||
-- table.
|
||||
rebuildNameIndex :: [S.NamedRef (C.Referent, Maybe C.ConstructorType)] -> [S.NamedRef C.Reference] -> Transaction ()
|
||||
rebuildNameIndex termNames typeNames = do
|
||||
Q.resetNameLookupTables
|
||||
Q.insertTermNames ((fmap (c2sTextReferent *** fmap c2sConstructorType) <$> termNames))
|
||||
Q.insertTypeNames ((fmap c2sTextReference <$> typeNames))
|
||||
-- | Given lists of names to add and remove, update the index accordingly.
|
||||
updateNameIndex ::
|
||||
-- | (add terms, remove terms)
|
||||
([S.NamedRef (C.Referent, Maybe C.ConstructorType)], [S.NamedRef C.Referent]) ->
|
||||
-- | (add types, remove types)
|
||||
([S.NamedRef C.Reference], [S.NamedRef C.Reference]) ->
|
||||
Transaction ()
|
||||
updateNameIndex (newTermNames, removedTermNames) (newTypeNames, removedTypeNames) = do
|
||||
Q.ensureNameLookupTables
|
||||
Q.removeTermNames ((fmap c2sTextReferent <$> removedTermNames))
|
||||
Q.removeTypeNames ((fmap c2sTextReference <$> removedTypeNames))
|
||||
Q.insertTermNames (fmap (c2sTextReferent *** fmap c2sConstructorType) <$> newTermNames)
|
||||
Q.insertTypeNames (fmap c2sTextReference <$> newTypeNames)
|
||||
|
||||
data NamesByPath = NamesByPath
|
||||
{ termNamesInPath :: [S.NamedRef (C.Referent, Maybe C.ConstructorType)],
|
||||
|
@ -79,7 +79,9 @@ module U.Codebase.Sqlite.Queries
|
||||
loadCausalByCausalHash,
|
||||
expectCausalByCausalHash,
|
||||
loadBranchObjectIdByCausalHashId,
|
||||
loadBranchObjectIdByBranchHashId,
|
||||
expectBranchObjectIdByCausalHashId,
|
||||
expectBranchObjectIdByBranchHashId,
|
||||
|
||||
-- ** causal_parent table
|
||||
saveCausalParents,
|
||||
@ -104,6 +106,7 @@ module U.Codebase.Sqlite.Queries
|
||||
getDependentsForDependencyComponent,
|
||||
getDependenciesForDependent,
|
||||
getDependencyIdsForDependent,
|
||||
getDependenciesBetweenTerms,
|
||||
|
||||
-- ** migrations
|
||||
currentSchemaVersion,
|
||||
@ -130,9 +133,12 @@ module U.Codebase.Sqlite.Queries
|
||||
causalHashIdByBase32Prefix,
|
||||
|
||||
-- * Name Lookup
|
||||
resetNameLookupTables,
|
||||
ensureNameLookupTables,
|
||||
dropNameLookupTables,
|
||||
insertTermNames,
|
||||
insertTypeNames,
|
||||
removeTermNames,
|
||||
removeTypeNames,
|
||||
rootTermNamesByPath,
|
||||
rootTypeNamesByPath,
|
||||
getNamespaceDefinitionCount,
|
||||
@ -1038,6 +1044,19 @@ loadBranchObjectIdByCausalHashIdSql =
|
||||
WHERE causal.self_hash_id = ?
|
||||
|]
|
||||
|
||||
expectBranchObjectIdByBranchHashId :: BranchHashId -> Transaction BranchObjectId
|
||||
expectBranchObjectIdByBranchHashId id = queryOneCol loadBranchObjectIdByBranchHashIdSql (Only id)
|
||||
|
||||
loadBranchObjectIdByBranchHashId :: BranchHashId -> Transaction (Maybe BranchObjectId)
|
||||
loadBranchObjectIdByBranchHashId id = queryMaybeCol loadBranchObjectIdByBranchHashIdSql (Only id)
|
||||
|
||||
loadBranchObjectIdByBranchHashIdSql :: Sql
|
||||
loadBranchObjectIdByBranchHashIdSql =
|
||||
[here|
|
||||
SELECT object_id FROM hash_object
|
||||
WHERE hash_id = ?
|
||||
|]
|
||||
|
||||
saveCausalParents :: CausalHashId -> [CausalHashId] -> Transaction ()
|
||||
saveCausalParents child parents = executeMany sql $ (child,) <$> parents where
|
||||
sql = [here|
|
||||
@ -1286,8 +1305,8 @@ garbageCollectWatchesWithoutObjects = do
|
||||
(SELECT hash_object.hash_id FROM hash_object)
|
||||
|]
|
||||
|
||||
addToDependentsIndex :: Reference.Reference -> Reference.Id -> Transaction ()
|
||||
addToDependentsIndex dependency dependent = execute sql (dependency :. dependent)
|
||||
addToDependentsIndex :: [Reference.Reference] -> Reference.Id -> Transaction ()
|
||||
addToDependentsIndex dependencies dependent = executeMany sql (map (:. dependent) dependencies)
|
||||
where sql = [here|
|
||||
INSERT INTO dependents_index (
|
||||
dependency_builtin,
|
||||
@ -1387,13 +1406,122 @@ getDependencyIdsForDependent dependent@(C.Reference.Id oid0 _) =
|
||||
FROM dependents_index
|
||||
WHERE dependency_builtin IS NULL
|
||||
AND dependent_object_id = ?
|
||||
AND dependen_component_index = ?
|
||||
AND dependent_component_index = ?
|
||||
|]
|
||||
|
||||
isNotSelfReference :: Reference.Id -> Bool
|
||||
isNotSelfReference (C.Reference.Id oid1 _) =
|
||||
oid0 /= oid1
|
||||
|
||||
-- | Given two term (components) A and B, return the set of all terms that are along any "dependency path" from A to B,
|
||||
-- not including A nor B; i.e., the transitive dependencies of A that are transitive dependents of B.
|
||||
--
|
||||
-- For example, if A depends on X and Y, X depends on Q, Y depends on Z, and X and Z depend on B...
|
||||
--
|
||||
-- --X-----Q
|
||||
-- / \
|
||||
-- A B
|
||||
-- \ /
|
||||
-- Y---Z
|
||||
--
|
||||
-- ...then `getDependenciesBetweenTerms A B` would return the set {X Y Z}
|
||||
getDependenciesBetweenTerms :: ObjectId -> ObjectId -> Transaction (Set ObjectId)
|
||||
getDependenciesBetweenTerms oid1 oid2 =
|
||||
queryListCol sql (oid1, oid2, oid2) <&> Set.fromList
|
||||
where
|
||||
-- Given the example above, we'd have tables that look like this.
|
||||
--
|
||||
-- First, the `paths` table finds all paths from source `A`, exploring depth-first. As a minor optimization, we seed
|
||||
-- the search not with `A`, but rather the direct dependencies of `A` (namely `X` and `Y`).
|
||||
--
|
||||
-- Naming note: "path_init" / "path_last" refer to the "init" / "last" elements of a list segments of a list (though
|
||||
-- our "last" is in reverse order):
|
||||
--
|
||||
-- [foo, bar, baz, qux]
|
||||
-- init ^^^^^^^^^^^^^
|
||||
-- last ^^^
|
||||
--
|
||||
-- +-paths-------------------------+
|
||||
-- +-level-+-path_last-+-path_init-+
|
||||
-- | 0 | X | '' | -- path: [X]
|
||||
-- | 0 | Y | '' | -- path: [Y]
|
||||
-- | 1 | B | 'X,' | -- path: [X,B] -- ends in B, yay!
|
||||
-- | 1 | Q | 'X,' | -- path: [X,Q]
|
||||
-- | 1 | Z | 'Y,' | -- path: [Y,Z]
|
||||
-- | 2 | B | 'Z,Y,' | -- path: [Y,Z,B] -- ends in B, yay!
|
||||
-- +-------+-----------+-----------+
|
||||
--
|
||||
-- Next, we seed another recursive CTE with those paths that end in the sink `B`. This is just the (very verbose)
|
||||
-- way to unnest an array in SQLite. All we're doing is turning the set of strings {'X,' 'Z,Y,'}, each of which
|
||||
-- represents the inner nodes of a full path between `A` and `B`, into the set {X Z Y}, which is just the full set
|
||||
-- of such inner nodes, along any path.
|
||||
--
|
||||
-- +-elems-----------------+
|
||||
-- +-path_elem-+-path_init-+
|
||||
-- | | 'X,' |
|
||||
-- | | 'Z,Y,' |
|
||||
-- | 'X' | '' |
|
||||
-- | 'Z' | 'Y,' |
|
||||
-- | 'Y' | '' |
|
||||
-- +-----------+-----------+
|
||||
--
|
||||
-- And finally, we just select out the non-null `path_elem` rows from here, casting the strings back to integers for
|
||||
-- clarity (this isn't very matter - SQLite would cast on-the-fly).
|
||||
--
|
||||
-- +-path_elem-+
|
||||
-- | X |
|
||||
-- | Z |
|
||||
-- | Y |
|
||||
-- +-----------+
|
||||
--
|
||||
-- Notes
|
||||
--
|
||||
-- (1) We only care about term dependencies, not type dependencies. This is because a type can only depend on types,
|
||||
-- not terms, so there is no point in searching through a type's transitive dependencies looking for our sink.
|
||||
-- (2) No need to search beyond the sink itself, since component dependencies form a DAG.
|
||||
-- (3) An explicit cast from e.g. string '1' to int 1 isn't strictly necessary.
|
||||
sql :: Sql
|
||||
sql = [here|
|
||||
WITH RECURSIVE paths(level, path_last, path_init) AS (
|
||||
SELECT
|
||||
0,
|
||||
dependents_index.dependency_object_id,
|
||||
''
|
||||
FROM dependents_index
|
||||
JOIN object ON dependents_index.dependency_object_id = object.id
|
||||
WHERE dependents_index.dependent_object_id = ?
|
||||
AND object.type_id = 0 -- Note (1)
|
||||
AND dependents_index.dependent_object_id != dependents_index.dependency_object_id
|
||||
UNION ALL
|
||||
SELECT
|
||||
paths.level + 1 AS level,
|
||||
dependents_index.dependency_object_id,
|
||||
dependents_index.dependent_object_id || ',' || paths.path_init
|
||||
FROM paths
|
||||
JOIN dependents_index
|
||||
ON paths.path_last = dependents_index.dependent_object_id
|
||||
JOIN object ON dependents_index.dependency_object_id = object.id
|
||||
WHERE object.type_id = 0 -- Note (1)
|
||||
AND dependents_index.dependent_object_id != dependents_index.dependency_object_id
|
||||
AND paths.path_last != ? -- Note (2)
|
||||
ORDER BY level DESC
|
||||
),
|
||||
elems(path_elem, path_init) AS (
|
||||
SELECT null, path_init
|
||||
FROM paths
|
||||
WHERE paths.path_last = ?
|
||||
UNION ALL
|
||||
SELECT
|
||||
substr(path_init, 0, instr(path_init, ',')),
|
||||
substr(path_init, instr(path_init, ',') + 1)
|
||||
FROM elems
|
||||
WHERE path_init != ''
|
||||
)
|
||||
SELECT DISTINCT CAST(path_elem AS integer) AS path_elem -- Note (3)
|
||||
FROM elems
|
||||
WHERE path_elem IS NOT null
|
||||
|]
|
||||
|
||||
objectIdByBase32Prefix :: ObjectType -> Text -> Transaction [ObjectId]
|
||||
objectIdByBase32Prefix objType prefix = queryListCol sql (objType, likeEscape '\\' prefix <> "%") where sql = [here|
|
||||
SELECT object.id FROM object
|
||||
@ -1441,14 +1569,26 @@ removeHashObjectsByHashingVersion hashVersion =
|
||||
WHERE hash_version = ?
|
||||
|]
|
||||
|
||||
-- | Drop and recreate the name lookup tables. Use this when resetting names to a new branch.
|
||||
resetNameLookupTables :: Transaction ()
|
||||
resetNameLookupTables = do
|
||||
execute_ "DROP TABLE IF EXISTS term_name_lookup"
|
||||
execute_ "DROP TABLE IF EXISTS type_name_lookup"
|
||||
-- | Not used in typical operations, but if we ever end up in a situation where a bug
|
||||
-- has caused the name lookup index to go out of sync this can be used to get back to a clean
|
||||
-- slate.
|
||||
dropNameLookupTables :: Transaction ()
|
||||
dropNameLookupTables = do
|
||||
execute_
|
||||
[here|
|
||||
CREATE TABLE term_name_lookup (
|
||||
DROP TABLE IF EXISTS term_name_lookup
|
||||
|]
|
||||
execute_
|
||||
[here|
|
||||
DROP TABLE IF EXISTS type_name_lookup
|
||||
|]
|
||||
|
||||
-- | Ensure the name lookup tables exist.
|
||||
ensureNameLookupTables :: Transaction ()
|
||||
ensureNameLookupTables = do
|
||||
execute_
|
||||
[here|
|
||||
CREATE TABLE IF NOT EXISTS term_name_lookup (
|
||||
-- The name of the term: E.g. map.List.base
|
||||
reversed_name TEXT NOT NULL,
|
||||
-- The namespace containing this term, not reversed: E.g. base.List
|
||||
@ -1463,7 +1603,7 @@ resetNameLookupTables = do
|
||||
|]
|
||||
execute_
|
||||
[here|
|
||||
CREATE INDEX term_names_by_namespace ON term_name_lookup(namespace)
|
||||
CREATE INDEX IF NOT EXISTS term_names_by_namespace ON term_name_lookup(namespace)
|
||||
|]
|
||||
-- Don't need this index at the moment, but will likely be useful later.
|
||||
-- execute_
|
||||
@ -1472,7 +1612,7 @@ resetNameLookupTables = do
|
||||
-- |]
|
||||
execute_
|
||||
[here|
|
||||
CREATE TABLE type_name_lookup (
|
||||
CREATE TABLE IF NOT EXISTS type_name_lookup (
|
||||
-- The name of the term: E.g. List.base
|
||||
reversed_name TEXT NOT NULL,
|
||||
-- The namespace containing this term, not reversed: E.g. base.List
|
||||
@ -1485,7 +1625,7 @@ resetNameLookupTables = do
|
||||
|]
|
||||
execute_
|
||||
[here|
|
||||
CREATE INDEX type_names_by_namespace ON type_name_lookup(namespace)
|
||||
CREATE INDEX IF NOT EXISTS type_names_by_namespace ON type_name_lookup(namespace)
|
||||
|]
|
||||
|
||||
-- Don't need this index at the moment, but will likely be useful later.
|
||||
@ -1508,6 +1648,37 @@ insertTermNames names = do
|
||||
ON CONFLICT DO NOTHING
|
||||
|]
|
||||
|
||||
-- | Remove the given set of term names into the name lookup table
|
||||
removeTermNames :: [NamedRef Referent.TextReferent] -> Transaction ()
|
||||
removeTermNames names = do
|
||||
executeMany sql names
|
||||
where
|
||||
sql =
|
||||
[here|
|
||||
DELETE FROM term_name_lookup
|
||||
WHERE
|
||||
reversed_name IS ?
|
||||
AND referent_builtin IS ?
|
||||
AND referent_component_hash IS ?
|
||||
AND referent_component_index IS ?
|
||||
AND referent_constructor_index IS ?
|
||||
|]
|
||||
|
||||
-- | Remove the given set of term names into the name lookup table
|
||||
removeTypeNames :: [NamedRef (Reference.TextReference)] -> Transaction ()
|
||||
removeTypeNames names = do
|
||||
executeMany sql names
|
||||
where
|
||||
sql =
|
||||
[here|
|
||||
DELETE FROM type_name_lookup
|
||||
WHERE
|
||||
reversed_name IS ?
|
||||
AND reference_builtin IS ?
|
||||
AND reference_component_hash IS ?
|
||||
AND reference_component_index IS ?
|
||||
|]
|
||||
|
||||
-- | We need to escape any special characters for globbing.
|
||||
--
|
||||
-- >>> globEscape "Nat.*.doc"
|
||||
@ -1612,6 +1783,7 @@ rootTypeNamesByPath mayNamespace = do
|
||||
ORDER BY (namespace GLOB ? OR namespace = ?) DESC
|
||||
|]
|
||||
|
||||
-- | @before x y@ returns whether or not @x@ occurred before @y@, i.e. @x@ is an ancestor of @y@.
|
||||
before :: CausalHashId -> CausalHashId -> Transaction Bool
|
||||
before chId1 chId2 = queryOneCol sql (chId2, chId1)
|
||||
where
|
||||
@ -1877,8 +2049,7 @@ saveTermComponent hh@HashHandle {toReference, toReferenceMentions} maybeEncodedT
|
||||
in S.putBytes Serialization.putTermFormat $ S.Term.Term li
|
||||
oId <- saveObject hh hashId ObjectType.TermComponent bytes
|
||||
-- populate dependents index
|
||||
let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sTermElements `zip` [0 ..])
|
||||
unlocalizeRefs :: ((LocalIds, S.Term.Term, S.Term.Type), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id)
|
||||
let unlocalizeRefs :: ((LocalIds, S.Term.Term, S.Term.Type), C.Reference.Pos) -> (Set S.Reference.Reference, S.Reference.Id)
|
||||
unlocalizeRefs ((LocalIds tIds oIds, tm, tp), i) =
|
||||
let self = C.Reference.Id oId i
|
||||
dependencies :: Set S.Reference =
|
||||
@ -1903,8 +2074,9 @@ saveTermComponent hh@HashHandle {toReference, toReferenceMentions} maybeEncodedT
|
||||
++ map getSTermLink tmLinks
|
||||
++ map getTypeSRef (tpRefs ++ tpRefs')
|
||||
++ map getSTypeLink tpLinks
|
||||
in Set.map (,self) dependencies
|
||||
traverse_ (uncurry addToDependentsIndex) dependencies
|
||||
in (dependencies, self)
|
||||
for_ (map unlocalizeRefs (sTermElements `zip` [0 ..])) \(dependencies, dependent) ->
|
||||
addToDependentsIndex (Set.toList dependencies) dependent
|
||||
for_ ((snd <$> terms) `zip` [0 ..]) \(tp, i) -> do
|
||||
let self = C.Referent.RefId (C.Reference.Id oId i)
|
||||
typeForIndexing = toReference tp
|
||||
@ -1936,8 +2108,7 @@ saveDeclComponent hh@HashHandle {toReferenceDecl, toReferenceDeclMentions} maybe
|
||||
in S.putBytes Serialization.putDeclFormat $ S.Decl.Decl li
|
||||
oId <- saveObject hh hashId ObjectType.DeclComponent bytes
|
||||
-- populate dependents index
|
||||
let dependencies :: Set (S.Reference.Reference, S.Reference.Id) = foldMap unlocalizeRefs (sDeclElements `zip` [0 ..])
|
||||
unlocalizeRefs :: ((LocalIds, S.Decl.Decl Symbol), C.Reference.Pos) -> Set (S.Reference.Reference, S.Reference.Id)
|
||||
let unlocalizeRefs :: ((LocalIds, S.Decl.Decl Symbol), C.Reference.Pos) -> (Set S.Reference.Reference, S.Reference.Id)
|
||||
unlocalizeRefs ((LocalIds tIds oIds, decl), i) =
|
||||
let self = C.Reference.Id oId i
|
||||
dependencies :: Set S.Decl.TypeRef = C.Decl.dependencies decl
|
||||
@ -1946,8 +2117,9 @@ saveDeclComponent hh@HashHandle {toReferenceDecl, toReferenceDeclMentions} maybe
|
||||
C.ReferenceBuiltin t -> C.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 ((,self) . getSRef) dependencies
|
||||
traverse_ (uncurry addToDependentsIndex) dependencies
|
||||
in (Set.map getSRef dependencies, self)
|
||||
for_ (map unlocalizeRefs (sDeclElements `zip` [0 ..])) \(dependencies, dependent) ->
|
||||
addToDependentsIndex (Set.toList dependencies) dependent
|
||||
for_ ((fmap C.Decl.constructorTypes decls) `zip` [0 ..]) \(ctors, i) ->
|
||||
for_ (ctors `zip` [0 ..]) \(tp, j) -> do
|
||||
let self = C.Referent.ConId (C.Reference.Id oId i) j
|
||||
|
@ -265,9 +265,8 @@ trySync hh runSrc runDest tCache hCache oCache cCache = \case
|
||||
syncDependenciesIndex :: Sqlite.Reference.Id -> Sqlite.Reference.Id -> m ()
|
||||
syncDependenciesIndex ref ref' = do
|
||||
deps <- runSrc (Q.getDependenciesForDependent ref)
|
||||
for_ deps \dep -> do
|
||||
dep' <- expectSyncedObjectReference dep
|
||||
runDest (Q.addToDependentsIndex dep' ref')
|
||||
deps' <- for deps expectSyncedObjectReference
|
||||
runDest (Q.addToDependentsIndex deps' ref')
|
||||
|
||||
syncLocalIds :: L.LocalIds -> ValidateT (Set Entity) m L.LocalIds
|
||||
syncLocalIds (L.LocalIds tIds oIds) = do
|
||||
|
@ -2,7 +2,13 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module U.Codebase.ShortHash where
|
||||
module U.Codebase.ShortHash
|
||||
( ShortHash (..),
|
||||
ShortCausalHash (..),
|
||||
ShortNamespaceHash (..),
|
||||
shortenTo,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
@ -20,7 +26,11 @@ data ShortHash
|
||||
| ShortHash {prefix :: Text, cycle :: Maybe Word64, cid :: Maybe Word64}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data ShortBranchHash = ShortBranchHash {toText :: Text} deriving (Eq, Ord, Show)
|
||||
newtype ShortCausalHash = ShortCausalHash {shortCausalHashToText :: Text}
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
newtype ShortNamespaceHash = ShortNamespaceHash {shortNamespaceHashToText :: Text}
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
shortenTo :: Int -> ShortHash -> ShortHash
|
||||
shortenTo _ b@(Builtin _) = b
|
||||
|
@ -171,7 +171,7 @@ visit' f t = case out t of
|
||||
|
||||
-- | Apply an effectful function to an ABT tree top down, sequencing the results.
|
||||
visit_ ::
|
||||
(Traversable f, Monad g, Ord v) =>
|
||||
(Traversable f, Applicative g, Ord v) =>
|
||||
(f (Term f v a) -> g ()) ->
|
||||
Term f v a ->
|
||||
g (Term f v a)
|
||||
@ -179,7 +179,7 @@ visit_ f t = case out t of
|
||||
Var _ -> pure t
|
||||
Cycle body -> cycle (annotation t) <$> visit_ f body
|
||||
Abs x e -> abs (annotation t) x <$> visit_ f e
|
||||
Tm body -> f body >> tm (annotation t) <$> traverse (visit_ f) body
|
||||
Tm body -> f body *> (tm (annotation t) <$> traverse (visit_ f) body)
|
||||
|
||||
-- | `visit` specialized to the `Identity` effect.
|
||||
visitPure ::
|
||||
|
@ -1,6 +1,7 @@
|
||||
module U.Util.Monoid where
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Control.Monad.Extra ((>=>))
|
||||
import Data.Foldable (toList)
|
||||
import Data.List (intersperse)
|
||||
|
||||
@ -10,6 +11,9 @@ intercalateMap :: (Foldable t, Monoid a) => a -> (b -> a) -> t b -> a
|
||||
intercalateMap separator renderer elements =
|
||||
mconcat $ intersperse separator (renderer <$> toList elements)
|
||||
|
||||
intercalateMapM :: (Traversable t, Monad m, Monoid a) => a -> (b -> m a) -> t b -> m a
|
||||
intercalateMapM separator renderer = traverse renderer >=> return . intercalateMap separator id
|
||||
|
||||
fromMaybe :: Monoid a => Maybe a -> a
|
||||
fromMaybe Nothing = mempty
|
||||
fromMaybe (Just a) = a
|
||||
@ -24,4 +28,4 @@ isEmpty a = a == mempty
|
||||
nonEmpty = not . isEmpty
|
||||
|
||||
foldMapM :: (Monad m, Foldable f, Monoid b) => (a -> m b) -> f a -> m b
|
||||
foldMapM f as = foldM (\b a -> fmap (b <>) (f a)) mempty as
|
||||
foldMapM f = foldM (\b a -> fmap (b <>) (f a)) mempty
|
||||
|
103
docs/configuration.md
Normal file
103
docs/configuration.md
Normal file
@ -0,0 +1,103 @@
|
||||
# Configuration
|
||||
|
||||
|
||||
* [UCM Configuration](#ucm-configuration)
|
||||
* [`UNISON_DEBUG`](#unison_debug)
|
||||
* [`UNISON_PAGER`](#unison_pager)
|
||||
* [`UNISON_LSP_PORT`](#unison_lsp_port)
|
||||
* [`UNISON_SHARE_HOST`](#unison_share_host)
|
||||
* [`UNISON_SHARE_ACCESS_TOKEN`](#unison_share_access_token)
|
||||
* [Local Codebase Server](#local-codebase-server)
|
||||
* [Codebase Configuration](#codebase-configuration)
|
||||
|
||||
## UCM Configuration
|
||||
|
||||
### `UNISON_DEBUG`
|
||||
|
||||
Enable debugging output for various portions of the application.
|
||||
See `lib/unison-prelude/src/Unison/Debug.hs` for the full list of supported flags.
|
||||
|
||||
E.g.
|
||||
|
||||
```sh
|
||||
# Enable ALL debugging flags (likely quite noisy)
|
||||
$ UNISON_DEBUG= ucm
|
||||
# Enable timing debugging, printing how long different actions take.
|
||||
$ UNISON_DEBUG=timing ucm
|
||||
# Enable LSP and TIMING debugging
|
||||
$ UNISON_DEBUG=lsp,timing ucm
|
||||
```
|
||||
|
||||
### `UNISON_PAGER`
|
||||
|
||||
Allows selecting which pager to use for long command outputs.
|
||||
Defaults to `less` on Linux & Mac, `more` on Windows
|
||||
|
||||
E.g.
|
||||
|
||||
```sh
|
||||
# User more instead of less
|
||||
$ UNISON_PAGER=more ucm
|
||||
```
|
||||
|
||||
### `UNISON_LSP_PORT`
|
||||
|
||||
Allows selecting the port to run the LSP server on. Defaults to `5757`.
|
||||
|
||||
E.g.
|
||||
|
||||
```sh
|
||||
$ UNISON_LSP_PORT=8080 ucm
|
||||
```
|
||||
|
||||
### `UNISON_SHARE_HOST`
|
||||
|
||||
Allows selecting the location for the default Share server.
|
||||
|
||||
E.g.
|
||||
|
||||
```sh
|
||||
$ UNISON_SHARE_HOST="http://localhost:5424" ucm
|
||||
```
|
||||
|
||||
### `UNISON_SHARE_ACCESS_TOKEN`
|
||||
|
||||
Allows overriding the credentials used when authenticating with the Share server.
|
||||
|
||||
E.g.
|
||||
|
||||
```sh
|
||||
$ UNISON_SHARE_ACCESS_TOKEN="my.token.string" ucm
|
||||
```
|
||||
|
||||
### Local Codebase Server
|
||||
|
||||
The port, host and token to be used for the local codebase server can all be configured by providing environment
|
||||
variables when starting `ucm`, using `UCM_PORT`, `UCM_HOST`, and `UCM_TOKEN`.
|
||||
|
||||
E.g.
|
||||
|
||||
```sh
|
||||
UCM_PORT=8080 UCM_HOST=localhost UCM_TOKEN=1234 ucm
|
||||
```
|
||||
|
||||
## Codebase Configuration
|
||||
|
||||
Also, see the guide [here](https://www.unison-lang.org/learn/tooling/configuration/)
|
||||
|
||||
The following configuration options can be provided within the `.unisonConfig` file,
|
||||
which exists within the codebase directory, or at `~/.unisonConfig` for your default codebase.
|
||||
|
||||
```
|
||||
# Attach myself as author and use BSD license for all of my contributions
|
||||
DefaultMetadata = [ ".metadata.authors.chrispenner"
|
||||
, ".metadata.licenses.chrispenner" ]
|
||||
|
||||
# RemoteMapping allows mapping a path in the codebase to a specific location on share.
|
||||
# Here I state that I want my .share namespace to push to .chrispenner.public
|
||||
# Everything inside .share will be mapped accordingly, e.g. .share.foo will map to
|
||||
# chrispenner.public.foo on share.
|
||||
RemoteMapping {
|
||||
share = "chrispenner.public"
|
||||
}
|
||||
```
|
@ -6,9 +6,9 @@
|
||||
|
||||
Supported features:
|
||||
|
||||
* Show type on hover
|
||||
* Autocompletion
|
||||
* Inline type and parser error messages
|
||||
* NO autocomplete yet, but soon.
|
||||
* Show type on hover
|
||||
|
||||
Notes:
|
||||
|
||||
@ -30,7 +30,8 @@ Configuration for [coc-nvim](https://github.com/neoclide/coc.nvim), enter the fo
|
||||
"unison": {
|
||||
"filetypes": ["unison"],
|
||||
"host": "127.0.0.1",
|
||||
"port": 5757
|
||||
"port": 5757,
|
||||
"settings": {}
|
||||
}
|
||||
}
|
||||
```
|
||||
@ -39,5 +40,25 @@ Note that you'll need to start UCM _before_ you try connecting to it in your edi
|
||||
|
||||
### VSCode
|
||||
|
||||
VSCode doesn't allow customizing LSP implementations without an extension,
|
||||
Hang tight, one will be available soon!
|
||||
Simply install the [Unison Language VSCode extension](https://marketplace.visualstudio.com/items?itemName=unison-lang.unison).
|
||||
|
||||
|
||||
### Other Editors
|
||||
|
||||
If your editor provides a mechanism for connecting to a host and port, provide a host of `127.0.0.1` and port `5757`.
|
||||
|
||||
If your editor requires a command to run, you can provide the command `nc localhost 5757` on Mac, or `netcat localhost 5757` on linux.
|
||||
Note that some editors require passing the command and arguments as separate parameters.
|
||||
|
||||
## Configuration
|
||||
|
||||
Supported settings and their defaults. See information for your language server client about where to provide these.
|
||||
|
||||
```json
|
||||
{
|
||||
// The number of completions the server should collect and send based on a single query.
|
||||
// Increasing this limit will provide more completion results, but at the cost of being slower to respond.
|
||||
// If explicitly set to `null` the server will return ALL completions available.
|
||||
"maxCompletions": 100
|
||||
}
|
||||
```
|
||||
|
15
hie.yaml
15
hie.yaml
@ -51,6 +51,12 @@ cradle:
|
||||
- path: "lib/unison-util-base32hex-orphans-sqlite/src"
|
||||
component: "unison-util-base32hex-orphans-sqlite:lib"
|
||||
|
||||
- path: "lib/unison-util-bytes/src"
|
||||
component: "unison-util-bytes:lib"
|
||||
|
||||
- path: "lib/unison-util-bytes/test"
|
||||
component: "unison-util-bytes:test:util-bytes-tests"
|
||||
|
||||
- path: "lib/unison-util-relation/src"
|
||||
component: "unison-util-relation:lib"
|
||||
|
||||
@ -60,6 +66,9 @@ cradle:
|
||||
- path: "lib/unison-util-relation/benchmarks/relation/Main.hs"
|
||||
component: "unison-util-relation:bench:relation"
|
||||
|
||||
- path: "lib/unison-util-rope/src"
|
||||
component: "unison-util-rope:lib"
|
||||
|
||||
- path: "parser-typechecker/src"
|
||||
component: "unison-parser-typechecker:lib"
|
||||
|
||||
@ -102,6 +111,12 @@ cradle:
|
||||
- path: "unison-share-api/src"
|
||||
component: "unison-share-api:lib"
|
||||
|
||||
- path: "unison-syntax/src"
|
||||
component: "unison-syntax:lib"
|
||||
|
||||
- path: "unison-syntax/test"
|
||||
component: "unison-syntax:test:syntax-tests"
|
||||
|
||||
- path: "yaks/easytest/src"
|
||||
component: "easytest:lib"
|
||||
|
||||
|
@ -34,6 +34,9 @@ data DebugFlag
|
||||
LSP
|
||||
| -- | Timing how long things take
|
||||
Timing
|
||||
| -- | Useful for adding temporary debugging statements during development.
|
||||
-- Remove uses of Debug.Temp before merging to keep things clean for the next person :)
|
||||
Temp
|
||||
deriving (Eq, Ord, Show, Bounded, Enum)
|
||||
|
||||
debugFlags :: Set DebugFlag
|
||||
@ -54,6 +57,7 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of
|
||||
"SYNC" -> pure Sync
|
||||
"LSP" -> pure LSP
|
||||
"TIMING" -> pure Timing
|
||||
"TEMP" -> pure Temp
|
||||
_ -> empty
|
||||
{-# NOINLINE debugFlags #-}
|
||||
|
||||
@ -93,6 +97,10 @@ debugTiming :: Bool
|
||||
debugTiming = Timing `Set.member` debugFlags
|
||||
{-# NOINLINE debugTiming #-}
|
||||
|
||||
debugTemp :: Bool
|
||||
debugTemp = Temp `Set.member` debugFlags
|
||||
{-# NOINLINE debugTemp #-}
|
||||
|
||||
-- | Use for trace-style selective debugging.
|
||||
-- E.g. 1 + (debug Git "The second number" 2)
|
||||
--
|
||||
@ -142,3 +150,4 @@ shouldDebug = \case
|
||||
Sync -> debugSync
|
||||
LSP -> debugLSP
|
||||
Timing -> debugTiming
|
||||
Temp -> debugTemp
|
||||
|
@ -40,6 +40,7 @@ module Unison.Util.Pretty
|
||||
column3UnzippedM,
|
||||
column3sep,
|
||||
column3Header,
|
||||
columnNHeader,
|
||||
commas,
|
||||
commented,
|
||||
oxfordCommas,
|
||||
@ -101,6 +102,7 @@ module Unison.Util.Pretty
|
||||
spaceIfNeeded,
|
||||
spaced,
|
||||
spacedMap,
|
||||
spacedTraverse,
|
||||
spacesIfBreak,
|
||||
string,
|
||||
surroundCommas,
|
||||
@ -405,6 +407,9 @@ spaced = intercalateMap softbreak id
|
||||
spacedMap :: (Foldable f, IsString s) => (a -> Pretty s) -> f a -> Pretty s
|
||||
spacedMap f as = spaced . fmap f $ toList as
|
||||
|
||||
spacedTraverse :: (Traversable f, IsString s, Applicative m) => (a -> m (Pretty s)) -> f a -> m (Pretty s)
|
||||
spacedTraverse f as = spaced <$> traverse f as
|
||||
|
||||
commas :: (Foldable f, IsString s) => f (Pretty s) -> Pretty s
|
||||
commas = intercalateMap ("," <> softbreak) id
|
||||
|
||||
@ -469,7 +474,7 @@ excerptSep' ::
|
||||
excerptSep' maxCount summarize s ps = case maxCount of
|
||||
Just max
|
||||
| length ps > max ->
|
||||
sep s (take max ps) <> summarize (length ps - max)
|
||||
sep s (take max ps) <> summarize (length ps - max)
|
||||
_ -> sep s ps
|
||||
|
||||
nonEmpty :: (Foldable f, IsString s) => f (Pretty s) -> [Pretty s]
|
||||
@ -579,7 +584,7 @@ excerptColumn2Headed ::
|
||||
excerptColumn2Headed max hd cols = case max of
|
||||
Just max
|
||||
| len > max ->
|
||||
lines [column2 (hd : take max cols), "... " <> shown (len - max) <> " more"]
|
||||
lines [column2 (hd : take max cols), "... " <> shown (len - max) <> " more"]
|
||||
_ -> column2 (hd : cols)
|
||||
where
|
||||
len = length cols
|
||||
|
67
lib/unison-util-bytes/package.yaml
Normal file
67
lib/unison-util-bytes/package.yaml
Normal file
@ -0,0 +1,67 @@
|
||||
name: unison-util-bytes
|
||||
github: unisonweb/unison
|
||||
copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors
|
||||
|
||||
ghc-options: -Wall
|
||||
|
||||
dependencies:
|
||||
- base
|
||||
- basement
|
||||
- bytestring
|
||||
- bytestring-to-vector
|
||||
- deepseq
|
||||
- memory
|
||||
- primitive
|
||||
- text
|
||||
- vector
|
||||
- unison-prelude
|
||||
- unison-util-rope
|
||||
- zlib
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
when:
|
||||
- condition: false
|
||||
other-modules: Paths_unison_util_bytes
|
||||
|
||||
tests:
|
||||
util-bytes-tests:
|
||||
when:
|
||||
- condition: false
|
||||
other-modules: Paths_unison_util_bytes
|
||||
dependencies:
|
||||
- code-page
|
||||
- easytest
|
||||
- unison-util-bytes
|
||||
main: Main.hs
|
||||
source-dirs: test
|
||||
|
||||
default-extensions:
|
||||
- ApplicativeDo
|
||||
- BangPatterns
|
||||
- BlockArguments
|
||||
- DeriveAnyClass
|
||||
- DeriveFoldable
|
||||
- DeriveFunctor
|
||||
- DeriveGeneric
|
||||
- DeriveTraversable
|
||||
- DerivingStrategies
|
||||
- DerivingVia
|
||||
- DoAndIfThenElse
|
||||
- DuplicateRecordFields
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- FunctionalDependencies
|
||||
- GeneralizedNewtypeDeriving
|
||||
- LambdaCase
|
||||
- MultiParamTypeClasses
|
||||
- NamedFieldPuns
|
||||
- OverloadedStrings
|
||||
- PatternSynonyms
|
||||
- RankNTypes
|
||||
- ScopedTypeVariables
|
||||
- StandaloneDeriving
|
||||
- TupleSections
|
||||
- TypeApplications
|
||||
- TypeFamilies
|
||||
- ViewPatterns
|
@ -1,6 +1,3 @@
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
||||
|
@ -1,14 +1,18 @@
|
||||
module Unison.Test.Util.Bytes where
|
||||
module Main (main) where
|
||||
|
||||
import Control.Monad
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.List (foldl')
|
||||
import EasyTest
|
||||
import System.IO.CodePage (withCP65001)
|
||||
import Unison.Prelude
|
||||
import qualified Unison.Util.Bytes as Bytes
|
||||
|
||||
main :: IO ()
|
||||
main =
|
||||
withCP65001 (run (scope "util.bytes" test))
|
||||
|
||||
test :: Test ()
|
||||
test =
|
||||
scope "util.bytes" . tests $
|
||||
tests $
|
||||
[ scope "empty ==" . expect $ Bytes.empty == Bytes.empty,
|
||||
scope "empty `compare`" . expect $ Bytes.empty `compare` Bytes.empty == EQ,
|
||||
scope "==" . expect $
|
119
lib/unison-util-bytes/unison-util-bytes.cabal
Normal file
119
lib/unison-util-bytes/unison-util-bytes.cabal
Normal file
@ -0,0 +1,119 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: unison-util-bytes
|
||||
version: 0.0.0
|
||||
homepage: https://github.com/unisonweb/unison#readme
|
||||
bug-reports: https://github.com/unisonweb/unison/issues
|
||||
copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors
|
||||
build-type: Simple
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/unisonweb/unison
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Unison.Util.Bytes
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions:
|
||||
ApplicativeDo
|
||||
BangPatterns
|
||||
BlockArguments
|
||||
DeriveAnyClass
|
||||
DeriveFoldable
|
||||
DeriveFunctor
|
||||
DeriveGeneric
|
||||
DeriveTraversable
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
DoAndIfThenElse
|
||||
DuplicateRecordFields
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
FunctionalDependencies
|
||||
GeneralizedNewtypeDeriving
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
NamedFieldPuns
|
||||
OverloadedStrings
|
||||
PatternSynonyms
|
||||
RankNTypes
|
||||
ScopedTypeVariables
|
||||
StandaloneDeriving
|
||||
TupleSections
|
||||
TypeApplications
|
||||
TypeFamilies
|
||||
ViewPatterns
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base
|
||||
, basement
|
||||
, bytestring
|
||||
, bytestring-to-vector
|
||||
, deepseq
|
||||
, memory
|
||||
, primitive
|
||||
, text
|
||||
, unison-prelude
|
||||
, unison-util-rope
|
||||
, vector
|
||||
, zlib
|
||||
default-language: Haskell2010
|
||||
|
||||
test-suite util-bytes-tests
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Main.hs
|
||||
hs-source-dirs:
|
||||
test
|
||||
default-extensions:
|
||||
ApplicativeDo
|
||||
BangPatterns
|
||||
BlockArguments
|
||||
DeriveAnyClass
|
||||
DeriveFoldable
|
||||
DeriveFunctor
|
||||
DeriveGeneric
|
||||
DeriveTraversable
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
DoAndIfThenElse
|
||||
DuplicateRecordFields
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
FunctionalDependencies
|
||||
GeneralizedNewtypeDeriving
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
NamedFieldPuns
|
||||
OverloadedStrings
|
||||
PatternSynonyms
|
||||
RankNTypes
|
||||
ScopedTypeVariables
|
||||
StandaloneDeriving
|
||||
TupleSections
|
||||
TypeApplications
|
||||
TypeFamilies
|
||||
ViewPatterns
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base
|
||||
, basement
|
||||
, bytestring
|
||||
, bytestring-to-vector
|
||||
, code-page
|
||||
, deepseq
|
||||
, easytest
|
||||
, memory
|
||||
, primitive
|
||||
, text
|
||||
, unison-prelude
|
||||
, unison-util-bytes
|
||||
, unison-util-rope
|
||||
, vector
|
||||
, zlib
|
||||
default-language: Haskell2010
|
45
lib/unison-util-rope/package.yaml
Normal file
45
lib/unison-util-rope/package.yaml
Normal file
@ -0,0 +1,45 @@
|
||||
name: unison-util-rope
|
||||
github: unisonweb/unison
|
||||
copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors
|
||||
|
||||
ghc-options: -Wall
|
||||
|
||||
dependencies:
|
||||
- base
|
||||
- deepseq
|
||||
|
||||
library:
|
||||
source-dirs: src
|
||||
when:
|
||||
- condition: false
|
||||
other-modules: Paths_unison_util_rope
|
||||
|
||||
default-extensions:
|
||||
- ApplicativeDo
|
||||
- BangPatterns
|
||||
- BlockArguments
|
||||
- DeriveAnyClass
|
||||
- DeriveFoldable
|
||||
- DeriveFunctor
|
||||
- DeriveGeneric
|
||||
- DeriveTraversable
|
||||
- DerivingStrategies
|
||||
- DerivingVia
|
||||
- DoAndIfThenElse
|
||||
- DuplicateRecordFields
|
||||
- FlexibleContexts
|
||||
- FlexibleInstances
|
||||
- FunctionalDependencies
|
||||
- GeneralizedNewtypeDeriving
|
||||
- LambdaCase
|
||||
- MultiParamTypeClasses
|
||||
- NamedFieldPuns
|
||||
- OverloadedStrings
|
||||
- PatternSynonyms
|
||||
- RankNTypes
|
||||
- ScopedTypeVariables
|
||||
- StandaloneDeriving
|
||||
- TupleSections
|
||||
- TypeApplications
|
||||
- TypeFamilies
|
||||
- ViewPatterns
|
@ -1,6 +1,3 @@
|
||||
{-# LANGUAGE DeriveFoldable #-}
|
||||
{-# LANGUAGE FunctionalDependencies #-}
|
||||
|
||||
module Unison.Util.Rope
|
||||
( chunks,
|
||||
singleton,
|
56
lib/unison-util-rope/unison-util-rope.cabal
Normal file
56
lib/unison-util-rope/unison-util-rope.cabal
Normal file
@ -0,0 +1,56 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.34.4.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
name: unison-util-rope
|
||||
version: 0.0.0
|
||||
homepage: https://github.com/unisonweb/unison#readme
|
||||
bug-reports: https://github.com/unisonweb/unison/issues
|
||||
copyright: Copyright (C) 2013-2022 Unison Computing, PBC and contributors
|
||||
build-type: Simple
|
||||
|
||||
source-repository head
|
||||
type: git
|
||||
location: https://github.com/unisonweb/unison
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Unison.Util.Rope
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-extensions:
|
||||
ApplicativeDo
|
||||
BangPatterns
|
||||
BlockArguments
|
||||
DeriveAnyClass
|
||||
DeriveFoldable
|
||||
DeriveFunctor
|
||||
DeriveGeneric
|
||||
DeriveTraversable
|
||||
DerivingStrategies
|
||||
DerivingVia
|
||||
DoAndIfThenElse
|
||||
DuplicateRecordFields
|
||||
FlexibleContexts
|
||||
FlexibleInstances
|
||||
FunctionalDependencies
|
||||
GeneralizedNewtypeDeriving
|
||||
LambdaCase
|
||||
MultiParamTypeClasses
|
||||
NamedFieldPuns
|
||||
OverloadedStrings
|
||||
PatternSynonyms
|
||||
RankNTypes
|
||||
ScopedTypeVariables
|
||||
StandaloneDeriving
|
||||
TupleSections
|
||||
TypeApplications
|
||||
TypeFamilies
|
||||
ViewPatterns
|
||||
ghc-options: -Wall
|
||||
build-depends:
|
||||
base
|
||||
, deepseq
|
||||
default-language: Haskell2010
|
@ -45,6 +45,7 @@ dependencies:
|
||||
- fingertree
|
||||
- fsnotify
|
||||
- fuzzyfind
|
||||
- free
|
||||
- generic-lens
|
||||
- generic-monoid
|
||||
- hashable
|
||||
@ -111,9 +112,12 @@ dependencies:
|
||||
- unison-prelude
|
||||
- unison-pretty-printer
|
||||
- unison-sqlite
|
||||
- unison-syntax
|
||||
- unison-util
|
||||
- unison-util-base32hex
|
||||
- unison-util-bytes
|
||||
- unison-util-relation
|
||||
- unison-util-rope
|
||||
- unison-util-serialization
|
||||
- unliftio
|
||||
- uri-encode
|
||||
|
174
parser-typechecker/src/U/Codebase/Branch/Diff.hs
Normal file
174
parser-typechecker/src/U/Codebase/Branch/Diff.hs
Normal file
@ -0,0 +1,174 @@
|
||||
module U.Codebase.Branch.Diff
|
||||
( TreeDiff (..),
|
||||
NameChanges (..),
|
||||
DefinitionDiffs (..),
|
||||
Diff (..),
|
||||
diffBranches,
|
||||
nameChanges,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Comonad.Cofree
|
||||
import Control.Lens (ifoldMap)
|
||||
import qualified Control.Lens as Lens
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Semialign as Align
|
||||
import qualified Data.Set as Set
|
||||
import Data.These
|
||||
import U.Codebase.Branch
|
||||
import qualified U.Codebase.Branch.Type as Branch
|
||||
import qualified U.Codebase.Causal as Causal
|
||||
import U.Codebase.Reference (Reference)
|
||||
import U.Codebase.Referent (Referent)
|
||||
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
|
||||
import Unison.Name (Name)
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.Prelude
|
||||
|
||||
data Diff a = Diff
|
||||
{ adds :: Set a,
|
||||
removals :: Set a
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
-- | Represents the changes to definitions at a given path, not including child paths.
|
||||
--
|
||||
-- Note: doesn't yet include any info on metadata or patch diffs. Feel free to add it.
|
||||
data DefinitionDiffs = DefinitionDiffs
|
||||
{ termDiffs :: Map NameSegment (Diff Referent),
|
||||
typeDiffs :: Map NameSegment (Diff Reference)
|
||||
-- termMetadataDiffs :: Map (NameSegment, Referent) (Diff Reference),
|
||||
-- typeMetadataDiffs :: Map (NameSegment, Reference) (Diff Reference)
|
||||
-- patchDiffs :: Map NameSegment (Diff ())
|
||||
}
|
||||
deriving stock (Show, Eq, Ord)
|
||||
|
||||
instance Semigroup DefinitionDiffs where
|
||||
a <> b =
|
||||
DefinitionDiffs
|
||||
{ termDiffs = termDiffs a <> termDiffs b,
|
||||
typeDiffs = typeDiffs a <> typeDiffs b
|
||||
}
|
||||
|
||||
instance Monoid DefinitionDiffs where
|
||||
mempty = DefinitionDiffs mempty mempty
|
||||
|
||||
-- | A tree of local diffs. Each node of the tree contains the definition diffs at that path.
|
||||
newtype TreeDiff = TreeDiff
|
||||
{ unTreeDiff :: Cofree (Map NameSegment) DefinitionDiffs
|
||||
}
|
||||
deriving stock (Show, Eq, Ord)
|
||||
|
||||
instance Semigroup TreeDiff where
|
||||
TreeDiff (a :< as) <> TreeDiff (b :< bs) =
|
||||
TreeDiff $ (a <> b) :< (Map.unionWith mergeCofrees as bs)
|
||||
where
|
||||
mergeCofrees x y = unTreeDiff (TreeDiff x <> TreeDiff y)
|
||||
|
||||
instance Monoid TreeDiff where
|
||||
mempty = TreeDiff (mempty :< mempty)
|
||||
|
||||
instance Lens.AsEmpty TreeDiff where
|
||||
_Empty = Lens.only mempty
|
||||
|
||||
-- | A summary of a 'TreeDiff', containing all names added and removed.
|
||||
-- Note that there isn't a clear notion of a name "changing" since conflicts might muddy the notion
|
||||
-- by having multiple copies of both the from and to names, so we just talk about adds and
|
||||
-- removals instead.
|
||||
data NameChanges = NameChanges
|
||||
{ termNameAdds :: [(Name, Referent)],
|
||||
termNameRemovals :: [(Name, Referent)],
|
||||
typeNameAdds :: [(Name, Reference)],
|
||||
typeNameRemovals :: [(Name, Reference)]
|
||||
}
|
||||
|
||||
instance Semigroup NameChanges where
|
||||
(NameChanges a b c d) <> (NameChanges a2 b2 c2 d2) =
|
||||
NameChanges (a <> a2) (b <> b2) (c <> c2) (d <> d2)
|
||||
|
||||
instance Monoid NameChanges where
|
||||
mempty = NameChanges mempty mempty mempty mempty
|
||||
|
||||
-- | Diff two Branches, returning a tree containing all of the changes
|
||||
diffBranches :: forall m. Monad m => Branch m -> Branch m -> m TreeDiff
|
||||
diffBranches from to = do
|
||||
let termDiffs = diffMap (terms from) (terms to)
|
||||
let typeDiffs = diffMap (types from) (types to)
|
||||
let defDiff = DefinitionDiffs {termDiffs, typeDiffs}
|
||||
childDiff <- do
|
||||
Align.align (children from) (children to)
|
||||
& wither
|
||||
( \case
|
||||
This ca -> do
|
||||
-- TODO: For the names index we really don't need to know which exact
|
||||
-- names were removed, we just need to delete from the index using a
|
||||
-- prefix query, this would be faster than crawling to get all the deletes.
|
||||
removedChildBranch <- Causal.value ca
|
||||
Just . unTreeDiff <$> diffBranches removedChildBranch Branch.empty
|
||||
That ca -> do
|
||||
newChildBranch <- Causal.value ca
|
||||
Just . unTreeDiff <$> diffBranches Branch.empty newChildBranch
|
||||
These fromC toC
|
||||
| Causal.valueHash fromC == Causal.valueHash toC -> do
|
||||
-- This child didn't change.
|
||||
pure Nothing
|
||||
| otherwise -> do
|
||||
fromChildBranch <- Causal.value fromC
|
||||
toChildBranch <- Causal.value toC
|
||||
diffBranches fromChildBranch toChildBranch >>= \case
|
||||
Lens.Empty -> pure Nothing
|
||||
TreeDiff cfr -> pure . Just $ cfr
|
||||
)
|
||||
pure $ TreeDiff (defDiff :< childDiff)
|
||||
where
|
||||
diffMap :: forall ref. Ord ref => Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Map ref (m MdValues)) -> Map NameSegment (Diff ref)
|
||||
diffMap l r =
|
||||
Align.align l r
|
||||
& fmap
|
||||
( \case
|
||||
(This refs) -> (Diff {removals = Map.keysSet refs, adds = mempty})
|
||||
(That refs) -> (Diff {removals = mempty, adds = Map.keysSet refs})
|
||||
(These l' r') ->
|
||||
let lRefs = Map.keysSet l'
|
||||
rRefs = Map.keysSet r'
|
||||
in (Diff {removals = lRefs `Set.difference` rRefs, adds = rRefs `Set.difference` lRefs})
|
||||
)
|
||||
|
||||
-- | Get a summary of all of the name adds and removals from a tree diff.
|
||||
--
|
||||
-- The provided name will be prepended to all names in the output diff, and can be useful if diffing branches at a
|
||||
-- specific sub-tree, but you can pass 'Nothing' if you're diffing from the root.
|
||||
nameChanges ::
|
||||
Maybe Name ->
|
||||
TreeDiff ->
|
||||
NameChanges
|
||||
nameChanges namePrefix (TreeDiff (DefinitionDiffs {termDiffs, typeDiffs} :< children)) =
|
||||
let (termNameAdds, termNameRemovals) =
|
||||
( termDiffs
|
||||
& ifoldMap \ns diff ->
|
||||
let name = appendName ns
|
||||
in (listifyNames name $ adds diff, listifyNames name $ removals diff)
|
||||
)
|
||||
(typeNameAdds, typeNameRemovals) =
|
||||
( typeDiffs
|
||||
& ifoldMap \ns diff ->
|
||||
let name = appendName ns
|
||||
in (listifyNames name $ adds diff, listifyNames name $ removals diff)
|
||||
)
|
||||
childNameChanges =
|
||||
( children
|
||||
& ifoldMap \ns childTree ->
|
||||
nameChanges (Just $ appendName ns) (TreeDiff childTree)
|
||||
)
|
||||
in NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals} <> childNameChanges
|
||||
where
|
||||
appendName :: NameSegment -> Name
|
||||
appendName ns =
|
||||
case namePrefix of
|
||||
Nothing -> Name.fromSegment . Cv.namesegment2to1 $ ns
|
||||
Just prefix -> prefix Lens.|> Cv.namesegment2to1 ns
|
||||
listifyNames :: (Name -> Set ref -> [(Name, ref)])
|
||||
listifyNames name xs =
|
||||
xs
|
||||
& Set.toList
|
||||
& fmap (name,)
|
@ -12,6 +12,7 @@ module Unison.Codebase
|
||||
unsafeGetTypeOfTermById,
|
||||
isTerm,
|
||||
putTerm,
|
||||
putTermComponent,
|
||||
termMetadata,
|
||||
|
||||
-- ** Referents (sorta-termlike)
|
||||
@ -28,6 +29,7 @@ module Unison.Codebase
|
||||
unsafeGetTypeDeclaration,
|
||||
getDeclComponent,
|
||||
putTypeDeclaration,
|
||||
putTypeDeclarationComponent,
|
||||
typeReferencesByPrefix,
|
||||
isType,
|
||||
|
||||
@ -35,7 +37,7 @@ module Unison.Codebase
|
||||
branchExists,
|
||||
getBranchForHash,
|
||||
putBranch,
|
||||
branchHashesByPrefix,
|
||||
causalHashesByPrefix,
|
||||
lca,
|
||||
beforeImpl,
|
||||
getShallowBranchAtPath,
|
||||
@ -273,7 +275,7 @@ debug :: Bool
|
||||
debug = False
|
||||
|
||||
-- | Write all of UCM's dependencies (builtins types and an empty namespace) into the codebase
|
||||
installUcmDependencies :: forall m. Monad m => Codebase m Symbol Parser.Ann -> m ()
|
||||
installUcmDependencies :: Codebase m Symbol Parser.Ann -> Sqlite.Transaction ()
|
||||
installUcmDependencies c = do
|
||||
let uf =
|
||||
( UF.typecheckedUnisonFile
|
||||
@ -288,10 +290,10 @@ installUcmDependencies c = do
|
||||
-- if it makes sense to later.
|
||||
addDefsToCodebase ::
|
||||
forall m v a.
|
||||
(Monad m, Var v, Show a) =>
|
||||
(Var v, Show a) =>
|
||||
Codebase m v a ->
|
||||
UF.TypecheckedUnisonFile v a ->
|
||||
m ()
|
||||
Sqlite.Transaction ()
|
||||
addDefsToCodebase c uf = do
|
||||
traverse_ (goType Right) (UF.dataDeclarationsId' uf)
|
||||
traverse_ (goType Left) (UF.effectDeclarationsId' uf)
|
||||
@ -302,11 +304,11 @@ addDefsToCodebase c uf = do
|
||||
goTerm (r, Nothing, tm, tp) = putTerm c r tm tp
|
||||
goTerm (r, Just WK.TestWatch, tm, tp) = putTerm c r tm tp
|
||||
goTerm _ = pure ()
|
||||
goType :: Show t => (t -> Decl v a) -> (Reference.Id, t) -> m ()
|
||||
goType :: Show t => (t -> Decl v a) -> (Reference.Id, t) -> Sqlite.Transaction ()
|
||||
goType _f pair | debug && trace ("Codebase.addDefsToCodebase.goType " ++ show pair) False = undefined
|
||||
goType f (ref, decl) = putTypeDeclaration c ref (f decl)
|
||||
|
||||
getTypeOfConstructor :: (Monad m, Ord v) => Codebase m v a -> ConstructorReference -> m (Maybe (Type v a))
|
||||
getTypeOfConstructor :: Ord v => Codebase m v a -> ConstructorReference -> Sqlite.Transaction (Maybe (Type v a))
|
||||
getTypeOfConstructor codebase (ConstructorReference r0 cid) =
|
||||
case r0 of
|
||||
Reference.DerivedId r -> do
|
||||
@ -330,10 +332,10 @@ lookupWatchCache codebase h = do
|
||||
maybe (getWatch codebase WK.TestWatch h) (pure . Just) m1
|
||||
|
||||
typeLookupForDependencies ::
|
||||
(Monad m, BuiltinAnnotation a) =>
|
||||
BuiltinAnnotation a =>
|
||||
Codebase m Symbol a ->
|
||||
Set Reference ->
|
||||
m (TL.TypeLookup Symbol a)
|
||||
Sqlite.Transaction (TL.TypeLookup Symbol a)
|
||||
typeLookupForDependencies codebase s = do
|
||||
when debug $ traceM $ "typeLookupForDependencies " ++ show s
|
||||
foldM go mempty s
|
||||
@ -351,9 +353,9 @@ typeLookupForDependencies codebase s = do
|
||||
Nothing -> pure mempty
|
||||
go tl Reference.Builtin {} = pure tl -- codebase isn't consulted for builtins
|
||||
|
||||
toCodeLookup :: Monad m => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
|
||||
toCodeLookup :: MonadIO m => Codebase m Symbol Parser.Ann -> CL.CodeLookup Symbol m Parser.Ann
|
||||
toCodeLookup c =
|
||||
CL.CodeLookup (getTerm c) (getTypeDeclaration c)
|
||||
CL.CodeLookup (getTerm c) (runTransaction c . getTypeDeclaration c)
|
||||
<> Builtin.codeLookup
|
||||
<> IOSource.codeLookupM
|
||||
|
||||
@ -362,10 +364,10 @@ toCodeLookup c =
|
||||
-- Note that it is possible to call 'putTerm', then 'getTypeOfTerm', and receive @Nothing@, per the semantics of
|
||||
-- 'putTerm'.
|
||||
getTypeOfTerm ::
|
||||
(Applicative m, BuiltinAnnotation a) =>
|
||||
BuiltinAnnotation a =>
|
||||
Codebase m Symbol a ->
|
||||
Reference ->
|
||||
m (Maybe (Type Symbol a))
|
||||
Sqlite.Transaction (Maybe (Type Symbol a))
|
||||
getTypeOfTerm _c r | debug && trace ("Codebase.getTypeOfTerm " ++ show r) False = undefined
|
||||
getTypeOfTerm c r = case r of
|
||||
Reference.DerivedId h -> getTypeOfTermImpl c h
|
||||
@ -376,10 +378,10 @@ getTypeOfTerm c r = case r of
|
||||
|
||||
-- | Get the type of a referent.
|
||||
getTypeOfReferent ::
|
||||
(BuiltinAnnotation a, Monad m) =>
|
||||
BuiltinAnnotation a =>
|
||||
Codebase m Symbol a ->
|
||||
Referent.Referent ->
|
||||
m (Maybe (Type Symbol a))
|
||||
Sqlite.Transaction (Maybe (Type Symbol a))
|
||||
getTypeOfReferent c = \case
|
||||
Referent.Ref r -> getTypeOfTerm c r
|
||||
Referent.Con r _ -> getTypeOfConstructor c r
|
||||
@ -392,7 +394,7 @@ componentReferencesForReference c = \case
|
||||
|
||||
-- | Get the set of terms, type declarations, and builtin types that depend on the given term, type declaration, or
|
||||
-- builtin type.
|
||||
dependents :: Functor m => Codebase m v a -> Queries.DependentsSelector -> Reference -> m (Set Reference)
|
||||
dependents :: Codebase m v a -> Queries.DependentsSelector -> Reference -> Sqlite.Transaction (Set Reference)
|
||||
dependents c selector r =
|
||||
Set.union (Builtin.builtinTypeDependents r)
|
||||
. Set.map Reference.DerivedId
|
||||
@ -426,13 +428,13 @@ termsMentioningType c ty =
|
||||
|
||||
-- | Check whether a reference is a term.
|
||||
isTerm ::
|
||||
(Applicative m, BuiltinAnnotation a) =>
|
||||
BuiltinAnnotation a =>
|
||||
Codebase m Symbol a ->
|
||||
Reference ->
|
||||
m Bool
|
||||
Sqlite.Transaction Bool
|
||||
isTerm code = fmap isJust . getTypeOfTerm code
|
||||
|
||||
isType :: Applicative m => Codebase m v a -> Reference -> m Bool
|
||||
isType :: Codebase m v a -> Reference -> Sqlite.Transaction Bool
|
||||
isType c r = case r of
|
||||
Reference.Builtin {} -> pure $ Builtin.isBuiltinType r
|
||||
Reference.DerivedId r -> isJust <$> getTypeDeclaration c r
|
||||
@ -446,7 +448,7 @@ data Preprocessing m
|
||||
| Preprocessed (Branch m -> m (Branch m))
|
||||
|
||||
-- | Sync elements as needed from a remote git codebase into the local one.
|
||||
-- If `sbh` is supplied, we try to load the specified branch hash;
|
||||
-- If `sch` is supplied, we try to load the specified branch hash;
|
||||
-- otherwise we try to load the root branch.
|
||||
importRemoteBranch ::
|
||||
forall m v a.
|
||||
@ -499,21 +501,21 @@ unsafeGetTerm codebase rid =
|
||||
Just term -> pure term
|
||||
|
||||
-- | Like 'getTypeDeclaration', for when the type declaration is known to exist in the codebase.
|
||||
unsafeGetTypeDeclaration :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Decl v a)
|
||||
unsafeGetTypeDeclaration :: HasCallStack => Codebase m v a -> Reference.Id -> Sqlite.Transaction (Decl v a)
|
||||
unsafeGetTypeDeclaration codebase rid =
|
||||
getTypeDeclaration codebase rid >>= \case
|
||||
Nothing -> error (reportBug "E129043" ("type decl " ++ show rid ++ " not found"))
|
||||
Just decl -> pure decl
|
||||
|
||||
-- | Like 'getTypeOfTerm', but for when the term is known to exist in the codebase.
|
||||
unsafeGetTypeOfTermById :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Type v a)
|
||||
unsafeGetTypeOfTermById :: HasCallStack => Codebase m v a -> Reference.Id -> Sqlite.Transaction (Type v a)
|
||||
unsafeGetTypeOfTermById codebase rid =
|
||||
getTypeOfTermImpl codebase rid >>= \case
|
||||
Nothing -> error (reportBug "E377910" ("type of term " ++ show rid ++ " not found"))
|
||||
Just ty -> pure ty
|
||||
|
||||
-- | Like 'unsafeGetTerm', but returns the type of the term, too.
|
||||
unsafeGetTermWithType :: (HasCallStack, Monad m) => Codebase m v a -> Reference.Id -> m (Term v a, Type v a)
|
||||
unsafeGetTermWithType :: (HasCallStack, MonadIO m) => Codebase m v a -> Reference.Id -> m (Term v a, Type v a)
|
||||
unsafeGetTermWithType codebase rid = do
|
||||
term <- unsafeGetTerm codebase rid
|
||||
ty <-
|
||||
@ -521,7 +523,7 @@ unsafeGetTermWithType codebase rid = do
|
||||
-- inferred type). In this case, we can avoid looking up the type separately.
|
||||
case term of
|
||||
Term.Ann' _ ty -> pure ty
|
||||
_ -> unsafeGetTypeOfTermById codebase rid
|
||||
_ -> runTransaction codebase (unsafeGetTypeOfTermById codebase rid)
|
||||
pure (term, ty)
|
||||
|
||||
-- | Like 'getTermComponentWithTypes', for when the term component is known to exist in the codebase.
|
||||
|
@ -28,7 +28,6 @@ module Unison.Codebase.Branch
|
||||
|
||||
-- * Branch tests
|
||||
isEmpty,
|
||||
isEmpty0,
|
||||
isOne,
|
||||
before,
|
||||
lca,
|
||||
@ -85,12 +84,16 @@ module Unison.Codebase.Branch
|
||||
where
|
||||
|
||||
import Control.Lens hiding (children, cons, transform, uncons)
|
||||
import Control.Monad.State (State)
|
||||
import qualified Control.Monad.State as State
|
||||
import Data.Bifunctor (second)
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Semialign as Align
|
||||
import qualified Data.Sequence as Seq
|
||||
import qualified Data.Set as Set
|
||||
import Data.These (These (..))
|
||||
import U.Codebase.Branch (NamespaceStats (..))
|
||||
import U.Codebase.Branch.Type (NamespaceStats (..))
|
||||
import Unison.Codebase.Branch.Raw (Raw)
|
||||
import Unison.Codebase.Branch.Type
|
||||
( Branch (..),
|
||||
@ -104,6 +107,7 @@ import Unison.Codebase.Branch.Type
|
||||
head,
|
||||
headHash,
|
||||
history,
|
||||
namespaceHash,
|
||||
)
|
||||
import Unison.Codebase.Causal (Causal)
|
||||
import qualified Unison.Codebase.Causal as Causal
|
||||
@ -121,7 +125,7 @@ import Unison.Prelude hiding (empty)
|
||||
import Unison.Reference (TypeReference)
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Util.List as List
|
||||
import Unison.Util.Relation (Relation)
|
||||
import qualified Unison.Util.Monoid as Monoid
|
||||
import qualified Unison.Util.Relation as R
|
||||
import qualified Unison.Util.Relation as Relation
|
||||
import qualified Unison.Util.Relation4 as R4
|
||||
@ -193,6 +197,11 @@ branch0 terms types children edits =
|
||||
_types = types,
|
||||
_children = children,
|
||||
_edits = edits,
|
||||
isEmpty0 =
|
||||
R.null (Star3.d1 terms)
|
||||
&& R.null (Star3.d1 types)
|
||||
&& Map.null edits
|
||||
&& all (isEmpty0 . head) children,
|
||||
-- These are all overwritten immediately
|
||||
deepTerms = R.empty,
|
||||
deepTypes = R.empty,
|
||||
@ -211,80 +220,157 @@ branch0 terms types children edits =
|
||||
-- | Derive the 'deepTerms' field of a branch.
|
||||
deriveDeepTerms :: Branch0 m -> Branch0 m
|
||||
deriveDeepTerms branch =
|
||||
branch {deepTerms = makeDeepTerms (_terms branch) (nonEmptyChildren branch)}
|
||||
branch {deepTerms = R.fromList (makeDeepTerms branch)}
|
||||
where
|
||||
makeDeepTerms :: Metadata.Star Referent NameSegment -> Map NameSegment (Branch m) -> Relation Referent Name
|
||||
makeDeepTerms terms children =
|
||||
R.mapRanMonotonic Name.fromSegment (Star3.d1 terms) <> ifoldMap go children
|
||||
makeDeepTerms :: Branch0 m -> [(Referent, Name)]
|
||||
makeDeepTerms branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
|
||||
where
|
||||
go :: NameSegment -> Branch m -> Relation Referent Name
|
||||
go n b =
|
||||
R.mapRan (Name.cons n) (deepTerms $ head b)
|
||||
-- `reversePrefix` might be ["Nat", "base", "lib"], and `b0` the `Nat` sub-namespace.
|
||||
-- Then `R.toList` might produce the NameSegment "+", and we put the two together to
|
||||
-- construct the name `Name Relative ("+" :| ["Nat","base","lib"])`.
|
||||
go ::
|
||||
forall m.
|
||||
Seq (DeepChildAcc m) ->
|
||||
[(Referent, Name)] ->
|
||||
DeepState m [(Referent, Name)]
|
||||
go Seq.Empty acc = pure acc
|
||||
go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
|
||||
let terms :: [(Referent, Name)]
|
||||
terms =
|
||||
map
|
||||
(second (Name.fromReverseSegments . (NonEmpty.:| reversePrefix)))
|
||||
(R.toList (Star3.d1 (_terms b0)))
|
||||
children <- deepChildrenHelper e
|
||||
go (work <> children) (terms <> acc)
|
||||
|
||||
-- | Derive the 'deepTypes' field of a branch.
|
||||
deriveDeepTypes :: Branch0 m -> Branch0 m
|
||||
deriveDeepTypes :: forall m. Branch0 m -> Branch0 m
|
||||
deriveDeepTypes branch =
|
||||
branch {deepTypes = makeDeepTypes (_types branch) (nonEmptyChildren branch)}
|
||||
branch {deepTypes = R.fromList (makeDeepTypes branch)}
|
||||
where
|
||||
makeDeepTypes :: Metadata.Star TypeReference NameSegment -> Map NameSegment (Branch m) -> Relation TypeReference Name
|
||||
makeDeepTypes types children =
|
||||
R.mapRanMonotonic Name.fromSegment (Star3.d1 types) <> ifoldMap go children
|
||||
makeDeepTypes :: Branch0 m -> [(TypeReference, Name)]
|
||||
makeDeepTypes branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
|
||||
where
|
||||
go :: NameSegment -> Branch m -> Relation TypeReference Name
|
||||
go n b =
|
||||
R.mapRan (Name.cons n) (deepTypes $ head b)
|
||||
go ::
|
||||
Seq (DeepChildAcc m) ->
|
||||
[(TypeReference, Name)] ->
|
||||
DeepState m [(TypeReference, Name)]
|
||||
go Seq.Empty acc = pure acc
|
||||
go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
|
||||
let types :: [(TypeReference, Name)]
|
||||
types = map (second (Name.fromReverseSegments . (NonEmpty.:| reversePrefix))) (R.toList (Star3.d1 (_types b0)))
|
||||
children <- deepChildrenHelper e
|
||||
go (work <> children) (types <> acc)
|
||||
|
||||
-- | Derive the 'deepTermMetadata' field of a branch.
|
||||
deriveDeepTermMetadata :: Branch0 m -> Branch0 m
|
||||
deriveDeepTermMetadata :: forall m. Branch0 m -> Branch0 m
|
||||
deriveDeepTermMetadata branch =
|
||||
branch {deepTermMetadata = makeDeepTermMetadata (_terms branch) (nonEmptyChildren branch)}
|
||||
branch {deepTermMetadata = R4.fromList (makeDeepTermMetadata branch)}
|
||||
where
|
||||
makeDeepTermMetadata :: Metadata.Star Referent NameSegment -> Map NameSegment (Branch m) -> Metadata.R4 Referent Name
|
||||
makeDeepTermMetadata terms children =
|
||||
R4.mapD2Monotonic Name.fromSegment (Metadata.starToR4 terms) <> ifoldMap go children
|
||||
makeDeepTermMetadata :: Branch0 m -> [(Referent, Name, Metadata.Type, Metadata.Value)]
|
||||
makeDeepTermMetadata branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
|
||||
where
|
||||
go :: NameSegment -> Branch m -> Metadata.R4 Referent Name
|
||||
go n b =
|
||||
R4.mapD2 (Name.cons n) (deepTermMetadata $ head b)
|
||||
go ::
|
||||
Seq (DeepChildAcc m) ->
|
||||
[(Referent, Name, Metadata.Type, Metadata.Value)] ->
|
||||
DeepState m [(Referent, Name, Metadata.Type, Metadata.Value)]
|
||||
go Seq.Empty acc = pure acc
|
||||
go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
|
||||
let termMetadata :: [(Referent, Name, Metadata.Type, Metadata.Value)]
|
||||
termMetadata =
|
||||
map
|
||||
(\(r, n, t, v) -> (r, Name.fromReverseSegments (n NonEmpty.:| reversePrefix), t, v))
|
||||
(Metadata.starToR4List (_terms b0))
|
||||
children <- deepChildrenHelper e
|
||||
go (work <> children) (termMetadata <> acc)
|
||||
|
||||
-- | Derive the 'deepTypeMetadata' field of a branch.
|
||||
deriveDeepTypeMetadata :: Branch0 m -> Branch0 m
|
||||
deriveDeepTypeMetadata :: forall m. Branch0 m -> Branch0 m
|
||||
deriveDeepTypeMetadata branch =
|
||||
branch {deepTypeMetadata = makeDeepTypeMetadata (_types branch) (nonEmptyChildren branch)}
|
||||
branch {deepTypeMetadata = R4.fromList (makeDeepTypeMetadata branch)}
|
||||
where
|
||||
makeDeepTypeMetadata :: Metadata.Star TypeReference NameSegment -> Map NameSegment (Branch m) -> Metadata.R4 TypeReference Name
|
||||
makeDeepTypeMetadata types children =
|
||||
R4.mapD2Monotonic Name.fromSegment (Metadata.starToR4 types) <> ifoldMap go children
|
||||
makeDeepTypeMetadata :: Branch0 m -> [(TypeReference, Name, Metadata.Type, Metadata.Value)]
|
||||
makeDeepTypeMetadata branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
|
||||
where
|
||||
go :: NameSegment -> Branch m -> Metadata.R4 TypeReference Name
|
||||
go n b =
|
||||
R4.mapD2 (Name.cons n) (deepTypeMetadata $ head b)
|
||||
go ::
|
||||
Seq (DeepChildAcc m) ->
|
||||
[(TypeReference, Name, Metadata.Type, Metadata.Value)] ->
|
||||
DeepState m [(TypeReference, Name, Metadata.Type, Metadata.Value)]
|
||||
go Seq.Empty acc = pure acc
|
||||
go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
|
||||
let typeMetadata :: [(TypeReference, Name, Metadata.Type, Metadata.Value)]
|
||||
typeMetadata =
|
||||
map
|
||||
(\(r, n, t, v) -> (r, Name.fromReverseSegments (n NonEmpty.:| reversePrefix), t, v))
|
||||
(Metadata.starToR4List (_types b0))
|
||||
children <- deepChildrenHelper e
|
||||
go (work <> children) (typeMetadata <> acc)
|
||||
|
||||
-- | Derive the 'deepPaths' field of a branch.
|
||||
deriveDeepPaths :: Branch0 m -> Branch0 m
|
||||
deriveDeepPaths :: forall m. Branch0 m -> Branch0 m
|
||||
deriveDeepPaths branch =
|
||||
branch {deepPaths = makeDeepPaths (nonEmptyChildren branch)}
|
||||
branch {deepPaths = makeDeepPaths branch}
|
||||
where
|
||||
makeDeepPaths :: Map NameSegment (Branch m) -> Set Path
|
||||
makeDeepPaths children =
|
||||
Set.mapMonotonic Path.singleton (Map.keysSet children) <> ifoldMap go children
|
||||
makeDeepPaths :: Branch0 m -> Set Path
|
||||
makeDeepPaths branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
|
||||
where
|
||||
go :: NameSegment -> Branch m -> Set Path
|
||||
go n b =
|
||||
Set.map (Path.cons n) (deepPaths $ head b)
|
||||
go :: Seq (DeepChildAcc m) -> Set Path -> DeepState m (Set Path)
|
||||
go Seq.Empty acc = pure acc
|
||||
go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
|
||||
let paths :: Set Path
|
||||
paths =
|
||||
if isEmpty0 b0
|
||||
then Set.empty
|
||||
else (Set.singleton . Path . Seq.fromList . reverse) reversePrefix
|
||||
children <- deepChildrenHelper e
|
||||
go (work <> children) (paths <> acc)
|
||||
|
||||
-- | Derive the 'deepEdits' field of a branch.
|
||||
deriveDeepEdits :: Branch0 m -> Branch0 m
|
||||
deriveDeepEdits :: forall m. Branch0 m -> Branch0 m
|
||||
deriveDeepEdits branch =
|
||||
branch {deepEdits = makeDeepEdits (_edits branch) (nonEmptyChildren branch)}
|
||||
branch {deepEdits = makeDeepEdits branch}
|
||||
where
|
||||
makeDeepEdits :: Map NameSegment (EditHash, m Patch) -> Map NameSegment (Branch m) -> Map Name EditHash
|
||||
makeDeepEdits edits children =
|
||||
Map.mapKeysMonotonic Name.fromSegment (Map.map fst edits) <> ifoldMap go children
|
||||
makeDeepEdits :: Branch0 m -> Map Name EditHash
|
||||
makeDeepEdits branch = State.evalState (go (Seq.singleton ([], 0, branch)) mempty) Set.empty
|
||||
where
|
||||
go :: NameSegment -> Branch m -> Map Name EditHash
|
||||
go n b =
|
||||
Map.mapKeys (Name.cons n) (deepEdits $ head b)
|
||||
go :: (Seq (DeepChildAcc m)) -> Map Name EditHash -> DeepState m (Map Name EditHash)
|
||||
go Seq.Empty acc = pure acc
|
||||
go (e@(reversePrefix, _, b0) Seq.:<| work) acc = do
|
||||
let edits :: Map Name EditHash
|
||||
edits =
|
||||
Map.mapKeysMonotonic
|
||||
(Name.fromReverseSegments . (NonEmpty.:| reversePrefix))
|
||||
(fst <$> _edits b0)
|
||||
children <- deepChildrenHelper e
|
||||
go (work <> children) (edits <> acc)
|
||||
|
||||
-- | State used by deepChildrenHelper to determine whether to descend into a child branch.
|
||||
-- Contains the set of visited namespace hashes.
|
||||
type DeepState m = State (Set (NamespaceHash m))
|
||||
|
||||
-- | Represents a unit of remaining work in traversing children for computing `deep*`.
|
||||
-- (reverse prefix to a branch, the number of `lib` segments in the reverse prefix, and the branch itself)
|
||||
type DeepChildAcc m = ([NameSegment], Int, Branch0 m)
|
||||
|
||||
-- | Helper for knowing whether to descend into a child branch or not.
|
||||
-- Accepts child namespaces with previously unseen hashes, and any nested under 1 or fewer `lib` segments.
|
||||
deepChildrenHelper :: forall m. DeepChildAcc m -> DeepState m (Seq (DeepChildAcc m))
|
||||
deepChildrenHelper (reversePrefix, libDepth, b0) = do
|
||||
let go :: (NameSegment, Branch m) -> DeepState m (Seq (DeepChildAcc m))
|
||||
go (ns, b) = do
|
||||
let h = namespaceHash b
|
||||
result <- do
|
||||
let isShallowDependency = libDepth <= 1
|
||||
isUnseenNamespace <- State.gets (Set.notMember h)
|
||||
pure
|
||||
if isShallowDependency || isUnseenNamespace
|
||||
then
|
||||
let libDepth' = if ns == "lib" then libDepth + 1 else libDepth
|
||||
in Seq.singleton (ns : reversePrefix, libDepth', head b)
|
||||
else Seq.empty
|
||||
State.modify' (Set.insert h)
|
||||
pure result
|
||||
Monoid.foldMapM go (Map.toList (nonEmptyChildren b0))
|
||||
|
||||
-- | Update the head of the current causal.
|
||||
-- This re-hashes the current causal head after modifications.
|
||||
@ -360,17 +446,7 @@ one = Branch . Causal.one
|
||||
|
||||
empty0 :: Branch0 m
|
||||
empty0 =
|
||||
Branch0 mempty mempty mempty mempty mempty mempty mempty mempty mempty mempty
|
||||
|
||||
-- | Checks whether a Branch0 is empty, which means that the branch contains no terms or
|
||||
-- types, and that the heads of all children are empty by the same definition.
|
||||
-- This is not as easy as checking whether the branch is equal to the `empty0` branch
|
||||
-- because child branches may be empty, but still have history.
|
||||
isEmpty0 :: Branch0 m -> Bool
|
||||
isEmpty0 (Branch0 _terms _types _children _edits deepTerms deepTypes _deepTermMetadata _deepTypeMetadata _deepPaths deepEdits) =
|
||||
Relation.null deepTerms
|
||||
&& Relation.null deepTypes
|
||||
&& Map.null deepEdits
|
||||
Branch0 mempty mempty mempty mempty True mempty mempty mempty mempty mempty mempty
|
||||
|
||||
-- | Checks whether a branch is empty AND has no history.
|
||||
isEmpty :: Branch m -> Bool
|
||||
|
@ -5,6 +5,7 @@ module Unison.Codebase.Branch.Type
|
||||
CausalHash (..),
|
||||
head,
|
||||
headHash,
|
||||
namespaceHash,
|
||||
Branch (..),
|
||||
Branch0 (..),
|
||||
history,
|
||||
@ -51,13 +52,17 @@ head (Branch c) = Causal.head c
|
||||
headHash :: Branch m -> CausalHash
|
||||
headHash (Branch c) = Causal.currentHash c
|
||||
|
||||
namespaceHash :: Branch m -> NamespaceHash m
|
||||
namespaceHash (Branch c) = Causal.valueHash c
|
||||
|
||||
-- | A node in the Unison namespace hierarchy.
|
||||
--
|
||||
-- '_terms' and '_types' are the declarations at this level.
|
||||
-- '_children' are the nodes one level below us.
|
||||
-- '_edits' are the 'Patch's stored at this node in the code.
|
||||
--
|
||||
-- The @deep*@ fields are derived from the four above.
|
||||
-- The remaining fields are derived from the four above.
|
||||
-- Please don't set them manually; use Branch.empty0 or Branch.branch0 to construct them.
|
||||
data Branch0 m = Branch0
|
||||
{ _terms :: Star Referent NameSegment,
|
||||
_types :: Star Reference NameSegment,
|
||||
@ -65,6 +70,9 @@ data Branch0 m = Branch0
|
||||
-- Every level in the tree has a history.
|
||||
_children :: Map NameSegment (Branch m),
|
||||
_edits :: Map NameSegment (EditHash, m Patch),
|
||||
-- | True if a branch and its children have no definitions or edits in them.
|
||||
-- (Computed recursively, and small enough to justify storing here to avoid computing more than once.)
|
||||
isEmpty0 :: Bool,
|
||||
-- names and metadata for this branch and its children
|
||||
-- (ref, (name, value)) iff ref has metadata `value` at name `name`
|
||||
deepTerms :: Relation Referent Name,
|
||||
|
@ -11,8 +11,8 @@ import qualified Data.Text as Text
|
||||
import qualified U.Util.Monoid as Monoid
|
||||
import Unison.Codebase.Path (Path)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
|
||||
import qualified Unison.Codebase.ShortBranchHash as SBH
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import qualified Unison.Codebase.ShortCausalHash as SCH
|
||||
import Unison.Prelude
|
||||
import Unison.Share.Types
|
||||
|
||||
@ -66,7 +66,7 @@ writeToReadGit = \case
|
||||
writePathToRead :: WriteRemotePath -> ReadRemoteNamespace
|
||||
writePathToRead = \case
|
||||
WriteRemotePathGit WriteGitRemotePath {repo, path} ->
|
||||
ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo = writeToReadGit repo, sbh = Nothing, path}
|
||||
ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo = writeToReadGit repo, sch = Nothing, path}
|
||||
WriteRemotePathShare WriteShareRemotePath {server, repo, path} ->
|
||||
ReadRemoteNamespaceShare ReadShareRemoteNamespace {server, repo, path}
|
||||
|
||||
@ -80,12 +80,12 @@ printWriteGitRepo WriteGitRepo {url, branch} = "git(" <> url <> Monoid.fromMaybe
|
||||
-- | print remote namespace
|
||||
printNamespace :: ReadRemoteNamespace -> Text
|
||||
printNamespace = \case
|
||||
ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sbh, path} ->
|
||||
printReadGitRepo repo <> maybePrintSBH sbh <> maybePrintPath path
|
||||
ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sch, path} ->
|
||||
printReadGitRepo repo <> maybePrintSCH sch <> maybePrintPath path
|
||||
where
|
||||
maybePrintSBH = \case
|
||||
maybePrintSCH = \case
|
||||
Nothing -> mempty
|
||||
Just sbh -> "#" <> SBH.toText sbh
|
||||
Just sch -> "#" <> SCH.toText sch
|
||||
ReadRemoteNamespaceShare ReadShareRemoteNamespace {server, repo, path} ->
|
||||
displayShareCodeserver server repo path
|
||||
|
||||
@ -110,7 +110,7 @@ data ReadRemoteNamespace
|
||||
|
||||
data ReadGitRemoteNamespace = ReadGitRemoteNamespace
|
||||
{ repo :: ReadGitRepo,
|
||||
sbh :: Maybe ShortBranchHash,
|
||||
sch :: Maybe ShortCausalHash,
|
||||
path :: Path
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
@ -118,7 +118,7 @@ data ReadGitRemoteNamespace = ReadGitRemoteNamespace
|
||||
data ReadShareRemoteNamespace = ReadShareRemoteNamespace
|
||||
{ server :: ShareCodeserver,
|
||||
repo :: Text,
|
||||
-- sbh :: Maybe ShortBranchHash, -- maybe later
|
||||
-- sch :: Maybe ShortCausalHash, -- maybe later
|
||||
path :: Path
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
@ -35,7 +35,7 @@ execute codebase runtime mainName =
|
||||
let parseNames = Names.makeAbsolute (Branch.toNames (Branch.head root))
|
||||
loadTypeOfTerm = Codebase.getTypeOfTerm codebase
|
||||
let mainType = Runtime.mainType runtime
|
||||
mt <- liftIO $ getMainTerm loadTypeOfTerm parseNames mainName mainType
|
||||
mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm parseNames mainName mainType
|
||||
case mt of
|
||||
MainTerm.NotAFunctionName s -> throwError ("Not a function name: " <> P.string s)
|
||||
MainTerm.NotFound s -> throwError ("Not found: " <> P.string s)
|
||||
|
@ -4,7 +4,7 @@ module Unison.Codebase.GitError where
|
||||
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo)
|
||||
import Unison.Codebase.Path
|
||||
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Prelude
|
||||
|
||||
type CodebasePath = FilePath
|
||||
@ -28,8 +28,8 @@ data GitProtocolError
|
||||
deriving anyclass (Exception)
|
||||
|
||||
data GitCodebaseError h
|
||||
= NoRemoteNamespaceWithHash ReadGitRepo ShortBranchHash
|
||||
| RemoteNamespaceHashAmbiguous ReadGitRepo ShortBranchHash (Set h)
|
||||
= NoRemoteNamespaceWithHash ReadGitRepo ShortCausalHash
|
||||
| RemoteNamespaceHashAmbiguous ReadGitRepo ShortCausalHash (Set h)
|
||||
| CouldntLoadRootBranch ReadGitRepo h
|
||||
| CouldntParseRemoteBranch ReadGitRepo String
|
||||
| CouldntLoadSyncedBranch ReadGitRemoteNamespace h
|
||||
|
@ -146,7 +146,7 @@ withNewUcmCodebaseOrExit cbInit debugName path action = do
|
||||
prettyDir <- P.string <$> canonicalizePath path
|
||||
let codebaseSetup codebase = do
|
||||
liftIO $ PT.putPrettyLn' . P.wrap $ "Initializing a new codebase in: " <> prettyDir
|
||||
Codebase.installUcmDependencies codebase
|
||||
Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase)
|
||||
createCodebase cbInit debugName path (\cb -> codebaseSetup cb *> action cb)
|
||||
>>= \case
|
||||
Left error -> liftIO $ PT.putPrettyLn' error >> exitFailure
|
||||
|
@ -29,7 +29,16 @@ type Star a n = Star3 a n Type (Type, Value)
|
||||
type R4 a n = R4.Relation4 a n Type Value
|
||||
|
||||
starToR4 :: (Ord r, Ord n) => Star r n -> Relation4 r n Type Value
|
||||
starToR4 = R4.fromList . fmap (\(r, n, _, (t, v)) -> (r, n, t, v)) . Star3.toList
|
||||
starToR4 = R4.fromList . starToR4List
|
||||
|
||||
-- | Flattens a Metadata.Star into a 4-tuple.
|
||||
starToR4List :: Ord r => Star r n -> [(r, n, Type, Value)]
|
||||
starToR4List s =
|
||||
[ (f, x, y, z)
|
||||
| f <- Set.toList (Star3.fact s),
|
||||
x <- Set.toList (R.lookupDom f (Star3.d1 s)),
|
||||
(y, z) <- Set.toList (R.lookupDom f (Star3.d3 s))
|
||||
]
|
||||
|
||||
hasMetadata :: Ord a => a -> Type -> Value -> Star a n -> Bool
|
||||
hasMetadata a t v = Set.member (t, v) . R.lookupDom a . Star3.d3
|
||||
|
@ -1,38 +0,0 @@
|
||||
module Unison.Codebase.ShortBranchHash
|
||||
( toString,
|
||||
toHash,
|
||||
fromHash,
|
||||
fromText,
|
||||
ShortBranchHash (..),
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Unison.Hash as Hash
|
||||
import Unison.Prelude
|
||||
|
||||
newtype ShortBranchHash = ShortBranchHash {toText :: Text} -- base32hex characters
|
||||
deriving stock (Eq, Ord, Generic)
|
||||
|
||||
toString :: ShortBranchHash -> String
|
||||
toString = Text.unpack . toText
|
||||
|
||||
toHash :: Coercible Hash.Hash h => ShortBranchHash -> Maybe h
|
||||
toHash = fmap coerce . Hash.fromBase32Hex . toText
|
||||
|
||||
fromHash :: Coercible h Hash.Hash => Int -> h -> ShortBranchHash
|
||||
fromHash len =
|
||||
ShortBranchHash . Text.take len . Hash.base32Hex . coerce
|
||||
|
||||
-- abc -> SBH abc
|
||||
-- #abc -> SBH abc
|
||||
fromText :: Text -> Maybe ShortBranchHash
|
||||
fromText (Text.dropWhile (== '#') -> t)
|
||||
| Text.all (`Set.member` Hash.validBase32HexChars) t =
|
||||
Just $
|
||||
ShortBranchHash t
|
||||
fromText _ = Nothing
|
||||
|
||||
instance Show ShortBranchHash where
|
||||
show (ShortBranchHash h) = '#' : Text.unpack h
|
39
parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs
Normal file
39
parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs
Normal file
@ -0,0 +1,39 @@
|
||||
module Unison.Codebase.ShortCausalHash
|
||||
( toString,
|
||||
toHash,
|
||||
fromHash,
|
||||
fromText,
|
||||
ShortCausalHash (..),
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Unison.Hash as Hash
|
||||
import Unison.Prelude
|
||||
|
||||
-- | Causal Hash Prefix
|
||||
newtype ShortCausalHash = ShortCausalHash {toText :: Text} -- base32hex characters
|
||||
deriving stock (Eq, Ord, Generic)
|
||||
|
||||
toString :: ShortCausalHash -> String
|
||||
toString = Text.unpack . toText
|
||||
|
||||
toHash :: Coercible Hash.Hash h => ShortCausalHash -> Maybe h
|
||||
toHash = fmap coerce . Hash.fromBase32Hex . toText
|
||||
|
||||
fromHash :: Coercible h Hash.Hash => Int -> h -> ShortCausalHash
|
||||
fromHash len =
|
||||
ShortCausalHash . Text.take len . Hash.base32Hex . coerce
|
||||
|
||||
-- abc -> SCH abc
|
||||
-- #abc -> SCH abc
|
||||
fromText :: Text -> Maybe ShortCausalHash
|
||||
fromText (Text.dropWhile (== '#') -> t)
|
||||
| Text.all (`Set.member` Hash.validBase32HexChars) t =
|
||||
Just $
|
||||
ShortCausalHash t
|
||||
fromText _ = Nothing
|
||||
|
||||
instance Show ShortCausalHash where
|
||||
show (ShortCausalHash h) = '#' : Text.unpack h
|
@ -27,14 +27,13 @@ import qualified System.Console.ANSI as ANSI
|
||||
import qualified System.FilePath as FilePath
|
||||
import qualified System.FilePath.Posix as FilePath.Posix
|
||||
import qualified U.Codebase.Branch as V2Branch
|
||||
import U.Codebase.HashTags (CausalHash (CausalHash))
|
||||
import U.Codebase.HashTags (BranchHash, CausalHash (CausalHash))
|
||||
import qualified U.Codebase.Reflog as Reflog
|
||||
import qualified U.Codebase.Sqlite.Operations as Ops
|
||||
import qualified U.Codebase.Sqlite.Queries as Q
|
||||
import qualified U.Codebase.Sqlite.Sync22 as Sync22
|
||||
import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle)
|
||||
import qualified U.Codebase.Sync as Sync
|
||||
import qualified U.Util.Cache as Cache
|
||||
import U.Util.Timing (time)
|
||||
import Unison.Codebase (Codebase, CodebasePath)
|
||||
import qualified Unison.Codebase as Codebase1
|
||||
@ -58,7 +57,7 @@ import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
|
||||
import qualified Unison.Codebase.Init.OpenCodebaseError as Codebase1
|
||||
import Unison.Codebase.Patch (Patch)
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
|
||||
import qualified Unison.Codebase.SqliteCodebase.Branch.Dependencies as BD
|
||||
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
|
||||
@ -197,12 +196,9 @@ sqliteCodebase ::
|
||||
(Codebase m Symbol Ann -> m r) ->
|
||||
m (Either Codebase1.OpenCodebaseError r)
|
||||
sqliteCodebase debugName root localOrRemote migrationStrategy action = do
|
||||
termCache <- Cache.semispaceCache 8192 -- pure Cache.nullCache -- to disable
|
||||
typeOfTermCache <- Cache.semispaceCache 8192
|
||||
declCache <- Cache.semispaceCache 1024
|
||||
rootBranchCache <- newTVarIO Nothing
|
||||
branchCache <- newBranchCache
|
||||
getDeclType <- CodebaseOps.mkGetDeclType
|
||||
getDeclType <- CodebaseOps.makeCachedTransaction 2048 CodebaseOps.getDeclType
|
||||
-- The v1 codebase interface has operations to read and write individual definitions
|
||||
-- whereas the v2 codebase writes them as complete components. These two fields buffer
|
||||
-- the individual definitions until a complete component has been written.
|
||||
@ -239,26 +235,19 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
|
||||
printBuffer "Terms:" terms
|
||||
|
||||
flip finally finalizer do
|
||||
let getTerm :: Reference.Id -> m (Maybe (Term Symbol Ann))
|
||||
getTerm id =
|
||||
runTransaction (CodebaseOps.getTerm getDeclType id)
|
||||
getTermTransaction <- CodebaseOps.makeMaybeCachedTransaction 8192 (CodebaseOps.getTerm getDeclType)
|
||||
let getTerm id = runTransaction (getTermTransaction id)
|
||||
|
||||
getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type Symbol Ann))
|
||||
getTypeOfTermImpl id | debug && trace ("getTypeOfTermImpl " ++ show id) False = undefined
|
||||
getTypeOfTermImpl id =
|
||||
runTransaction (CodebaseOps.getTypeOfTermImpl id)
|
||||
getTypeOfTermImpl <- CodebaseOps.makeMaybeCachedTransaction 8192 (CodebaseOps.getTypeOfTermImpl)
|
||||
getTypeDeclaration <- CodebaseOps.makeMaybeCachedTransaction 1024 CodebaseOps.getTypeDeclaration
|
||||
|
||||
getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
|
||||
let getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term Symbol Ann, Type Symbol Ann)])
|
||||
getTermComponentWithTypes =
|
||||
CodebaseOps.getTermComponentWithTypes getDeclType
|
||||
|
||||
getTypeDeclaration :: Reference.Id -> m (Maybe (Decl Symbol Ann))
|
||||
getTypeDeclaration id =
|
||||
runTransaction (CodebaseOps.getTypeDeclaration id)
|
||||
|
||||
getDeclComponent :: Hash -> m (Maybe [Decl Symbol Ann])
|
||||
getDeclComponent h =
|
||||
runTransaction (CodebaseOps.getDeclComponent h)
|
||||
getDeclComponent :: Hash -> Sqlite.Transaction (Maybe [Decl Symbol Ann])
|
||||
getDeclComponent =
|
||||
CodebaseOps.getDeclComponent
|
||||
|
||||
getCycleLength :: Hash -> m (Maybe Reference.CycleSize)
|
||||
getCycleLength h =
|
||||
@ -271,14 +260,22 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
|
||||
-- option 2: switch codebase interface from putTerm to putTerms -- buffering can be local to the function
|
||||
-- option 3: switch from putTerm to putTermComponent -- needs to buffer dependencies non-locally (or require application to manage + die horribly)
|
||||
|
||||
putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> m ()
|
||||
putTerm :: Reference.Id -> Term Symbol Ann -> Type Symbol Ann -> Sqlite.Transaction ()
|
||||
putTerm id tm tp | debug && trace ("SqliteCodebase.putTerm " ++ show id ++ " " ++ show tm ++ " " ++ show tp) False = undefined
|
||||
putTerm id tm tp =
|
||||
runTransaction (CodebaseOps.putTerm termBuffer declBuffer id tm tp)
|
||||
CodebaseOps.putTerm termBuffer declBuffer id tm tp
|
||||
|
||||
putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> m ()
|
||||
putTypeDeclaration id decl =
|
||||
runTransaction (CodebaseOps.putTypeDeclaration termBuffer declBuffer id decl)
|
||||
putTermComponent :: Hash -> [(Term Symbol Ann, Type Symbol Ann)] -> Sqlite.Transaction ()
|
||||
putTermComponent =
|
||||
CodebaseOps.putTermComponent termBuffer declBuffer
|
||||
|
||||
putTypeDeclaration :: Reference.Id -> Decl Symbol Ann -> Sqlite.Transaction ()
|
||||
putTypeDeclaration =
|
||||
CodebaseOps.putTypeDeclaration termBuffer declBuffer
|
||||
|
||||
putTypeDeclarationComponent :: Hash -> [Decl Symbol Ann] -> Sqlite.Transaction ()
|
||||
putTypeDeclarationComponent =
|
||||
CodebaseOps.putTypeDeclarationComponent termBuffer declBuffer
|
||||
|
||||
getRootCausalHash :: MonadIO m => m V2Branch.CausalHash
|
||||
getRootCausalHash =
|
||||
@ -335,9 +332,9 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
|
||||
patchExists h =
|
||||
runTransaction (CodebaseOps.patchExists h)
|
||||
|
||||
dependentsImpl :: Q.DependentsSelector -> Reference -> m (Set Reference.Id)
|
||||
dependentsImpl selector r =
|
||||
runTransaction (CodebaseOps.dependentsImpl selector r)
|
||||
dependentsImpl :: Q.DependentsSelector -> Reference -> Sqlite.Transaction (Set Reference.Id)
|
||||
dependentsImpl =
|
||||
CodebaseOps.dependentsImpl
|
||||
|
||||
dependentsOfComponentImpl :: Hash -> m (Set Reference.Id)
|
||||
dependentsOfComponentImpl h =
|
||||
@ -409,9 +406,9 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
|
||||
referentsByPrefix sh =
|
||||
runTransaction (CodebaseOps.referentsByPrefix getDeclType sh)
|
||||
|
||||
branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.CausalHash)
|
||||
branchHashesByPrefix sh =
|
||||
runTransaction (CodebaseOps.branchHashesByPrefix sh)
|
||||
causalHashesByPrefix :: ShortCausalHash -> m (Set Branch.CausalHash)
|
||||
causalHashesByPrefix sh =
|
||||
runTransaction (CodebaseOps.causalHashesByPrefix sh)
|
||||
|
||||
sqlLca :: Branch.CausalHash -> Branch.CausalHash -> m (Maybe (Branch.CausalHash))
|
||||
sqlLca h1 h2 =
|
||||
@ -426,21 +423,23 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
|
||||
namesAtPath path =
|
||||
runTransaction (CodebaseOps.namesAtPath path)
|
||||
|
||||
updateNameLookup :: m ()
|
||||
updateNameLookup :: Path -> Maybe BranchHash -> BranchHash -> Sqlite.Transaction ()
|
||||
updateNameLookup =
|
||||
runTransaction (CodebaseOps.updateNameLookupIndexFromV2Root getDeclType)
|
||||
CodebaseOps.updateNameLookupIndex getDeclType
|
||||
|
||||
let codebase =
|
||||
C.Codebase
|
||||
{ getTerm = Cache.applyDefined termCache getTerm,
|
||||
getTypeOfTermImpl = Cache.applyDefined typeOfTermCache getTypeOfTermImpl,
|
||||
getTypeDeclaration = Cache.applyDefined declCache getTypeDeclaration,
|
||||
{ getTerm,
|
||||
getTypeOfTermImpl,
|
||||
getTypeDeclaration,
|
||||
getDeclType =
|
||||
\r ->
|
||||
withConn \conn ->
|
||||
Sqlite.runReadOnlyTransaction conn \run -> run (getDeclType r),
|
||||
putTerm,
|
||||
putTermComponent,
|
||||
putTypeDeclaration,
|
||||
putTypeDeclarationComponent,
|
||||
getTermComponentWithTypes,
|
||||
getDeclComponent,
|
||||
getComponentLength = getCycleLength,
|
||||
@ -473,7 +472,7 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
|
||||
typeReferencesByPrefix = declReferencesByPrefix,
|
||||
termReferentsByPrefix = referentsByPrefix,
|
||||
branchHashLength,
|
||||
branchHashesByPrefix,
|
||||
causalHashesByPrefix,
|
||||
lcaImpl = Just sqlLca,
|
||||
beforeImpl,
|
||||
namesAtPath,
|
||||
@ -662,7 +661,7 @@ viewRemoteBranch' ::
|
||||
Git.GitBranchBehavior ->
|
||||
((Branch m, CodebasePath) -> m r) ->
|
||||
m (Either C.GitError r)
|
||||
viewRemoteBranch' ReadGitRemoteNamespace {repo, sbh, path} gitBranchBehavior action = UnliftIO.try $ do
|
||||
viewRemoteBranch' ReadGitRemoteNamespace {repo, sch, path} gitBranchBehavior action = UnliftIO.try $ do
|
||||
-- set up the cache dir
|
||||
time "Git fetch" $
|
||||
throwEitherMWith C.GitProtocolError . withRepo repo gitBranchBehavior $ \remoteRepo -> do
|
||||
@ -685,19 +684,19 @@ viewRemoteBranch' ReadGitRemoteNamespace {repo, sbh, path} gitBranchBehavior act
|
||||
|
||||
result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath Remote MigrateAfterPrompt \codebase -> do
|
||||
-- try to load the requested branch from it
|
||||
branch <- time "Git fetch (sbh)" $ case sbh of
|
||||
branch <- time "Git fetch (sch)" $ case sch of
|
||||
-- no sub-branch was specified, so use the root.
|
||||
Nothing -> time "Get remote root branch" $ Codebase1.getRootBranch codebase
|
||||
-- load from a specific `ShortBranchHash`
|
||||
Just sbh -> do
|
||||
branchCompletions <- Codebase1.branchHashesByPrefix codebase sbh
|
||||
-- load from a specific `ShortCausalHash`
|
||||
Just sch -> do
|
||||
branchCompletions <- Codebase1.causalHashesByPrefix codebase sch
|
||||
case toList branchCompletions of
|
||||
[] -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh
|
||||
[] -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sch
|
||||
[h] ->
|
||||
(Codebase1.getBranchForHash codebase h) >>= \case
|
||||
Just b -> pure b
|
||||
Nothing -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sbh
|
||||
_ -> throwIO . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sbh branchCompletions
|
||||
Nothing -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sch
|
||||
_ -> throwIO . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sch branchCompletions
|
||||
case Branch.getAt path branch of
|
||||
Just b -> action (b, remotePath)
|
||||
Nothing -> throwIO . C.GitCodebaseError $ GitError.CouldntFindRemoteBranch repo path
|
||||
|
@ -28,7 +28,7 @@ import qualified Unison.Codebase.Branch as V1.Branch
|
||||
import qualified Unison.Codebase.Causal.Type as V1.Causal
|
||||
import qualified Unison.Codebase.Metadata as V1.Metadata
|
||||
import qualified Unison.Codebase.Patch as V1
|
||||
import qualified Unison.Codebase.ShortBranchHash as V1
|
||||
import qualified Unison.Codebase.ShortCausalHash as V1
|
||||
import Unison.Codebase.SqliteCodebase.Branch.Cache
|
||||
import qualified Unison.Codebase.TermEdit as V1.TermEdit
|
||||
import qualified Unison.Codebase.TypeEdit as V1.TypeEdit
|
||||
@ -57,8 +57,8 @@ import qualified Unison.Util.Star3 as V1.Star3
|
||||
import qualified Unison.Var as Var
|
||||
import qualified Unison.WatchKind as V1.WK
|
||||
|
||||
sbh1to2 :: V1.ShortBranchHash -> V2.ShortBranchHash
|
||||
sbh1to2 (V1.ShortBranchHash b32) = V2.ShortBranchHash b32
|
||||
sch1to2 :: V1.ShortCausalHash -> V2.ShortCausalHash
|
||||
sch1to2 (V1.ShortCausalHash b32) = V2.ShortCausalHash b32
|
||||
|
||||
decltype2to1 :: V2.Decl.DeclType -> CT.ConstructorType
|
||||
decltype2to1 = \case
|
||||
@ -204,6 +204,13 @@ term2to1 h lookupCT =
|
||||
V2.Term.PConcat -> V1.Pattern.Concat
|
||||
a = Ann.External
|
||||
|
||||
termComponent1to2 ::
|
||||
Hash ->
|
||||
[(V1.Term.Term V1.Symbol Ann, V1.Type.Type V1.Symbol a)] ->
|
||||
[(V2.Term.Term V2.Symbol, V2.Type.TypeT V2.Symbol)]
|
||||
termComponent1to2 h =
|
||||
map (bimap (term1to2 h) ttype1to2)
|
||||
|
||||
decl2to1 :: Hash -> V2.Decl.Decl V2.Symbol -> V1.Decl.Decl V1.Symbol Ann
|
||||
decl2to1 h (V2.Decl.DataDeclaration dt m bound cts) =
|
||||
goCT dt $
|
||||
|
@ -8,7 +8,7 @@
|
||||
module Unison.Codebase.SqliteCodebase.Operations where
|
||||
|
||||
import Control.Lens (ifor)
|
||||
import Data.Bifunctor (Bifunctor (bimap), second)
|
||||
import Data.Bifunctor (second)
|
||||
import Data.Bitraversable (bitraverse)
|
||||
import Data.Either.Extra ()
|
||||
import qualified Data.List as List
|
||||
@ -18,8 +18,9 @@ import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified U.Codebase.Branch as V2Branch
|
||||
import qualified U.Codebase.Branch.Diff as BranchDiff
|
||||
import qualified U.Codebase.Causal as V2Causal
|
||||
import U.Codebase.HashTags (CausalHash (unCausalHash))
|
||||
import U.Codebase.HashTags (BranchHash, CausalHash (unCausalHash))
|
||||
import qualified U.Codebase.Reference as C.Reference
|
||||
import qualified U.Codebase.Referent as C.Referent
|
||||
import U.Codebase.Sqlite.DbId (ObjectId)
|
||||
@ -41,7 +42,7 @@ import qualified Unison.Codebase.Causal.Type as Causal
|
||||
import Unison.Codebase.Patch (Patch)
|
||||
import Unison.Codebase.Path (Path)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.SqliteCodebase.Branch.Cache (BranchCache)
|
||||
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
@ -232,6 +233,19 @@ getDeclComponent h =
|
||||
decl2 <- Ops.loadDeclComponent h
|
||||
pure (map (Cv.decl2to1 h) decl2)
|
||||
|
||||
putTermComponent ::
|
||||
TVar (Map Hash TermBufferEntry) ->
|
||||
TVar (Map Hash DeclBufferEntry) ->
|
||||
-- | The hash of the term component.
|
||||
Hash ->
|
||||
[(Term Symbol Ann, Type Symbol Ann)] ->
|
||||
Transaction ()
|
||||
putTermComponent termBuffer declBuffer h component =
|
||||
unlessM (Ops.objectExistsForHash h) do
|
||||
for_ (Reference.componentFor h component) \(ref, (tm, tp)) -> do
|
||||
putTerm_ termBuffer declBuffer ref tm tp
|
||||
tryFlushTermBuffer termBuffer h
|
||||
|
||||
putTerm ::
|
||||
TVar (Map Hash TermBufferEntry) ->
|
||||
TVar (Map Hash DeclBufferEntry) ->
|
||||
@ -239,46 +253,50 @@ putTerm ::
|
||||
Term Symbol Ann ->
|
||||
Type Symbol Ann ->
|
||||
Transaction ()
|
||||
putTerm termBuffer declBuffer (Reference.Id h i) tm tp =
|
||||
putTerm termBuffer declBuffer ref@(Reference.Id h _) tm tp =
|
||||
unlessM (Ops.objectExistsForHash h) do
|
||||
BufferEntry size comp missing waiting <- Sqlite.unsafeIO (getBuffer termBuffer h)
|
||||
let termDependencies = Set.toList $ Term.termDependencies tm
|
||||
-- update the component target size if we encounter any higher self-references
|
||||
let size' = max size (Just $ biggestSelfReference + 1)
|
||||
where
|
||||
biggestSelfReference =
|
||||
maximum1 $
|
||||
i :| [i' | Reference.Derived h' i' <- termDependencies, h == h']
|
||||
let comp' = Map.insert i (tm, tp) comp
|
||||
-- for the component element that's been passed in, add its dependencies to missing'
|
||||
missingTerms' <-
|
||||
filterM
|
||||
(fmap not . Ops.objectExistsForHash)
|
||||
[h | Reference.Derived h _i <- termDependencies]
|
||||
missingTypes' <-
|
||||
filterM (fmap not . Ops.objectExistsForHash) $
|
||||
[h | Reference.Derived h _i <- Set.toList $ Term.typeDependencies tm]
|
||||
++ [h | Reference.Derived h _i <- Set.toList $ Type.dependencies tp]
|
||||
let missing' = missing <> Set.fromList (missingTerms' <> missingTypes')
|
||||
Sqlite.unsafeIO do
|
||||
-- notify each of the dependencies that h depends on them.
|
||||
traverse_ (addBufferDependent h termBuffer) missingTerms'
|
||||
traverse_ (addBufferDependent h declBuffer) missingTypes'
|
||||
putBuffer termBuffer h (BufferEntry size' comp' missing' waiting)
|
||||
putTerm_ termBuffer declBuffer ref tm tp
|
||||
tryFlushTermBuffer termBuffer h
|
||||
|
||||
putTerm_ ::
|
||||
TVar (Map Hash TermBufferEntry) ->
|
||||
TVar (Map Hash DeclBufferEntry) ->
|
||||
Reference.Id ->
|
||||
Term Symbol Ann ->
|
||||
Type Symbol Ann ->
|
||||
Transaction ()
|
||||
putTerm_ termBuffer declBuffer (Reference.Id h i) tm tp = do
|
||||
BufferEntry size comp missing waiting <- Sqlite.unsafeIO (getBuffer termBuffer h)
|
||||
let termDependencies = Set.toList $ Term.termDependencies tm
|
||||
-- update the component target size if we encounter any higher self-references
|
||||
let size' = max size (Just $ biggestSelfReference + 1)
|
||||
where
|
||||
biggestSelfReference =
|
||||
maximum1 $
|
||||
i :| [i' | Reference.Derived h' i' <- termDependencies, h == h']
|
||||
let comp' = Map.insert i (tm, tp) comp
|
||||
-- for the component element that's been passed in, add its dependencies to missing'
|
||||
missingTerms' <-
|
||||
filterM
|
||||
(fmap not . Ops.objectExistsForHash)
|
||||
[h | Reference.Derived h _i <- termDependencies]
|
||||
missingTypes' <-
|
||||
filterM (fmap not . Ops.objectExistsForHash) $
|
||||
[h | Reference.Derived h _i <- Set.toList $ Term.typeDependencies tm]
|
||||
++ [h | Reference.Derived h _i <- Set.toList $ Type.dependencies tp]
|
||||
let missing' = missing <> Set.fromList (missingTerms' <> missingTypes')
|
||||
Sqlite.unsafeIO do
|
||||
-- notify each of the dependencies that h depends on them.
|
||||
traverse_ (addBufferDependent h termBuffer) missingTerms'
|
||||
traverse_ (addBufferDependent h declBuffer) missingTypes'
|
||||
putBuffer termBuffer h (BufferEntry size' comp' missing' waiting)
|
||||
|
||||
tryFlushTermBuffer :: TVar (Map Hash TermBufferEntry) -> Hash -> Transaction ()
|
||||
tryFlushTermBuffer termBuffer =
|
||||
let loop h =
|
||||
tryFlushBuffer
|
||||
termBuffer
|
||||
( \h2 component ->
|
||||
void $
|
||||
saveTermComponent
|
||||
Nothing
|
||||
h2
|
||||
(fmap (bimap (Cv.term1to2 h) Cv.ttype1to2) component)
|
||||
)
|
||||
(\h2 component -> void $ saveTermComponent Nothing h2 (Cv.termComponent1to2 h component))
|
||||
loop
|
||||
h
|
||||
in loop
|
||||
@ -293,31 +311,51 @@ addDeclComponentTypeIndex oId ctorss =
|
||||
Ops.addTypeToIndexForTerm self (Cv.reference1to2 typeForIndexing)
|
||||
Ops.addTypeMentionsToIndexForTerm self (Set.map Cv.reference1to2 typeMentionsForIndexing)
|
||||
|
||||
putTypeDeclarationComponent ::
|
||||
TVar (Map Hash TermBufferEntry) ->
|
||||
TVar (Map Hash DeclBufferEntry) ->
|
||||
Hash ->
|
||||
[Decl Symbol Ann] ->
|
||||
Transaction ()
|
||||
putTypeDeclarationComponent termBuffer declBuffer h decls =
|
||||
unlessM (Ops.objectExistsForHash h) do
|
||||
for_ (Reference.componentFor h decls) \(ref, decl) ->
|
||||
putTypeDeclaration_ declBuffer ref decl
|
||||
tryFlushDeclBuffer termBuffer declBuffer h
|
||||
|
||||
putTypeDeclaration ::
|
||||
TVar (Map Hash TermBufferEntry) ->
|
||||
TVar (Map Hash DeclBufferEntry) ->
|
||||
Reference.Id ->
|
||||
Decl Symbol Ann ->
|
||||
Transaction ()
|
||||
putTypeDeclaration termBuffer declBuffer (Reference.Id h i) decl =
|
||||
putTypeDeclaration termBuffer declBuffer ref@(Reference.Id h _) decl = do
|
||||
unlessM (Ops.objectExistsForHash h) do
|
||||
BufferEntry size comp missing waiting <- Sqlite.unsafeIO (getBuffer declBuffer h)
|
||||
let declDependencies = Set.toList $ Decl.declDependencies decl
|
||||
let size' = max size (Just $ biggestSelfReference + 1)
|
||||
where
|
||||
biggestSelfReference =
|
||||
maximum1 $
|
||||
i :| [i' | Reference.Derived h' i' <- declDependencies, h == h']
|
||||
let comp' = Map.insert i decl comp
|
||||
moreMissing <-
|
||||
filterM (fmap not . Ops.objectExistsForHash) $
|
||||
[h | Reference.Derived h _i <- declDependencies]
|
||||
let missing' = missing <> Set.fromList moreMissing
|
||||
Sqlite.unsafeIO do
|
||||
traverse_ (addBufferDependent h declBuffer) moreMissing
|
||||
putBuffer declBuffer h (BufferEntry size' comp' missing' waiting)
|
||||
putTypeDeclaration_ declBuffer ref decl
|
||||
tryFlushDeclBuffer termBuffer declBuffer h
|
||||
|
||||
putTypeDeclaration_ ::
|
||||
TVar (Map Hash DeclBufferEntry) ->
|
||||
Reference.Id ->
|
||||
Decl Symbol Ann ->
|
||||
Transaction ()
|
||||
putTypeDeclaration_ declBuffer (Reference.Id h i) decl = do
|
||||
BufferEntry size comp missing waiting <- Sqlite.unsafeIO (getBuffer declBuffer h)
|
||||
let declDependencies = Set.toList $ Decl.declDependencies decl
|
||||
let size' = max size (Just $ biggestSelfReference + 1)
|
||||
where
|
||||
biggestSelfReference =
|
||||
maximum1 $
|
||||
i :| [i' | Reference.Derived h' i' <- declDependencies, h == h']
|
||||
let comp' = Map.insert i decl comp
|
||||
moreMissing <-
|
||||
filterM (fmap not . Ops.objectExistsForHash) $
|
||||
[h | Reference.Derived h _i <- declDependencies]
|
||||
let missing' = missing <> Set.fromList moreMissing
|
||||
Sqlite.unsafeIO do
|
||||
traverse_ (addBufferDependent h declBuffer) moreMissing
|
||||
putBuffer declBuffer h (BufferEntry size' comp' missing' waiting)
|
||||
|
||||
tryFlushDeclBuffer ::
|
||||
TVar (Map Hash TermBufferEntry) ->
|
||||
TVar (Map Hash DeclBufferEntry) ->
|
||||
@ -516,7 +554,13 @@ referentsByPrefix doGetDeclType (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to
|
||||
termReferents <-
|
||||
Ops.termReferentsByPrefix prefix cycle
|
||||
>>= traverse (Cv.referentid2to1 doGetDeclType)
|
||||
declReferents' <- Ops.declReferentsByPrefix prefix cycle (read . Text.unpack <$> cid)
|
||||
cid' <- case cid of
|
||||
Nothing -> pure Nothing
|
||||
Just c ->
|
||||
case readMaybe (Text.unpack c) of
|
||||
Nothing -> error $ reportBug "994787297" "cid of ShortHash must be an integer but got: " <> show cid
|
||||
Just cInt -> pure $ Just cInt
|
||||
declReferents' <- Ops.declReferentsByPrefix prefix cycle cid'
|
||||
let declReferents =
|
||||
[ Referent.ConId (ConstructorReference (Reference.Id h pos) (fromIntegral cid)) (Cv.decltype2to1 ct)
|
||||
| (h, pos, ct, cids) <- declReferents',
|
||||
@ -524,12 +568,12 @@ referentsByPrefix doGetDeclType (SH.ShortHash prefix (fmap Cv.shortHashSuffix1to
|
||||
]
|
||||
pure . Set.fromList $ termReferents <> declReferents
|
||||
|
||||
branchHashesByPrefix :: ShortBranchHash -> Transaction (Set Branch.CausalHash)
|
||||
branchHashesByPrefix sh = do
|
||||
causalHashesByPrefix :: ShortCausalHash -> Transaction (Set Branch.CausalHash)
|
||||
causalHashesByPrefix sh = do
|
||||
-- given that a Branch is shallow, it's really `CausalHash` that you'd
|
||||
-- refer to to specify a full namespace w/ history.
|
||||
-- but do we want to be able to refer to a namespace without its history?
|
||||
cs <- Ops.causalHashesByPrefix (Cv.sbh1to2 sh)
|
||||
cs <- Ops.causalHashesByPrefix (Cv.sch1to2 sh)
|
||||
pure $ Set.map (Causal.CausalHash . unCausalHash) cs
|
||||
|
||||
sqlLca :: Branch.CausalHash -> Branch.CausalHash -> Transaction (Maybe Branch.CausalHash)
|
||||
@ -601,11 +645,49 @@ namesAtPath path = do
|
||||
|
||||
-- | Update the root namespace names index which is used by the share server for serving api
|
||||
-- requests.
|
||||
updateNameLookupIndex ::
|
||||
(C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) ->
|
||||
Path ->
|
||||
-- | "from" branch, if 'Nothing' use the empty branch
|
||||
Maybe BranchHash ->
|
||||
-- | "to" branch
|
||||
BranchHash ->
|
||||
Sqlite.Transaction ()
|
||||
updateNameLookupIndex getDeclType pathPrefix mayFromBranchHash toBranchHash = do
|
||||
fromBranch <- case mayFromBranchHash of
|
||||
Nothing -> pure V2Branch.empty
|
||||
Just fromBH -> Ops.expectBranchByBranchHash fromBH
|
||||
toBranch <- Ops.expectBranchByBranchHash toBranchHash
|
||||
treeDiff <- BranchDiff.diffBranches fromBranch toBranch
|
||||
let namePrefix = case pathPrefix of
|
||||
Path.Empty -> Nothing
|
||||
(p Path.:< ps) -> Just $ Name.fromSegments (p :| Path.toList ps)
|
||||
let BranchDiff.NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals} = BranchDiff.nameChanges namePrefix treeDiff
|
||||
termNameAddsWithCT <- do
|
||||
for termNameAdds \(name, ref) -> do
|
||||
refWithCT <- addReferentCT ref
|
||||
pure $ toNamedRef (name, refWithCT)
|
||||
Ops.updateNameIndex (termNameAddsWithCT, toNamedRef <$> termNameRemovals) (toNamedRef <$> typeNameAdds, toNamedRef <$> typeNameRemovals)
|
||||
where
|
||||
toNamedRef :: (Name, ref) -> S.NamedRef ref
|
||||
toNamedRef (name, ref) = S.NamedRef {reversedSegments = coerce $ Name.reverseSegments name, ref = ref}
|
||||
addReferentCT :: C.Referent.Referent -> Transaction (C.Referent.Referent, Maybe C.Referent.ConstructorType)
|
||||
addReferentCT referent = case referent of
|
||||
C.Referent.Ref {} -> pure (referent, Nothing)
|
||||
C.Referent.Con ref _conId -> do
|
||||
ct <- getDeclType ref
|
||||
pure (referent, Just $ Cv.constructorType1to2 ct)
|
||||
|
||||
-- | Compute the root namespace names index which is used by the share server for serving api
|
||||
-- requests. Using 'updateNameLookupIndex' is preferred whenever possible, since it's
|
||||
-- considerably faster. This can be used to reset the index if it ever gets out of sync due to
|
||||
-- a bug.
|
||||
--
|
||||
-- This version should be used if you've already got the root Branch pre-loaded, otherwise
|
||||
-- it's faster to use 'updateNameLookupIndexFromV2Branch'
|
||||
updateNameLookupIndexFromV1Branch :: Branch Transaction -> Sqlite.Transaction ()
|
||||
updateNameLookupIndexFromV1Branch root = do
|
||||
-- This version can be used if you've already got the root Branch pre-loaded, otherwise
|
||||
-- it's faster to use 'initializeNameLookupIndexFromV2Root'
|
||||
initializeNameLookupIndexFromV1Branch :: Branch Transaction -> Sqlite.Transaction ()
|
||||
initializeNameLookupIndexFromV1Branch root = do
|
||||
Q.dropNameLookupTables
|
||||
saveRootNamesIndexV1 (V1Branch.toNames . Branch.head $ root)
|
||||
where
|
||||
saveRootNamesIndexV1 :: Names -> Transaction ()
|
||||
@ -618,7 +700,7 @@ updateNameLookupIndexFromV1Branch root = do
|
||||
<&> ( \(name, ref) ->
|
||||
S.NamedRef {reversedSegments = nameSegments name, ref = Cv.reference1to2 ref}
|
||||
)
|
||||
Ops.rebuildNameIndex termNames typeNames
|
||||
Ops.updateNameIndex (termNames, []) (typeNames, [])
|
||||
where
|
||||
nameSegments :: Name -> NonEmpty Text
|
||||
nameSegments = coerce @(NonEmpty NameSegment) @(NonEmpty Text) . Name.reverseSegments
|
||||
@ -627,13 +709,16 @@ updateNameLookupIndexFromV1Branch root = do
|
||||
Referent.Ref {} -> (Cv.referent1to2 referent, Nothing)
|
||||
Referent.Con _ref ct -> (Cv.referent1to2 referent, Just (Cv.constructorType1to2 ct))
|
||||
|
||||
-- | Update the root namespace names index which is used by the share server for serving api
|
||||
-- requests.
|
||||
-- | Compute the root namespace names index which is used by the share server for serving api
|
||||
-- requests. Using 'updateNameLookupIndex' is preferred whenever possible, since it's
|
||||
-- considerably faster. This can be used to reset the index if it ever gets out of sync due to
|
||||
-- a bug.
|
||||
--
|
||||
-- This version should be used if you don't already have the root Branch pre-loaded,
|
||||
-- If you do, use 'updateNameLookupIndexFromV2Branch' instead.
|
||||
updateNameLookupIndexFromV2Root :: (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> Sqlite.Transaction ()
|
||||
updateNameLookupIndexFromV2Root getDeclType = do
|
||||
-- If you do, use 'initializeNameLookupIndexFromV1Branch' instead.
|
||||
initializeNameLookupIndexFromV2Root :: (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType) -> Sqlite.Transaction ()
|
||||
initializeNameLookupIndexFromV2Root getDeclType = do
|
||||
Q.dropNameLookupTables
|
||||
rootHash <- Ops.expectRootCausalHash
|
||||
causalBranch <- Ops.expectCausalBranchByCausalHash rootHash
|
||||
(termNameMap, typeNameMap) <- nameMapsFromV2Branch [] causalBranch
|
||||
@ -646,7 +731,7 @@ updateNameLookupIndexFromV2Root getDeclType = do
|
||||
(name, refs) <- Map.toList typeNameMap
|
||||
ref <- Set.toList refs
|
||||
pure $ S.NamedRef {S.reversedSegments = coerce name, S.ref = ref}
|
||||
Ops.rebuildNameIndex termNameList typeNameList
|
||||
Ops.updateNameIndex (termNameList, []) (typeNameList, [])
|
||||
where
|
||||
addReferentCT :: C.Referent.Referent -> Transaction (C.Referent.Referent, Maybe C.Referent.ConstructorType)
|
||||
addReferentCT referent = case referent of
|
||||
@ -667,9 +752,24 @@ updateNameLookupIndexFromV2Root getDeclType = do
|
||||
fold <$> (ifor (V2Branch.children b) $ \nameSegment cb -> (nameMapsFromV2Branch (nameSegment : reversedNamePrefix) cb))
|
||||
pure (Map.mapKeys (NEList.:| reversedNamePrefix) shallowTermNames <> prefixedChildTerms, Map.mapKeys (NEList.:| reversedNamePrefix) shallowTypeNames <> prefixedChildTypes)
|
||||
|
||||
mkGetDeclType :: MonadIO m => m (C.Reference.Reference -> Sqlite.Transaction CT.ConstructorType)
|
||||
mkGetDeclType = do
|
||||
declTypeCache <- Cache.semispaceCache 2048
|
||||
pure $ \ref -> do
|
||||
-- | Given a transaction, return a transaction that first checks a semispace cache of the given size.
|
||||
--
|
||||
-- The transaction should probably be read-only, as we (of course) don't hit SQLite on a cache hit.
|
||||
makeCachedTransaction :: (Ord a, MonadIO m) => Word -> (a -> Sqlite.Transaction b) -> m (a -> Sqlite.Transaction b)
|
||||
makeCachedTransaction size action = do
|
||||
cache <- Cache.semispaceCache size
|
||||
pure \x -> do
|
||||
conn <- Sqlite.unsafeGetConnection
|
||||
Sqlite.unsafeIO $ Cache.apply declTypeCache (\ref -> Sqlite.unsafeUnTransaction (getDeclType ref) conn) ref
|
||||
Sqlite.unsafeIO (Cache.apply cache (\x -> Sqlite.unsafeUnTransaction (action x) conn) x)
|
||||
|
||||
-- | Like 'makeCachedTransaction', but for when the transaction returns a Maybe; only cache the Justs.
|
||||
makeMaybeCachedTransaction ::
|
||||
(Ord a, MonadIO m) =>
|
||||
Word ->
|
||||
(a -> Sqlite.Transaction (Maybe b)) ->
|
||||
m (a -> Sqlite.Transaction (Maybe b))
|
||||
makeMaybeCachedTransaction size action = do
|
||||
cache <- Cache.semispaceCache size
|
||||
pure \x -> do
|
||||
conn <- Sqlite.unsafeGetConnection
|
||||
Sqlite.unsafeIO (Cache.applyDefined cache (\x -> Sqlite.unsafeUnTransaction (action x) conn) x)
|
||||
|
@ -14,6 +14,7 @@ module Unison.Codebase.Type
|
||||
where
|
||||
|
||||
import qualified U.Codebase.Branch as V2
|
||||
import U.Codebase.HashTags (BranchHash)
|
||||
import qualified U.Codebase.Reference as V2
|
||||
import qualified U.Codebase.Reflog as Reflog
|
||||
import qualified U.Codebase.Sqlite.Queries as Queries
|
||||
@ -25,7 +26,7 @@ import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError)
|
||||
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
|
||||
import Unison.Codebase.Patch (Patch)
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..))
|
||||
import Unison.Codebase.SyncMode (SyncMode)
|
||||
import Unison.CodebasePath (CodebasePath)
|
||||
@ -60,24 +61,26 @@ data Codebase m v a = Codebase
|
||||
--
|
||||
-- Note that it is possible to call 'putTerm', then 'getTypeOfTermImpl', and receive @Nothing@, per the semantics of
|
||||
-- 'putTerm'.
|
||||
getTypeOfTermImpl :: Reference.Id -> m (Maybe (Type v a)),
|
||||
getTypeOfTermImpl :: Reference.Id -> Sqlite.Transaction (Maybe (Type v a)),
|
||||
-- | Get a type declaration.
|
||||
--
|
||||
-- Note that it is possible to call 'putTypeDeclaration', then 'getTypeDeclaration', and receive @Nothing@, per the
|
||||
-- semantics of 'putTypeDeclaration'.
|
||||
getTypeDeclaration :: Reference.Id -> m (Maybe (Decl v a)),
|
||||
getTypeDeclaration :: Reference.Id -> Sqlite.Transaction (Maybe (Decl v a)),
|
||||
-- | Get the type of a given decl.
|
||||
getDeclType :: V2.Reference -> m CT.ConstructorType,
|
||||
-- | Enqueue the put of a user-defined term (with its type) into the codebase, if it doesn't already exist. The
|
||||
-- implementation may choose to delay the put until all of the term's (and its type's) references are stored as
|
||||
-- well.
|
||||
putTerm :: Reference.Id -> Term v a -> Type v a -> m (),
|
||||
putTerm :: Reference.Id -> Term v a -> Type v a -> Sqlite.Transaction (),
|
||||
putTermComponent :: Hash -> [(Term v a, Type v a)] -> Sqlite.Transaction (),
|
||||
-- | Enqueue the put of a type declaration into the codebase, if it doesn't already exist. The implementation may
|
||||
-- choose to delay the put until all of the type declaration's references are stored as well.
|
||||
putTypeDeclaration :: Reference.Id -> Decl v a -> m (),
|
||||
putTypeDeclaration :: Reference.Id -> Decl v a -> Sqlite.Transaction (),
|
||||
putTypeDeclarationComponent :: Hash -> [Decl v a] -> Sqlite.Transaction (),
|
||||
-- getTermComponent :: Hash -> m (Maybe [Term v a]),
|
||||
getTermComponentWithTypes :: Hash -> Sqlite.Transaction (Maybe [(Term v a, Type v a)]),
|
||||
getDeclComponent :: Hash -> m (Maybe [Decl v a]),
|
||||
getDeclComponent :: Hash -> Sqlite.Transaction (Maybe [Decl v a]),
|
||||
getComponentLength :: Hash -> m (Maybe Reference.CycleSize),
|
||||
-- | Get the root causal Hash.
|
||||
getRootCausalHash :: m V2.CausalHash,
|
||||
@ -109,7 +112,7 @@ data Codebase m v a = Codebase
|
||||
patchExists :: Branch.EditHash -> m Bool,
|
||||
-- | Get the set of user-defined terms and type declarations that depend on the given term, type declaration, or
|
||||
-- builtin type.
|
||||
dependentsImpl :: Queries.DependentsSelector -> Reference -> m (Set Reference.Id),
|
||||
dependentsImpl :: Queries.DependentsSelector -> Reference -> Sqlite.Transaction (Set Reference.Id),
|
||||
dependentsOfComponentImpl :: Hash -> m (Set Reference.Id),
|
||||
-- | Copy a branch and all of its dependencies from the given codebase into this one.
|
||||
syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (),
|
||||
@ -153,7 +156,7 @@ data Codebase m v a = Codebase
|
||||
-- | The number of base32 characters needed to distinguish any two branch in the codebase.
|
||||
branchHashLength :: m Int,
|
||||
-- | Get the set of branches whose hash matches the given prefix.
|
||||
branchHashesByPrefix :: ShortBranchHash -> m (Set Branch.CausalHash),
|
||||
causalHashesByPrefix :: ShortCausalHash -> m (Set Branch.CausalHash),
|
||||
-- returns `Nothing` to not implemented, fallback to in-memory
|
||||
-- also `Nothing` if no LCA
|
||||
-- The result is undefined if the two hashes are not in the codebase.
|
||||
@ -169,9 +172,21 @@ data Codebase m v a = Codebase
|
||||
-- NOTE: this method requires an up-to-date name lookup index, which is
|
||||
-- currently not kept up-to-date automatically (because it's slow to do so).
|
||||
namesAtPath :: Path -> m ScopedNames,
|
||||
-- Updates the root namespace names index.
|
||||
-- Updates the root namespace names index from an old BranchHash to a new one.
|
||||
-- This isn't run automatically because it can be a bit slow.
|
||||
updateNameLookup :: m (),
|
||||
updateNameLookup ::
|
||||
-- Path to the root of the _changes_.
|
||||
-- E.g. if you know that all the changes occur at "base.List", you can pass "base.List"
|
||||
-- here, and pass the old and new branch hashes for the branch as "base.List".
|
||||
-- This allows us to avoid searching for changes in areas where it's impossible for it
|
||||
-- to have occurred.
|
||||
Path ->
|
||||
-- The branch hash at 'Path' which the existing index was built from.
|
||||
-- Pass 'Nothing' to build the index from scratch (i.e. compute a diff from an empty branch).
|
||||
Maybe BranchHash ->
|
||||
-- The new branch
|
||||
BranchHash ->
|
||||
Sqlite.Transaction (),
|
||||
-- | Acquire a new connection to the same underlying database file this codebase object connects to.
|
||||
withConnection :: forall x. (Sqlite.Connection -> m x) -> m x,
|
||||
-- | Acquire a new connection to the same underlying database file this codebase object connects to.
|
||||
|
@ -185,9 +185,8 @@ synthesizeFile ambient tl fqnsByShortName uf term = do
|
||||
in -- use tlcsFromTypechecker to inform annotation-stripping decisions
|
||||
traverse (traverse strippedTopLevelBinding) tlcsFromTypechecker
|
||||
let doTdnr = applyTdnrDecisions infos
|
||||
doTdnrInComponent (v, t, tp) = (\t -> (v, t, tp)) <$> doTdnr t
|
||||
_ <- doTdnr tdnrTerm
|
||||
tdnredTlcs <- (traverse . traverse) doTdnrInComponent topLevelComponents
|
||||
let doTdnrInComponent (v, t, tp) = (v, doTdnr t, tp)
|
||||
let tdnredTlcs = (fmap . fmap) doTdnrInComponent topLevelComponents
|
||||
let (watches', terms') = partition isWatch tdnredTlcs
|
||||
isWatch = all (\(v, _, _) -> Set.member v watchedVars)
|
||||
watchedVars = Set.fromList [v | (v, _) <- UF.allWatches uf]
|
||||
@ -208,19 +207,15 @@ synthesizeFile ambient tl fqnsByShortName uf term = do
|
||||
applyTdnrDecisions ::
|
||||
[Context.InfoNote v Ann] ->
|
||||
Term v ->
|
||||
Result' v (Term v)
|
||||
applyTdnrDecisions infos tdnrTerm = foldM go tdnrTerm decisions
|
||||
Term v
|
||||
applyTdnrDecisions infos tdnrTerm = ABT.visitPure resolve tdnrTerm
|
||||
where
|
||||
-- UF data/effect ctors + builtins + TLC Term.vars
|
||||
go term _decision@(shortv, loc, replacement) =
|
||||
ABT.visit (resolve shortv loc replacement) term
|
||||
decisions =
|
||||
[(v, loc, replacement) | Context.Decision v loc replacement <- infos]
|
||||
decisions = Map.fromList [((Var.nameStr v, loc), replacement) | Context.Decision v loc replacement <- infos]
|
||||
-- resolve (v,loc) in a matching Blank to whatever `fqn` maps to in `names`
|
||||
resolve shortv loc replacement t = case t of
|
||||
resolve t = case t of
|
||||
Term.Blank' (Blank.Recorded (Blank.Resolve loc' name))
|
||||
| loc' == loc && Var.nameStr shortv == name ->
|
||||
-- loc of replacement already chosen correctly by whatever made the
|
||||
-- Decision
|
||||
pure . pure $ replacement
|
||||
| Just replacement <- Map.lookup (name, loc') decisions ->
|
||||
-- loc of replacement already chosen correctly by whatever made the
|
||||
-- Decision
|
||||
Just $ replacement
|
||||
_ -> Nothing
|
||||
|
47
parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs
Normal file
47
parser-typechecker/src/Unison/PrettyPrintEnv/MonadPretty.hs
Normal file
@ -0,0 +1,47 @@
|
||||
{-# LANGUAGE ConstraintKinds #-}
|
||||
|
||||
module Unison.PrettyPrintEnv.MonadPretty where
|
||||
|
||||
import Control.Lens (over, set, view, views, _1, _2)
|
||||
import Control.Monad.Reader (MonadReader, Reader, local, runReader)
|
||||
import qualified Data.Set as Set
|
||||
import Unison.Prelude (Set)
|
||||
import Unison.PrettyPrintEnv (PrettyPrintEnv)
|
||||
import Unison.Var (Var)
|
||||
|
||||
type MonadPretty v m = (Var v, MonadReader (PrettyPrintEnv, Set v) m)
|
||||
|
||||
getPPE :: MonadPretty v m => m PrettyPrintEnv
|
||||
getPPE = view _1
|
||||
|
||||
-- | Run a computation with a modified PrettyPrintEnv, restoring the original
|
||||
withPPE :: MonadPretty v m => PrettyPrintEnv -> m a -> m a
|
||||
withPPE p = local (set _1 p)
|
||||
|
||||
applyPPE :: MonadPretty v m => (PrettyPrintEnv -> a) -> m a
|
||||
applyPPE = views _1
|
||||
|
||||
applyPPE2 :: MonadPretty v m => (PrettyPrintEnv -> a -> b) -> a -> m b
|
||||
applyPPE2 f a = views _1 (`f` a)
|
||||
|
||||
applyPPE3 :: MonadPretty v m => (PrettyPrintEnv -> a -> b -> c) -> a -> b -> m c
|
||||
applyPPE3 f a b = views _1 (\ppe -> f ppe a b)
|
||||
|
||||
-- | Run a computation with a modified PrettyPrintEnv, restoring the original
|
||||
modifyPPE :: MonadPretty v m => (PrettyPrintEnv -> PrettyPrintEnv) -> m a -> m a
|
||||
modifyPPE = local . over _1
|
||||
|
||||
modifyTypeVars :: MonadPretty v m => (Set v -> Set v) -> m a -> m a
|
||||
modifyTypeVars = local . over _2
|
||||
|
||||
-- | Add type variables to the set of variables that need to be avoided
|
||||
addTypeVars :: MonadPretty v m => [v] -> m a -> m a
|
||||
addTypeVars = modifyTypeVars . Set.union . Set.fromList
|
||||
|
||||
-- | Check if a list of type variables contains any variables that need to be
|
||||
-- avoided
|
||||
willCapture :: MonadPretty v m => [v] -> m Bool
|
||||
willCapture vs = views _2 (not . Set.null . Set.intersection (Set.fromList vs))
|
||||
|
||||
runPretty :: Var v => PrettyPrintEnv -> Reader (PrettyPrintEnv, Set v) a -> a
|
||||
runPretty ppe m = runReader m (ppe, mempty)
|
@ -223,6 +223,108 @@ enclose keep rec t@(Handle' h body)
|
||||
| otherwise = lam' a evs lbody
|
||||
enclose _ _ _ = Nothing
|
||||
|
||||
newtype Prefix v x = Pfx (Map v [v]) deriving (Show)
|
||||
|
||||
instance Functor (Prefix v) where
|
||||
fmap _ (Pfx m) = Pfx m
|
||||
instance Ord v => Applicative (Prefix v) where
|
||||
pure _ = Pfx Map.empty
|
||||
Pfx ml <*> Pfx mr = Pfx $ Map.unionWith common ml mr
|
||||
|
||||
common :: Eq v => [v] -> [v] -> [v]
|
||||
common (u:us) (v:vs)
|
||||
| u == v = u : common us vs
|
||||
common _ _ = []
|
||||
|
||||
splitPfx :: v -> [Term v a] -> (Prefix v x, [Term v a])
|
||||
splitPfx v = first (Pfx . Map.singleton v) . split
|
||||
where
|
||||
split (Var' u : as) = first (u :) $ split as
|
||||
split rest = ([], rest)
|
||||
|
||||
-- Finds the common variable prefixes that function variables are
|
||||
-- applied to, so that they can be reduced.
|
||||
prefix :: Ord v => Term v a -> Prefix v (Term v a)
|
||||
prefix = ABT.visit \case
|
||||
Apps' (Var' u) as -> case splitPfx u as of
|
||||
(pf, rest) -> Just $ traverse prefix rest *> pf
|
||||
_ -> Nothing
|
||||
|
||||
appPfx :: Ord v => Prefix v a -> v -> [v] -> [v]
|
||||
appPfx (Pfx m) v = maybe id common $ Map.lookup v m
|
||||
|
||||
-- Rewrites a term by dropping the first n arguments to every
|
||||
-- application of `v`. This just assumes such a thing makes sense, as
|
||||
-- in `beta`, where we've calculated how many arguments to drop by
|
||||
-- looking at every occurrence of `v`.
|
||||
dropPrefix :: Ord v => Semigroup a => v -> Int -> Term v a -> Term v a
|
||||
dropPrefix _ 0 = id
|
||||
dropPrefix v n = ABT.visitPure rw
|
||||
where
|
||||
rw (Apps' f@(Var' u) as)
|
||||
| v == u = Just (apps' (var (ABT.annotation f) u) (drop n as))
|
||||
rw _ = Nothing
|
||||
|
||||
dropPrefixes
|
||||
:: Ord v => Semigroup a => Map v Int -> Term v a -> Term v a
|
||||
dropPrefixes m = ABT.visitPure rw
|
||||
where
|
||||
rw (Apps' f@(Var' u) as)
|
||||
| Just n <- Map.lookup u m =
|
||||
Just (apps' (var (ABT.annotation f) u) (drop n as))
|
||||
rw _ = Nothing
|
||||
|
||||
-- Performs opposite transformations to those in enclose. Named after
|
||||
-- the lambda case, which is beta reduction.
|
||||
beta :: Var v => Monoid a => (Term v a -> Term v a) -> Term v a -> Maybe (Term v a)
|
||||
beta rec (LetRecNamedTop' top (fmap (fmap rec) -> vbs) (rec -> bd)) =
|
||||
Just $ letRec' top lvbs lbd
|
||||
where
|
||||
-- Avoid completely reducing a lambda expression, because recursive
|
||||
-- lets must be guarded.
|
||||
args (v, LamsNamed' vs Ann'{}) = (v, vs)
|
||||
args (v, LamsNamed' vs _) = (v, init vs)
|
||||
args (v, _) = (v, [])
|
||||
|
||||
Pfx m0 = traverse_ (prefix . snd) vbs *> prefix bd
|
||||
|
||||
f ls rs = case common ls rs of
|
||||
[] -> Nothing
|
||||
vs -> Just vs
|
||||
|
||||
m = Map.map length $ Map.differenceWith f (Map.fromList $ map args vbs) m0
|
||||
lvbs = vbs <&> \(v, b0) -> (,) v $ case b0 of
|
||||
LamsNamed' vs b | Just n <- Map.lookup v m ->
|
||||
lam' (ABT.annotation b0) (drop n vs) (dropPrefixes m b)
|
||||
-- shouldn't happen
|
||||
b -> dropPrefixes m b
|
||||
|
||||
lbd = dropPrefixes m bd
|
||||
|
||||
beta rec (Let1NamedTop' top v l@(LamsNamed' vs bd) (rec -> e))
|
||||
| n > 0 = Just $ let1' top [(v, lamb)] (dropPrefix v n e)
|
||||
| otherwise = Nothing
|
||||
where
|
||||
lamb = lam' al (drop n vs) (bd)
|
||||
al = ABT.annotation l
|
||||
-- Calculate a maximum number of arguments to drop.
|
||||
-- Enclosing doesn't create let-bound lambdas, so we
|
||||
-- should never reduce a lambda to a non-lambda, as that
|
||||
-- could affect evaluation order.
|
||||
m | Ann' _ _ <- bd = length vs
|
||||
| otherwise = length vs - 1
|
||||
n = min m . length $ appPfx (prefix e) v vs
|
||||
|
||||
beta rec (Apps' l@(LamsNamed' vs body) as)
|
||||
| n <- matchVars 0 vs as
|
||||
, n > 0 = Just $ apps' (lam' al (drop n vs) (rec body)) (drop n as)
|
||||
| otherwise = Nothing
|
||||
where
|
||||
al = ABT.annotation l
|
||||
matchVars !n (u:us) (Var' v : as) | u == v = matchVars (1+n) us as
|
||||
matchVars n _ _ = n
|
||||
beta _ _ = Nothing
|
||||
|
||||
isStructured :: Var v => Term v a -> Bool
|
||||
isStructured (Var' _) = False
|
||||
isStructured (Lam' _) = False
|
||||
@ -242,6 +344,10 @@ isStructured _ = True
|
||||
close :: (Var v, Monoid a) => Set v -> Term v a -> Term v a
|
||||
close keep tm = ABT.visitPure (enclose keep close) tm
|
||||
|
||||
-- Attempts to undo what was done in `close`. Useful for decompiling.
|
||||
open :: (Var v, Monoid a) => Term v a -> Term v a
|
||||
open x = ABT.visitPure (beta open) x
|
||||
|
||||
type FloatM v a r = State (Set v, [(v, Term v a)], [(v, Term v a)]) r
|
||||
|
||||
freshFloat :: Var v => Set v -> v -> v
|
||||
@ -365,7 +471,7 @@ float tm = case runState go0 (Set.empty, [], []) of
|
||||
subm = Map.fromList subvs
|
||||
in ( letRec' True [] . ABT.substs subs . deannotate $ bd,
|
||||
fmap (first DerivedId) tops,
|
||||
dcmp <&> \(v, tm) -> (DerivedId $ subm Map.! v, tm)
|
||||
dcmp <&> \(v, tm) -> (DerivedId $ subm Map.! v, open tm)
|
||||
)
|
||||
where
|
||||
go0 = fromMaybe (go tm) (floater True go tm)
|
||||
|
@ -2696,7 +2696,7 @@ declareForeigns = do
|
||||
declareForeign Untracked "Scope.bytearray" natToBox . mkForeign $ PA.newByteArray
|
||||
declareForeign Untracked "Scope.bytearrayOf" natNatToBox
|
||||
. mkForeign
|
||||
$ \(sz, init) -> do
|
||||
$ \(init, sz) -> do
|
||||
arr <- PA.newByteArray sz
|
||||
PA.fillByteArray arr 0 sz init
|
||||
pure arr
|
||||
|
@ -6,10 +6,11 @@ import Data.Text
|
||||
import GHC.Stack
|
||||
import Unison.Runtime.Stack
|
||||
import Unison.Util.Pretty as P
|
||||
import Unison.Reference (Reference)
|
||||
|
||||
data RuntimeExn
|
||||
= PE CallStack (P.Pretty P.ColorText)
|
||||
| BU Text Closure
|
||||
| BU [(Reference,Int)] Text Closure
|
||||
deriving (Show)
|
||||
|
||||
instance Exception RuntimeExn
|
||||
|
@ -92,6 +92,7 @@ import Unison.Runtime.Pattern
|
||||
import Unison.Runtime.Serialize as SER
|
||||
import Unison.Runtime.Stack
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Syntax.NamePrinter (prettyHashQualified)
|
||||
import Unison.Syntax.TermPrinter
|
||||
import qualified Unison.Term as Tm
|
||||
import Unison.Util.EnumContainers as EC
|
||||
@ -361,7 +362,7 @@ evalInContext ppe ctx activeThreads w = do
|
||||
decom = decompile (backReferenceTm crs (decompTm ctx))
|
||||
|
||||
prettyError (PE _ p) = p
|
||||
prettyError (BU nm c) = either id (bugMsg ppe nm) $ decom c
|
||||
prettyError (BU tr nm c) = either id (bugMsg ppe tr nm) $ decom c
|
||||
|
||||
tr tx c = case decom c of
|
||||
Right dv -> do
|
||||
@ -394,13 +395,18 @@ executeMainComb init cc = do
|
||||
Right () -> pure (Right ())
|
||||
where
|
||||
formatErr (PE _ msg) = pure msg
|
||||
formatErr (BU nm c) = do
|
||||
formatErr (BU tr nm c) = do
|
||||
crs <- readTVarIO (combRefs cc)
|
||||
let decom = decompile (backReferenceTm crs (decompTm $ cacheContext cc))
|
||||
pure . either id (bugMsg PPE.empty nm) $ decom c
|
||||
pure . either id (bugMsg PPE.empty tr nm) $ decom c
|
||||
|
||||
bugMsg :: PrettyPrintEnv -> Text -> Term Symbol -> Pretty ColorText
|
||||
bugMsg ppe name tm
|
||||
bugMsg
|
||||
:: PrettyPrintEnv
|
||||
-> [(Reference, Int)]
|
||||
-> Text
|
||||
-> Term Symbol
|
||||
-> Pretty ColorText
|
||||
bugMsg ppe tr name tm
|
||||
| name == "blank expression" =
|
||||
P.callout icon . P.lines $
|
||||
[ P.wrap
|
||||
@ -409,8 +415,8 @@ bugMsg ppe name tm
|
||||
),
|
||||
"",
|
||||
P.indentN 2 $ pretty ppe tm,
|
||||
"",
|
||||
sorryMsg
|
||||
"\n",
|
||||
stackTrace ppe tr
|
||||
]
|
||||
| "pattern match failure" `isPrefixOf` name =
|
||||
P.callout icon . P.lines $
|
||||
@ -423,13 +429,16 @@ bugMsg ppe name tm
|
||||
"",
|
||||
"This happens when calling a function that doesn't handle all \
|
||||
\possible inputs",
|
||||
sorryMsg
|
||||
"\n",
|
||||
stackTrace ppe tr
|
||||
]
|
||||
| name == "builtin.raise" =
|
||||
P.callout icon . P.lines $
|
||||
[ P.wrap ("The program halted with an unhandled exception:"),
|
||||
"",
|
||||
P.indentN 2 $ pretty ppe tm
|
||||
P.indentN 2 $ pretty ppe tm,
|
||||
"\n",
|
||||
stackTrace ppe tr
|
||||
]
|
||||
| name == "builtin.bug",
|
||||
RF.TupleTerm' [Tm.Text' msg, x] <- tm,
|
||||
@ -444,9 +453,10 @@ bugMsg ppe name tm
|
||||
"",
|
||||
"This happens when calling a function that doesn't handle all \
|
||||
\possible inputs",
|
||||
sorryMsg
|
||||
"\n",
|
||||
stackTrace ppe tr
|
||||
]
|
||||
bugMsg ppe name tm =
|
||||
bugMsg ppe tr name tm =
|
||||
P.callout icon . P.lines $
|
||||
[ P.wrap
|
||||
( "I've encountered a call to" <> P.red (P.text name)
|
||||
@ -454,18 +464,26 @@ bugMsg ppe name tm =
|
||||
),
|
||||
"",
|
||||
P.indentN 2 $ pretty ppe tm,
|
||||
"",
|
||||
sorryMsg
|
||||
"\n",
|
||||
stackTrace ppe tr
|
||||
]
|
||||
where
|
||||
|
||||
icon, sorryMsg :: Pretty ColorText
|
||||
stackTrace :: PrettyPrintEnv -> [(Reference, Int)] -> Pretty ColorText
|
||||
stackTrace ppe tr = "Stack trace:\n" <> P.indentN 2 (P.lines $ f <$> tr)
|
||||
where
|
||||
f (rf, n) = name <> count
|
||||
where
|
||||
count
|
||||
| n > 1 = " (" <> fromString (show n) <> " copies)"
|
||||
| otherwise = ""
|
||||
name =
|
||||
syntaxToColor .
|
||||
prettyHashQualified .
|
||||
PPE.termName ppe .
|
||||
RF.Ref $ rf
|
||||
|
||||
icon :: Pretty ColorText
|
||||
icon = "💔💥"
|
||||
sorryMsg =
|
||||
P.wrap $
|
||||
"I'm sorry this message doesn't have more detail about"
|
||||
<> "the location of the failure."
|
||||
<> "My makers plan to fix this in a future release. 😢"
|
||||
|
||||
catchInternalErrors ::
|
||||
IO (Either Error a) ->
|
||||
@ -536,7 +554,7 @@ tryM :: IO () -> IO (Maybe Error)
|
||||
tryM = fmap (either (Just . extract) (const Nothing)) . try
|
||||
where
|
||||
extract (PE _ e) = e
|
||||
extract (BU _ _) = "impossible"
|
||||
extract (BU _ _ _) = "impossible"
|
||||
|
||||
runStandalone :: StoredCache -> Word64 -> IO (Either (Pretty ColorText) ())
|
||||
runStandalone sc init =
|
||||
|
@ -28,6 +28,7 @@ module Unison.Runtime.MCode
|
||||
emitComb,
|
||||
emptyRNs,
|
||||
argsToLists,
|
||||
combRef,
|
||||
combDeps,
|
||||
combTypes,
|
||||
prettyCombs,
|
||||
@ -543,6 +544,9 @@ data CombIx
|
||||
!Word64 -- section
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
combRef :: CombIx -> Reference
|
||||
combRef (CIx r _ _) = r
|
||||
|
||||
data RefNums = RN
|
||||
{ dnum :: Reference -> Word64,
|
||||
cnum :: Reference -> Word64
|
||||
|
@ -152,7 +152,7 @@ eval0 !env !activeThreads !co = do
|
||||
bstk <- alloc
|
||||
(denv, k) <-
|
||||
topDEnv <$> readTVarIO (refTy env) <*> readTVarIO (refTm env)
|
||||
eval env denv activeThreads ustk bstk (k KE) co
|
||||
eval env denv activeThreads ustk bstk (k KE) dummyRef co
|
||||
|
||||
topDEnv ::
|
||||
M.Map Reference Word64 ->
|
||||
@ -241,31 +241,32 @@ exec ::
|
||||
Stack 'UN ->
|
||||
Stack 'BX ->
|
||||
K ->
|
||||
Reference ->
|
||||
Instr ->
|
||||
IO (DEnv, Stack 'UN, Stack 'BX, K)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (Info tx) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (Info tx) = do
|
||||
info tx ustk
|
||||
info tx bstk
|
||||
info tx k
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k (Name r args) = do
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k _ (Name r args) = do
|
||||
bstk <- name ustk bstk args =<< resolve env denv bstk r
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (SetDyn p i) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (SetDyn p i) = do
|
||||
clo <- peekOff bstk i
|
||||
pure (EC.mapInsert p clo denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (Capture p) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (Capture p) = do
|
||||
(cap, denv, ustk, bstk, k) <- splitCont denv ustk bstk k p
|
||||
bstk <- bump bstk
|
||||
poke bstk cap
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (UPrim1 op i) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (UPrim1 op i) = do
|
||||
ustk <- uprim1 ustk op i
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (UPrim2 op i j) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (UPrim2 op i j) = do
|
||||
ustk <- uprim2 ustk op i j
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 MISS i)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 MISS i)
|
||||
| sandboxed env = die "attempted to use sandboxed operation: isMissing"
|
||||
| otherwise = do
|
||||
clink <- peekOff bstk i
|
||||
@ -274,7 +275,7 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 MISS i)
|
||||
ustk <- bump ustk
|
||||
if (link `M.member` m) then poke ustk 1 else poke ustk 0
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CACH i)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 CACH i)
|
||||
| sandboxed env = die "attempted to use sandboxed operation: cache"
|
||||
| otherwise = do
|
||||
arg <- peekOffS bstk i
|
||||
@ -285,7 +286,7 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CACH i)
|
||||
bstk
|
||||
(Sq.fromList $ Foreign . Wrap Rf.termLinkRef . Ref <$> unknown)
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CVLD i)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 CVLD i)
|
||||
| sandboxed env = die "attempted to use sandboxed operation: validate"
|
||||
| otherwise = do
|
||||
arg <- peekOffS bstk i
|
||||
@ -303,7 +304,7 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 CVLD i)
|
||||
pokeOffBi bstk 1 msg
|
||||
pokeOff bstk 2 clo
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LKUP i)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 LKUP i)
|
||||
| sandboxed env = die "attempted to use sandboxed operation: lookup"
|
||||
| otherwise = do
|
||||
clink <- peekOff bstk i
|
||||
@ -323,14 +324,14 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LKUP i)
|
||||
bstk <- bump bstk
|
||||
bstk <$ pokeBi bstk sg
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim1 TLTT i) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (BPrim1 TLTT i) = do
|
||||
clink <- peekOff bstk i
|
||||
let Ref link = unwrapForeign $ marshalToForeign clink
|
||||
let sh = Util.Text.fromText . SH.toText $ toShortHash link
|
||||
bstk <- bump bstk
|
||||
pokeBi bstk sh
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LOAD i)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 LOAD i)
|
||||
| sandboxed env = die "attempted to use sandboxed operation: load"
|
||||
| otherwise = do
|
||||
v <- peekOffBi bstk i
|
||||
@ -345,16 +346,16 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 LOAD i)
|
||||
poke ustk 1
|
||||
poke bstk x
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k (BPrim1 VALU i) = do
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim1 VALU i) = do
|
||||
m <- readTVarIO (tagRefs env)
|
||||
c <- peekOff bstk i
|
||||
bstk <- bump bstk
|
||||
pokeBi bstk =<< reflectValue m c
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim1 op i) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (BPrim1 op i) = do
|
||||
(ustk, bstk) <- bprim1 ustk bstk op i
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k (BPrim2 SDBX i j) = do
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim2 SDBX i j) = do
|
||||
s <- peekOffS bstk i
|
||||
c <- peekOff bstk j
|
||||
l <- decodeSandboxArgument s
|
||||
@ -362,92 +363,96 @@ exec !env !denv !_activeThreads !ustk !bstk !k (BPrim2 SDBX i j) = do
|
||||
ustk <- bump ustk
|
||||
poke ustk $ if b then 1 else 0
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim2 EQLU i j) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (BPrim2 EQLU i j) = do
|
||||
x <- peekOff bstk i
|
||||
y <- peekOff bstk j
|
||||
ustk <- bump ustk
|
||||
poke ustk $ if universalEq (==) x y then 1 else 0
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (BPrim2 CMPU i j) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (BPrim2 CMPU i j) = do
|
||||
x <- peekOff bstk i
|
||||
y <- peekOff bstk j
|
||||
ustk <- bump ustk
|
||||
poke ustk . fromEnum $ universalCompare compare x y
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k (BPrim2 TRCE i j)
|
||||
exec !_ !_ !_activeThreads !_ !bstk !k r (BPrim2 THRO i j) = do
|
||||
name <- peekOffBi @Util.Text.Text bstk i
|
||||
x <- peekOff bstk j
|
||||
throwIO (BU (traceK r k) (Util.Text.toText name) x)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k _ (BPrim2 TRCE i j)
|
||||
| sandboxed env = die "attempted to use sandboxed operation: trace"
|
||||
| otherwise = do
|
||||
tx <- peekOffBi bstk i
|
||||
clo <- peekOff bstk j
|
||||
tracer env tx clo
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_trackThreads !ustk !bstk !k (BPrim2 op i j) = do
|
||||
exec !_ !denv !_trackThreads !ustk !bstk !k _ (BPrim2 op i j) = do
|
||||
(ustk, bstk) <- bprim2 ustk bstk op i j
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (Pack r t args) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (Pack r t args) = do
|
||||
clo <- buildData ustk bstk r t args
|
||||
bstk <- bump bstk
|
||||
poke bstk clo
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (Unpack r i) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (Unpack r i) = do
|
||||
(ustk, bstk) <- dumpData r ustk bstk =<< peekOff bstk i
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (Print i) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (Print i) = do
|
||||
t <- peekOffBi bstk i
|
||||
Tx.putStrLn (Util.Text.toText t)
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (Lit (MI n)) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MI n)) = do
|
||||
ustk <- bump ustk
|
||||
poke ustk n
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (Lit (MD d)) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MD d)) = do
|
||||
ustk <- bump ustk
|
||||
pokeD ustk d
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (Lit (MT t)) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MT t)) = do
|
||||
bstk <- bump bstk
|
||||
poke bstk (Foreign (Wrap Rf.textRef t))
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (Lit (MM r)) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MM r)) = do
|
||||
bstk <- bump bstk
|
||||
poke bstk (Foreign (Wrap Rf.termLinkRef r))
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (Lit (MY r)) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (Lit (MY r)) = do
|
||||
bstk <- bump bstk
|
||||
poke bstk (Foreign (Wrap Rf.typeLinkRef r))
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (Reset ps) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (Reset ps) = do
|
||||
(ustk, ua) <- saveArgs ustk
|
||||
(bstk, ba) <- saveArgs bstk
|
||||
pure (denv, ustk, bstk, Mark ua ba ps clos k)
|
||||
where
|
||||
clos = EC.restrictKeys denv ps
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k (Seq as) = do
|
||||
exec !_ !denv !_activeThreads !ustk !bstk !k _ (Seq as) = do
|
||||
l <- closureArgs bstk as
|
||||
bstk <- bump bstk
|
||||
pokeS bstk $ Sq.fromList l
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k (ForeignCall _ w args)
|
||||
exec !env !denv !_activeThreads !ustk !bstk !k _ (ForeignCall _ w args)
|
||||
| Just (FF arg res ev) <- EC.lookup w (foreignFuncs env) =
|
||||
uncurry (denv,,,k)
|
||||
<$> (arg ustk bstk args >>= ev >>= res ustk bstk)
|
||||
| otherwise =
|
||||
die $ "reference to unknown foreign function: " ++ show w
|
||||
exec !env !denv !activeThreads !ustk !bstk !k (Fork i)
|
||||
exec !env !denv !activeThreads !ustk !bstk !k _ (Fork i)
|
||||
| sandboxed env = die "attempted to use sandboxed operation: fork"
|
||||
| otherwise = do
|
||||
tid <- forkEval env activeThreads =<< peekOff bstk i
|
||||
bstk <- bump bstk
|
||||
poke bstk . Foreign . Wrap Rf.threadIdRef $ tid
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !env !denv !activeThreads !ustk !bstk !k (Atomically i)
|
||||
exec !env !denv !activeThreads !ustk !bstk !k _ (Atomically i)
|
||||
| sandboxed env = die $ "attempted to use sandboxed operation: atomically"
|
||||
| otherwise = do
|
||||
c <- peekOff bstk i
|
||||
bstk <- bump bstk
|
||||
atomicEval env activeThreads (poke bstk) c
|
||||
pure (denv, ustk, bstk, k)
|
||||
exec !env !denv !activeThreads !ustk !bstk !k (TryForce i)
|
||||
exec !env !denv !activeThreads !ustk !bstk !k _ (TryForce i)
|
||||
| sandboxed env = die $ "attempted to use sandboxed operation: tryForce"
|
||||
| otherwise = do
|
||||
c <- peekOff bstk i
|
||||
@ -478,7 +483,7 @@ encodeExn ustk bstk (Left exn) = do
|
||||
| Just re <- fromException exn = case re of
|
||||
PE _stk msg ->
|
||||
(Rf.runtimeFailureRef, Util.Text.pack $ toPlainUnbroken msg, unitValue)
|
||||
BU tx cl -> (Rf.runtimeFailureRef, Util.Text.fromText tx, cl)
|
||||
BU _ tx cl -> (Rf.runtimeFailureRef, Util.Text.fromText tx, cl)
|
||||
| Just (ae :: ArithException) <- fromException exn =
|
||||
(Rf.arithmeticFailureRef, disp ae, unitValue)
|
||||
| Just (nae :: NestedAtomically) <- fromException exn =
|
||||
@ -496,15 +501,16 @@ eval ::
|
||||
Stack 'UN ->
|
||||
Stack 'BX ->
|
||||
K ->
|
||||
Reference ->
|
||||
Section ->
|
||||
IO ()
|
||||
eval !env !denv !activeThreads !ustk !bstk !k (Match i (TestT df cs)) = do
|
||||
eval !env !denv !activeThreads !ustk !bstk !k r (Match i (TestT df cs)) = do
|
||||
t <- peekOffBi bstk i
|
||||
eval env denv activeThreads ustk bstk k $ selectTextBranch t df cs
|
||||
eval !env !denv !activeThreads !ustk !bstk !k (Match i br) = do
|
||||
eval env denv activeThreads ustk bstk k r $ selectTextBranch t df cs
|
||||
eval !env !denv !activeThreads !ustk !bstk !k r (Match i br) = do
|
||||
n <- peekOffN ustk i
|
||||
eval env denv activeThreads ustk bstk k $ selectBranch n br
|
||||
eval !env !denv !activeThreads !ustk !bstk !k (Yield args)
|
||||
eval env denv activeThreads ustk bstk k r $ selectBranch n br
|
||||
eval !env !denv !activeThreads !ustk !bstk !k _ (Yield args)
|
||||
| asize ustk + asize bstk > 0,
|
||||
BArg1 i <- args =
|
||||
peekOff bstk i >>= apply env denv activeThreads ustk bstk k False ZArgs
|
||||
@ -513,23 +519,23 @@ eval !env !denv !activeThreads !ustk !bstk !k (Yield args)
|
||||
ustk <- frameArgs ustk
|
||||
bstk <- frameArgs bstk
|
||||
yield env denv activeThreads ustk bstk k
|
||||
eval !env !denv !activeThreads !ustk !bstk !k (App ck r args) =
|
||||
eval !env !denv !activeThreads !ustk !bstk !k _ (App ck r args) =
|
||||
resolve env denv bstk r
|
||||
>>= apply env denv activeThreads ustk bstk k ck args
|
||||
eval !env !denv !activeThreads !ustk !bstk !k (Call ck n args) =
|
||||
eval !env !denv !activeThreads !ustk !bstk !k _ (Call ck n args) =
|
||||
combSection env (CIx dummyRef n 0)
|
||||
>>= enter env denv activeThreads ustk bstk k ck args
|
||||
eval !env !denv !activeThreads !ustk !bstk !k (Jump i args) =
|
||||
eval !env !denv !activeThreads !ustk !bstk !k _ (Jump i args) =
|
||||
peekOff bstk i >>= jump env denv activeThreads ustk bstk k args
|
||||
eval !env !denv !activeThreads !ustk !bstk !k (Let nw cix) = do
|
||||
eval !env !denv !activeThreads !ustk !bstk !k r (Let nw cix) = do
|
||||
(ustk, ufsz, uasz) <- saveFrame ustk
|
||||
(bstk, bfsz, basz) <- saveFrame bstk
|
||||
eval env denv activeThreads ustk bstk (Push ufsz bfsz uasz basz cix k) nw
|
||||
eval !env !denv !activeThreads !ustk !bstk !k (Ins i nx) = do
|
||||
(denv, ustk, bstk, k) <- exec env denv activeThreads ustk bstk k i
|
||||
eval env denv activeThreads ustk bstk k nx
|
||||
eval !_ !_ !_ !_activeThreads !_ !_ Exit = pure ()
|
||||
eval !_ !_ !_ !_activeThreads !_ !_ (Die s) = die s
|
||||
eval env denv activeThreads ustk bstk (Push ufsz bfsz uasz basz cix k) r nw
|
||||
eval !env !denv !activeThreads !ustk !bstk !k r (Ins i nx) = do
|
||||
(denv, ustk, bstk, k) <- exec env denv activeThreads ustk bstk k r i
|
||||
eval env denv activeThreads ustk bstk k r nx
|
||||
eval !_ !_ !_ !_activeThreads !_ !_ _ Exit = pure ()
|
||||
eval !_ !_ !_ !_activeThreads !_ !_ _ (Die s) = die s
|
||||
{-# NOINLINE eval #-}
|
||||
|
||||
forkEval :: CCache -> ActiveThreads -> Closure -> IO ThreadId
|
||||
@ -587,7 +593,9 @@ enter !env !denv !activeThreads !ustk !bstk !k !ck !args !comb = do
|
||||
(ustk, bstk) <- moveArgs ustk bstk args
|
||||
ustk <- acceptArgs ustk ua
|
||||
bstk <- acceptArgs bstk ba
|
||||
eval env denv activeThreads ustk bstk k entry
|
||||
-- TODO: start putting references in `Call` if we ever start
|
||||
-- detecting saturated calls.
|
||||
eval env denv activeThreads ustk bstk k dummyRef entry
|
||||
where
|
||||
Lam ua ba uf bf entry = comb
|
||||
{-# INLINE enter #-}
|
||||
@ -626,7 +634,7 @@ apply !env !denv !activeThreads !ustk !bstk !k !ck !args (PAp comb useg bseg) =
|
||||
bstk <- dumpSeg bstk bseg A
|
||||
ustk <- acceptArgs ustk ua
|
||||
bstk <- acceptArgs bstk ba
|
||||
eval env denv activeThreads ustk bstk k entry
|
||||
eval env denv activeThreads ustk bstk k (combRef comb) entry
|
||||
| otherwise -> do
|
||||
(useg, bseg) <- closeArgs C ustk bstk useg bseg args
|
||||
ustk <- discardFrame =<< frameArgs ustk
|
||||
@ -1594,10 +1602,7 @@ bprim2 !ustk !bstk CATB i j = do
|
||||
bstk <- bump bstk
|
||||
pokeBi bstk (l <> r :: By.Bytes)
|
||||
pure (ustk, bstk)
|
||||
bprim2 !_ !bstk THRO i j = do
|
||||
name <- peekOffBi @Util.Text.Text bstk i
|
||||
x <- peekOff bstk j
|
||||
throwIO (BU (Util.Text.toText name) x)
|
||||
bprim2 !ustk !bstk THRO _ _ = pure (ustk, bstk) -- impossible
|
||||
bprim2 !ustk !bstk TRCE _ _ = pure (ustk, bstk) -- impossible
|
||||
bprim2 !ustk !bstk CMPU _ _ = pure (ustk, bstk) -- impossible
|
||||
bprim2 !ustk !bstk SDBX _ _ = pure (ustk, bstk) -- impossible
|
||||
@ -1626,7 +1631,7 @@ yield !env !denv !activeThreads !ustk !bstk !k = leap denv k
|
||||
bstk <- restoreFrame bstk bfsz basz
|
||||
ustk <- ensure ustk uf
|
||||
bstk <- ensure bstk bf
|
||||
eval env denv activeThreads ustk bstk k nx
|
||||
eval env denv activeThreads ustk bstk k (combRef cix) nx
|
||||
leap _ (CB (Hook f)) = f ustk bstk
|
||||
leap _ KE = pure ()
|
||||
{-# INLINE yield #-}
|
||||
@ -1713,7 +1718,7 @@ resolve env _ _ (Env n i) =
|
||||
resolve _ _ bstk (Stk i) = peekOff bstk i
|
||||
resolve _ denv _ (Dyn i) = case EC.lookup i denv of
|
||||
Just clo -> pure clo
|
||||
_ -> die $ "resolve: looked up bad dynamic: " ++ show i
|
||||
_ -> die $ "resolve: unhandled ability request: " ++ show i
|
||||
|
||||
combSection :: HasCallStack => CCache -> CombIx -> IO Comb
|
||||
combSection env (CIx _ n i) =
|
||||
@ -2157,7 +2162,8 @@ universalCompare frn = cmpc False
|
||||
cmpc tyEq (Foreign fl) (Foreign fr)
|
||||
| Just sl <- maybeUnwrapForeign Rf.listRef fl,
|
||||
Just sr <- maybeUnwrapForeign Rf.listRef fr =
|
||||
comparing Sq.length sl sr <> fold (Sq.zipWith (cmpc tyEq) sl sr)
|
||||
fold (Sq.zipWith (cmpc tyEq) sl sr)
|
||||
<> compare (length sl) (length sr)
|
||||
| Just al <- maybeUnwrapForeign Rf.iarrayRef fl,
|
||||
Just ar <- maybeUnwrapForeign Rf.iarrayRef fr =
|
||||
arrayCmp (cmpc tyEq) al ar
|
||||
|
@ -17,6 +17,7 @@ module Unison.Runtime.Stack
|
||||
Off,
|
||||
SZ,
|
||||
FP,
|
||||
traceK,
|
||||
frameDataSize,
|
||||
marshalToForeign,
|
||||
unull,
|
||||
@ -109,6 +110,14 @@ data Closure
|
||||
| BlackHole
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
traceK :: Reference -> K -> [(Reference, Int)]
|
||||
traceK begin = dedup (begin, 1) where
|
||||
dedup p (Mark _ _ _ _ k) = dedup p k
|
||||
dedup p@(cur,n) (Push _ _ _ _ (CIx r _ _) k)
|
||||
| cur == r = dedup (cur,1+n) k
|
||||
| otherwise = p : dedup (r,1) k
|
||||
dedup p _ = [p]
|
||||
|
||||
splitData :: Closure -> Maybe (Reference, Word64, [Int], [Closure])
|
||||
splitData (Enum r t) = Just (r, t, [], [])
|
||||
splitData (DataU1 r t i) = Just (r, t, [i], [])
|
||||
|
@ -22,6 +22,7 @@ import Unison.Reference (Reference (DerivedId))
|
||||
import qualified Unison.Referent as Referent
|
||||
import qualified Unison.Result as Result
|
||||
import Unison.Syntax.NamePrinter (styleHashQualified'')
|
||||
import Unison.Syntax.TypePrinter (runPretty)
|
||||
import qualified Unison.Syntax.TypePrinter as TypePrinter
|
||||
import qualified Unison.Term as Term
|
||||
import qualified Unison.Type as Type
|
||||
@ -73,9 +74,9 @@ prettyGADT env ctorType r name dd =
|
||||
where
|
||||
constructor (n, (_, _, t)) =
|
||||
prettyPattern env ctorType name (ConstructorReference r n)
|
||||
<> (fmt S.TypeAscriptionColon " :")
|
||||
`P.hang` TypePrinter.pretty0 env Map.empty (-1) t
|
||||
header = prettyEffectHeader name (DD.EffectDeclaration dd) <> (fmt S.ControlKeyword " where")
|
||||
<> fmt S.TypeAscriptionColon " :"
|
||||
`P.hang` TypePrinter.prettySyntax env t
|
||||
header = prettyEffectHeader name (DD.EffectDeclaration dd) <> fmt S.ControlKeyword " where"
|
||||
|
||||
prettyPattern ::
|
||||
PrettyPrintEnv ->
|
||||
@ -86,7 +87,7 @@ prettyPattern ::
|
||||
prettyPattern env ctorType namespace ref =
|
||||
styleHashQualified''
|
||||
(fmt (S.TermReference conRef))
|
||||
( HQ.stripNamespace (fromMaybe "" $ Name.toText <$> HQ.toName namespace) $
|
||||
( HQ.stripNamespace (maybe "" Name.toText (HQ.toName namespace)) $
|
||||
PPE.termName env conRef
|
||||
)
|
||||
where
|
||||
@ -106,26 +107,26 @@ prettyDataDecl (PrettyPrintEnvDecl unsuffixifiedPPE suffixifiedPPE) r name dd =
|
||||
[0 ..]
|
||||
(DD.constructors' dd)
|
||||
where
|
||||
constructor (n, (_, _, (Type.ForallsNamed' _ t))) = constructor' n t
|
||||
constructor (n, (_, _, Type.ForallsNamed' _ t)) = constructor' n t
|
||||
constructor (n, (_, _, t)) = constructor' n t
|
||||
constructor' n t = case Type.unArrows t of
|
||||
Nothing -> prettyPattern suffixifiedPPE CT.Data name (ConstructorReference r n)
|
||||
Just ts -> case fieldNames unsuffixifiedPPE r name dd of
|
||||
Nothing ->
|
||||
P.group . P.hang' (prettyPattern suffixifiedPPE CT.Data name (ConstructorReference r n)) " " $
|
||||
P.spaced (TypePrinter.prettyRaw suffixifiedPPE Map.empty 10 <$> init ts)
|
||||
P.spaced (runPretty suffixifiedPPE (traverse (TypePrinter.prettyRaw Map.empty 10) (init ts)))
|
||||
Just fs ->
|
||||
P.group $
|
||||
(fmt S.DelimiterChar "{ ")
|
||||
fmt S.DelimiterChar "{ "
|
||||
<> P.sep
|
||||
((fmt S.DelimiterChar ",") <> " " `P.orElse` "\n ")
|
||||
(fmt S.DelimiterChar "," <> " " `P.orElse` "\n ")
|
||||
(field <$> zip fs (init ts))
|
||||
<> (fmt S.DelimiterChar " }")
|
||||
<> fmt S.DelimiterChar " }"
|
||||
field (fname, typ) =
|
||||
P.group $
|
||||
styleHashQualified'' (fmt (S.TypeReference r)) fname
|
||||
<> (fmt S.TypeAscriptionColon " :") `P.hang` TypePrinter.prettyRaw suffixifiedPPE Map.empty (-1) typ
|
||||
header = prettyDataHeader name dd <> (fmt S.DelimiterChar (" = " `P.orElse` "\n = "))
|
||||
<> fmt S.TypeAscriptionColon " :" `P.hang` runPretty suffixifiedPPE (TypePrinter.prettyRaw Map.empty (-1) typ)
|
||||
header = prettyDataHeader name dd <> fmt S.DelimiterChar (" = " `P.orElse` "\n = ")
|
||||
|
||||
-- Comes up with field names for a data declaration which has the form of a
|
||||
-- record, like `type Pt = { x : Int, y : Int }`. Works by generating the
|
||||
|
File diff suppressed because it is too large
Load Diff
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Unison.Syntax.TypePrinter
|
||||
( pretty,
|
||||
@ -12,6 +13,7 @@ module Unison.Syntax.TypePrinter
|
||||
prettySignaturesCTCollapsed,
|
||||
prettySignaturesAlt,
|
||||
prettySignaturesAlt',
|
||||
runPretty,
|
||||
)
|
||||
where
|
||||
|
||||
@ -23,6 +25,7 @@ import Unison.Prelude
|
||||
import Unison.PrettyPrintEnv (PrettyPrintEnv)
|
||||
import qualified Unison.PrettyPrintEnv as PrettyPrintEnv
|
||||
import Unison.PrettyPrintEnv.FQN (Imports, elideFQN)
|
||||
import Unison.PrettyPrintEnv.MonadPretty (MonadPretty, getPPE, runPretty, willCapture)
|
||||
import Unison.Reference (Reference, pattern Builtin)
|
||||
import Unison.Referent (Referent)
|
||||
import Unison.Syntax.NamePrinter (styleHashQualified'')
|
||||
@ -36,17 +39,17 @@ import qualified Unison.Var as Var
|
||||
|
||||
type SyntaxText = S.SyntaxText' Reference
|
||||
|
||||
pretty :: forall v a. (Var v) => PrettyPrintEnv -> Type v a -> Pretty ColorText
|
||||
pretty ppe = PP.syntaxToColor . prettySyntax ppe
|
||||
pretty :: Var v => PrettyPrintEnv -> Type v a -> Pretty ColorText
|
||||
pretty ppe t = PP.syntaxToColor $ prettySyntax ppe t
|
||||
|
||||
prettySyntax :: forall v a. (Var v) => PrettyPrintEnv -> Type v a -> Pretty SyntaxText
|
||||
prettySyntax ppe = pretty0 ppe mempty (-1)
|
||||
prettySyntax :: Var v => PrettyPrintEnv -> Type v a -> Pretty SyntaxText
|
||||
prettySyntax ppe = runPretty ppe . pretty0 Map.empty (-1)
|
||||
|
||||
prettyStr :: Var v => Maybe Width -> PrettyPrintEnv -> Type v a -> String
|
||||
prettyStr (Just width) n t =
|
||||
toPlain $ PP.render width $ PP.syntaxToColor $ pretty0 n Map.empty (-1) t
|
||||
prettyStr Nothing n t =
|
||||
toPlain $ PP.render maxBound $ PP.syntaxToColor $ pretty0 n Map.empty (-1) t
|
||||
prettyStr (Just width) ppe t =
|
||||
toPlain . PP.render width . PP.syntaxToColor . runPretty ppe $ pretty0 Map.empty (-1) t
|
||||
prettyStr Nothing ppe t =
|
||||
toPlain . PP.render maxBound . PP.syntaxToColor . runPretty ppe $ pretty0 Map.empty (-1) t
|
||||
|
||||
{- Explanation of precedence handling
|
||||
|
||||
@ -71,90 +74,103 @@ prettyStr Nothing n t =
|
||||
-}
|
||||
|
||||
pretty0 ::
|
||||
forall v a.
|
||||
(Var v) =>
|
||||
PrettyPrintEnv ->
|
||||
forall v a m.
|
||||
MonadPretty v m =>
|
||||
Imports ->
|
||||
Int ->
|
||||
Type v a ->
|
||||
Pretty SyntaxText
|
||||
pretty0 n im p tp = prettyRaw n im p (cleanup (removePureEffects tp))
|
||||
m (Pretty SyntaxText)
|
||||
pretty0 im p tp = prettyRaw im p (cleanup (removePureEffects tp))
|
||||
|
||||
prettyRaw ::
|
||||
forall v a.
|
||||
(Var v) =>
|
||||
PrettyPrintEnv ->
|
||||
forall v a m.
|
||||
MonadPretty v m =>
|
||||
Imports ->
|
||||
Int ->
|
||||
Type v a ->
|
||||
Pretty SyntaxText
|
||||
m (Pretty SyntaxText)
|
||||
-- p is the operator precedence of the enclosing context (a number from 0 to
|
||||
-- 11, or -1 to avoid outer parentheses unconditionally). Function
|
||||
-- application has precedence 10.
|
||||
prettyRaw n im p tp = go n im p tp
|
||||
prettyRaw im p tp = go im p tp
|
||||
where
|
||||
go :: PrettyPrintEnv -> Imports -> Int -> Type v a -> Pretty SyntaxText
|
||||
go n im p tp = case stripIntroOuters tp of
|
||||
Var' v -> fmt S.Var $ PP.text (Var.name v)
|
||||
DD.TupleType' xs | length xs /= 1 -> PP.parenthesizeCommas $ map (go n im 0) xs
|
||||
go :: Imports -> Int -> Type v a -> m (Pretty SyntaxText)
|
||||
go im p tp = case stripIntroOuters tp of
|
||||
Var' v -> pure . fmt S.Var $ PP.text (Var.name v)
|
||||
DD.TupleType' xs | length xs /= 1 -> PP.parenthesizeCommas <$> traverse (go im 0) xs
|
||||
-- Would be nice to use a different SyntaxHighlights color if the reference is an ability.
|
||||
Ref' r -> styleHashQualified'' (fmt $ S.TypeReference r) $ elideFQN im (PrettyPrintEnv.typeName n r)
|
||||
Cycle' _ _ -> fromString "error: TypeParser does not currently emit Cycle"
|
||||
Abs' _ -> fromString "error: TypeParser does not currently emit Abs"
|
||||
Ann' _ _ -> fromString "error: TypeParser does not currently emit Ann"
|
||||
App' (Ref' (Builtin "Sequence")) x ->
|
||||
PP.group $ (fmt S.DelimiterChar "[") <> go n im 0 x <> (fmt S.DelimiterChar "]")
|
||||
Ref' r -> do
|
||||
n <- getPPE
|
||||
pure $ styleHashQualified'' (fmt $ S.TypeReference r) $ elideFQN im (PrettyPrintEnv.typeName n r)
|
||||
Cycle' _ _ -> pure $ fromString "bug: TypeParser does not currently emit Cycle"
|
||||
Abs' _ -> pure $ fromString "bug: TypeParser does not currently emit Abs"
|
||||
Ann' _ _ -> pure $ fromString "bug: TypeParser does not currently emit Ann"
|
||||
App' (Ref' (Builtin "Sequence")) x -> do
|
||||
x' <- go im (-1) x
|
||||
pure $ PP.group $ fmt S.DelimiterChar "[" <> x' <> fmt S.DelimiterChar "]"
|
||||
Apps' f xs ->
|
||||
PP.parenthesizeIf (p >= 10) $
|
||||
go n im 9 f
|
||||
`PP.hang` PP.spaced
|
||||
(go n im 10 <$> xs)
|
||||
PP.parenthesizeIf (p >= 10)
|
||||
<$> ( PP.hang <$> go im 9 f <*> (PP.spaced <$> traverse (go im 10) xs)
|
||||
)
|
||||
Effect1' e t ->
|
||||
PP.parenthesizeIf (p >= 10) $ go n im 9 e <> " " <> go n im 10 t
|
||||
PP.parenthesizeIf (p >= 10) <$> ((\x y -> x <> " " <> y) <$> go im 9 e <*> go im 10 t)
|
||||
Effects' es -> effects (Just es)
|
||||
ForallsNamed' vs' body ->
|
||||
let vs = filter (\v -> Var.name v /= "()") vs'
|
||||
in if p < 0 && all Var.universallyQuantifyIfFree vs
|
||||
then go n im p body
|
||||
else
|
||||
paren (p >= 0) $
|
||||
let vformatted = PP.sep " " (fmt S.Var . PP.text . Var.name <$> vs)
|
||||
in (fmt S.TypeOperator "∀ " <> vformatted <> fmt S.TypeOperator ".")
|
||||
`PP.hang` go n im (-1) body
|
||||
prettyForall p = do
|
||||
let vformatted = PP.sep " " (fmt S.Var . PP.text . Var.name <$> vs)
|
||||
PP.hang (fmt S.TypeOperator "∀ " <> vformatted <> fmt S.TypeOperator ".") <$> go im p body
|
||||
in -- if we're printing a type signature, and all the type variables
|
||||
-- are universally quantified, then we can omit the `forall` keyword
|
||||
-- only if the type variables are not bound in an outer scope
|
||||
if p < 0 && all Var.universallyQuantifyIfFree vs
|
||||
then ifM (willCapture vs) (prettyForall p) (go im p body)
|
||||
else paren (p >= 0) <$> prettyForall (-1)
|
||||
t@(Arrow' _ _) -> case t of
|
||||
EffectfulArrows' (Ref' DD.UnitRef) rest ->
|
||||
PP.parenthesizeIf (p >= 10) $ arrows True True rest
|
||||
PP.parenthesizeIf (p >= 10) <$> arrows True True rest
|
||||
EffectfulArrows' fst rest ->
|
||||
case fst of
|
||||
Var' v
|
||||
| Var.name v == "()" ->
|
||||
PP.parenthesizeIf (p >= 10) $ arrows True True rest
|
||||
PP.parenthesizeIf (p >= 10) <$> arrows True True rest
|
||||
_ ->
|
||||
PP.parenthesizeIf (p >= 0) $
|
||||
go n im 0 fst <> arrows False False rest
|
||||
_ -> "error"
|
||||
_ -> "error"
|
||||
effects Nothing = mempty
|
||||
effects (Just es) = PP.group $ fmt S.AbilityBraces "{" <> PP.commas (go n im 0 <$> es) <> (fmt S.AbilityBraces "}")
|
||||
PP.parenthesizeIf (p >= 0)
|
||||
<$> ((<>) <$> go im 0 fst <*> arrows False False rest)
|
||||
_ -> pure . fromString $ "bug: unexpected Arrow form in prettyRaw: " <> show t
|
||||
_ -> pure . fromString $ "bug: unexpected form in prettyRaw: " <> show tp
|
||||
effects Nothing = pure mempty
|
||||
effects (Just es) =
|
||||
PP.group . (fmt S.AbilityBraces "{" <>) . (<> fmt S.AbilityBraces "}")
|
||||
<$> (PP.commas <$> traverse (go im 0) es)
|
||||
-- `first`: is this the first argument?
|
||||
-- `mes`: list of effects
|
||||
arrow delay first mes =
|
||||
(if first then mempty else PP.softbreak <> fmt S.TypeOperator "->")
|
||||
<> (if delay then (if first then fmt S.DelayForceChar "'" else fmt S.DelayForceChar " '") else mempty)
|
||||
<> effects mes
|
||||
<> if isJust mes || not delay && not first then " " else mempty
|
||||
arrow delay first mes = do
|
||||
es <- effects mes
|
||||
pure $
|
||||
(if first then mempty else PP.softbreak <> fmt S.TypeOperator "->")
|
||||
<> (if delay then (if first then fmt S.DelayForceChar "'" else fmt S.DelayForceChar " '") else mempty)
|
||||
<> es
|
||||
<> if isJust mes || not delay && not first then " " else mempty
|
||||
|
||||
arrows delay first [(mes, Ref' DD.UnitRef)] = arrow delay first mes <> fmt S.Unit "()"
|
||||
arrows delay first ((mes, Ref' DD.UnitRef) : rest) =
|
||||
arrow delay first mes <> parenNoGroup delay (arrows True True rest)
|
||||
arrows delay first ((mes, arg) : rest) =
|
||||
arrow delay first mes
|
||||
<> parenNoGroup
|
||||
(delay && not (null rest))
|
||||
(go n im 0 arg <> arrows False False rest)
|
||||
arrows False False [] = mempty
|
||||
arrows False True [] = mempty -- not reachable
|
||||
arrows True _ [] = mempty -- not reachable
|
||||
arrows ::
|
||||
Bool ->
|
||||
Bool ->
|
||||
[(Maybe [Type v a], Type v a)] ->
|
||||
m (Pretty SyntaxText)
|
||||
arrows delay first [(mes, Ref' DD.UnitRef)] = (<> fmt S.Unit "()") <$> arrow delay first mes
|
||||
arrows delay first ((mes, Ref' DD.UnitRef) : rest) = do
|
||||
es <- arrow delay first mes
|
||||
rest' <- arrows True True rest
|
||||
pure $ es <> parenNoGroup delay rest'
|
||||
arrows delay first ((mes, arg) : rest) = do
|
||||
es <- arrow delay first mes
|
||||
arg' <- go im 0 arg
|
||||
rest' <- arrows False False rest
|
||||
pure $ es <> parenNoGroup (delay && not (null rest)) (arg' <> rest')
|
||||
arrows False False [] = pure mempty
|
||||
arrows False True [] = pure mempty -- not reachable
|
||||
arrows True _ [] = pure mempty -- not reachable
|
||||
paren True s = PP.group $ fmt S.Parenthesis "(" <> s <> fmt S.Parenthesis ")"
|
||||
paren False s = PP.group s
|
||||
|
||||
@ -170,30 +186,32 @@ prettySignaturesCT ::
|
||||
PrettyPrintEnv ->
|
||||
[(Referent, HashQualified Name, Type v a)] ->
|
||||
[Pretty ColorText]
|
||||
prettySignaturesCT env ts = map PP.syntaxToColor $ prettySignaturesST env ts
|
||||
prettySignaturesCT ppe ts = map PP.syntaxToColor $ prettySignaturesST ppe ts
|
||||
|
||||
prettySignaturesCTCollapsed ::
|
||||
Var v =>
|
||||
PrettyPrintEnv ->
|
||||
[(Referent, HashQualified Name, Type v a)] ->
|
||||
Pretty ColorText
|
||||
prettySignaturesCTCollapsed env ts =
|
||||
PP.lines $
|
||||
PP.group <$> prettySignaturesCT env ts
|
||||
prettySignaturesCTCollapsed ppe ts =
|
||||
PP.lines
|
||||
. map PP.group
|
||||
$ prettySignaturesCT ppe ts
|
||||
|
||||
prettySignaturesST ::
|
||||
Var v =>
|
||||
PrettyPrintEnv ->
|
||||
[(Referent, HashQualified Name, Type v a)] ->
|
||||
[Pretty SyntaxText]
|
||||
prettySignaturesST env ts =
|
||||
PP.align [(name r hq, sig typ) | (r, hq, typ) <- ts]
|
||||
prettySignaturesST ppe ts =
|
||||
PP.align . runPretty ppe $ traverse (\(r, hq, typ) -> (name r hq,) <$> sig typ) ts
|
||||
where
|
||||
name r hq =
|
||||
styleHashQualified'' (fmt $ S.TermReference r) hq
|
||||
sig typ =
|
||||
(fmt S.TypeAscriptionColon ": " <> pretty0 env Map.empty (-1) typ)
|
||||
`PP.orElse` (fmt S.TypeAscriptionColon ": " <> PP.indentNAfterNewline 2 (pretty0 env Map.empty (-1) typ))
|
||||
sig typ = do
|
||||
t <- pretty0 Map.empty (-1) typ
|
||||
let col = fmt S.TypeAscriptionColon ": "
|
||||
pure $ (col <> t) `PP.orElse` (col <> PP.indentNAfterNewline 2 t)
|
||||
|
||||
-- todo: provide sample output in comment; different from prettySignatures'
|
||||
prettySignaturesAlt' ::
|
||||
@ -201,19 +219,21 @@ prettySignaturesAlt' ::
|
||||
PrettyPrintEnv ->
|
||||
[([HashQualified Name], Type v a)] ->
|
||||
[Pretty ColorText]
|
||||
prettySignaturesAlt' env ts =
|
||||
map PP.syntaxToColor $
|
||||
PP.align
|
||||
[ ( PP.commas . fmap (\name -> styleHashQualified'' (fmt $ S.HashQualifier name) name) $ names,
|
||||
(fmt S.TypeAscriptionColon ": " <> pretty0 env Map.empty (-1) typ)
|
||||
`PP.orElse` ( fmt S.TypeAscriptionColon ": "
|
||||
<> PP.indentNAfterNewline 2 (pretty0 env Map.empty (-1) typ)
|
||||
)
|
||||
prettySignaturesAlt' ppe ts = runPretty ppe $
|
||||
do
|
||||
ts' <- traverse f ts
|
||||
pure $ map PP.syntaxToColor $ PP.align ts'
|
||||
where
|
||||
f :: MonadPretty v m => ([HashQualified Name], Type v a) -> m (Pretty SyntaxText, Pretty SyntaxText)
|
||||
f (names, typ) = do
|
||||
typ' <- pretty0 Map.empty (-1) typ
|
||||
let col = fmt S.TypeAscriptionColon ": "
|
||||
pure
|
||||
( PP.commas . fmap (\name -> styleHashQualified'' (fmt $ S.HashQualifier name) name) $ names,
|
||||
(col <> typ') `PP.orElse` (col <> PP.indentNAfterNewline 2 typ')
|
||||
)
|
||||
| (names, typ) <- ts
|
||||
]
|
||||
|
||||
-- prettySignatures'' :: Var v => PrettyPrintEnv -> [(Name, Type v a)] -> [Pretty ColorText]
|
||||
-- prettySignatures'' :: Var v => [(Name, Type v a)] -> [Pretty ColorText]
|
||||
-- prettySignatures'' env ts = prettySignatures' env (first HQ.fromName <$> ts)
|
||||
|
||||
prettySignaturesAlt ::
|
||||
@ -221,6 +241,7 @@ prettySignaturesAlt ::
|
||||
PrettyPrintEnv ->
|
||||
[([HashQualified Name], Type v a)] ->
|
||||
Pretty ColorText
|
||||
prettySignaturesAlt env ts =
|
||||
PP.lines $
|
||||
PP.group <$> prettySignaturesAlt' env ts
|
||||
prettySignaturesAlt ppe ts =
|
||||
PP.lines
|
||||
. map PP.group
|
||||
$ prettySignaturesAlt' ppe ts
|
||||
|
@ -1,7 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.UnisonFile.Type where
|
||||
|
||||
@ -10,6 +7,7 @@ import Data.Bifunctor (first)
|
||||
import qualified Unison.ABT as ABT
|
||||
import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId)
|
||||
import qualified Unison.Reference as Reference
|
||||
import Unison.Term (Term)
|
||||
import qualified Unison.Term as Term
|
||||
@ -18,16 +16,16 @@ import qualified Unison.Type as Type
|
||||
import Unison.WatchKind (WatchKind)
|
||||
|
||||
data UnisonFile v a = UnisonFileId
|
||||
{ dataDeclarationsId :: Map v (Reference.Id, DataDeclaration v a),
|
||||
effectDeclarationsId :: Map v (Reference.Id, EffectDeclaration v a),
|
||||
{ dataDeclarationsId :: Map v (TermReferenceId, DataDeclaration v a),
|
||||
effectDeclarationsId :: Map v (TermReferenceId, EffectDeclaration v a),
|
||||
terms :: [(v, Term v a)],
|
||||
watches :: Map WatchKind [(v, Term v a)]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
pattern UnisonFile ::
|
||||
Map v (Reference.Reference, DataDeclaration v a) ->
|
||||
Map v (Reference.Reference, EffectDeclaration v a) ->
|
||||
Map v (TypeReference, DataDeclaration v a) ->
|
||||
Map v (TypeReference, EffectDeclaration v a) ->
|
||||
[(v, Term v a)] ->
|
||||
Map WatchKind [(v, Term v a)] ->
|
||||
UnisonFile v a
|
||||
@ -43,24 +41,24 @@ pattern UnisonFile ds es tms ws <-
|
||||
-- | A UnisonFile after typechecking. Terms are split into groups by
|
||||
-- cycle and the type of each term is known.
|
||||
data TypecheckedUnisonFile v a = TypecheckedUnisonFileId
|
||||
{ dataDeclarationsId' :: Map v (Reference.Id, DataDeclaration v a),
|
||||
effectDeclarationsId' :: Map v (Reference.Id, EffectDeclaration v a),
|
||||
{ dataDeclarationsId' :: Map v (TypeReferenceId, DataDeclaration v a),
|
||||
effectDeclarationsId' :: Map v (TypeReferenceId, EffectDeclaration v a),
|
||||
topLevelComponents' :: [[(v, Term v a, Type v a)]],
|
||||
watchComponents :: [(WatchKind, [(v, Term v a, Type v a)])],
|
||||
hashTermsId :: Map v (Reference.Id, Maybe WatchKind, Term v a, Type v a)
|
||||
hashTermsId :: Map v (TermReferenceId, Maybe WatchKind, Term v a, Type v a)
|
||||
}
|
||||
deriving stock (Generic, Show)
|
||||
|
||||
{-# COMPLETE TypecheckedUnisonFile #-}
|
||||
|
||||
pattern TypecheckedUnisonFile ::
|
||||
Map v (Reference.Reference, DataDeclaration v a) ->
|
||||
Map v (Reference.Reference, EffectDeclaration v a) ->
|
||||
Map v (TypeReference, DataDeclaration v a) ->
|
||||
Map v (TypeReference, EffectDeclaration v a) ->
|
||||
[[(v, Term v a, Type v a)]] ->
|
||||
[(WatchKind, [(v, Term v a, Type v a)])] ->
|
||||
Map
|
||||
v
|
||||
( Reference.Reference,
|
||||
( TermReference,
|
||||
Maybe WatchKind,
|
||||
ABT.Term (Term.F v a a) v a,
|
||||
ABT.Term Type.F v a
|
||||
|
63
parser-typechecker/src/Unison/Util/Pretty/MegaParsec.hs
Normal file
63
parser-typechecker/src/Unison/Util/Pretty/MegaParsec.hs
Normal file
@ -0,0 +1,63 @@
|
||||
module Unison.Util.Pretty.MegaParsec where
|
||||
|
||||
import qualified Data.List.NonEmpty as NE
|
||||
import Data.Proxy
|
||||
import Data.Void
|
||||
import qualified Text.Megaparsec as Parser
|
||||
import Unison.Prelude
|
||||
import qualified Unison.Util.Pretty as P
|
||||
|
||||
prettyPrintParseError :: String -> Parser.ParseErrorBundle Text Void -> P.Pretty P.ColorText
|
||||
prettyPrintParseError input errBundle =
|
||||
let (firstError, sp) = NE.head . fst $ Parser.attachSourcePos Parser.errorOffset (Parser.bundleErrors errBundle) (Parser.bundlePosState errBundle)
|
||||
in case firstError of
|
||||
Parser.TrivialError _errorOffset ue ee ->
|
||||
P.lines
|
||||
[ printLocation sp,
|
||||
P.newline,
|
||||
printTrivial ue ee
|
||||
]
|
||||
Parser.FancyError _errorOffset ee ->
|
||||
let errors = foldMap (P.string . mappend "\n" . showErrorFancy) ee
|
||||
in P.lines
|
||||
[ printLocation sp,
|
||||
errors
|
||||
]
|
||||
where
|
||||
printLocation :: Parser.SourcePos -> P.Pretty P.ColorText
|
||||
printLocation sp =
|
||||
let col = (Parser.unPos $ Parser.sourceColumn sp) - 1
|
||||
row = (Parser.unPos $ Parser.sourceLine sp) - 1
|
||||
errorLine = lines input !! row
|
||||
in P.lines
|
||||
[ P.newline,
|
||||
P.string errorLine,
|
||||
P.string $ Prelude.replicate col ' ' <> "^-- This is where I gave up."
|
||||
]
|
||||
|
||||
printTrivial :: (Maybe (Parser.ErrorItem Char)) -> (Set (Parser.ErrorItem Char)) -> P.Pretty P.ColorText
|
||||
printTrivial ue ee =
|
||||
let expected = "I expected " <> foldMap (P.singleQuoted . P.string . showErrorItem) ee
|
||||
found = P.string . mappend "I found " . showErrorItem <$> ue
|
||||
message = [expected] <> catMaybes [found]
|
||||
in P.oxfordCommasWith "." message
|
||||
|
||||
showErrorFancy :: Parser.ShowErrorComponent e => Parser.ErrorFancy e -> String
|
||||
showErrorFancy (Parser.ErrorFail msg) = msg
|
||||
showErrorFancy (Parser.ErrorIndentation ord ref actual) =
|
||||
"incorrect indentation (got " <> show (Parser.unPos actual)
|
||||
<> ", should be "
|
||||
<> p
|
||||
<> show (Parser.unPos ref)
|
||||
<> ")"
|
||||
where
|
||||
p = case ord of
|
||||
LT -> "less than "
|
||||
EQ -> "equal to "
|
||||
GT -> "greater than "
|
||||
showErrorFancy (Parser.ErrorCustom a) = Parser.showErrorComponent a
|
||||
|
||||
showErrorItem :: Parser.ErrorItem (Parser.Token Text) -> String
|
||||
showErrorItem (Parser.Tokens ts) = Parser.showTokens (Proxy @Text) ts
|
||||
showErrorItem (Parser.Label label) = NE.toList label
|
||||
showErrorItem Parser.EndOfInput = "end of input"
|
@ -47,11 +47,47 @@ cpattern p = CP p (run p)
|
||||
|
||||
run :: Pattern -> Text -> Maybe ([Text], Text)
|
||||
run p =
|
||||
let cp = compile p (\_ _ -> Nothing) (\acc rem -> Just (reverse acc, rem))
|
||||
in \t -> cp [] t
|
||||
let cp = compile p (\_ _ -> Nothing) (\acc rem -> Just (s acc, rem))
|
||||
s = reverse . capturesToList . stackCaptures
|
||||
in \t -> cp (Empty emptyCaptures) t
|
||||
|
||||
-- Pattern a -> ([a] -> a -> r) -> ... -- might need a takeable and droppable interface if go this route
|
||||
compile :: Pattern -> ([Text] -> Text -> r) -> ([Text] -> Text -> r) -> [Text] -> Text -> r
|
||||
-- Stack used to track captures and to support backtracking.
|
||||
-- A `try` will push a `Mark` that allows the old state
|
||||
-- (both the list of captures and the current remainder)
|
||||
-- to be restored on failure.
|
||||
data Stack = Empty !Captures | Mark !Captures !Text !Stack
|
||||
|
||||
-- A difference list for representing the captures of a pattern.
|
||||
-- So that capture lists can be appended in O(1).
|
||||
type Captures = [Text] -> [Text]
|
||||
|
||||
stackCaptures :: Stack -> Captures
|
||||
stackCaptures (Mark cs _ _) = cs
|
||||
stackCaptures (Empty cs) = cs
|
||||
{-# INLINE stackCaptures #-}
|
||||
|
||||
pushCaptures :: Captures -> Stack -> Stack
|
||||
pushCaptures c (Empty cs) = Empty (appendCaptures c cs)
|
||||
pushCaptures c (Mark cs t s) = Mark (appendCaptures c cs) t s
|
||||
{-# INLINE pushCaptures #-}
|
||||
|
||||
pushCapture :: Text -> Stack -> Stack
|
||||
pushCapture txt = pushCaptures (txt :)
|
||||
{-# INLINE pushCapture #-}
|
||||
|
||||
appendCaptures :: Captures -> Captures -> Captures
|
||||
appendCaptures c1 c2 = c1 . c2
|
||||
{-# INLINE appendCaptures #-}
|
||||
|
||||
emptyCaptures :: Captures
|
||||
emptyCaptures = id
|
||||
|
||||
capturesToList :: Captures -> [Text]
|
||||
capturesToList c = c []
|
||||
|
||||
type Compiled r = (Stack -> Text -> r) -> (Stack -> Text -> r) -> Stack -> Text -> r
|
||||
|
||||
compile :: Pattern -> Compiled r
|
||||
compile !Eof !err !success = go
|
||||
where
|
||||
go acc t
|
||||
@ -68,17 +104,17 @@ compile AnyChar !err !success = go
|
||||
rem
|
||||
| Text.size t > Text.size rem -> success acc rem
|
||||
| otherwise -> err acc rem
|
||||
compile (Capture (Many AnyChar)) !_ !success = \acc t -> success (t : acc) Text.empty
|
||||
compile (Capture (Many AnyChar)) !_ !success = \acc t -> success (pushCapture t acc) Text.empty
|
||||
compile (Capture c) !err !success = go
|
||||
where
|
||||
err' _ _ acc0 t0 = err acc0 t0
|
||||
success' _ rem acc0 t0 = success (Text.take (Text.size t0 - Text.size rem) t0 : acc0) rem
|
||||
success' _ rem acc0 t0 = success (pushCapture (Text.take (Text.size t0 - Text.size rem) t0) acc0) rem
|
||||
compiled = compile c err' success'
|
||||
go acc t = compiled acc t acc t
|
||||
compile (Or p1 p2) err success = cp1
|
||||
where
|
||||
cp2 = compile p2 err success
|
||||
cp1 = compile p1 cp2 success
|
||||
cp1 = try "Or" (compile p1) cp2 success
|
||||
compile (Join ps) !err !success = go ps
|
||||
where
|
||||
go [] = success
|
||||
@ -112,6 +148,8 @@ compile (Many p) !_ !success = case p of
|
||||
AnyChar -> (\acc _ -> success acc Text.empty)
|
||||
CharIn cs -> walker (charInPred cs)
|
||||
NotCharIn cs -> walker (charNotInPred cs)
|
||||
CharRange c1 c2 -> walker (\ch -> ch >= c1 && c1 <= c2)
|
||||
NotCharRange c1 c2 -> walker (\ch -> ch < c1 || ch > c2)
|
||||
Digit -> walker isDigit
|
||||
Letter -> walker isLetter
|
||||
Punctuation -> walker isPunctuation
|
||||
@ -144,16 +182,18 @@ compile (Replicate m n p) !err !success = case p of
|
||||
else success acc (Text.drop n t)
|
||||
CharIn cs -> dropper (charInPred cs)
|
||||
NotCharIn cs -> dropper (charNotInPred cs)
|
||||
CharRange c1 c2 -> dropper (\ch -> ch >= c1 && c1 <= c2)
|
||||
NotCharRange c1 c2 -> dropper (\ch -> ch < c1 || ch > c2)
|
||||
Digit -> dropper isDigit
|
||||
Letter -> dropper isLetter
|
||||
Punctuation -> dropper isPunctuation
|
||||
Space -> dropper isSpace
|
||||
_ -> go1 m
|
||||
_ -> try "Replicate" (go1 m) err (go2 (n - m))
|
||||
where
|
||||
go1 0 = go2 (n - m)
|
||||
go1 n = compile p err (go1 (n - 1))
|
||||
go1 0 = \_err success stk rem -> success stk rem
|
||||
go1 n = \err success -> compile p err (go1 (n - 1) err success)
|
||||
go2 0 = success
|
||||
go2 n = compile p success (go2 (n - 1))
|
||||
go2 n = try "Replicate" (compile p) success (go2 (n - 1))
|
||||
|
||||
dropper ok acc t
|
||||
| (i, rest) <- Text.dropWhileMax ok n t, i >= m = success acc rest
|
||||
@ -184,3 +224,16 @@ charInPred [] = const False
|
||||
charInPred (c : chs) = let ok = charInPred chs in \ci -> ci == c || ok ci
|
||||
charNotInPred [] = const True
|
||||
charNotInPred (c : chs) = let ok = charNotInPred chs in (\ci -> ci /= c && ok ci)
|
||||
|
||||
-- runs c and if it fails, restores state to what it was before
|
||||
try :: String -> Compiled r -> Compiled r
|
||||
try msg c err success stk rem =
|
||||
c err' success' (Mark id rem stk) rem
|
||||
where
|
||||
success' stk rem = case stk of
|
||||
Mark caps _ stk -> success (pushCaptures caps stk) rem
|
||||
_ -> error $ "Pattern compiler error in: " <> msg
|
||||
err' stk _ = case stk of
|
||||
Mark _ rem stk -> err stk rem
|
||||
_ -> error $ "Pattern compiler error in: " <> msg
|
||||
{-# INLINE try #-}
|
||||
|
@ -19,7 +19,6 @@ import qualified Unison.Test.DataDeclaration as DataDeclaration
|
||||
import qualified Unison.Test.MCode as MCode
|
||||
import qualified Unison.Test.Referent as Referent
|
||||
import qualified Unison.Test.Syntax.FileParser as FileParser
|
||||
import qualified Unison.Test.Syntax.Lexer as Lexer
|
||||
import qualified Unison.Test.Syntax.TermParser as TermParser
|
||||
import qualified Unison.Test.Syntax.TermPrinter as TermPrinter
|
||||
import qualified Unison.Test.Syntax.TypePrinter as TypePrinter
|
||||
@ -29,7 +28,6 @@ import qualified Unison.Test.Typechecker as Typechecker
|
||||
import qualified Unison.Test.Typechecker.Context as Context
|
||||
import qualified Unison.Test.Typechecker.TypeError as TypeError
|
||||
import qualified Unison.Test.UnisonSources as UnisonSources
|
||||
import qualified Unison.Test.Util.Bytes as Bytes
|
||||
import qualified Unison.Test.Util.PinBoard as PinBoard
|
||||
import qualified Unison.Test.Util.Relation as Relation
|
||||
import qualified Unison.Test.Util.Text as Text
|
||||
@ -39,7 +37,6 @@ test :: Test ()
|
||||
test =
|
||||
tests
|
||||
[ Cache.test,
|
||||
Lexer.test,
|
||||
Term.test,
|
||||
TermParser.test,
|
||||
TermPrinter.test,
|
||||
@ -49,7 +46,6 @@ test =
|
||||
UnisonSources.test,
|
||||
FileParser.test,
|
||||
DataDeclaration.test,
|
||||
Bytes.test,
|
||||
Text.test,
|
||||
Relation.test,
|
||||
Path.test,
|
||||
|
@ -1,214 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Unison.Test.Syntax.Lexer where
|
||||
|
||||
import EasyTest
|
||||
import qualified Unison.ShortHash as ShortHash
|
||||
import Unison.Syntax.Lexer
|
||||
|
||||
test :: Test ()
|
||||
test =
|
||||
scope "lexer"
|
||||
. tests
|
||||
$ [ t "1" [Numeric "1"],
|
||||
t "+1" [Numeric "+1"],
|
||||
t "-1" [Numeric "-1"],
|
||||
t "-1.0" [Numeric "-1.0"],
|
||||
t "+1.0" [Numeric "+1.0"],
|
||||
t "1e3" [Numeric "1e3"],
|
||||
t "1e+3" [Numeric "1e+3"],
|
||||
t "1e-3" [Numeric "1e-3"],
|
||||
t "+1e3" [Numeric "+1e3"],
|
||||
t "+1e+3" [Numeric "+1e+3"],
|
||||
t "+1e-3" [Numeric "+1e-3"],
|
||||
t "-1e3" [Numeric "-1e3"],
|
||||
t "-1e+3" [Numeric "-1e+3"],
|
||||
t "-1e-3" [Numeric "-1e-3"],
|
||||
t "1.2e3" [Numeric "1.2e3"],
|
||||
t "1.2e+3" [Numeric "1.2e+3"],
|
||||
t "1.2e-3" [Numeric "1.2e-3"],
|
||||
t "+1.2e3" [Numeric "+1.2e3"],
|
||||
t "+1.2e+3" [Numeric "+1.2e+3"],
|
||||
t "+1.2e-3" [Numeric "+1.2e-3"],
|
||||
t "-1.2e3" [Numeric "-1.2e3"],
|
||||
t "-1.2e+3" [Numeric "-1.2e+3"],
|
||||
t "-1.2e-3" [Numeric "-1.2e-3"],
|
||||
t "1E3" [Numeric "1e3"],
|
||||
t "1E+3" [Numeric "1e+3"],
|
||||
t "1E-3" [Numeric "1e-3"],
|
||||
t "+1E3" [Numeric "+1e3"],
|
||||
t "+1E+3" [Numeric "+1e+3"],
|
||||
t "+1E-3" [Numeric "+1e-3"],
|
||||
t "-1E3" [Numeric "-1e3"],
|
||||
t "-1E+3" [Numeric "-1e+3"],
|
||||
t "-1E-3" [Numeric "-1e-3"],
|
||||
t "1.2E3" [Numeric "1.2e3"],
|
||||
t "1.2E+3" [Numeric "1.2e+3"],
|
||||
t "1.2E-3" [Numeric "1.2e-3"],
|
||||
t "+1.2E3" [Numeric "+1.2e3"],
|
||||
t "+1.2E+3" [Numeric "+1.2e+3"],
|
||||
t "+1.2E-3" [Numeric "+1.2e-3"],
|
||||
t "-1.2E3" [Numeric "-1.2e3"],
|
||||
t "-1.2E+3" [Numeric "-1.2e+3"],
|
||||
t "-1.2E-3" [Numeric "-1.2e-3"],
|
||||
t "1-1" [Numeric "1", simpleSymbolyId "-", Numeric "1"],
|
||||
t "1+1" [Numeric "1", simpleSymbolyId "+", Numeric "1"],
|
||||
t "1 +1" [Numeric "1", Numeric "+1"],
|
||||
t "1+ 1" [Numeric "1", simpleSymbolyId "+", Numeric "1"],
|
||||
t "x+y" [simpleWordyId "x", simpleSymbolyId "+", simpleWordyId "y"],
|
||||
t "++;++" [simpleSymbolyId "++", Semi False, simpleSymbolyId "++"],
|
||||
t "++; woot" [simpleSymbolyId "++", Semi False, simpleWordyId "woot"],
|
||||
t "woot;woot" [simpleWordyId "woot", Semi False, simpleWordyId "woot"],
|
||||
t "woot;(woot)" [simpleWordyId "woot", Semi False, Open "(", simpleWordyId "woot", Close],
|
||||
t
|
||||
"[+1,+1]"
|
||||
[Open "[", Numeric "+1", Reserved ",", Numeric "+1", Close],
|
||||
t
|
||||
"[ +1 , +1 ]"
|
||||
[Open "[", Numeric "+1", Reserved ",", Numeric "+1", Close],
|
||||
t "-- a comment 1.0" [],
|
||||
t "\"woot\" -- a comment 1.0" [Textual "woot"],
|
||||
t "0:Int" [Numeric "0", Reserved ":", simpleWordyId "Int"],
|
||||
t "0 : Int" [Numeric "0", Reserved ":", simpleWordyId "Int"],
|
||||
t
|
||||
".Foo Foo . .foo.bar.baz"
|
||||
[ simpleWordyId ".Foo",
|
||||
simpleWordyId "Foo",
|
||||
simpleSymbolyId ".",
|
||||
simpleWordyId ".foo.bar.baz"
|
||||
],
|
||||
t ".Foo.Bar.+" [simpleSymbolyId ".Foo.Bar.+"],
|
||||
-- idents with hashes
|
||||
t "foo#bar" [WordyId "foo" (Just (ShortHash.unsafeFromText "#bar"))],
|
||||
t "+#bar" [SymbolyId "+" (Just (ShortHash.unsafeFromText "#bar"))],
|
||||
-- note - these are all the same, just with different spacing
|
||||
let ex1 = "if x then y else z"
|
||||
ex2 = unlines ["if", " x", "then", " y", "else z"]
|
||||
ex3 = unlines ["if", " x", " then", " y", "else z"]
|
||||
ex4 = unlines ["if", " x", " then", " y", "else z"]
|
||||
expected =
|
||||
[ Open "if",
|
||||
simpleWordyId "x",
|
||||
Close,
|
||||
Open "then",
|
||||
simpleWordyId "y",
|
||||
Close,
|
||||
Open "else",
|
||||
simpleWordyId "z",
|
||||
Close
|
||||
]
|
||||
in -- directly close empty = block
|
||||
tests $ map (`t` expected) [ex1, ex2, ex3, ex4],
|
||||
let ex = unlines ["test =", "", "x = 1"]
|
||||
in -- directly close nested empty blocks
|
||||
t
|
||||
ex
|
||||
[ simpleWordyId "test",
|
||||
Open "=",
|
||||
Close,
|
||||
(Semi True),
|
||||
simpleWordyId "x",
|
||||
Open "=",
|
||||
Numeric "1",
|
||||
Close
|
||||
],
|
||||
let ex = unlines ["test =", " test2 =", "", "x = 1"]
|
||||
in t
|
||||
ex
|
||||
[ simpleWordyId "test",
|
||||
Open "=",
|
||||
simpleWordyId "test2",
|
||||
Open "=",
|
||||
Close,
|
||||
Close,
|
||||
(Semi True),
|
||||
simpleWordyId "x",
|
||||
Open "=",
|
||||
Numeric "1",
|
||||
Close
|
||||
],
|
||||
let ex =
|
||||
unlines
|
||||
["if a then b", "else if c then d", "else if e then f", "else g"] -- close of the three `else` blocks
|
||||
in -- In an empty `then` clause, the `else` is interpreted as a `Reserved` token
|
||||
t
|
||||
ex
|
||||
[ Open "if",
|
||||
simpleWordyId "a",
|
||||
Close,
|
||||
Open "then",
|
||||
simpleWordyId "b",
|
||||
Close,
|
||||
Open "else",
|
||||
Open "if",
|
||||
simpleWordyId "c",
|
||||
Close,
|
||||
Open "then",
|
||||
simpleWordyId "d",
|
||||
Close,
|
||||
Open "else",
|
||||
Open "if",
|
||||
simpleWordyId "e",
|
||||
Close,
|
||||
Open "then",
|
||||
simpleWordyId "f",
|
||||
Close,
|
||||
Open "else",
|
||||
simpleWordyId "g",
|
||||
Close,
|
||||
Close,
|
||||
Close
|
||||
],
|
||||
t
|
||||
"if x then else"
|
||||
[ Open "if",
|
||||
simpleWordyId "x",
|
||||
Close,
|
||||
Open "then",
|
||||
Close,
|
||||
Open "else",
|
||||
Close
|
||||
],
|
||||
-- Empty `else` clause
|
||||
t
|
||||
"if x then 1 else"
|
||||
[ Open "if",
|
||||
simpleWordyId "x",
|
||||
Close,
|
||||
Open "then",
|
||||
Numeric "1",
|
||||
Close,
|
||||
Open "else",
|
||||
Close
|
||||
],
|
||||
-- shouldn't be too eager to find keywords at the front of identifiers,
|
||||
-- particularly for block-closing keywords (see #2727)
|
||||
tests $ do
|
||||
kw <- ["if", "then", "else"]
|
||||
suffix <- ["0", "x", "!", "'"] -- examples of wordyIdChar
|
||||
let i = kw ++ suffix
|
||||
-- a keyword at the front of an identifier should still be an identifier
|
||||
pure $ t i [simpleWordyId i],
|
||||
-- Test string literals
|
||||
t
|
||||
"\"simple string without escape characters\""
|
||||
[Textual "simple string without escape characters"],
|
||||
t
|
||||
"\"test escaped quotes \\\"in quotes\\\"\""
|
||||
[Textual "test escaped quotes \"in quotes\""],
|
||||
t "\"\\n \\t \\b \\a\"" [Textual "\n \t \b \a"],
|
||||
-- Delayed string
|
||||
t "'\"\"" [Reserved "'", Textual ""]
|
||||
]
|
||||
|
||||
t :: String -> [Lexeme] -> Test ()
|
||||
t s expected =
|
||||
let actual0 = payload <$> lexer "ignored filename" s
|
||||
actual = take (length actual0 - 2) . drop 1 $ actual0
|
||||
in scope s $
|
||||
if actual == expected
|
||||
then ok
|
||||
else do
|
||||
note $ "expected: " ++ show expected
|
||||
note $ "actual : " ++ show actual
|
||||
crash "actual != expected"
|
@ -234,7 +234,7 @@ test =
|
||||
\else c) with\n\
|
||||
\ 112 -> x", -- dodgy layout. note #517
|
||||
tc "handle bar with Pair 1 1",
|
||||
tc "handle bar with x -> foo",
|
||||
tcDiff "handle bar with x -> foo" "handle bar with 'foo",
|
||||
tcDiffRtt
|
||||
True
|
||||
"let\n\
|
||||
@ -399,8 +399,8 @@ test =
|
||||
tcDiff "'('bar)" "''bar",
|
||||
tcDiff "!('bar)" "!'bar",
|
||||
tcDiff "'(!foo)" "'!foo",
|
||||
tc "x -> '(y -> 'z)",
|
||||
tc "'(x -> '(y -> z))",
|
||||
tcDiff "x -> '(y -> 'z)" "''''z",
|
||||
tcDiff "'(x -> '(y -> z))" "''''z",
|
||||
tc "(\"a\", 2)",
|
||||
tc "(\"a\", 2, 2.0)",
|
||||
tcDiff "(2)" "2",
|
||||
@ -463,6 +463,12 @@ test =
|
||||
tcBinding 50 "+" Nothing "a b -> foo a b" "a + b = foo a b",
|
||||
tcBinding 50 "+" Nothing "a b c -> foo a b c" "(+) a b c = foo a b c",
|
||||
tcBinding 50 "." Nothing "f g x -> f (g x)" "(.) f g x = f (g x)",
|
||||
tcBinding
|
||||
50
|
||||
"foo"
|
||||
(Just "forall a. a -> a")
|
||||
"x -> let\n bar : forall a. a -> a\n bar x = x\n bar 10\n x"
|
||||
"foo : a -> a\nfoo x =\n bar : \8704 a. a -> a\n bar x = x\n bar 10\n x",
|
||||
tcBreaks
|
||||
32
|
||||
"let\n\
|
||||
|
@ -1,3 +1,7 @@
|
||||
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
|
||||
|
||||
{-# HLINT ignore "Use camelCase" #-}
|
||||
|
||||
module Unison.Test.Syntax.TypePrinter where
|
||||
|
||||
import qualified Data.Map as Map
|
||||
@ -18,7 +22,7 @@ tc_diff_rtt :: Bool -> String -> String -> PP.Width -> Test ()
|
||||
tc_diff_rtt rtt s expected width =
|
||||
let input_type = Common.t s
|
||||
get_names = PPE.fromNames Common.hqLength Unison.Builtin.names
|
||||
prettied = fmap toPlain $ PP.syntaxToColor $ prettyRaw get_names Map.empty (-1) input_type
|
||||
prettied = fmap toPlain $ PP.syntaxToColor . runPretty get_names $ prettyRaw Map.empty (-1) input_type
|
||||
actual =
|
||||
if width == 0
|
||||
then PP.renderUnbroken $ prettied
|
||||
@ -26,26 +30,24 @@ tc_diff_rtt rtt s expected width =
|
||||
actual_reparsed = Common.t actual
|
||||
in scope s $
|
||||
tests
|
||||
[ ( if actual == expected
|
||||
then ok
|
||||
else do
|
||||
note $ "expected: " ++ show expected
|
||||
note $ "actual : " ++ show actual
|
||||
note $ "expectedS:\n" ++ expected
|
||||
note $ "actualS:\n" ++ actual
|
||||
note $ "show(input) : " ++ show input_type
|
||||
note $ "prettyprint : " ++ show prettied
|
||||
crash "actual != expected"
|
||||
),
|
||||
( if (not rtt) || (input_type == actual_reparsed)
|
||||
then ok
|
||||
else do
|
||||
note $ "round trip test..."
|
||||
note $ "single parse: " ++ show input_type
|
||||
note $ "double parse: " ++ show actual_reparsed
|
||||
note $ "prettyprint : " ++ show prettied
|
||||
crash "single parse != double parse"
|
||||
)
|
||||
[ if actual == expected
|
||||
then ok
|
||||
else do
|
||||
note $ "expected: " ++ show expected
|
||||
note $ "actual : " ++ show actual
|
||||
note $ "expectedS:\n" ++ expected
|
||||
note $ "actualS:\n" ++ actual
|
||||
note $ "show(input) : " ++ show input_type
|
||||
note $ "prettyprint : " ++ show prettied
|
||||
crash "actual != expected",
|
||||
if not rtt || (input_type == actual_reparsed)
|
||||
then ok
|
||||
else do
|
||||
note $ "round trip test..."
|
||||
note $ "single parse: " ++ show input_type
|
||||
note $ "double parse: " ++ show actual_reparsed
|
||||
note $ "prettyprint : " ++ show prettied
|
||||
crash "single parse != double parse"
|
||||
]
|
||||
|
||||
-- As above, but do the round-trip test unconditionally.
|
||||
@ -87,6 +89,9 @@ test =
|
||||
tc "Pair (a -> b) (c -> d)",
|
||||
tc "Pair a b ->{e1, e2} Pair a b ->{} Pair (a -> b) d -> Pair c d",
|
||||
tc "[Pair a a]",
|
||||
tc "[a]",
|
||||
tc "[a -> b]",
|
||||
tc "[a ->{g} b]",
|
||||
tc "'a",
|
||||
tc "'Pair a a",
|
||||
tc "a -> 'b",
|
||||
|
@ -124,6 +124,57 @@ test =
|
||||
dpart = P.Join [P.Literal ".", part]
|
||||
ip = P.Join [part, P.Replicate 3 3 dpart, P.Eof]
|
||||
in P.run ip "127.0.0.1" == Just (["127", "0", "0", "1"], "")
|
||||
expect' $
|
||||
let p = P.Replicate 5 8 (P.Capture P.Digit)
|
||||
in P.run p "12345" == Just (["1", "2", "3", "4", "5"], "")
|
||||
expect' $
|
||||
let p = P.Replicate 5 8 (P.Capture P.Digit) `P.Or` P.Join []
|
||||
in P.run p "1234" == Just ([], "1234")
|
||||
expect' $
|
||||
let p = P.Replicate 5 8 (P.Capture (P.Join [P.Digit, P.Literal "z"])) `P.Or` P.Join []
|
||||
in P.run p "1z2z3z4z5z6a" == Just (["1z", "2z", "3z", "4z", "5z"], "6a")
|
||||
-- https://github.com/unisonweb/unison/issues/3530
|
||||
expectEqual Nothing $
|
||||
let p =
|
||||
P.Or
|
||||
(P.Join [P.Literal "a", P.Literal "b"])
|
||||
(P.Join [P.Literal "a", P.Literal "c"])
|
||||
in P.run p "aac"
|
||||
expectEqual (Just ([], "")) $
|
||||
let p =
|
||||
P.Or
|
||||
( P.Capture $
|
||||
( P.Or
|
||||
(P.Join [P.Literal "a", P.Literal "b"])
|
||||
(P.Join [P.Literal "a", P.Literal "c"])
|
||||
)
|
||||
)
|
||||
(P.Join [P.Literal "aa", P.Literal "cd"])
|
||||
in P.run p "aacd"
|
||||
-- this is just making sure we don't duplicate captures to our left
|
||||
-- when entering an `Or` node
|
||||
expectEqual (Just (["@"], "")) $
|
||||
let p = P.Join [P.Capture P.AnyChar, P.Or (P.Literal "c") (P.Join []), P.Literal "d"]
|
||||
in P.run p "@cd"
|
||||
expectEqual (Just (["%", "c"], "")) $
|
||||
let p = P.Join [P.Capture P.AnyChar, (P.Or (P.Capture (P.Literal "c")) (P.Join [])), P.Literal "d"]
|
||||
in P.run p "%cd"
|
||||
expectEqual (Just ([""], "ac")) $
|
||||
let p = P.Capture (P.Or (P.Join [P.Literal "a", P.Literal "b"]) (P.Join []))
|
||||
in P.run p "ac"
|
||||
expectEqual (Just ([""], "ac")) $
|
||||
let p = P.Capture (P.Replicate 0 1 (P.Join [P.Literal "a", P.Literal "b"]))
|
||||
in P.run p "ac"
|
||||
-- nested or tests
|
||||
expectEqual (Just (["zzzaaa", "!"], "!!")) $
|
||||
let p =
|
||||
P.Or
|
||||
( P.Or
|
||||
(P.Literal "a")
|
||||
(P.Join [P.Literal "z", P.Replicate 3 5 (P.Literal "z")])
|
||||
)
|
||||
(P.Join [P.Capture (P.Literal "zzzaaa"), P.Capture (P.Literal "!")])
|
||||
in P.run p "zzzaaa!!!"
|
||||
ok
|
||||
]
|
||||
where
|
||||
|
@ -23,6 +23,7 @@ flag optimized
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
U.Codebase.Branch.Diff
|
||||
Unison.Builtin
|
||||
Unison.Builtin.Decls
|
||||
Unison.Builtin.Terms
|
||||
@ -60,7 +61,7 @@ library
|
||||
Unison.Codebase.PushBehavior
|
||||
Unison.Codebase.Runtime
|
||||
Unison.Codebase.Serialization
|
||||
Unison.Codebase.ShortBranchHash
|
||||
Unison.Codebase.ShortCausalHash
|
||||
Unison.Codebase.SqliteCodebase
|
||||
Unison.Codebase.SqliteCodebase.Branch.Cache
|
||||
Unison.Codebase.SqliteCodebase.Branch.Dependencies
|
||||
@ -88,10 +89,10 @@ library
|
||||
Unison.CodebasePath
|
||||
Unison.FileParsers
|
||||
Unison.Hashing.V2.Convert
|
||||
Unison.Parser.Ann
|
||||
Unison.Parsers
|
||||
Unison.PrettyPrintEnv
|
||||
Unison.PrettyPrintEnv.FQN
|
||||
Unison.PrettyPrintEnv.MonadPretty
|
||||
Unison.PrettyPrintEnv.Names
|
||||
Unison.PrettyPrintEnv.Util
|
||||
Unison.PrettyPrintEnvDecl
|
||||
@ -119,9 +120,7 @@ library
|
||||
Unison.Share.Types
|
||||
Unison.Syntax.DeclPrinter
|
||||
Unison.Syntax.FileParser
|
||||
Unison.Syntax.Lexer
|
||||
Unison.Syntax.NamePrinter
|
||||
Unison.Syntax.Parser
|
||||
Unison.Syntax.TermParser
|
||||
Unison.Syntax.TermPrinter
|
||||
Unison.Syntax.TypeParser
|
||||
@ -135,10 +134,8 @@ library
|
||||
Unison.Typechecker.TypeVar
|
||||
Unison.UnisonFile
|
||||
Unison.UnisonFile.Env
|
||||
Unison.UnisonFile.Error
|
||||
Unison.UnisonFile.Names
|
||||
Unison.UnisonFile.Type
|
||||
Unison.Util.Bytes
|
||||
Unison.Util.Convert
|
||||
Unison.Util.CycleTable
|
||||
Unison.Util.CyclicEq
|
||||
@ -147,7 +144,7 @@ library
|
||||
Unison.Util.Exception
|
||||
Unison.Util.Logger
|
||||
Unison.Util.PinBoard
|
||||
Unison.Util.Rope
|
||||
Unison.Util.Pretty.MegaParsec
|
||||
Unison.Util.Star3
|
||||
Unison.Util.Text
|
||||
Unison.Util.Text.Pattern
|
||||
@ -213,6 +210,7 @@ library
|
||||
, extra
|
||||
, filepath
|
||||
, fingertree
|
||||
, free
|
||||
, fsnotify
|
||||
, fuzzyfind
|
||||
, generic-lens
|
||||
@ -281,9 +279,12 @@ library
|
||||
, unison-prelude
|
||||
, unison-pretty-printer
|
||||
, unison-sqlite
|
||||
, unison-syntax
|
||||
, unison-util
|
||||
, unison-util-base32hex
|
||||
, unison-util-bytes
|
||||
, unison-util-relation
|
||||
, unison-util-rope
|
||||
, unison-util-serialization
|
||||
, unliftio
|
||||
, uri-encode
|
||||
@ -317,7 +318,6 @@ test-suite parser-typechecker-tests
|
||||
Unison.Test.MCode
|
||||
Unison.Test.Referent
|
||||
Unison.Test.Syntax.FileParser
|
||||
Unison.Test.Syntax.Lexer
|
||||
Unison.Test.Syntax.TermParser
|
||||
Unison.Test.Syntax.TermPrinter
|
||||
Unison.Test.Syntax.TypePrinter
|
||||
@ -328,7 +328,6 @@ test-suite parser-typechecker-tests
|
||||
Unison.Test.Typechecker.Context
|
||||
Unison.Test.Typechecker.TypeError
|
||||
Unison.Test.UnisonSources
|
||||
Unison.Test.Util.Bytes
|
||||
Unison.Test.Util.PinBoard
|
||||
Unison.Test.Util.Pretty
|
||||
Unison.Test.Util.Relation
|
||||
@ -397,6 +396,7 @@ test-suite parser-typechecker-tests
|
||||
, filemanip
|
||||
, filepath
|
||||
, fingertree
|
||||
, free
|
||||
, fsnotify
|
||||
, fuzzyfind
|
||||
, generic-lens
|
||||
@ -467,9 +467,12 @@ test-suite parser-typechecker-tests
|
||||
, unison-prelude
|
||||
, unison-pretty-printer
|
||||
, unison-sqlite
|
||||
, unison-syntax
|
||||
, unison-util
|
||||
, unison-util-base32hex
|
||||
, unison-util-bytes
|
||||
, unison-util-relation
|
||||
, unison-util-rope
|
||||
, unison-util-serialization
|
||||
, unliftio
|
||||
, uri-encode
|
||||
|
@ -9,15 +9,16 @@ fi
|
||||
|
||||
usage() {
|
||||
echo "NOTE: must be run from the root of the project."
|
||||
echo "Usage: $0 VERSION [TARGET]"
|
||||
echo "Usage: $0 VERSION SHARE_BASE_PATH [TARGET]"
|
||||
echo "VERSION: The version you're releasing, e.g. M4a"
|
||||
echo "SHARE_BASE_PATH: Which base version to pull from share, e.g. 'unison.public.base.releases.M4'"
|
||||
echo "TARGET: The revision to make the release from, defaults to 'trunk'"
|
||||
echo ""
|
||||
echo "E.g."
|
||||
echo "$0 M4a"
|
||||
}
|
||||
|
||||
if [[ -z "$1" ]] ; then
|
||||
if [[ -z "$1" || -z "$2" ]] ; then
|
||||
usage
|
||||
exit 1
|
||||
fi
|
||||
@ -35,7 +36,8 @@ fi
|
||||
|
||||
version="${1}"
|
||||
prev_version=$(./scripts/previous-tag.sh "$version")
|
||||
target=${2:-trunk}
|
||||
share_base_path=${2}
|
||||
target=${3:-trunk}
|
||||
tag="release/${version}"
|
||||
|
||||
echo "Creating release in unison-local-ui..."
|
||||
@ -44,7 +46,7 @@ gh release create "release/${version}" --repo unisonweb/unison-local-ui --target
|
||||
echo "Kicking off release workflow in unisonweb/unison"
|
||||
git tag "${tag}" "${target}"
|
||||
git push origin "${tag}"
|
||||
gh workflow run release --repo unisonweb/unison --field "version=${version}"
|
||||
gh workflow run release --repo unisonweb/unison --field "version=${version}" --field "share_base_path=${share_base_path}"
|
||||
|
||||
echo "Kicking off Homebrew update task"
|
||||
gh workflow run release --repo unisonweb/homebrew-unison --field "version=${version}"
|
||||
|
@ -16,6 +16,7 @@ packages:
|
||||
- unison-cli
|
||||
- unison-hashing-v2
|
||||
- unison-share-api
|
||||
- unison-syntax
|
||||
- codebase2/codebase
|
||||
- codebase2/codebase-sqlite
|
||||
- codebase2/codebase-sqlite-hashing-v2
|
||||
@ -29,7 +30,9 @@ packages:
|
||||
- lib/unison-util-base32hex
|
||||
- lib/unison-util-base32hex-orphans-aeson
|
||||
- lib/unison-util-base32hex-orphans-sqlite
|
||||
- lib/unison-util-bytes
|
||||
- lib/unison-util-relation
|
||||
- lib/unison-util-rope
|
||||
- lib/unison-pretty-printer
|
||||
|
||||
#compiler-check: match-exact
|
||||
|
@ -28,6 +28,7 @@ dependencies:
|
||||
- exceptions
|
||||
- extra
|
||||
- filepath
|
||||
- free
|
||||
- fuzzyfind
|
||||
- friendly-time
|
||||
- generic-lens
|
||||
@ -75,6 +76,7 @@ dependencies:
|
||||
- unison-pretty-printer
|
||||
- unison-share-api
|
||||
- unison-sqlite
|
||||
- unison-syntax
|
||||
- unison-util
|
||||
- unison-util-base32hex
|
||||
- unison-util-relation
|
||||
|
@ -36,6 +36,9 @@ module Unison.Cli.Monad
|
||||
-- * Debug-timing actions
|
||||
time,
|
||||
|
||||
-- * Running transactions
|
||||
runTransaction,
|
||||
|
||||
-- * Misc types
|
||||
LoadSourceResult (..),
|
||||
)
|
||||
@ -61,6 +64,7 @@ import qualified U.Codebase.Branch as V2Branch
|
||||
import Unison.Auth.CredentialManager (CredentialManager)
|
||||
import Unison.Auth.HTTPClient (AuthenticatedHttpClient)
|
||||
import Unison.Codebase (Codebase)
|
||||
import qualified Unison.Codebase as Codebase
|
||||
import Unison.Codebase.Branch (Branch)
|
||||
import Unison.Codebase.Editor.Input (Input)
|
||||
import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output)
|
||||
@ -71,6 +75,7 @@ import qualified Unison.Debug as Debug
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import qualified Unison.Server.CodebaseServer as Server
|
||||
import qualified Unison.Sqlite as Sqlite
|
||||
import Unison.Symbol (Symbol)
|
||||
import qualified Unison.Syntax.Parser as Parser
|
||||
import Unison.Term (Term)
|
||||
@ -322,7 +327,7 @@ time label action =
|
||||
then Cli \env k s -> do
|
||||
systemStart <- getSystemTime
|
||||
cpuPicoStart <- getCPUTime
|
||||
r <- unCli action env k s
|
||||
a <- unCli action env (\a loopState -> pure (Success a, loopState)) s
|
||||
cpuPicoEnd <- getCPUTime
|
||||
systemEnd <- getSystemTime
|
||||
let systemDiff =
|
||||
@ -330,7 +335,7 @@ time label action =
|
||||
(diffAbsoluteTime (systemToTAITime systemEnd) (systemToTAITime systemStart))
|
||||
let cpuDiff = picosToNanos (cpuPicoEnd - cpuPicoStart)
|
||||
printf "%s: %s (cpu), %s (system)\n" label (renderNanos cpuDiff) (renderNanos systemDiff)
|
||||
pure r
|
||||
feed k a
|
||||
else action
|
||||
where
|
||||
diffTimeToNanos :: DiffTime -> Double
|
||||
@ -371,3 +376,8 @@ respondNumbered output = do
|
||||
args <- liftIO (notifyNumbered output)
|
||||
unless (null args) do
|
||||
#numberedArgs .= args
|
||||
|
||||
runTransaction :: Sqlite.Transaction a -> Cli a
|
||||
runTransaction action = do
|
||||
Env {codebase} <- ask
|
||||
liftIO (Codebase.runTransaction codebase action)
|
||||
|
@ -13,7 +13,7 @@ module Unison.Cli.MonadUtils
|
||||
|
||||
-- ** Resolving branch identifiers
|
||||
resolveAbsBranchId,
|
||||
resolveShortBranchHash,
|
||||
resolveShortCausalHash,
|
||||
|
||||
-- ** Getting/setting branches
|
||||
getRootBranch,
|
||||
@ -92,8 +92,8 @@ import Unison.Codebase.Patch (Patch (..))
|
||||
import qualified Unison.Codebase.Patch as Patch
|
||||
import Unison.Codebase.Path (Path, Path' (..))
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
|
||||
import qualified Unison.Codebase.ShortBranchHash as SBH
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import qualified Unison.Codebase.ShortCausalHash as SCH
|
||||
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
|
||||
import qualified Unison.HashQualified' as HQ'
|
||||
import Unison.NameSegment (NameSegment)
|
||||
@ -141,22 +141,22 @@ resolveSplit' =
|
||||
-- branches by path are OK - the empty branch will be returned).
|
||||
resolveAbsBranchId :: Input.AbsBranchId -> Cli (Branch IO)
|
||||
resolveAbsBranchId = \case
|
||||
Left hash -> resolveShortBranchHash hash
|
||||
Left hash -> resolveShortCausalHash hash
|
||||
Right path -> getBranchAt path
|
||||
|
||||
-- | Resolve a @ShortBranchHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found.
|
||||
resolveShortBranchHash :: ShortBranchHash -> Cli (Branch IO)
|
||||
resolveShortBranchHash hash = do
|
||||
Cli.time "resolveShortBranchHash" do
|
||||
-- | Resolve a @ShortCausalHash@ to the corresponding @Branch IO@, or fail if no such branch hash is found.
|
||||
resolveShortCausalHash :: ShortCausalHash -> Cli (Branch IO)
|
||||
resolveShortCausalHash hash = do
|
||||
Cli.time "resolveShortCausalHash" do
|
||||
Cli.Env {codebase} <- ask
|
||||
hashSet <- liftIO (Codebase.branchHashesByPrefix codebase hash)
|
||||
hashSet <- liftIO (Codebase.causalHashesByPrefix codebase hash)
|
||||
len <- liftIO (Codebase.branchHashLength codebase)
|
||||
h <-
|
||||
Set.asSingleton hashSet & onNothing do
|
||||
Cli.returnEarly
|
||||
if Set.null hashSet
|
||||
then Output.NoBranchWithHash hash
|
||||
else Output.BranchHashAmbiguous hash (Set.map (SBH.fromHash len) hashSet)
|
||||
else Output.BranchHashAmbiguous hash (Set.map (SCH.fromHash len) hashSet)
|
||||
branch <- liftIO (Codebase.getBranchForHash codebase h)
|
||||
pure (fromMaybe Branch.empty branch)
|
||||
|
||||
@ -249,11 +249,10 @@ branchExistsAtPath' :: Path' -> Cli Bool
|
||||
branchExistsAtPath' path' = do
|
||||
absPath <- resolvePath' path'
|
||||
Cli.Env {codebase} <- ask
|
||||
liftIO $ do
|
||||
causal <- Codebase.getShallowCausalFromRoot codebase Nothing (Path.unabsolute absPath)
|
||||
branch <- V2Causal.value causal
|
||||
isEmpty <- Codebase.runTransaction codebase $ V2Branch.isEmpty branch
|
||||
pure (not isEmpty)
|
||||
causal <- liftIO $ Codebase.getShallowCausalFromRoot codebase Nothing (Path.unabsolute absPath)
|
||||
branch <- liftIO $ V2Causal.value causal
|
||||
isEmpty <- Cli.runTransaction $ V2Branch.isEmpty branch
|
||||
pure (not isEmpty)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Updating branches
|
||||
|
@ -20,6 +20,7 @@ import Unison.NamesWithHistory (NamesWithHistory (..))
|
||||
import Unison.Parser.Ann (Ann (..))
|
||||
import Unison.Prelude
|
||||
import qualified Unison.Result as Result
|
||||
import qualified Unison.Sqlite as Sqlite
|
||||
import Unison.Symbol (Symbol(Symbol))
|
||||
import qualified Unison.Syntax.Lexer as L
|
||||
import qualified Unison.Syntax.Parser as Parser
|
||||
@ -42,7 +43,7 @@ typecheck ambient names sourceName source =
|
||||
Cli.time "typecheck" do
|
||||
Cli.Env {codebase, generateUniqueName} <- ask
|
||||
uniqueName <- liftIO generateUniqueName
|
||||
(liftIO . Result.getResult) $
|
||||
(Cli.runTransaction . Result.getResult) $
|
||||
parseAndSynthesizeFile
|
||||
ambient
|
||||
(((<> Builtin.typeLookup) <$>) . Codebase.typeLookupForDependencies codebase)
|
||||
@ -65,7 +66,7 @@ typecheckHelper ::
|
||||
)
|
||||
typecheckHelper codebase generateUniqueName ambient names sourceName source = do
|
||||
uniqueName <- liftIO generateUniqueName
|
||||
(liftIO . Result.getResult) $
|
||||
(liftIO . Codebase.runTransaction codebase . Result.getResult) $
|
||||
parseAndSynthesizeFile
|
||||
ambient
|
||||
(((<> Builtin.typeLookup) <$>) . Codebase.typeLookupForDependencies codebase)
|
||||
@ -80,37 +81,38 @@ typecheckTerm ::
|
||||
(Seq (Result.Note Symbol Ann))
|
||||
(Type Symbol Ann))
|
||||
typecheckTerm tm = do
|
||||
Cli.Env { generateUniqueName } <- ask
|
||||
Cli.Env { codebase, generateUniqueName } <- ask
|
||||
un <- liftIO generateUniqueName
|
||||
let v = Symbol 0 (Var.Inference Var.Other)
|
||||
fmap extract <$>
|
||||
typecheckFile' [] (UF.UnisonFileId mempty mempty [(v, tm)] mempty)
|
||||
liftIO $ fmap extract <$>
|
||||
Codebase.runTransaction codebase (typecheckFile' codebase [] (UF.UnisonFileId mempty mempty [(v, tm)] mempty))
|
||||
where
|
||||
extract tuf
|
||||
| [[(_,_,ty)]] <- UF.topLevelComponents' tuf = ty
|
||||
| otherwise = error "internal error: typecheckTerm"
|
||||
|
||||
typecheckFile' ::
|
||||
Codebase m Symbol Ann ->
|
||||
[Type Symbol Ann] ->
|
||||
UF.UnisonFile Symbol Ann ->
|
||||
Cli
|
||||
Sqlite.Transaction
|
||||
( Result.Result
|
||||
(Seq (Result.Note Symbol Ann))
|
||||
(UF.TypecheckedUnisonFile Symbol Ann))
|
||||
typecheckFile' ambient file = do
|
||||
Cli.Env {codebase} <- ask
|
||||
typecheckFile' codebase ambient file = do
|
||||
typeLookup <-
|
||||
liftIO $
|
||||
(<> Builtin.typeLookup)
|
||||
<$> Codebase.typeLookupForDependencies codebase (UF.dependencies file)
|
||||
(<> Builtin.typeLookup)
|
||||
<$> Codebase.typeLookupForDependencies codebase (UF.dependencies file)
|
||||
pure $ synthesizeFile' ambient typeLookup file
|
||||
|
||||
typecheckFile ::
|
||||
Codebase m Symbol Ann ->
|
||||
[Type Symbol Ann] ->
|
||||
UF.UnisonFile Symbol Ann ->
|
||||
Cli
|
||||
Sqlite.Transaction
|
||||
( Result.Result
|
||||
(Seq (Result.Note Symbol Ann))
|
||||
(Either Names (UF.TypecheckedUnisonFile Symbol Ann))
|
||||
)
|
||||
typecheckFile ambient file = fmap Right <$> typecheckFile' ambient file
|
||||
typecheckFile codebase ambient file =
|
||||
fmap Right <$> typecheckFile' codebase ambient file
|
||||
|
@ -40,6 +40,8 @@ import System.Directory
|
||||
)
|
||||
import System.FilePath ((</>))
|
||||
import qualified Text.Megaparsec as P
|
||||
import qualified U.Codebase.Branch.Diff as V2Branch
|
||||
import qualified U.Codebase.Causal as V2Causal
|
||||
import U.Codebase.HashTags (CausalHash (..))
|
||||
import qualified U.Codebase.Reflog as Reflog
|
||||
import qualified U.Codebase.Sqlite.Operations as Ops
|
||||
@ -55,6 +57,7 @@ import Unison.Cli.Monad (Cli)
|
||||
import qualified Unison.Cli.Monad as Cli
|
||||
import qualified Unison.Cli.MonadUtils as Cli
|
||||
import Unison.Cli.NamesUtils (basicParseNames, basicPrettyPrintNamesA, displayNames, findHistoricalHQs, getBasicPrettyPrintNames, makeHistoricalParsingNames, makePrintNamesFromLabeled', makeShadowedPrintNamesFromHQ)
|
||||
import Unison.Cli.TypeCheck (typecheck)
|
||||
import Unison.Cli.UnisonConfigUtils (gitUrlKey, remoteMappingKey)
|
||||
import Unison.Codebase (Codebase, Preprocessing (..), PushGitBranchOpts (..))
|
||||
import qualified Unison.Codebase as Codebase
|
||||
@ -111,7 +114,7 @@ import qualified Unison.Codebase.Path.Parse as Path
|
||||
import Unison.Codebase.PushBehavior (PushBehavior)
|
||||
import qualified Unison.Codebase.PushBehavior as PushBehavior
|
||||
import qualified Unison.Codebase.Runtime as Runtime
|
||||
import qualified Unison.Codebase.ShortBranchHash as SBH
|
||||
import qualified Unison.Codebase.ShortCausalHash as SCH
|
||||
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
|
||||
import qualified Unison.Codebase.SyncMode as SyncMode
|
||||
import qualified Unison.Syntax.TermPrinter as TP
|
||||
@ -171,6 +174,7 @@ import qualified Unison.Share.Sync as Share
|
||||
import qualified Unison.Share.Sync.Types as Share
|
||||
import Unison.Share.Types (codeserverBaseURL)
|
||||
import qualified Unison.ShortHash as SH
|
||||
import qualified Unison.Sqlite as Sqlite
|
||||
import Unison.Symbol (Symbol)
|
||||
import qualified Unison.Sync.Types as Share (Path (..), hashJWTHash)
|
||||
import qualified Unison.Syntax.Lexer as L
|
||||
@ -276,15 +280,15 @@ loop e = do
|
||||
#latestTypecheckedFile .= (Just unisonFile)
|
||||
|
||||
case e of
|
||||
Left (IncomingRootBranch hashes) -> do
|
||||
Left (IncomingRootBranch hashes) -> Cli.time "IncomingRootBranch" do
|
||||
Cli.Env {codebase} <- ask
|
||||
sbhLength <- liftIO (Codebase.branchHashLength codebase)
|
||||
schLength <- liftIO (Codebase.branchHashLength codebase)
|
||||
rootBranch <- Cli.getRootBranch
|
||||
Cli.respond $
|
||||
WarnIncomingRootBranch
|
||||
(SBH.fromHash sbhLength $ Branch.headHash rootBranch)
|
||||
(Set.map (SBH.fromHash sbhLength) hashes)
|
||||
Left (UnisonFileChanged sourceName text) ->
|
||||
(SCH.fromHash schLength $ Branch.headHash rootBranch)
|
||||
(Set.map (SCH.fromHash schLength) hashes)
|
||||
Left (UnisonFileChanged sourceName text) -> Cli.time "UnisonFileChanged" do
|
||||
-- We skip this update if it was programmatically generated
|
||||
Cli.getLatestFile >>= \case
|
||||
Just (_, True) -> (#latestFile . _Just . _2) .= False
|
||||
@ -354,6 +358,7 @@ loop e = do
|
||||
Path.HQSplit' ->
|
||||
Cli ()
|
||||
delete getTerms getTypes hq' = do
|
||||
Cli.Env {codebase} <- ask
|
||||
hq <- Cli.resolveSplit' hq'
|
||||
terms <- getTerms hq
|
||||
types <- getTypes hq
|
||||
@ -366,7 +371,7 @@ loop e = do
|
||||
toRel = R.fromList . fmap (name,) . toList
|
||||
-- these names are relative to the root
|
||||
toDelete = Names (toRel terms) (toRel types)
|
||||
endangerments <- getEndangeredDependents toDelete rootNames
|
||||
endangerments <- Cli.runTransaction (getEndangeredDependents codebase toDelete rootNames)
|
||||
if null endangerments
|
||||
then do
|
||||
let makeDeleteTermNames = map (BranchUtil.makeDeleteTermName resolvedPath) . Set.toList $ terms
|
||||
@ -380,7 +385,7 @@ loop e = do
|
||||
else do
|
||||
ppeDecl <- currentPrettyPrintEnvDecl Backend.Within
|
||||
Cli.respondNumbered (CantDeleteDefinitions ppeDecl endangerments)
|
||||
in case input of
|
||||
in Cli.time "InputPattern" case input of
|
||||
ApiI -> do
|
||||
Cli.Env {serverBaseUrl} <- ask
|
||||
whenJust serverBaseUrl \baseUrl ->
|
||||
@ -397,18 +402,18 @@ loop e = do
|
||||
Cli.respond $ PrintMessage pretty
|
||||
ShowReflogI -> do
|
||||
Cli.Env {codebase} <- ask
|
||||
sbhLength <- liftIO (Codebase.branchHashLength codebase)
|
||||
schLength <- liftIO (Codebase.branchHashLength codebase)
|
||||
let numEntriesToShow = 500
|
||||
entries <- liftIO (Codebase.getReflog codebase numEntriesToShow) <&> fmap (first $ SBH.fromHash sbhLength)
|
||||
entries <- liftIO (Codebase.getReflog codebase numEntriesToShow) <&> fmap (first $ SCH.fromHash schLength)
|
||||
let moreEntriesToLoad = length entries == numEntriesToShow
|
||||
let expandedEntries = List.unfoldr expandEntries (entries, Nothing, moreEntriesToLoad)
|
||||
let numberedEntries = expandedEntries <&> \(_time, hash, _reason) -> "#" <> SBH.toString hash
|
||||
let numberedEntries = expandedEntries <&> \(_time, hash, _reason) -> "#" <> SCH.toString hash
|
||||
#numberedArgs .= numberedEntries
|
||||
Cli.respond $ ShowReflog expandedEntries
|
||||
where
|
||||
expandEntries ::
|
||||
([Reflog.Entry SBH.ShortBranchHash Text], Maybe SBH.ShortBranchHash, Bool) ->
|
||||
Maybe ((Maybe UTCTime, SBH.ShortBranchHash, Text), ([Reflog.Entry SBH.ShortBranchHash Text], Maybe SBH.ShortBranchHash, Bool))
|
||||
([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool) ->
|
||||
Maybe ((Maybe UTCTime, SCH.ShortCausalHash, Text), ([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool))
|
||||
expandEntries ([], Just expectedHash, moreEntriesToLoad) =
|
||||
if moreEntriesToLoad
|
||||
then Nothing
|
||||
@ -428,7 +433,7 @@ loop e = do
|
||||
Cli.time "reset-root" do
|
||||
newRoot <-
|
||||
case src0 of
|
||||
Left hash -> Cli.resolveShortBranchHash hash
|
||||
Left hash -> Cli.resolveShortCausalHash hash
|
||||
Right path' -> Cli.expectBranchAtPath' path'
|
||||
description <- inputDescription input
|
||||
Cli.updateRoot newRoot description
|
||||
@ -436,7 +441,7 @@ loop e = do
|
||||
ForkLocalBranchI src0 dest0 -> do
|
||||
srcb <-
|
||||
case src0 of
|
||||
Left hash -> Cli.resolveShortBranchHash hash
|
||||
Left hash -> Cli.resolveShortCausalHash hash
|
||||
Right path' -> Cli.expectBranchAtPath' path'
|
||||
Cli.assertNoBranchAtPath' dest0
|
||||
description <- inputDescription input
|
||||
@ -549,6 +554,7 @@ loop e = do
|
||||
Cli.respond DeletedEverything
|
||||
else Cli.respond DeleteEverythingConfirmation
|
||||
DeleteBranchI insistence (Just p) -> do
|
||||
Cli.Env {codebase} <- ask
|
||||
branch <- Cli.expectBranchAtPath' (Path.unsplit' p)
|
||||
description <- inputDescription input
|
||||
absPath <- Cli.resolveSplit' p
|
||||
@ -558,7 +564,7 @@ loop e = do
|
||||
(Branch.toNames (Branch.head branch))
|
||||
afterDelete <- do
|
||||
rootNames <- Branch.toNames <$> Cli.getRootBranch0
|
||||
endangerments <- getEndangeredDependents toDelete rootNames
|
||||
endangerments <- Cli.runTransaction (getEndangeredDependents codebase toDelete rootNames)
|
||||
case (null endangerments, insistence) of
|
||||
(True, _) -> pure (Cli.respond Success)
|
||||
(False, Force) -> do
|
||||
@ -598,27 +604,27 @@ loop e = do
|
||||
HistoryI resultsCap diffCap from -> do
|
||||
branch <-
|
||||
case from of
|
||||
Left hash -> Cli.resolveShortBranchHash hash
|
||||
Left hash -> Cli.resolveShortCausalHash hash
|
||||
Right path' -> do
|
||||
path <- Cli.resolvePath' path'
|
||||
Cli.getMaybeBranchAt path & onNothingM (Cli.returnEarly (CreatedNewBranch path))
|
||||
Cli.Env {codebase} <- ask
|
||||
sbhLength <- liftIO (Codebase.branchHashLength codebase)
|
||||
history <- liftIO (doHistory sbhLength 0 branch [])
|
||||
schLength <- liftIO (Codebase.branchHashLength codebase)
|
||||
history <- liftIO (doHistory schLength 0 branch [])
|
||||
Cli.respondNumbered history
|
||||
where
|
||||
doHistory :: Int -> Int -> Branch IO -> [(Causal.CausalHash, NamesWithHistory.Diff)] -> IO NumberedOutput
|
||||
doHistory sbhLength !n b acc =
|
||||
doHistory schLength !n b acc =
|
||||
if maybe False (n >=) resultsCap
|
||||
then pure (History diffCap sbhLength acc (PageEnd (Branch.headHash b) n))
|
||||
then pure (History diffCap schLength acc (PageEnd (Branch.headHash b) n))
|
||||
else case Branch._history b of
|
||||
Causal.One {} -> pure (History diffCap sbhLength acc (EndOfLog $ Branch.headHash b))
|
||||
Causal.One {} -> pure (History diffCap schLength acc (EndOfLog $ Branch.headHash b))
|
||||
Causal.Merge _ _ _ tails ->
|
||||
pure (History diffCap sbhLength acc (MergeTail (Branch.headHash b) $ Map.keys tails))
|
||||
pure (History diffCap schLength acc (MergeTail (Branch.headHash b) $ Map.keys tails))
|
||||
Causal.Cons _ _ _ tail -> do
|
||||
b' <- fmap Branch.Branch $ snd tail
|
||||
let elem = (Branch.headHash b, Branch.namesDiff b' b)
|
||||
doHistory sbhLength (n + 1) b' (elem : acc)
|
||||
doHistory schLength (n + 1) b' (elem : acc)
|
||||
UndoI -> do
|
||||
rootBranch <- Cli.getRootBranch
|
||||
(_, prev) <-
|
||||
@ -840,7 +846,7 @@ loop e = do
|
||||
AuthorInfo.createAuthorInfo Ann.External authorFullName
|
||||
description <- inputDescription input
|
||||
-- add the new definitions to the codebase and to the namespace
|
||||
traverse_ (liftIO . uncurry3 (Codebase.putTerm codebase)) [guid, author, copyrightHolder]
|
||||
Cli.runTransaction (traverse_ (uncurry3 (Codebase.putTerm codebase)) [guid, author, copyrightHolder])
|
||||
authorPath <- Cli.resolveSplit' authorPath'
|
||||
copyrightHolderPath <- Cli.resolveSplit' (base |> "copyrightHolders" |> authorNameSegment)
|
||||
guidPath <- Cli.resolveSplit' (authorPath' |> "guid")
|
||||
@ -950,11 +956,11 @@ loop e = do
|
||||
#numberedArgs .= fmap entryToHQString entries
|
||||
getRoot <- atomically . STM.readTMVar <$> use #root
|
||||
let buildPPE = do
|
||||
sbhLength <- liftIO (Codebase.branchHashLength codebase)
|
||||
schLength <- liftIO (Codebase.branchHashLength codebase)
|
||||
rootBranch <- getRoot
|
||||
pure $
|
||||
Backend.basicSuffixifiedNames
|
||||
sbhLength
|
||||
schLength
|
||||
rootBranch
|
||||
(Backend.AllNames (Path.unabsolute pathArgAbs))
|
||||
Cli.respond $ ListShallow buildPPE entries
|
||||
@ -1042,8 +1048,11 @@ loop e = do
|
||||
|
||||
replaceTerms :: Reference -> Reference -> Cli ()
|
||||
replaceTerms fr tr = do
|
||||
mft <- liftIO (Codebase.getTypeOfTerm codebase fr)
|
||||
mtt <- liftIO (Codebase.getTypeOfTerm codebase tr)
|
||||
(mft, mtt) <-
|
||||
Cli.runTransaction do
|
||||
mft <- Codebase.getTypeOfTerm codebase fr
|
||||
mtt <- Codebase.getTypeOfTerm codebase tr
|
||||
pure (mft, mtt)
|
||||
let termNotFound =
|
||||
Cli.returnEarly
|
||||
. TermNotFound'
|
||||
@ -1119,7 +1128,7 @@ loop e = do
|
||||
let sr = Slurp.slurpFile uf vars Slurp.AddOp currentNames
|
||||
let adds = SlurpResult.adds sr
|
||||
Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf)
|
||||
liftIO . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf
|
||||
Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf
|
||||
ppe <- prettyPrintEnvDecl =<< displayNames uf
|
||||
Cli.respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr
|
||||
addDefaultMetadata adds
|
||||
@ -1134,7 +1143,7 @@ loop e = do
|
||||
let sr = Slurp.slurpFile uf (Set.singleton resultVar) Slurp.AddOp currentNames
|
||||
let adds = SlurpResult.adds sr
|
||||
Cli.stepAtNoSync (Path.unabsolute currentPath, doSlurpAdds adds uf)
|
||||
liftIO . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf
|
||||
Cli.runTransaction . Codebase.addDefsToCodebase codebase . SlurpResult.filterUnisonFile sr $ uf
|
||||
ppe <- prettyPrintEnvDecl =<< displayNames uf
|
||||
Cli.returnEarly $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr
|
||||
addDefaultMetadata adds
|
||||
@ -1219,7 +1228,7 @@ loop e = do
|
||||
let noMain = Cli.returnEarly $ NoMainFunction (HQ.toString main) ppe [testType]
|
||||
case toList results of
|
||||
[Referent.Ref ref] -> do
|
||||
liftIO (loadTypeOfTerm codebase (Referent.Ref ref)) >>= \case
|
||||
Cli.runTransaction (loadTypeOfTerm codebase (Referent.Ref ref)) >>= \case
|
||||
Just typ | Typechecker.isSubtype typ testType -> pure ref
|
||||
_ -> noMain
|
||||
_ -> noMain
|
||||
@ -1244,7 +1253,7 @@ loop e = do
|
||||
(Map.fromList Builtin.builtinEffectDecls)
|
||||
[Builtin.builtinTermsSrc Intrinsic]
|
||||
mempty
|
||||
liftIO (Codebase.addDefsToCodebase codebase uf)
|
||||
Cli.runTransaction (Codebase.addDefsToCodebase codebase uf)
|
||||
-- add the names; note, there are more names than definitions
|
||||
-- due to builtin terms; so we don't just reuse `uf` above.
|
||||
let srcb = BranchUtil.fromNames Builtin.names0
|
||||
@ -1263,9 +1272,10 @@ loop e = do
|
||||
(Map.fromList Builtin.builtinEffectDecls)
|
||||
[Builtin.builtinTermsSrc Intrinsic]
|
||||
mempty
|
||||
liftIO (Codebase.addDefsToCodebase codebase uf)
|
||||
-- these have not necessarily been added yet
|
||||
liftIO (Codebase.addDefsToCodebase codebase IOSource.typecheckedFile')
|
||||
Cli.runTransaction do
|
||||
Codebase.addDefsToCodebase codebase uf
|
||||
-- these have not necessarily been added yet
|
||||
Codebase.addDefsToCodebase codebase IOSource.typecheckedFile'
|
||||
|
||||
-- add the names; note, there are more names than definitions
|
||||
-- due to builtin terms; so we don't just reuse `uf` above.
|
||||
@ -1295,7 +1305,7 @@ loop e = do
|
||||
for_ lds \ld -> do
|
||||
dependencies :: Set Reference <-
|
||||
let tp r@(Reference.DerivedId i) =
|
||||
liftIO (Codebase.getTypeDeclaration codebase i) <&> \case
|
||||
Codebase.getTypeDeclaration codebase i <&> \case
|
||||
Nothing -> error $ "What happened to " ++ show i ++ "?"
|
||||
Just decl -> Set.delete r . DD.dependencies $ DD.asDataDecl decl
|
||||
tp _ = pure mempty
|
||||
@ -1304,13 +1314,13 @@ loop e = do
|
||||
Nothing -> error $ "What happened to " ++ show i ++ "?"
|
||||
Just tm -> Set.delete r $ Term.dependencies tm
|
||||
tm con@(Referent.Con (ConstructorReference (Reference.DerivedId i) cid) _ct) =
|
||||
liftIO (Codebase.getTypeDeclaration codebase i) <&> \case
|
||||
Cli.runTransaction (Codebase.getTypeDeclaration codebase i) <&> \case
|
||||
Nothing -> error $ "What happened to " ++ show i ++ "?"
|
||||
Just decl -> case DD.typeOfConstructor (DD.asDataDecl decl) cid of
|
||||
Nothing -> error $ "What happened to " ++ show con ++ "?"
|
||||
Just tp -> Type.dependencies tp
|
||||
tm _ = pure mempty
|
||||
in LD.fold tp tm ld
|
||||
in LD.fold (Cli.runTransaction . tp) tm ld
|
||||
(missing, names0) <- liftIO (Branch.findHistoricalRefs' dependencies rootBranch)
|
||||
let types = R.toList $ Names.types names0
|
||||
let terms = fmap (second Referent.toReference) $ R.toList $ Names.terms names0
|
||||
@ -1357,7 +1367,7 @@ loop e = do
|
||||
Causal.Merge h _bh b (Map.toList -> tails) -> goBranch h b (map fst tails) (tails ++ queue)
|
||||
goBranch :: forall m. Monad m => Branch.CausalHash -> Branch0 m -> [Branch.CausalHash] -> [(Branch.CausalHash, m (Branch.UnwrappedBranch m))] -> StateT (Set Branch.CausalHash) m ()
|
||||
goBranch h b (Set.fromList -> causalParents) queue = case b of
|
||||
Branch0 terms0 types0 children0 patches0 _ _ _ _ _ _ ->
|
||||
Branch0 terms0 types0 children0 patches0 _ _ _ _ _ _ _ ->
|
||||
let wrangleMetadata :: (Ord r, Ord n) => Metadata.Star r n -> r -> (r, (Set n, Set Metadata.Value))
|
||||
wrangleMetadata s r =
|
||||
(r, (R.lookupDom r $ Star3.d1 s, Set.map snd . R.lookupDom r $ Star3.d3 s))
|
||||
@ -1399,9 +1409,26 @@ loop e = do
|
||||
Cli.Env {codebase} <- ask
|
||||
liftIO (Codebase.clearWatches codebase)
|
||||
DebugDoctorI {} -> do
|
||||
Cli.Env {codebase} <- ask
|
||||
r <- liftIO (Codebase.runTransaction codebase IntegrityCheck.integrityCheckFullCodebase)
|
||||
r <- Cli.runTransaction IntegrityCheck.integrityCheckFullCodebase
|
||||
Cli.respond (IntegrityCheck r)
|
||||
DebugNameDiffI fromSCH toSCH -> do
|
||||
Cli.Env {codebase} <- ask
|
||||
schLen <- liftIO $ Codebase.branchHashLength codebase
|
||||
fromCHs <- liftIO $ Codebase.causalHashesByPrefix codebase fromSCH
|
||||
toCHs <- liftIO $ Codebase.causalHashesByPrefix codebase toSCH
|
||||
(fromCH, toCH) <- case (Set.toList fromCHs, Set.toList toCHs) of
|
||||
((_ : _ : _), _) -> Cli.returnEarly $ Output.BranchHashAmbiguous fromSCH (Set.map (SCH.fromHash schLen) fromCHs)
|
||||
([], _) -> Cli.returnEarly $ Output.NoBranchWithHash fromSCH
|
||||
(_, []) -> Cli.returnEarly $ Output.NoBranchWithHash toSCH
|
||||
(_, (_ : _ : _)) -> Cli.returnEarly $ Output.BranchHashAmbiguous toSCH (Set.map (SCH.fromHash schLen) toCHs)
|
||||
([fromCH], [toCH]) -> pure (fromCH, toCH)
|
||||
output <- liftIO do
|
||||
fromBranch <- (Codebase.getShallowCausalForHash codebase $ Cv.causalHash1to2 fromCH) >>= V2Causal.value
|
||||
toBranch <- (Codebase.getShallowCausalForHash codebase $ Cv.causalHash1to2 toCH) >>= V2Causal.value
|
||||
treeDiff <- V2Branch.diffBranches fromBranch toBranch
|
||||
let nameChanges = V2Branch.nameChanges Nothing treeDiff
|
||||
pure (DisplayDebugNameDiff nameChanges)
|
||||
Cli.respond output
|
||||
DeprecateTermI {} -> Cli.respond NotImplemented
|
||||
DeprecateTypeI {} -> Cli.respond NotImplemented
|
||||
RemoveTermReplacementI from patchPath -> doRemoveReplacement from patchPath True
|
||||
@ -1587,6 +1614,7 @@ inputDescription input =
|
||||
CreatePullRequestI {} -> wat
|
||||
DebugClearWatchI {} -> wat
|
||||
DebugDoctorI {} -> wat
|
||||
DebugNameDiffI {} -> wat
|
||||
DebugDumpNamespaceSimpleI {} -> wat
|
||||
DebugDumpNamespacesI {} -> wat
|
||||
DebugNumberedArgsI {} -> wat
|
||||
@ -1626,7 +1654,7 @@ inputDescription input =
|
||||
VersionI -> wat
|
||||
DebugTabCompletionI _input -> wat
|
||||
where
|
||||
hp' :: Either SBH.ShortBranchHash Path' -> Cli Text
|
||||
hp' :: Either SCH.ShortCausalHash Path' -> Cli Text
|
||||
hp' = either (pure . Text.pack . show) p'
|
||||
p' :: Path' -> Cli Text
|
||||
p' = fmap tShow . Cli.resolvePath'
|
||||
@ -1727,7 +1755,7 @@ handleFindI isVerbose fscope ws input = do
|
||||
pure $ uniqueBy SR.toReferent srs
|
||||
let respondResults results = do
|
||||
#numberedArgs .= fmap searchResultToHQString results
|
||||
results' <- liftIO (Backend.loadSearchResults codebase results)
|
||||
results' <- Cli.runTransaction (Backend.loadSearchResults codebase results)
|
||||
ppe <-
|
||||
suffixifiedPPE
|
||||
=<< makePrintNamesFromLabeled'
|
||||
@ -1753,12 +1781,12 @@ handleDependents hq = do
|
||||
for_ lds \ld -> do
|
||||
-- The full set of dependent references, any number of which may not have names in the current namespace.
|
||||
dependents <-
|
||||
let tp r = liftIO (Codebase.dependents codebase Queries.ExcludeOwnComponent r)
|
||||
let tp r = Codebase.dependents codebase Queries.ExcludeOwnComponent r
|
||||
tm = \case
|
||||
Referent.Ref r -> liftIO (Codebase.dependents codebase Queries.ExcludeOwnComponent r)
|
||||
Referent.Ref r -> Codebase.dependents codebase Queries.ExcludeOwnComponent r
|
||||
Referent.Con (ConstructorReference r _cid) _ct ->
|
||||
liftIO (Codebase.dependents codebase Queries.ExcludeOwnComponent r)
|
||||
in LD.fold tp tm ld
|
||||
Codebase.dependents codebase Queries.ExcludeOwnComponent r
|
||||
in Cli.runTransaction (LD.fold tp tm ld)
|
||||
-- Use an unsuffixified PPE here, so we display full names (relative to the current path), rather than the shortest possible
|
||||
-- unambiguous name.
|
||||
ppe <- PPE.unsuffixifiedPPE <$> currentPrettyPrintEnvDecl Backend.Within
|
||||
@ -1849,13 +1877,13 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do
|
||||
Cli.ioE (Codebase.pushGitBranch codebase repo opts (\_remoteRoot -> pure (Right sourceBranch))) \err ->
|
||||
Cli.returnEarly (Output.GitError err)
|
||||
_branch <- result & onLeft Cli.returnEarly
|
||||
sbhLength <- liftIO (Codebase.branchHashLength codebase)
|
||||
schLength <- liftIO (Codebase.branchHashLength codebase)
|
||||
Cli.respond $
|
||||
GistCreated
|
||||
( ReadRemoteNamespaceGit
|
||||
ReadGitRemoteNamespace
|
||||
{ repo = writeToReadGit repo,
|
||||
sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)),
|
||||
sch = Just (SCH.fromHash schLength (Branch.headHash sourceBranch)),
|
||||
path = Path.empty
|
||||
}
|
||||
)
|
||||
@ -1883,7 +1911,7 @@ handlePushToUnisonShare remote@WriteShareRemotePath {server, repo, path = remote
|
||||
|
||||
-- doesn't handle the case where a non-existent path is supplied
|
||||
localCausalHash <-
|
||||
liftIO (Codebase.runTransaction codebase (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath)))) & onNothingM do
|
||||
Cli.runTransaction (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath))) & onNothingM do
|
||||
Cli.returnEarly (EmptyPush . Path.absoluteToPath' $ localPath)
|
||||
|
||||
let checkAndSetPush :: Maybe Hash32 -> IO (Either (Share.SyncError Share.CheckAndSetPushError) ())
|
||||
@ -2243,13 +2271,20 @@ doDisplay outputLoc names tm = do
|
||||
Just (tm, _) -> pure (Just $ Term.unannotate tm)
|
||||
loadTerm _ = pure Nothing
|
||||
loadDecl (Reference.DerivedId r) = case Map.lookup r typs of
|
||||
Nothing -> fmap (fmap $ DD.amap (const ())) $ liftIO (Codebase.getTypeDeclaration codebase r)
|
||||
Nothing -> fmap (fmap $ DD.amap (const ())) $ Codebase.getTypeDeclaration codebase r
|
||||
Just decl -> pure (Just $ DD.amap (const ()) decl)
|
||||
loadDecl _ = pure Nothing
|
||||
loadTypeOfTerm' (Referent.Ref (Reference.DerivedId r))
|
||||
| Just (_, ty) <- Map.lookup r tms = pure $ Just (void ty)
|
||||
loadTypeOfTerm' r = fmap (fmap void) . loadTypeOfTerm codebase $ r
|
||||
rendered <- DisplayValues.displayTerm ppe (liftIO . loadTerm) (liftIO . loadTypeOfTerm') evalTerm loadDecl tm
|
||||
rendered <-
|
||||
DisplayValues.displayTerm
|
||||
ppe
|
||||
(liftIO . loadTerm)
|
||||
(Cli.runTransaction . loadTypeOfTerm')
|
||||
evalTerm
|
||||
(Cli.runTransaction . loadDecl)
|
||||
tm
|
||||
Cli.respond $ DisplayRendered loc rendered
|
||||
|
||||
getLinks ::
|
||||
@ -2288,7 +2323,7 @@ getLinks' src selection0 = do
|
||||
allMd' = maybe allMd (`R.restrictDom` allMd) selection0
|
||||
-- then list the values after filtering by type
|
||||
allRefs :: Set Reference = R.ran allMd'
|
||||
sigs <- for (toList allRefs) (liftIO . loadTypeOfTerm codebase . Referent.Ref)
|
||||
sigs <- Cli.runTransaction (for (toList allRefs) (loadTypeOfTerm codebase . Referent.Ref))
|
||||
let deps =
|
||||
Set.map LD.termRef allRefs
|
||||
<> Set.unions [Set.map LD.typeRef . Type.dependencies $ t | Just t <- sigs]
|
||||
@ -2313,8 +2348,9 @@ propagatePatch inputDescription patch scopePath = do
|
||||
-- | 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 <- checkTodo patch names0
|
||||
todo <- Cli.runTransaction (checkTodo codebase patch names0)
|
||||
if TO.noConflicts todo && TO.noEdits todo
|
||||
then Cli.respond NoConflictsOrEdits
|
||||
else do
|
||||
@ -2328,22 +2364,21 @@ doShowTodoOutput patch scopePath = do
|
||||
prettyPrintEnvDecl names
|
||||
Cli.respondNumbered $ TodoOutput ppe todo
|
||||
|
||||
checkTodo :: Patch -> Names -> Cli (TO.TodoOutput Symbol Ann)
|
||||
checkTodo patch names0 = do
|
||||
Cli.Env {codebase} <- ask
|
||||
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 -> IO (Set Reference)
|
||||
getDependents :: Reference -> Sqlite.Transaction (Set Reference)
|
||||
getDependents ref = do
|
||||
dependents <- Codebase.dependents codebase Queries.ExcludeSelf ref
|
||||
pure (dependents & removeEditedThings & removeNamelessThings)
|
||||
-- (r,r2) ∈ dependsOn if r depends on r2, excluding self-references (i.e. (r,r))
|
||||
dependsOn <- liftIO (Monoid.foldMapM (\ref -> R.fromManyDom <$> getDependents ref <*> pure ref) edited)
|
||||
dependsOn <- Monoid.foldMapM (\ref -> R.fromManyDom <$> getDependents ref <*> pure ref) edited
|
||||
let dirty = R.dom dependsOn
|
||||
transitiveDirty <- liftIO (transitiveClosure getDependents dirty)
|
||||
(frontierTerms, frontierTypes) <- loadDisplayInfo (R.ran dependsOn)
|
||||
(dirtyTerms, dirtyTypes) <- loadDisplayInfo dirty
|
||||
transitiveDirty <- transitiveClosure getDependents dirty
|
||||
(frontierTerms, frontierTypes) <- loadDisplayInfo codebase (R.ran dependsOn)
|
||||
(dirtyTerms, dirtyTypes) <- loadDisplayInfo codebase dirty
|
||||
pure $
|
||||
TO.TodoOutput
|
||||
(Set.size transitiveDirty)
|
||||
@ -2744,27 +2779,27 @@ loadPropagateDiffDefaultPatch inputDescription maybeDest0 dest = do
|
||||
-- definition is going "extinct"). In this case we may wish to take some action or warn the
|
||||
-- user about these "endangered" definitions which would now contain unnamed references.
|
||||
getEndangeredDependents ::
|
||||
Codebase m v a ->
|
||||
-- | Which names we want to delete
|
||||
Names ->
|
||||
-- | All names from the root branch
|
||||
Names ->
|
||||
-- | map from references going extinct to the set of endangered dependents
|
||||
Cli (Map LabeledDependency (NESet LabeledDependency))
|
||||
getEndangeredDependents namesToDelete rootNames = do
|
||||
Cli.Env {codebase} <- ask
|
||||
Sqlite.Transaction (Map LabeledDependency (NESet LabeledDependency))
|
||||
getEndangeredDependents codebase namesToDelete rootNames = do
|
||||
let remainingNames :: Names
|
||||
remainingNames = rootNames `Names.difference` namesToDelete
|
||||
refsToDelete, remainingRefs, extinct :: Set LabeledDependency
|
||||
refsToDelete = Names.labeledReferences namesToDelete
|
||||
remainingRefs = Names.labeledReferences remainingNames -- left over after delete
|
||||
extinct = refsToDelete `Set.difference` remainingRefs -- deleting and not left over
|
||||
accumulateDependents :: LabeledDependency -> IO (Map LabeledDependency (Set LabeledDependency))
|
||||
accumulateDependents :: LabeledDependency -> Sqlite.Transaction (Map LabeledDependency (Set LabeledDependency))
|
||||
accumulateDependents ld =
|
||||
let ref = LD.fold id Referent.toReference ld
|
||||
in Map.singleton ld . Set.map LD.termRef <$> Codebase.dependents codebase Queries.ExcludeOwnComponent ref
|
||||
-- All dependents of extinct, including terms which might themselves be in the process of being deleted.
|
||||
allDependentsOfExtinct :: Map LabeledDependency (Set LabeledDependency) <-
|
||||
liftIO (Map.unionsWith (<>) <$> for (Set.toList extinct) accumulateDependents)
|
||||
Map.unionsWith (<>) <$> for (Set.toList extinct) accumulateDependents
|
||||
|
||||
-- Filtered to only include dependencies which are not being deleted, but depend one which
|
||||
-- is going extinct.
|
||||
@ -2863,26 +2898,25 @@ docsI srcLoc prettyPrintNames src =
|
||||
| otherwise -> Cli.respond $ ListOfLinks PPE.empty []
|
||||
|
||||
loadDisplayInfo ::
|
||||
Codebase m Symbol Ann ->
|
||||
Set Reference ->
|
||||
Cli
|
||||
Sqlite.Transaction
|
||||
( [(Reference, Maybe (Type Symbol Ann))],
|
||||
[(Reference, DisplayObject () (DD.Decl Symbol Ann))]
|
||||
)
|
||||
loadDisplayInfo refs = do
|
||||
Cli.Env {codebase} <- ask
|
||||
termRefs <- filterM (liftIO . Codebase.isTerm codebase) (toList refs)
|
||||
typeRefs <- filterM (liftIO . Codebase.isType codebase) (toList refs)
|
||||
terms <- forM termRefs $ \r -> (r,) <$> liftIO (Codebase.getTypeOfTerm codebase r)
|
||||
types <- forM typeRefs $ \r -> (r,) <$> loadTypeDisplayObject r
|
||||
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 :: Reference -> Cli (DisplayObject () (DD.Decl Symbol Ann))
|
||||
loadTypeDisplayObject = \case
|
||||
loadTypeDisplayObject :: Codebase m Symbol Ann -> Reference -> Sqlite.Transaction (DisplayObject () (DD.Decl Symbol Ann))
|
||||
loadTypeDisplayObject codebase = \case
|
||||
Reference.Builtin _ -> pure (BuiltinObject ())
|
||||
Reference.DerivedId id -> do
|
||||
Cli.Env {codebase} <- ask
|
||||
Reference.DerivedId id ->
|
||||
maybe (MissingObject $ Reference.idToShortHash id) UserObject
|
||||
<$> liftIO (Codebase.getTypeDeclaration codebase id)
|
||||
<$> Codebase.getTypeDeclaration codebase id
|
||||
|
||||
lexedSource :: Text -> Text -> Cli (NamesWithHistory, (Text, [L.Token L.Lexeme]))
|
||||
lexedSource name src = do
|
||||
@ -3013,7 +3047,7 @@ getTerm' mainName =
|
||||
Cli.Env {codebase, runtime} <- ask
|
||||
|
||||
parseNames <- basicParseNames
|
||||
let loadTypeOfTerm ref = liftIO (Codebase.getTypeOfTerm codebase ref)
|
||||
let loadTypeOfTerm ref = Cli.runTransaction (Codebase.getTypeOfTerm codebase ref)
|
||||
mainToFile
|
||||
=<< MainTerm.getMainTerm loadTypeOfTerm parseNames mainName (Runtime.mainType runtime)
|
||||
where
|
||||
@ -3068,7 +3102,7 @@ executePPE ::
|
||||
executePPE unisonFile =
|
||||
suffixifiedPPE =<< displayNames unisonFile
|
||||
|
||||
loadTypeOfTerm :: Monad m => Codebase m Symbol Ann -> Referent -> m (Maybe (Type Symbol Ann))
|
||||
loadTypeOfTerm :: Codebase m Symbol Ann -> Referent -> Sqlite.Transaction (Maybe (Type Symbol Ann))
|
||||
loadTypeOfTerm codebase (Referent.Ref r) = Codebase.getTypeOfTerm codebase r
|
||||
loadTypeOfTerm codebase (Referent.Con (ConstructorReference (Reference.DerivedId r) cid) _) = do
|
||||
decl <- Codebase.getTypeDeclaration codebase r
|
||||
|
@ -32,7 +32,6 @@ import qualified Unison.PrettyPrintEnv as PPE
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
import qualified Unison.Server.Backend as Backend
|
||||
import Unison.Symbol (Symbol)
|
||||
import qualified Unison.Util.Monoid as Monoid
|
||||
import qualified Unison.Util.Relation as R
|
||||
import qualified Unison.Util.Set as Set
|
||||
@ -40,7 +39,7 @@ import qualified Unison.Util.Set as Set
|
||||
-- Add default metadata to all added types and terms in a slurp component.
|
||||
--
|
||||
-- No-op if the slurp component is empty.
|
||||
addDefaultMetadata :: SlurpComponent Symbol -> Cli ()
|
||||
addDefaultMetadata :: SlurpComponent -> Cli ()
|
||||
addDefaultMetadata adds =
|
||||
when (not (SC.isEmpty adds)) do
|
||||
Cli.time "add-default-metadata" do
|
||||
@ -125,11 +124,11 @@ resolveMetadata name = do
|
||||
Cli.Env {codebase} <- ask
|
||||
root' <- Cli.getRootBranch
|
||||
currentPath' <- Cli.getCurrentPath
|
||||
sbhLength <- liftIO (Codebase.branchHashLength codebase)
|
||||
schLength <- liftIO (Codebase.branchHashLength codebase)
|
||||
|
||||
let ppe :: PPE.PrettyPrintEnv
|
||||
ppe =
|
||||
Backend.basicSuffixifiedNames sbhLength root' (Backend.Within $ Path.unabsolute currentPath')
|
||||
Backend.basicSuffixifiedNames schLength root' (Backend.Within $ Path.unabsolute currentPath')
|
||||
|
||||
terms <- getHQTerms name
|
||||
ref <-
|
||||
@ -137,10 +136,9 @@ resolveMetadata name = do
|
||||
Just (Referent.Ref ref) -> pure ref
|
||||
-- FIXME: we want a different error message if the given name is associated with a data constructor (`Con`).
|
||||
_ -> Cli.returnEarly (MetadataAmbiguous name ppe (Set.toList terms))
|
||||
liftIO (Codebase.getTypeOfTerm codebase ref) >>= \case
|
||||
Just ty -> pure $ Right (Hashing.typeToReference ty, ref)
|
||||
Nothing ->
|
||||
pure (Left (MetadataMissingType ppe (Referent.Ref ref)))
|
||||
Cli.runTransaction ((Codebase.getTypeOfTerm codebase ref)) <&> \case
|
||||
Just ty -> Right (Hashing.typeToReference ty, ref)
|
||||
Nothing -> Left (MetadataMissingType ppe (Referent.Ref ref))
|
||||
|
||||
resolveDefaultMetadata :: Path.Absolute -> Cli [String]
|
||||
resolveDefaultMetadata path = do
|
||||
|
@ -8,6 +8,7 @@ import Control.Monad.Trans.Maybe
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Unison.Cli.Monad (Cli, Env (..))
|
||||
import qualified Unison.Cli.Monad as Cli
|
||||
import qualified Unison.Codebase as Codebase
|
||||
import Unison.Codebase.Branch (Branch0)
|
||||
import qualified Unison.Codebase.Branch as Branch
|
||||
@ -41,11 +42,13 @@ namespaceDependencies :: Branch0 m -> Cli (Map LabeledDependency (Set Name))
|
||||
namespaceDependencies branch = do
|
||||
Env {codebase} <- ask
|
||||
|
||||
typeDeps <- for (Map.toList currentBranchTypeRefs) $ \(typeRef, names) -> fmap (fromMaybe Map.empty) . runMaybeT $ do
|
||||
refId <- MaybeT . pure $ Reference.toId typeRef
|
||||
decl <- MaybeT $ liftIO (Codebase.getTypeDeclaration codebase refId)
|
||||
let typeDeps = Set.map LD.typeRef $ DD.dependencies (DD.asDataDecl decl)
|
||||
pure $ foldMap (`Map.singleton` names) typeDeps
|
||||
typeDeps <-
|
||||
Cli.runTransaction do
|
||||
for (Map.toList currentBranchTypeRefs) $ \(typeRef, names) -> fmap (fromMaybe Map.empty) . runMaybeT $ do
|
||||
refId <- MaybeT . pure $ Reference.toId typeRef
|
||||
decl <- MaybeT $ Codebase.getTypeDeclaration codebase refId
|
||||
let typeDeps = Set.map LD.typeRef $ DD.dependencies (DD.asDataDecl decl)
|
||||
pure $ foldMap (`Map.singleton` names) typeDeps
|
||||
|
||||
termDeps <- for (Map.toList currentBranchTermRefs) $ \(termRef, names) -> fmap (fromMaybe Map.empty) . runMaybeT $ do
|
||||
refId <- MaybeT . pure $ Referent.toReferenceId termRef
|
||||
|
@ -27,6 +27,7 @@ import qualified Unison.PrettyPrintEnvDecl as PPE hiding (biasTo)
|
||||
import Unison.Reference (Reference (..))
|
||||
import qualified Unison.Reference as Reference
|
||||
import qualified Unison.Server.Backend as Backend
|
||||
import qualified Unison.Sqlite as Sqlite
|
||||
import Unison.Symbol (Symbol)
|
||||
|
||||
diffHelper ::
|
||||
@ -42,18 +43,17 @@ diffHelper before after =
|
||||
diff <- liftIO (BranchDiff.diff0 before after)
|
||||
let (_parseNames, prettyNames0, _local) = Backend.namesForBranch rootBranch (Backend.AllNames $ Path.unabsolute currentPath)
|
||||
ppe <- PPE.suffixifiedPPE <$> prettyPrintEnvDecl (NamesWithHistory prettyNames0 mempty)
|
||||
liftIO do
|
||||
fmap (ppe,) do
|
||||
OBranchDiff.toOutput
|
||||
(Codebase.getTypeOfReferent codebase)
|
||||
(declOrBuiltin codebase)
|
||||
hqLength
|
||||
(Branch.toNames before)
|
||||
(Branch.toNames after)
|
||||
ppe
|
||||
diff
|
||||
fmap (ppe,) do
|
||||
OBranchDiff.toOutput
|
||||
(Cli.runTransaction . Codebase.getTypeOfReferent codebase)
|
||||
(Cli.runTransaction . declOrBuiltin codebase)
|
||||
hqLength
|
||||
(Branch.toNames before)
|
||||
(Branch.toNames after)
|
||||
ppe
|
||||
diff
|
||||
|
||||
declOrBuiltin :: Applicative m => Codebase m Symbol Ann -> Reference -> m (Maybe (DD.DeclOrBuiltin Symbol Ann))
|
||||
declOrBuiltin :: Codebase m Symbol Ann -> Reference -> Sqlite.Transaction (Maybe (DD.DeclOrBuiltin Symbol Ann))
|
||||
declOrBuiltin codebase r = case r of
|
||||
Reference.Builtin {} ->
|
||||
pure . fmap DD.Builtin $ Map.lookup r Builtin.builtinConstructorType
|
||||
|
@ -66,10 +66,14 @@ lookupTermRefWithType
|
||||
-> Cli [(Reference,Type Symbol Ann)]
|
||||
lookupTermRefWithType codebase name = do
|
||||
nms <- basicParseNames
|
||||
fmap catMaybes . traverse annot . fst $ lookupTermRefs name nms
|
||||
liftIO .
|
||||
Codebase.runTransaction codebase .
|
||||
fmap catMaybes .
|
||||
traverse annot .
|
||||
fst $ lookupTermRefs name nms
|
||||
where
|
||||
annot tm =
|
||||
fmap ((,) tm) <$> liftIO (Codebase.getTypeOfTerm codebase tm)
|
||||
fmap ((,) tm) <$> Codebase.getTypeOfTerm codebase tm
|
||||
|
||||
resolveTerm :: HQ.HashQualified Name -> Cli Referent
|
||||
resolveTerm name = basicParseNames >>= \nms ->
|
||||
|
@ -11,7 +11,7 @@ import qualified Data.List as List
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Set.NonEmpty as NESet
|
||||
import qualified Data.Tuple as Tuple
|
||||
import qualified U.Codebase.Sqlite.Queries as Queries
|
||||
import qualified Unison.ABT as ABT
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import qualified Unison.Cli.Monad as Cli
|
||||
@ -40,6 +40,7 @@ import Unison.Codebase.Path (Path)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.Codebase.TermEdit as TermEdit
|
||||
import qualified Unison.Codebase.TypeEdit as TypeEdit
|
||||
import Unison.DataDeclaration (Decl)
|
||||
import Unison.Hash (Hash)
|
||||
import Unison.Name (Name)
|
||||
import qualified Unison.Name as Name
|
||||
@ -48,7 +49,7 @@ import qualified Unison.Names as Names
|
||||
import Unison.Parser.Ann (Ann (..))
|
||||
import Unison.Prelude
|
||||
import qualified Unison.PrettyPrintEnvDecl as PPE hiding (biasTo)
|
||||
import Unison.Reference (Reference (..), TermReference, TermReferenceId, TypeReference)
|
||||
import Unison.Reference (Reference (..), TermReference, TermReferenceId, TypeReference, TypeReferenceId)
|
||||
import qualified Unison.Reference as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
@ -65,11 +66,10 @@ import Unison.UnisonFile (TypecheckedUnisonFile, UnisonFile)
|
||||
import qualified Unison.UnisonFile as UF
|
||||
import qualified Unison.UnisonFile.Names as UF
|
||||
import Unison.UnisonFile.Type (UnisonFile (UnisonFileId))
|
||||
import qualified Unison.Util.Map as Map (remap)
|
||||
import qualified Unison.Util.Map as Map (remap, upsert)
|
||||
import Unison.Util.Monoid (foldMapM)
|
||||
import qualified Unison.Util.Relation as R
|
||||
import qualified Unison.Util.Set as Set
|
||||
import Unison.Var (Var)
|
||||
import qualified Unison.Var as Var
|
||||
import Unison.WatchKind (WatchKind)
|
||||
import qualified Unison.WatchKind as WK
|
||||
@ -86,7 +86,7 @@ handleUpdate input optionalPatch requestedNames = do
|
||||
UsePatch p -> Just p
|
||||
slurpCheckNames <- Branch.toNames <$> Cli.getCurrentBranch0
|
||||
sr <- getSlurpResultForUpdate requestedNames slurpCheckNames
|
||||
let addsAndUpdates :: SlurpComponent Symbol
|
||||
let addsAndUpdates :: SlurpComponent
|
||||
addsAndUpdates = Slurp.updates sr <> Slurp.adds sr
|
||||
fileNames :: Names
|
||||
fileNames = UF.typecheckedToNames (Slurp.originalFile sr)
|
||||
@ -144,9 +144,10 @@ handleUpdate input optionalPatch requestedNames = do
|
||||
neededTypes = collectOldForTyping (map (\(_, old, new) -> (old, new)) termEdits) ye'ol'Patch
|
||||
|
||||
allTypes :: Map Reference (Type v Ann) <-
|
||||
fmap Map.fromList . for (toList neededTypes) $ \r ->
|
||||
(r,) . fromMaybe (Type.builtin External "unknown type")
|
||||
<$> (liftIO . Codebase.getTypeOfTerm codebase) r
|
||||
(liftIO . Codebase.runTransaction codebase) do
|
||||
fmap Map.fromList . for (toList neededTypes) $ \r ->
|
||||
(r,) . fromMaybe (Type.builtin External "unknown type")
|
||||
<$> Codebase.getTypeOfTerm codebase r
|
||||
|
||||
let typing r1 r2 = case (Map.lookup r1 allTypes, Map.lookup r2 hashTerms) of
|
||||
(Just t1, Just t2)
|
||||
@ -189,7 +190,10 @@ handleUpdate input optionalPatch requestedNames = do
|
||||
Nothing -> []
|
||||
Just (_, update, p) -> [(Path.unabsolute p, update)]
|
||||
)
|
||||
liftIO . Codebase.addDefsToCodebase codebase . Slurp.filterUnisonFile sr $ Slurp.originalFile sr
|
||||
Cli.runTransaction
|
||||
. Codebase.addDefsToCodebase codebase
|
||||
. Slurp.filterUnisonFile sr
|
||||
$ Slurp.originalFile sr
|
||||
ppe <- prettyPrintEnvDecl =<< displayNames (Slurp.originalFile sr)
|
||||
Cli.respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr
|
||||
whenJust patchOps \(updatedPatch, _, _) ->
|
||||
@ -202,9 +206,9 @@ handleUpdate input optionalPatch requestedNames = do
|
||||
& Path.resolve @_ @_ @Path.Absolute currentPath'
|
||||
& tShow
|
||||
|
||||
getSlurpResultForUpdate :: Set Name -> Names -> Cli (SlurpResult Symbol)
|
||||
getSlurpResultForUpdate :: Set Name -> Names -> Cli SlurpResult
|
||||
getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
let slurp :: TypecheckedUnisonFile Symbol Ann -> SlurpResult Symbol
|
||||
let slurp :: TypecheckedUnisonFile Symbol Ann -> SlurpResult
|
||||
slurp file =
|
||||
Slurp.slurpFile file (Set.map Name.toVar requestedNames) Slurp.UpdateOp slurpCheckNames
|
||||
|
||||
@ -243,6 +247,15 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
-- terms in it fails.
|
||||
let slurp0 = slurp unisonFile0
|
||||
|
||||
-- Grab some interim info out of the original slurp.
|
||||
--
|
||||
-- Running example:
|
||||
--
|
||||
-- "ping" => (#newping, Nothing, <#wham + 4>, <Nat>)
|
||||
let nameToInterimInfo :: Map Symbol (TermReferenceId, Maybe WatchKind, Term Symbol Ann, Type Symbol Ann)
|
||||
nameToInterimInfo =
|
||||
UF.hashTermsId (Slurp.originalFile slurp0)
|
||||
|
||||
-- Get the set of names that are being updated.
|
||||
--
|
||||
-- Running example:
|
||||
@ -252,14 +265,21 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
namesBeingUpdated =
|
||||
SC.terms (Slurp.updates slurp0)
|
||||
|
||||
-- Associate each such name with the set of "old" references (already in the codebase) that it's associated with.
|
||||
-- Associate each such name with the set of old (already in the codebase) and new (in the scratch file) references
|
||||
-- that it's associated with.
|
||||
--
|
||||
-- Running example:
|
||||
--
|
||||
-- "ping" => { #pingpong.ping }
|
||||
let updatedNameToOldRefs :: Map Symbol (Set TermReference)
|
||||
updatedNameToOldRefs =
|
||||
Map.fromSet nameToTermRefs namesBeingUpdated
|
||||
-- "ping" => ({ #pingpong.ping }, #newping)
|
||||
let updatedNameToRefs :: Map Symbol (Set TermReference, TermReferenceId)
|
||||
updatedNameToRefs =
|
||||
Map.fromSet
|
||||
( \name ->
|
||||
case Map.lookup name nameToInterimInfo of
|
||||
Nothing -> error (reportBug "E798907" "no interim ref for name")
|
||||
Just (interimRef, _, _, _) -> (nameToTermRefs name, interimRef)
|
||||
)
|
||||
namesBeingUpdated
|
||||
|
||||
-- Identify all of the implicit terms, which are:
|
||||
--
|
||||
@ -295,64 +315,126 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
-- Furthermore, #wham is both a dependent of #pingpong (B), and a dependency of #newping, so it too is an implicit
|
||||
-- term.
|
||||
--
|
||||
-- FIXME: this currently only looks at old components; doesn't search for new cycles.
|
||||
--
|
||||
-- Running example:
|
||||
--
|
||||
-- #pingpong.pong => (<#pingpong.ping + 2>, "pong")
|
||||
-- #wham => (<#pingpong.pong + 3>, "wham")
|
||||
implicitTerms :: Map TermReferenceId (Term Symbol Ann, Symbol) <-
|
||||
liftIO do
|
||||
-- Running example:
|
||||
--
|
||||
--
|
||||
-- { #pingpong }
|
||||
let oldHashes :: Set Hash
|
||||
oldHashes =
|
||||
foldMap (Set.mapMaybe Reference.toHash) updatedNameToOldRefs
|
||||
Codebase.withConnection codebase \conn ->
|
||||
Sqlite.runTransaction conn do
|
||||
-- Running example:
|
||||
--
|
||||
-- #pingpong => #newping
|
||||
let oldHashToInterimHash :: Map Hash Hash
|
||||
oldHashToInterimHash =
|
||||
updatedNameToRefs & foldMap \(oldRefs, interimRef) ->
|
||||
let interimHash = Reference.idToHash interimRef
|
||||
in Map.fromList $
|
||||
oldRefs
|
||||
& Set.toList
|
||||
& mapMaybe Reference.toHash
|
||||
& map (,interimHash)
|
||||
|
||||
oldHashes & foldMapM \oldHash -> do
|
||||
-- Running example:
|
||||
--
|
||||
-- [ (<#pingpong.pong + 1>, <Nat>),
|
||||
-- (<#pingpong.ping + 2>, <Nat>)
|
||||
-- ]
|
||||
terms <-
|
||||
Codebase.withConnection codebase \conn ->
|
||||
Sqlite.runTransaction conn (Codebase.unsafeGetTermComponent codebase oldHash)
|
||||
pure $
|
||||
terms
|
||||
-- Running example:
|
||||
--
|
||||
-- [ (#pingpong.ping, (<#pingpong.pong + 1>, <Nat>)),
|
||||
-- (#pingpong.pong, (<#pingpong.ping + 2>, <Nat>))
|
||||
-- ]
|
||||
& Reference.componentFor oldHash
|
||||
& List.foldl'
|
||||
( \acc (ref, (term, _typ)) ->
|
||||
let -- (D) After getting the entire component of `oldHash`, which has at least one member being
|
||||
-- updated, we want to keep only the members that are *not* being updated (i.e. those who have
|
||||
-- no name that is being updated).
|
||||
--
|
||||
-- Running example, first time through (processing #pingpong.ping):
|
||||
--
|
||||
-- Set.disjoint { "ping" } { "ping" } is false, so don't add to the map.
|
||||
--
|
||||
-- Running example, second time through (processing #pingpong.pong):
|
||||
--
|
||||
-- Set.disjoint { "ping" } { "pong" } is true, so add
|
||||
-- #pingpong.pong => (<#pingpong.ping + 2>, { "pong" })) to the map.
|
||||
notBeingUpdated = Set.disjoint namesBeingUpdated
|
||||
nameIsUnconflicted name = Set.size (nameToTermRefs name) == 1
|
||||
names = termRefToNames ref
|
||||
in if notBeingUpdated names
|
||||
then case Foldable.find nameIsUnconflicted names {- (E) -} of
|
||||
Nothing -> acc
|
||||
Just name -> Map.insert ref (term, name) acc
|
||||
else acc
|
||||
)
|
||||
Map.empty
|
||||
let hashToImplicitTerms :: Hash -> Sqlite.Transaction (Map TermReferenceId (Term Symbol Ann, Symbol))
|
||||
hashToImplicitTerms hash = do
|
||||
-- Running example (for `oldHash` iteration):
|
||||
--
|
||||
-- [ (<#pingpong.pong + 1>, <Nat>),
|
||||
-- (<#pingpong.ping + 2>, <Nat>)
|
||||
-- ]
|
||||
terms <- Codebase.unsafeGetTermComponent codebase hash
|
||||
let keep :: TermReferenceId -> Maybe Symbol
|
||||
keep ref =
|
||||
if notBeingUpdated names
|
||||
then Foldable.find nameIsUnconflicted names -- (E)
|
||||
else Nothing
|
||||
where
|
||||
-- (D) After getting the entire component of `oldHash`, which has at least one member being
|
||||
-- updated, we want to keep only the members that are *not* being updated (i.e. those who have
|
||||
-- no name that is being updated).
|
||||
--
|
||||
-- Running example, first time through (processing #pingpong.ping):
|
||||
--
|
||||
-- Set.disjoint { "ping" } { "ping" } is false, so don't add to the map.
|
||||
--
|
||||
-- Running example, second time through (processing #pingpong.pong):
|
||||
--
|
||||
-- Set.disjoint { "ping" } { "pong" } is true, so add
|
||||
-- #pingpong.pong => (<#pingpong.ping + 2>, { "pong" })) to the map.
|
||||
notBeingUpdated = Set.disjoint namesBeingUpdated
|
||||
nameIsUnconflicted name = Set.size (nameToTermRefs name) == 1
|
||||
names = termRefToNames ref
|
||||
pure $
|
||||
terms
|
||||
-- Running example:
|
||||
--
|
||||
-- [ (#pingpong.ping, (<#pingpong.pong + 1>, <Nat>)),
|
||||
-- (#pingpong.pong, (<#pingpong.ping + 2>, <Nat>))
|
||||
-- ]
|
||||
& Reference.componentFor hash
|
||||
& List.foldl'
|
||||
( \acc (ref, (term, _typ)) ->
|
||||
case keep ref of
|
||||
Nothing -> acc
|
||||
Just name -> Map.insert ref (term, name) acc
|
||||
)
|
||||
Map.empty
|
||||
|
||||
if Map.null oldHashToInterimHash
|
||||
then pure Map.empty
|
||||
else do
|
||||
Sqlite.savepoint do
|
||||
-- Compute the actual interim decl/term components in the latest typechecked file. These aren't quite
|
||||
-- given in the unison file structure itself - in the `topLevelComponents'` field we have the
|
||||
-- components in some arbitrary order (I *think*), each tagged with its stringy name, and in the
|
||||
-- `hashTermsId` field we have all of the individual terms organized by reference.
|
||||
let interimDeclComponents :: [(Hash, [Decl Symbol Ann])]
|
||||
interimDeclComponents =
|
||||
decls UF.dataDeclarationsId' Right ++ decls UF.effectDeclarationsId' Left
|
||||
where
|
||||
decls ::
|
||||
(TypecheckedUnisonFile Symbol Ann -> Map Symbol (TypeReferenceId, decl)) ->
|
||||
(decl -> Decl Symbol Ann) ->
|
||||
[(Hash, [Decl Symbol Ann])]
|
||||
decls project inject =
|
||||
slurp0
|
||||
& Slurp.originalFile
|
||||
& project
|
||||
& Map.elems
|
||||
& recomponentize
|
||||
& over (mapped . _2 . mapped) inject
|
||||
interimTermComponents :: [(Hash, [(Term Symbol Ann, Type Symbol Ann)])]
|
||||
interimTermComponents =
|
||||
nameToInterimInfo
|
||||
& Map.elems
|
||||
& map (\(ref, _wk, term, typ) -> (ref, (term, typ)))
|
||||
& componentize
|
||||
& uncomponentize
|
||||
|
||||
-- Insert each interim component into the codebase proper. Note: this relies on the codebase interface
|
||||
-- being smart enough to handle out-of-order components (i.e. inserting a dependent before a
|
||||
-- dependency). That's currently how the codebase interface works, but maybe in the future it'll grow
|
||||
-- a precondition that components can only be inserted after their dependencies.
|
||||
for_ interimDeclComponents \(hash, decls) -> Codebase.putTypeDeclarationComponent codebase hash decls
|
||||
for_ interimTermComponents \(hash, terms) -> Codebase.putTermComponent codebase hash terms
|
||||
|
||||
terms <-
|
||||
let interimHashes :: Set Hash
|
||||
interimHashes = Set.fromList (map fst interimTermComponents)
|
||||
in Map.toList oldHashToInterimHash & foldMapM \(oldHash, interimHash) -> do
|
||||
hashes <-
|
||||
Queries.loadObjectIdForAnyHash oldHash >>= \case
|
||||
-- better would be to short-circuit all the way to the user and say, actually we can't
|
||||
-- perform this update at all, due to some intervening delete (e.g. some sort of
|
||||
-- hard-reset or garbage collection on the codebase)
|
||||
Nothing -> pure Set.empty
|
||||
Just oldOid -> do
|
||||
interimOid <- Queries.expectObjectIdForPrimaryHash interimHash
|
||||
betweenOids <- Queries.getDependenciesBetweenTerms interimOid oldOid
|
||||
(Set.\\ interimHashes) <$> Set.traverse Queries.expectPrimaryHashByObjectId betweenOids
|
||||
foldMapM hashToImplicitTerms (oldHash : Set.toList hashes)
|
||||
pure (Left terms) -- left = rollback to savepoint
|
||||
if Map.null implicitTerms
|
||||
then pure slurp0
|
||||
else do
|
||||
@ -363,26 +445,6 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
--
|
||||
-- 2. Re-typecheck, and if it that succeeds, use the resulting typechecked unison file and slurp.
|
||||
|
||||
-- Grab some interim info out of the original slurp.
|
||||
--
|
||||
-- Running example:
|
||||
--
|
||||
-- "ping" => (#newping, Nothing, <#wham + 4>, <Nat>)
|
||||
let nameToInterimInfo :: Map Symbol (TermReferenceId, Maybe WatchKind, Term Symbol Ann, Type Symbol Ann)
|
||||
nameToInterimInfo =
|
||||
UF.hashTermsId (Slurp.originalFile slurp0)
|
||||
|
||||
-- Associate each term name being updated with its interim reference.
|
||||
--
|
||||
-- Running example:
|
||||
--
|
||||
-- "ping" <=> #newping
|
||||
let nameToInterimRef :: Bij Symbol TermReferenceId
|
||||
nameToInterimRef =
|
||||
nameToInterimInfo
|
||||
& Map.map (\(ref, _wk, _term, _typ) -> ref)
|
||||
& bijFromMap
|
||||
|
||||
-- Remap the references contained in each implicit term, then add back in the slurped interim terms and unhash
|
||||
-- the collection. The unhashing process will invent a fresh variable name for each term.
|
||||
--
|
||||
@ -423,21 +485,13 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
-- ref -> ref
|
||||
rewrite :: Term Symbol Ann -> Term Symbol Ann
|
||||
rewrite =
|
||||
updatedNameToOldRefs
|
||||
& Map.toList
|
||||
& foldMap
|
||||
( \(name, oldRefs) ->
|
||||
oldRefs
|
||||
& Set.toList
|
||||
& map
|
||||
( \oldRef ->
|
||||
case bijLookupL name nameToInterimRef of
|
||||
Just interimRef -> (oldRef, interimRef)
|
||||
Nothing -> error (reportBug "E798907" "no interim ref for name")
|
||||
)
|
||||
& Map.fromList
|
||||
)
|
||||
& rewriteTermReferences
|
||||
rewriteTermReferences (foldMap toMapping updatedNameToRefs)
|
||||
where
|
||||
toMapping ::
|
||||
(Set TermReference, TermReferenceId) ->
|
||||
Map TermReference TermReferenceId
|
||||
toMapping (oldRefs, interimRef) =
|
||||
foldMap (\oldRef -> Map.singleton oldRef interimRef) oldRefs
|
||||
|
||||
let unisonFile :: UnisonFile Symbol Ann
|
||||
unisonFile =
|
||||
@ -454,7 +508,7 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
-- irrelevant, so we don't need to copy them over.
|
||||
watches = Map.empty
|
||||
}
|
||||
result <- typecheckFile [] unisonFile
|
||||
result <- liftIO (Codebase.runTransaction codebase (typecheckFile codebase [] unisonFile))
|
||||
case runIdentity (Result.toMaybe result) of
|
||||
Just (Right file0) -> do
|
||||
-- Map each name generated by unhashing back to the name it should have in the Unison file we're going to
|
||||
@ -469,13 +523,22 @@ getSlurpResultForUpdate requestedNames slurpCheckNames = do
|
||||
generatedNameToName =
|
||||
refToGeneratedNameAndTerm & Map.remap \(ref, (generatedName, _term)) ->
|
||||
( generatedName,
|
||||
case bijLookupR ref nameToInterimRef of
|
||||
case Map.lookup ref interimRefToName of
|
||||
Just name -> name
|
||||
Nothing ->
|
||||
case Map.lookup ref implicitTerms of
|
||||
Just (_term, name) -> name
|
||||
Nothing -> error (reportBug "E836680" "ref not interim nor implicit")
|
||||
)
|
||||
where
|
||||
-- Associate each term name being updated with its interim reference.
|
||||
--
|
||||
-- Running example:
|
||||
--
|
||||
-- #newping => "ping"
|
||||
interimRefToName :: Map TermReferenceId Symbol
|
||||
interimRefToName =
|
||||
Map.remap (\(name, (ref, _wk, _term, _typ)) -> (ref, name)) nameToInterimInfo
|
||||
|
||||
let renameTerm ::
|
||||
(Symbol, Term Symbol Ann, Type Symbol Ann) ->
|
||||
@ -513,10 +576,10 @@ rewriteTermReferences mapping =
|
||||
|
||||
-- updates the namespace for adding `slurp`
|
||||
doSlurpAdds ::
|
||||
forall m v.
|
||||
(Monad m, Var v) =>
|
||||
SlurpComponent v ->
|
||||
TypecheckedUnisonFile v Ann ->
|
||||
forall m.
|
||||
Monad m =>
|
||||
SlurpComponent ->
|
||||
TypecheckedUnisonFile Symbol Ann ->
|
||||
(Branch0 m -> Branch0 m)
|
||||
doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions)
|
||||
where
|
||||
@ -531,7 +594,7 @@ doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions)
|
||||
if Set.member v tests
|
||||
then Metadata.singleton isTestType isTestValue
|
||||
else Metadata.empty
|
||||
doTerm :: v -> (Path, Branch0 m -> Branch0 m)
|
||||
doTerm :: Symbol -> (Path, Branch0 m -> Branch0 m)
|
||||
doTerm v = case toList (Names.termsNamed names (Name.unsafeFromVar v)) of
|
||||
[] -> errorMissingVar v
|
||||
[r] ->
|
||||
@ -543,7 +606,7 @@ doSlurpAdds slurp uf = Branch.batchUpdates (typeActions <> termActions)
|
||||
<> Var.nameStr v
|
||||
<> ": "
|
||||
<> show wha
|
||||
doType :: v -> (Path, Branch0 m -> Branch0 m)
|
||||
doType :: Symbol -> (Path, Branch0 m -> Branch0 m)
|
||||
doType v = case toList (Names.typesNamed names (Name.unsafeFromVar v)) of
|
||||
[] -> errorMissingVar v
|
||||
[r] ->
|
||||
@ -599,23 +662,26 @@ propagatePatchNoSync patch scopePath =
|
||||
Cli.time "propagatePatchNoSync" do
|
||||
Cli.stepAtNoSync' (Path.unabsolute scopePath, Propagate.propagateAndApply patch)
|
||||
|
||||
------------------------------------------------------------------------------------------------------------------------
|
||||
-- Tiny helper bijection type
|
||||
--
|
||||
-- This is semantically a set of `(a, b)` tuples, where no `a` nor `b` appears more than once. An `a` can be looked up
|
||||
-- given its associated `b`, and vice-versa.
|
||||
recomponentize :: [(Reference.Id, a)] -> [(Hash, [a])]
|
||||
recomponentize =
|
||||
uncomponentize . componentize
|
||||
|
||||
data Bij a b
|
||||
= Bij (Map a b) (Map b a)
|
||||
-- Misc. helper: convert a component in listy-form to mappy-form.
|
||||
componentize :: [(Reference.Id, a)] -> Map Hash (Map Reference.Pos a)
|
||||
componentize =
|
||||
foldl' step Map.empty
|
||||
where
|
||||
step :: Map Hash (Map Reference.Pos a) -> (Reference.Id, a) -> Map Hash (Map Reference.Pos a)
|
||||
step acc (Reference.Id hash pos, x) =
|
||||
Map.upsert
|
||||
( \case
|
||||
Nothing -> Map.singleton pos x
|
||||
Just acc1 -> Map.insert pos x acc1
|
||||
)
|
||||
hash
|
||||
acc
|
||||
|
||||
bijFromMap :: Ord b => Map a b -> Bij a b
|
||||
bijFromMap m =
|
||||
Bij m (Map.remap Tuple.swap m)
|
||||
|
||||
bijLookupL :: Ord a => a -> Bij a b -> Maybe b
|
||||
bijLookupL x (Bij m _) =
|
||||
Map.lookup x m
|
||||
|
||||
bijLookupR :: Ord b => b -> Bij a b -> Maybe a
|
||||
bijLookupR x (Bij _ m) =
|
||||
Map.lookup x m
|
||||
-- Misc. helper: convert a component in mappy-form to listy-form.
|
||||
uncomponentize :: Map Hash (Map Reference.Pos a) -> [(Hash, [a])]
|
||||
uncomponentize =
|
||||
over (mapped . _2) Map.elems . Map.toList
|
||||
|
@ -9,6 +9,7 @@ module Unison.Codebase.Editor.Input
|
||||
BranchId,
|
||||
AbsBranchId,
|
||||
parseBranchId,
|
||||
parseShortCausalHash,
|
||||
HashOrHQSplit',
|
||||
Insistence (..),
|
||||
PullMode (..),
|
||||
@ -27,8 +28,8 @@ import Unison.Codebase.Path (Path')
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.Codebase.Path.Parse as Path
|
||||
import Unison.Codebase.PushBehavior (PushBehavior)
|
||||
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
|
||||
import qualified Unison.Codebase.ShortBranchHash as SBH
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import qualified Unison.Codebase.ShortCausalHash as SCH
|
||||
import Unison.Codebase.SyncMode (SyncMode)
|
||||
import Unison.Codebase.Verbosity
|
||||
import qualified Unison.HashQualified as HQ
|
||||
@ -51,9 +52,9 @@ type PatchPath = Path.Split'
|
||||
data OptionalPatch = NoPatch | DefaultPatch | UsePatch PatchPath
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
type BranchId = Either ShortBranchHash Path'
|
||||
type BranchId = Either ShortCausalHash Path'
|
||||
|
||||
type AbsBranchId = Either ShortBranchHash Path.Absolute
|
||||
type AbsBranchId = Either ShortCausalHash Path.Absolute
|
||||
|
||||
type HashOrHQSplit' = Either ShortHash Path.HQSplit'
|
||||
|
||||
@ -62,11 +63,15 @@ data Insistence = Force | Try
|
||||
deriving (Show, Eq)
|
||||
|
||||
parseBranchId :: String -> Either String BranchId
|
||||
parseBranchId ('#' : s) = case SBH.fromText (Text.pack s) of
|
||||
parseBranchId ('#' : s) = case SCH.fromText (Text.pack s) of
|
||||
Nothing -> Left "Invalid hash, expected a base32hex string."
|
||||
Just h -> pure $ Left h
|
||||
parseBranchId s = Right <$> Path.parsePath' s
|
||||
|
||||
parseShortCausalHash :: String -> Either String ShortCausalHash
|
||||
parseShortCausalHash ('#' : s) | Just sch <- SCH.fromText (Text.pack s) = Right sch
|
||||
parseShortCausalHash _ = Left "Invalid hash, expected a base32hex string."
|
||||
|
||||
data PullMode
|
||||
= PullWithHistory
|
||||
| PullWithoutHistory
|
||||
@ -79,7 +84,7 @@ data Input
|
||||
-- directory ops
|
||||
-- `Link` must describe a repo and a source path within that repo.
|
||||
-- clone w/o merge, error if would clobber
|
||||
ForkLocalBranchI (Either ShortBranchHash Path') Path'
|
||||
ForkLocalBranchI (Either ShortCausalHash Path') Path'
|
||||
| -- merge first causal into destination
|
||||
MergeLocalBranchI Path' Path' Branch.MergeMode
|
||||
| PreviewMergeLocalBranchI Path' Path'
|
||||
@ -88,7 +93,7 @@ data Input
|
||||
| PushRemoteBranchI PushRemoteBranchInput
|
||||
| CreatePullRequestI ReadRemoteNamespace ReadRemoteNamespace
|
||||
| LoadPullRequestI ReadRemoteNamespace ReadRemoteNamespace Path'
|
||||
| ResetRootI (Either ShortBranchHash Path')
|
||||
| ResetRootI (Either ShortCausalHash Path')
|
||||
| -- todo: Q: Does it make sense to publish to not-the-root of a Github repo?
|
||||
-- Does it make sense to fork from not-the-root of a Github repo?
|
||||
-- used in Welcome module to give directions to user
|
||||
@ -194,6 +199,7 @@ data Input
|
||||
| DebugDumpNamespaceSimpleI
|
||||
| DebugClearWatchI
|
||||
| DebugDoctorI
|
||||
| DebugNameDiffI ShortCausalHash ShortCausalHash
|
||||
| QuitI
|
||||
| ApiI
|
||||
| UiI
|
||||
|
@ -20,6 +20,7 @@ import Data.Set.NonEmpty (NESet)
|
||||
import Data.Time (UTCTime)
|
||||
import Network.URI (URI)
|
||||
import qualified System.Console.Haskeline as Completion
|
||||
import U.Codebase.Branch.Diff (NameChanges)
|
||||
import Unison.Auth.Types (CredentialFailure)
|
||||
import qualified Unison.Codebase.Branch as Branch
|
||||
import Unison.Codebase.Editor.DisplayObject (DisplayObject)
|
||||
@ -36,8 +37,8 @@ import Unison.Codebase.Path (Path')
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Codebase.PushBehavior (PushBehavior)
|
||||
import qualified Unison.Codebase.Runtime as Runtime
|
||||
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
|
||||
import qualified Unison.Codebase.ShortBranchHash as SBH
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import qualified Unison.Codebase.ShortCausalHash as SCH
|
||||
import Unison.Codebase.Type (GitError)
|
||||
import qualified Unison.CommandLine.InputPattern as Input
|
||||
import Unison.DataDeclaration (Decl)
|
||||
@ -122,7 +123,7 @@ data Output
|
||||
NoMainFunction String PPE.PrettyPrintEnv [Type Symbol Ann]
|
||||
| -- Main function found, but has improper type
|
||||
BadMainFunction String (Type Symbol Ann) PPE.PrettyPrintEnv [Type Symbol Ann]
|
||||
| BranchEmpty (Either ShortBranchHash Path')
|
||||
| BranchEmpty (Either ShortCausalHash Path')
|
||||
| BranchNotEmpty Path'
|
||||
| LoadPullRequest ReadRemoteNamespace ReadRemoteNamespace Path' Path' Path' Path'
|
||||
| CreatedNewBranch Path.Absolute
|
||||
@ -140,7 +141,7 @@ data Output
|
||||
| DeleteNameAmbiguous Int Path.HQSplit' (Set Referent) (Set Reference)
|
||||
| TermAmbiguous (HQ.HashQualified Name) (Set Referent)
|
||||
| HashAmbiguous ShortHash (Set Referent)
|
||||
| BranchHashAmbiguous ShortBranchHash (Set ShortBranchHash)
|
||||
| BranchHashAmbiguous ShortCausalHash (Set ShortCausalHash)
|
||||
| BadNamespace String String
|
||||
| BranchNotFound Path'
|
||||
| EmptyPush Path'
|
||||
@ -186,7 +187,7 @@ data Output
|
||||
| ListShallow (IO PPE.PrettyPrintEnv) [ShallowListEntry Symbol Ann]
|
||||
| ListOfPatches (Set Name)
|
||||
| -- show the result of add/update
|
||||
SlurpOutput Input PPE.PrettyPrintEnv (SlurpResult Symbol)
|
||||
SlurpOutput Input PPE.PrettyPrintEnv SlurpResult
|
||||
| -- Original source, followed by the errors:
|
||||
ParseErrors Text [Parser.Err Symbol]
|
||||
| TypeErrors Path.Absolute Text PPE.PrettyPrintEnv [Context.ErrorNote Symbol Ann]
|
||||
@ -199,7 +200,7 @@ data Output
|
||||
[(Symbol, Term Symbol ())]
|
||||
(Map Symbol (Ann, WK.WatchKind, Term Symbol (), Runtime.IsCacheHit))
|
||||
| RunResult PPE.PrettyPrintEnv (Term Symbol ())
|
||||
| Typechecked SourceName PPE.PrettyPrintEnv (SlurpResult Symbol) (UF.TypecheckedUnisonFile Symbol Ann)
|
||||
| Typechecked SourceName PPE.PrettyPrintEnv SlurpResult (UF.TypecheckedUnisonFile Symbol Ann)
|
||||
| DisplayRendered (Maybe FilePath) (P.Pretty P.ColorText)
|
||||
| -- "display" definitions, possibly to a FilePath on disk (e.g. editing)
|
||||
DisplayDefinitions
|
||||
@ -234,9 +235,9 @@ data Output
|
||||
NothingToPatch PatchPath Path'
|
||||
| PatchNeedsToBeConflictFree
|
||||
| PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference)
|
||||
| WarnIncomingRootBranch ShortBranchHash (Set ShortBranchHash)
|
||||
| WarnIncomingRootBranch ShortCausalHash (Set ShortCausalHash)
|
||||
| StartOfCurrentPathHistory
|
||||
| ShowReflog [(Maybe UTCTime, SBH.ShortBranchHash, Text)]
|
||||
| ShowReflog [(Maybe UTCTime, SCH.ShortCausalHash, Text)]
|
||||
| PullAlreadyUpToDate ReadRemoteNamespace Path'
|
||||
| PullSuccessful ReadRemoteNamespace Path'
|
||||
| -- | Indicates a trivial merge where the destination was empty and was just replaced.
|
||||
@ -246,7 +247,7 @@ data Output
|
||||
| -- | No conflicts or edits remain for the current patch.
|
||||
NoConflictsOrEdits
|
||||
| NotImplemented
|
||||
| NoBranchWithHash ShortBranchHash
|
||||
| NoBranchWithHash ShortCausalHash
|
||||
| ListDependencies Int LabeledDependency [(Name, Reference)] (Set Reference)
|
||||
| -- | List dependents of a type or term.
|
||||
ListDependents Int LabeledDependency [(Reference, Maybe Name)]
|
||||
@ -274,6 +275,7 @@ data Output
|
||||
| CredentialFailureMsg CredentialFailure
|
||||
| PrintVersion Text
|
||||
| IntegrityCheck IntegrityResult
|
||||
| DisplayDebugNameDiff NameChanges
|
||||
| DisplayDebugCompletions [Completion.Completion]
|
||||
|
||||
data ShareError
|
||||
@ -321,7 +323,8 @@ isFailure o = case o of
|
||||
BadMainFunction {} -> True
|
||||
CreatedNewBranch {} -> False
|
||||
BranchAlreadyExists {} -> True
|
||||
FindNoLocalMatches {} -> True
|
||||
-- we do a global search after finding no local matches, so let's not call this a failure yet
|
||||
FindNoLocalMatches {} -> False
|
||||
PatchAlreadyExists {} -> True
|
||||
NoExactTypeMatches -> True
|
||||
BranchEmpty {} -> True
|
||||
@ -420,6 +423,7 @@ isFailure o = case o of
|
||||
ShareError {} -> True
|
||||
ViewOnShare {} -> False
|
||||
DisplayDebugCompletions {} -> False
|
||||
DisplayDebugNameDiff {} -> False
|
||||
|
||||
isNumberedFailure :: NumberedOutput -> Bool
|
||||
isNumberedFailure = \case
|
||||
|
@ -144,9 +144,9 @@ propagateCtorMapping oldComponent newComponent =
|
||||
-- If the cycle is size 1 for old and new, then the type names need not be the same,
|
||||
-- and if the number of constructors is 1, then the constructor names need not
|
||||
-- be the same.
|
||||
genInitialCtorMapping :: Codebase IO Symbol Ann -> Names -> Map Reference Reference -> Cli (Map Referent Referent)
|
||||
genInitialCtorMapping :: Codebase IO Symbol Ann -> Names -> Map Reference Reference -> Sqlite.Transaction (Map Referent Referent)
|
||||
genInitialCtorMapping codebase rootNames initialTypeReplacements = do
|
||||
let mappings :: (Reference, Reference) -> Cli (Map Referent Referent)
|
||||
let mappings :: (Reference, Reference) -> Sqlite.Transaction (Map Referent Referent)
|
||||
mappings (old, new) = do
|
||||
old <- unhashTypeComponent codebase old
|
||||
new <- fmap (over _2 (either Decl.toDataDecl id)) <$> unhashTypeComponent codebase new
|
||||
@ -264,19 +264,24 @@ propagate patch b = case validatePatch patch of
|
||||
n : _ -> show n
|
||||
|
||||
Cli.Env {codebase} <- ask
|
||||
initialDirty <-
|
||||
computeDirty
|
||||
(liftIO . Codebase.dependents codebase Queries.ExcludeOwnComponent)
|
||||
patch
|
||||
(Names.contains names0)
|
||||
|
||||
let initialTypeReplacements = Map.mapMaybe TypeEdit.toReference initialTypeEdits
|
||||
-- TODO: once patches can directly contain constructor replacements, this
|
||||
-- line can turn into a pure function that takes the subset of the term replacements
|
||||
-- in the patch which have a `Referent.Con` as their LHS.
|
||||
initialCtorMappings <- genInitialCtorMapping codebase rootNames initialTypeReplacements
|
||||
(initialDirty, initialTypeReplacements, initialCtorMappings, order) <-
|
||||
Cli.runTransaction do
|
||||
initialDirty <-
|
||||
computeDirty
|
||||
(Codebase.dependents codebase Queries.ExcludeOwnComponent)
|
||||
patch
|
||||
(Names.contains names0)
|
||||
|
||||
let initialTypeReplacements = Map.mapMaybe TypeEdit.toReference initialTypeEdits
|
||||
-- TODO: once patches can directly contain constructor replacements, this
|
||||
-- line can turn into a pure function that takes the subset of the term replacements
|
||||
-- in the patch which have a `Referent.Con` as their LHS.
|
||||
initialCtorMappings <- genInitialCtorMapping codebase rootNames initialTypeReplacements
|
||||
|
||||
order <- sortDependentsGraph codebase initialDirty entireBranch
|
||||
pure (initialDirty, initialTypeReplacements, initialCtorMappings, order)
|
||||
|
||||
order <- liftIO (sortDependentsGraph codebase initialDirty entireBranch)
|
||||
let getOrdered :: Set Reference -> Map Int Reference
|
||||
getOrdered rs =
|
||||
Map.fromList [(i, r) | r <- toList rs, Just i <- [Map.lookup r order]]
|
||||
@ -302,26 +307,29 @@ propagate patch b = case validatePatch patch of
|
||||
if Map.member r termEdits || Set.member r seen || Map.member r typeEdits
|
||||
then collectEdits es seen todo
|
||||
else do
|
||||
haveType <- liftIO (Codebase.isType codebase r)
|
||||
haveTerm <- liftIO (Codebase.isTerm codebase r)
|
||||
let message =
|
||||
"This reference is not a term nor a type " <> show r
|
||||
mayEdits <-
|
||||
Cli.runTransaction do
|
||||
haveType <- Codebase.isType codebase r
|
||||
haveTerm <- Codebase.isTerm codebase r
|
||||
let message =
|
||||
"This reference is not a term nor a type " <> show r
|
||||
mmayEdits
|
||||
| haveTerm = doTerm r
|
||||
| haveType = doType r
|
||||
| otherwise = error message
|
||||
mmayEdits
|
||||
| haveTerm = doTerm r
|
||||
| haveType = doType r
|
||||
| otherwise = error message
|
||||
mayEdits <- mmayEdits
|
||||
case mayEdits of
|
||||
(Nothing, seen') -> collectEdits es seen' todo
|
||||
(Just edits', seen') -> do
|
||||
-- plan to update the dependents of this component too
|
||||
dependents <- case r of
|
||||
Reference.Builtin {} -> liftIO (Codebase.dependents codebase Queries.ExcludeOwnComponent r)
|
||||
Reference.Builtin {} ->
|
||||
Cli.runTransaction (Codebase.dependents codebase Queries.ExcludeOwnComponent r)
|
||||
Reference.Derived h _i -> liftIO (Codebase.dependentsOfComponent codebase h)
|
||||
let todo' = todo <> getOrdered dependents
|
||||
collectEdits edits' seen' todo'
|
||||
|
||||
doType :: Reference -> Cli (Maybe (Edits Symbol), Set Reference)
|
||||
doType :: Reference -> Sqlite.Transaction (Maybe (Edits Symbol), Set Reference)
|
||||
doType r = do
|
||||
when debugMode $ traceM ("Rewriting type: " <> refName r)
|
||||
componentMap <- unhashTypeComponent codebase r
|
||||
@ -365,7 +373,7 @@ propagate patch b = case validatePatch patch of
|
||||
)
|
||||
seen' = seen <> Set.fromList (view _1 . view _2 <$> joinedStuff)
|
||||
writeTypes = traverse_ $ \case
|
||||
(Reference.DerivedId id, tp) -> liftIO (Codebase.putTypeDeclaration codebase id tp)
|
||||
(Reference.DerivedId id, tp) -> Codebase.putTypeDeclaration codebase id tp
|
||||
_ -> error "propagate: Expected DerivedId"
|
||||
!newCtorMappings =
|
||||
let r = propagateCtorMapping componentMap hashedComponents'
|
||||
@ -384,17 +392,18 @@ propagate patch b = case validatePatch patch of
|
||||
constructorReplacements',
|
||||
seen'
|
||||
)
|
||||
doTerm :: Reference -> Cli (Maybe (Edits Symbol), Set Reference)
|
||||
doTerm :: Reference -> Sqlite.Transaction (Maybe (Edits Symbol), Set Reference)
|
||||
doTerm r = do
|
||||
when debugMode (traceM $ "Rewriting term: " <> show r)
|
||||
componentMap <- unhashTermComponent r
|
||||
let componentMap' =
|
||||
over
|
||||
_2
|
||||
(Term.updateDependencies termReplacements typeReplacements)
|
||||
<$> componentMap
|
||||
seen' = seen <> Set.fromList (view _1 <$> Map.elems componentMap)
|
||||
mayComponent <- verifyTermComponent componentMap' es
|
||||
componentMap <- unhashTermComponent codebase r
|
||||
let seen' = seen <> Set.fromList (view _1 <$> Map.elems componentMap)
|
||||
mayComponent <- do
|
||||
let componentMap' =
|
||||
over
|
||||
_2
|
||||
(Term.updateDependencies termReplacements typeReplacements)
|
||||
<$> componentMap
|
||||
verifyTermComponent codebase componentMap' es
|
||||
case mayComponent of
|
||||
Nothing -> do
|
||||
when debugMode (traceM $ refName r <> " did not typecheck after substitutions")
|
||||
@ -424,7 +433,7 @@ propagate patch b = case validatePatch patch of
|
||||
toNewTerm (_, r', tm, _, tp) = (r', (tm, tp))
|
||||
writeTerms =
|
||||
traverse_ \case
|
||||
(Reference.DerivedId id, (tm, tp)) -> liftIO (Codebase.putTerm codebase id tm tp)
|
||||
(Reference.DerivedId id, (tm, tp)) -> Codebase.putTerm codebase id tm tp
|
||||
_ -> error "propagate: Expected DerivedId"
|
||||
writeTerms
|
||||
[(r, (tm, ty)) | (_old, r, tm, _oldTy, ty) <- joinedStuff]
|
||||
@ -457,15 +466,15 @@ propagate patch b = case validatePatch patch of
|
||||
initialTermReplacements ctors es =
|
||||
ctors
|
||||
<> (Map.mapKeys Referent.Ref . fmap Referent.Ref . Map.mapMaybe TermEdit.toReference) es
|
||||
sortDependentsGraph :: Codebase IO Symbol Ann -> Set Reference -> Set Reference -> IO (Map Reference Int)
|
||||
sortDependentsGraph :: Codebase IO Symbol Ann -> Set Reference -> Set Reference -> Sqlite.Transaction (Map Reference Int)
|
||||
sortDependentsGraph codebase dependencies restrictTo = do
|
||||
closure <-
|
||||
transitiveClosure
|
||||
(fmap (Set.intersection restrictTo) . liftIO . Codebase.dependents codebase Queries.ExcludeOwnComponent)
|
||||
(fmap (Set.intersection restrictTo) . Codebase.dependents codebase Queries.ExcludeOwnComponent)
|
||||
dependencies
|
||||
dependents <-
|
||||
traverse
|
||||
(\r -> (r,) <$> (liftIO . Codebase.dependents codebase Queries.ExcludeOwnComponent) r)
|
||||
(\r -> (r,) <$> (Codebase.dependents codebase Queries.ExcludeOwnComponent) r)
|
||||
(toList closure)
|
||||
let graphEdges = [(r, r, toList deps) | (r, deps) <- toList dependents]
|
||||
(graph, getReference, _) = Graph.graphFromEdges graphEdges
|
||||
@ -486,20 +495,22 @@ propagate patch b = case validatePatch patch of
|
||||
-- Free (Command m i v) monad, passing in the actions that are needed.
|
||||
-- However, if we want this to be parametric in the annotation type, then
|
||||
-- Command would have to be made parametric in the annotation type too.
|
||||
unhashTermComponent :: Reference -> Cli (Map Symbol (Reference, Term Symbol Ann, Type Symbol Ann))
|
||||
unhashTermComponent r = case Reference.toId r of
|
||||
unhashTermComponent ::
|
||||
Codebase m Symbol Ann ->
|
||||
Reference ->
|
||||
Sqlite.Transaction (Map Symbol (Reference, Term Symbol Ann, Type Symbol Ann))
|
||||
unhashTermComponent codebase r = case Reference.toId r of
|
||||
Nothing -> pure mempty
|
||||
Just r -> do
|
||||
unhashed <- unhashTermComponent' (Reference.idToHash r)
|
||||
unhashed <- unhashTermComponent' codebase (Reference.idToHash r)
|
||||
pure $ fmap (over _1 Reference.DerivedId) unhashed
|
||||
|
||||
unhashTermComponent' :: Hash -> Cli (Map Symbol (Reference.Id, Term Symbol Ann, Type Symbol Ann))
|
||||
unhashTermComponent' h = do
|
||||
Cli.Env {codebase} <- ask
|
||||
maybeTermsWithTypes <-
|
||||
liftIO do
|
||||
Codebase.withConnection codebase \conn ->
|
||||
Sqlite.runTransaction conn (Codebase.getTermComponentWithTypes codebase h)
|
||||
unhashTermComponent' ::
|
||||
Codebase m Symbol Ann ->
|
||||
Hash ->
|
||||
Sqlite.Transaction (Map Symbol (Reference.Id, Term Symbol Ann, Type Symbol Ann))
|
||||
unhashTermComponent' codebase h = do
|
||||
maybeTermsWithTypes <- Codebase.getTermComponentWithTypes codebase h
|
||||
pure do
|
||||
foldMap (\termsWithTypes -> unhash $ Map.fromList (Reference.componentFor h termsWithTypes)) maybeTermsWithTypes
|
||||
where
|
||||
@ -512,10 +523,11 @@ propagate patch b = case validatePatch patch of
|
||||
[(v, (r, tm, tp)) | (r, (v, tm, tp)) <- Map.toList m']
|
||||
|
||||
verifyTermComponent ::
|
||||
Codebase m Symbol Ann ->
|
||||
Map Symbol (Reference, Term Symbol Ann, a) ->
|
||||
Edits Symbol ->
|
||||
Cli (Maybe (Map Symbol (Reference, Maybe WatchKind, Term Symbol Ann, Type Symbol Ann)))
|
||||
verifyTermComponent componentMap Edits {..} = do
|
||||
Sqlite.Transaction (Maybe (Map Symbol (Reference, Maybe WatchKind, Term Symbol Ann, Type Symbol Ann)))
|
||||
verifyTermComponent codebase componentMap Edits {..} = do
|
||||
-- If the term contains references to old patterns, we can't update it.
|
||||
-- If the term had a redunant type signature, it's discarded and a new type
|
||||
-- is inferred. If it wasn't redunant, we have already substituted any updates
|
||||
@ -538,32 +550,32 @@ propagate patch b = case validatePatch patch of
|
||||
mempty
|
||||
(Map.toList $ (\(_, tm, _) -> tm) <$> componentMap)
|
||||
mempty
|
||||
typecheckResult <- typecheckFile [] file
|
||||
typecheckResult <- typecheckFile codebase [] file
|
||||
pure
|
||||
. fmap UF.hashTerms
|
||||
$ runIdentity (Result.toMaybe typecheckResult)
|
||||
>>= hush
|
||||
|
||||
typecheckFile ::
|
||||
Codebase m Symbol Ann ->
|
||||
[Type Symbol Ann] ->
|
||||
UF.UnisonFile Symbol Ann ->
|
||||
Cli (Result.Result (Seq (Result.Note Symbol Ann)) (Either Names (UF.TypecheckedUnisonFile Symbol Ann)))
|
||||
typecheckFile ambient file = do
|
||||
Cli.Env {codebase} <- ask
|
||||
typeLookup <- liftIO (Codebase.typeLookupForDependencies codebase (UF.dependencies file))
|
||||
Sqlite.Transaction (Result.Result (Seq (Result.Note Symbol Ann)) (Either Names (UF.TypecheckedUnisonFile Symbol Ann)))
|
||||
typecheckFile codebase ambient file = do
|
||||
typeLookup <- Codebase.typeLookupForDependencies codebase (UF.dependencies file)
|
||||
pure . fmap Right $ synthesizeFile' ambient (typeLookup <> Builtin.typeLookup) file
|
||||
|
||||
-- TypecheckFile file ambient -> liftIO $ typecheck' ambient codebase file
|
||||
unhashTypeComponent :: Codebase IO Symbol Ann -> Reference -> Cli (Map Symbol (Reference, Decl Symbol Ann))
|
||||
unhashTypeComponent :: Codebase IO Symbol Ann -> Reference -> Sqlite.Transaction (Map Symbol (Reference, Decl Symbol Ann))
|
||||
unhashTypeComponent codebase r = case Reference.toId r of
|
||||
Nothing -> pure mempty
|
||||
Just id -> do
|
||||
unhashed <- unhashTypeComponent' codebase (Reference.idToHash id)
|
||||
pure $ over _1 Reference.DerivedId <$> unhashed
|
||||
|
||||
unhashTypeComponent' :: Codebase IO Symbol Ann -> Hash -> Cli (Map Symbol (Reference.Id, Decl Symbol Ann))
|
||||
unhashTypeComponent' :: Codebase IO Symbol Ann -> Hash -> Sqlite.Transaction (Map Symbol (Reference.Id, Decl Symbol Ann))
|
||||
unhashTypeComponent' codebase h =
|
||||
liftIO (Codebase.getDeclComponent codebase h) <&> foldMap \decls ->
|
||||
Codebase.getDeclComponent codebase h <&> foldMap \decls ->
|
||||
unhash $ Map.fromList (Reference.componentFor h decls)
|
||||
where
|
||||
unhash =
|
||||
|
@ -23,6 +23,7 @@ import Unison.Prelude
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
import qualified Unison.Referent' as Referent
|
||||
import Unison.Symbol (Symbol)
|
||||
import qualified Unison.UnisonFile as UF
|
||||
import qualified Unison.UnisonFile.Names as UF
|
||||
import qualified Unison.Util.Map as Map
|
||||
@ -41,11 +42,11 @@ data SlurpOp
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Tag a variable as representing a term, type, or constructor
|
||||
data TaggedVar v = TermVar v | TypeVar v | ConstructorVar v
|
||||
data TaggedVar = TermVar Symbol | TypeVar Symbol | ConstructorVar Symbol
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Extract the var from a TaggedVar
|
||||
untagged :: TaggedVar v -> v
|
||||
untagged :: TaggedVar -> Symbol
|
||||
untagged (TermVar v) = v
|
||||
untagged (TypeVar v) = v
|
||||
untagged (ConstructorVar v) = v
|
||||
@ -95,24 +96,22 @@ mostSevereDepStatus =
|
||||
-- | Analyze a file and determine the status of all of its definitions with respect to a set
|
||||
-- of vars to analyze and an operation you wish to perform.
|
||||
slurpFile ::
|
||||
forall v.
|
||||
Var v =>
|
||||
UF.TypecheckedUnisonFile v Ann ->
|
||||
Set v ->
|
||||
UF.TypecheckedUnisonFile Symbol Ann ->
|
||||
Set Symbol ->
|
||||
SlurpOp ->
|
||||
Names ->
|
||||
SR.SlurpResult v
|
||||
SR.SlurpResult
|
||||
slurpFile uf defsToConsider slurpOp unalteredCodebaseNames =
|
||||
let -- A mapping of all vars in the file to their references.
|
||||
-- TypeVars are keyed to Type references
|
||||
-- TermVars are keyed to Term references
|
||||
-- ConstructorVars are keyed to Constructor references
|
||||
varReferences :: Map (TaggedVar v) LD.LabeledDependency
|
||||
varReferences :: Map TaggedVar LD.LabeledDependency
|
||||
varReferences = buildVarReferences uf
|
||||
-- All variables which were either:
|
||||
-- 1. specified explicitly by the end-user
|
||||
-- 2. An in-file transitive dependency (within the file) of a var specified by the end-user.
|
||||
involvedVars :: Set (TaggedVar v)
|
||||
involvedVars :: Set TaggedVar
|
||||
involvedVars = computeInvolvedVars uf defsToConsider varReferences
|
||||
-- The set of names after removing any constructors which would
|
||||
-- be removed by the requested operation.
|
||||
@ -121,14 +120,14 @@ slurpFile uf defsToConsider slurpOp unalteredCodebaseNames =
|
||||
-- A mapping of every involved variable to its transitive dependencies.
|
||||
-- Dependency here is any type or term referenced within the definition (transitively).
|
||||
-- This also includes all Constructors of any type used by a term.
|
||||
varDeps :: Map (TaggedVar v) (Set (TaggedVar v))
|
||||
varDeps :: Map TaggedVar (Set TaggedVar)
|
||||
varDeps = computeVarDeps uf involvedVars
|
||||
-- Compute the status of each definition on its own.
|
||||
-- This doesn't consider the vars dependencies.
|
||||
selfStatuses :: Map (TaggedVar v) DefnStatus
|
||||
selfStatuses :: Map TaggedVar DefnStatus
|
||||
selfStatuses = computeSelfStatuses involvedVars varReferences codebaseNames
|
||||
-- A mapping from each definition's name to the most severe status of it plus its transitive dependencies.
|
||||
depStatuses :: Map (TaggedVar v) DepStatus
|
||||
depStatuses :: Map TaggedVar DepStatus
|
||||
depStatuses = computeDepStatuses varDeps selfStatuses
|
||||
in toSlurpResult uf slurpOp defsToConsider involvedVars fileNames codebaseNames selfStatuses depStatuses
|
||||
where
|
||||
@ -138,10 +137,9 @@ slurpFile uf defsToConsider slurpOp unalteredCodebaseNames =
|
||||
-- | Return a modified set of names with constructors which would be deprecated by possible
|
||||
-- updates are removed.
|
||||
computeNamesWithDeprecations ::
|
||||
Var v =>
|
||||
UF.TypecheckedUnisonFile v Ann ->
|
||||
UF.TypecheckedUnisonFile Symbol Ann ->
|
||||
Names ->
|
||||
Set (TaggedVar v) ->
|
||||
Set TaggedVar ->
|
||||
SlurpOp ->
|
||||
Names
|
||||
computeNamesWithDeprecations uf unalteredCodebaseNames involvedVars = \case
|
||||
@ -183,16 +181,14 @@ computeNamesWithDeprecations uf unalteredCodebaseNames involvedVars = \case
|
||||
|
||||
-- | Compute a mapping of each definition to its status.
|
||||
computeSelfStatuses ::
|
||||
forall v.
|
||||
(Ord v, Var v) =>
|
||||
Set (TaggedVar v) ->
|
||||
Map (TaggedVar v) LD.LabeledDependency ->
|
||||
Set TaggedVar ->
|
||||
Map TaggedVar LD.LabeledDependency ->
|
||||
Names ->
|
||||
Map (TaggedVar v) DefnStatus
|
||||
Map TaggedVar DefnStatus
|
||||
computeSelfStatuses vars varReferences codebaseNames =
|
||||
Map.fromSet definitionStatus vars
|
||||
where
|
||||
definitionStatus :: TaggedVar v -> DefnStatus
|
||||
definitionStatus :: TaggedVar -> DefnStatus
|
||||
definitionStatus tv =
|
||||
let ld = case Map.lookup tv varReferences of
|
||||
Just r -> r
|
||||
@ -232,12 +228,10 @@ computeDepStatuses varDeps selfStatuses =
|
||||
-- I.e. any variable requested by the user and all of their dependencies,
|
||||
-- component peers, and component peers of dependencies.
|
||||
computeInvolvedVars ::
|
||||
forall v.
|
||||
Var v =>
|
||||
UF.TypecheckedUnisonFile v Ann ->
|
||||
Set v ->
|
||||
Map (TaggedVar v) LD.LabeledDependency ->
|
||||
Set (TaggedVar v)
|
||||
UF.TypecheckedUnisonFile Symbol Ann ->
|
||||
Set Symbol ->
|
||||
Map TaggedVar LD.LabeledDependency ->
|
||||
Set TaggedVar
|
||||
computeInvolvedVars uf defsToConsider varReferences
|
||||
-- If nothing was specified, consider every var in the file.
|
||||
| Set.null defsToConsider = Map.keysSet varReferences
|
||||
@ -245,8 +239,8 @@ computeInvolvedVars uf defsToConsider varReferences
|
||||
where
|
||||
-- The user specifies _untyped_ names, which may not even exist in the file.
|
||||
-- We need to figure out which vars exist, and what type they are if they do.
|
||||
requestedVarsWhichActuallyExist :: Set (TaggedVar v)
|
||||
requestedVarsWhichActuallyExist = Set.fromList $ do
|
||||
requestedVarsWhichActuallyExist :: Set TaggedVar
|
||||
requestedVarsWhichActuallyExist = Set.fromList do
|
||||
v <- Set.toList defsToConsider
|
||||
-- We don't know whether each var is a type or term, so we try both.
|
||||
-- We don't test ConstructorVar because you can't request to add/update a Constructor in
|
||||
@ -257,11 +251,9 @@ computeInvolvedVars uf defsToConsider varReferences
|
||||
|
||||
-- | Compute transitive dependencies for all relevant variables.
|
||||
computeVarDeps ::
|
||||
forall v.
|
||||
Var v =>
|
||||
UF.TypecheckedUnisonFile v Ann ->
|
||||
Set (TaggedVar v) ->
|
||||
Map (TaggedVar v) (Set (TaggedVar v))
|
||||
UF.TypecheckedUnisonFile Symbol Ann ->
|
||||
Set TaggedVar ->
|
||||
Map TaggedVar (Set TaggedVar)
|
||||
computeVarDeps uf allInvolvedVars =
|
||||
allInvolvedVars
|
||||
& Set.toList
|
||||
@ -272,17 +264,17 @@ computeVarDeps uf allInvolvedVars =
|
||||
|
||||
-- | Compute the closure of all vars which the provided vars depend on.
|
||||
-- A type depends on its constructors.
|
||||
varClosure :: (Var v) => UF.TypecheckedUnisonFile v a -> Set (TaggedVar v) -> Set (TaggedVar v)
|
||||
varClosure :: UF.TypecheckedUnisonFile Symbol a -> Set TaggedVar -> Set TaggedVar
|
||||
varClosure uf (partitionVars -> sc) =
|
||||
let deps = SC.closeWithDependencies uf sc
|
||||
in mingleVars deps
|
||||
|
||||
-- | Collect a relation of term or type var to labelled dependency for all definitions mentioned in a file.
|
||||
buildVarReferences :: forall v a. (Ord v, Show v) => UF.TypecheckedUnisonFile v a -> Map (TaggedVar v) LD.LabeledDependency
|
||||
buildVarReferences :: UF.TypecheckedUnisonFile Symbol a -> Map TaggedVar LD.LabeledDependency
|
||||
buildVarReferences uf =
|
||||
decls <> effects <> terms <> constructors
|
||||
where
|
||||
terms :: Map (TaggedVar v) LD.LabeledDependency
|
||||
terms :: Map TaggedVar LD.LabeledDependency
|
||||
terms =
|
||||
UF.hashTermsId uf
|
||||
-- Filter out non-test watch expressions
|
||||
@ -295,30 +287,30 @@ buildVarReferences uf =
|
||||
& Map.bimap
|
||||
TermVar
|
||||
(\(refId, _, _, _) -> LD.derivedTerm refId)
|
||||
decls :: Map (TaggedVar v) LD.LabeledDependency
|
||||
decls :: Map TaggedVar LD.LabeledDependency
|
||||
decls =
|
||||
UF.dataDeclarationsId' uf
|
||||
& Map.bimap
|
||||
TypeVar
|
||||
(\(refId, _) -> LD.derivedType refId)
|
||||
|
||||
effects :: Map (TaggedVar v) LD.LabeledDependency
|
||||
effects :: Map TaggedVar LD.LabeledDependency
|
||||
effects =
|
||||
UF.effectDeclarationsId' uf
|
||||
& Map.bimap
|
||||
TypeVar
|
||||
(\(refId, _) -> LD.derivedType refId)
|
||||
|
||||
constructors :: Map (TaggedVar v) LD.LabeledDependency
|
||||
constructors :: Map TaggedVar LD.LabeledDependency
|
||||
constructors =
|
||||
let effectConstructors :: Map (TaggedVar v) LD.LabeledDependency
|
||||
let effectConstructors :: Map TaggedVar LD.LabeledDependency
|
||||
effectConstructors = Map.fromList $ do
|
||||
(_, (typeRefId, effect)) <- Map.toList (UF.effectDeclarations' uf)
|
||||
let decl = DD.toDataDecl effect
|
||||
(conId, constructorV) <- zip (DD.constructorIds decl) (DD.constructorVars decl)
|
||||
pure $ (ConstructorVar constructorV, LD.effectConstructor (CR.ConstructorReference typeRefId conId))
|
||||
|
||||
dataConstructors :: Map (TaggedVar v) LD.LabeledDependency
|
||||
dataConstructors :: Map TaggedVar LD.LabeledDependency
|
||||
dataConstructors = Map.fromList $ do
|
||||
(_, (typeRefId, decl)) <- Map.toList (UF.dataDeclarations' uf)
|
||||
(conId, constructorV) <- zip (DD.constructorIds decl) (DD.constructorVars decl)
|
||||
@ -326,16 +318,16 @@ buildVarReferences uf =
|
||||
in effectConstructors <> dataConstructors
|
||||
|
||||
-- A helper type just used by 'toSlurpResult' for partitioning results.
|
||||
data SlurpingSummary v = SlurpingSummary
|
||||
{ adds :: !(SlurpComponent v),
|
||||
duplicates :: !(SlurpComponent v),
|
||||
updates :: !(SlurpComponent v),
|
||||
termCtorColl :: !(SlurpComponent v),
|
||||
ctorTermColl :: !(SlurpComponent v),
|
||||
blocked :: !(SlurpComponent v)
|
||||
data SlurpingSummary = SlurpingSummary
|
||||
{ adds :: !SlurpComponent,
|
||||
duplicates :: !SlurpComponent,
|
||||
updates :: !SlurpComponent,
|
||||
termCtorColl :: !SlurpComponent,
|
||||
ctorTermColl :: !SlurpComponent,
|
||||
blocked :: !SlurpComponent
|
||||
}
|
||||
|
||||
instance Ord v => Semigroup (SlurpingSummary v) where
|
||||
instance Semigroup SlurpingSummary where
|
||||
SlurpingSummary a b c d e f
|
||||
<> SlurpingSummary a' b' c' d' e' f' =
|
||||
SlurpingSummary
|
||||
@ -346,22 +338,20 @@ instance Ord v => Semigroup (SlurpingSummary v) where
|
||||
(e <> e')
|
||||
(f <> f')
|
||||
|
||||
instance Ord v => Monoid (SlurpingSummary v) where
|
||||
instance Monoid SlurpingSummary where
|
||||
mempty = SlurpingSummary mempty mempty mempty mempty mempty mempty
|
||||
|
||||
-- | Convert a 'VarsByStatus' mapping into a 'SR.SlurpResult'
|
||||
toSlurpResult ::
|
||||
forall v.
|
||||
(Var v) =>
|
||||
UF.TypecheckedUnisonFile v Ann ->
|
||||
UF.TypecheckedUnisonFile Symbol Ann ->
|
||||
SlurpOp ->
|
||||
Set v ->
|
||||
Set (TaggedVar v) ->
|
||||
Set Symbol ->
|
||||
Set TaggedVar ->
|
||||
Names ->
|
||||
Names ->
|
||||
Map (TaggedVar v) DefnStatus ->
|
||||
Map (TaggedVar v) DepStatus ->
|
||||
SR.SlurpResult v
|
||||
Map TaggedVar DefnStatus ->
|
||||
Map TaggedVar DepStatus ->
|
||||
SR.SlurpResult
|
||||
toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatuses depStatuses =
|
||||
SR.SlurpResult
|
||||
{ SR.originalFile = uf,
|
||||
@ -393,7 +383,7 @@ toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatu
|
||||
|
||||
-- Compute a singleton summary for a single definition, per its own status and the most severe status of its
|
||||
-- transitive dependencies.
|
||||
summarize1 :: TaggedVar v -> DefnStatus -> SlurpingSummary v
|
||||
summarize1 :: TaggedVar -> DefnStatus -> SlurpingSummary
|
||||
summarize1 name = \case
|
||||
CtorTermCollision -> mempty {ctorTermColl = sc}
|
||||
Duplicated -> mempty {duplicates = sc}
|
||||
@ -413,7 +403,7 @@ toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatu
|
||||
DepNeedsUpdate -> mempty {updates = sc}
|
||||
DepCollision -> mempty {blocked = sc}
|
||||
where
|
||||
sc :: SlurpComponent v
|
||||
sc :: SlurpComponent
|
||||
sc =
|
||||
scFromTaggedVar name
|
||||
|
||||
@ -421,7 +411,7 @@ toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatu
|
||||
depStatus =
|
||||
Map.findWithDefault DepOk name depStatuses
|
||||
|
||||
scFromTaggedVar :: TaggedVar v -> SlurpComponent v
|
||||
scFromTaggedVar :: TaggedVar -> SlurpComponent
|
||||
scFromTaggedVar = \case
|
||||
TermVar v -> SC.fromTerms (Set.singleton v)
|
||||
TypeVar v -> SC.fromTypes (Set.singleton v)
|
||||
@ -430,8 +420,8 @@ toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatu
|
||||
buildAliases ::
|
||||
Rel.Relation Name Referent ->
|
||||
Rel.Relation Name Referent ->
|
||||
Set v ->
|
||||
Map v SR.Aliases
|
||||
Set Symbol ->
|
||||
Map Symbol SR.Aliases
|
||||
buildAliases existingNames namesFromFile dups =
|
||||
Map.fromList
|
||||
[ ( varFromName n,
|
||||
@ -452,14 +442,14 @@ toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatu
|
||||
Set.notMember (varFromName n) dups
|
||||
]
|
||||
|
||||
termAliases :: Map v SR.Aliases
|
||||
termAliases :: Map Symbol SR.Aliases
|
||||
termAliases =
|
||||
buildAliases
|
||||
(Names.terms codebaseNames)
|
||||
(Names.terms fileNames)
|
||||
(SC.terms duplicates)
|
||||
|
||||
typeAliases :: Map v SR.Aliases
|
||||
typeAliases :: Map Symbol SR.Aliases
|
||||
typeAliases =
|
||||
buildAliases
|
||||
(Rel.mapRan Referent.Ref $ Names.types codebaseNames)
|
||||
@ -470,7 +460,7 @@ toSlurpResult uf op requestedVars involvedVars fileNames codebaseNames selfStatu
|
||||
varFromName name = Var.named (Name.toText name)
|
||||
|
||||
-- | Sort out a set of variables by whether it is a term or type.
|
||||
partitionVars :: (Foldable f, Ord v) => f (TaggedVar v) -> SlurpComponent v
|
||||
partitionVars :: Foldable f => f TaggedVar -> SlurpComponent
|
||||
partitionVars =
|
||||
foldMap
|
||||
( \case
|
||||
@ -480,7 +470,7 @@ partitionVars =
|
||||
)
|
||||
|
||||
-- | Collapse a SlurpComponent into a tagged set.
|
||||
mingleVars :: Ord v => SlurpComponent v -> Set (TaggedVar v)
|
||||
mingleVars :: SlurpComponent -> Set TaggedVar
|
||||
mingleVars SlurpComponent {terms, types, ctors} =
|
||||
Set.map TypeVar types
|
||||
<> Set.map TermVar terms
|
||||
|
@ -1,41 +1,64 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
module Unison.Codebase.Editor.SlurpComponent
|
||||
( -- * Slurp component
|
||||
SlurpComponent (..),
|
||||
|
||||
module Unison.Codebase.Editor.SlurpComponent where
|
||||
-- ** Basic constructors
|
||||
empty,
|
||||
fromTerms,
|
||||
fromTypes,
|
||||
fromCtors,
|
||||
|
||||
-- ** Predicates
|
||||
isEmpty,
|
||||
|
||||
-- ** Set operations
|
||||
difference,
|
||||
intersection,
|
||||
|
||||
-- ** Closure
|
||||
closeWithDependencies,
|
||||
)
|
||||
where
|
||||
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import Data.Tuple (swap)
|
||||
import qualified Unison.DataDeclaration as DD
|
||||
import Unison.Prelude
|
||||
import Unison.Prelude hiding (empty)
|
||||
import Unison.Reference (Reference)
|
||||
import Unison.Symbol (Symbol)
|
||||
import qualified Unison.Term as Term
|
||||
import Unison.UnisonFile (TypecheckedUnisonFile)
|
||||
import qualified Unison.UnisonFile as UF
|
||||
|
||||
data SlurpComponent v = SlurpComponent {types :: Set v, terms :: Set v, ctors :: Set v}
|
||||
data SlurpComponent = SlurpComponent
|
||||
{ types :: Set Symbol,
|
||||
terms :: Set Symbol,
|
||||
ctors :: Set Symbol
|
||||
}
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
isEmpty :: SlurpComponent v -> Bool
|
||||
isEmpty :: SlurpComponent -> Bool
|
||||
isEmpty sc = Set.null (types sc) && Set.null (terms sc) && Set.null (ctors sc)
|
||||
|
||||
empty :: Ord v => SlurpComponent v
|
||||
empty = SlurpComponent {types = mempty, terms = mempty, ctors = mempty}
|
||||
empty :: SlurpComponent
|
||||
empty = SlurpComponent {types = Set.empty, terms = Set.empty, ctors = Set.empty}
|
||||
|
||||
difference :: Ord v => SlurpComponent v -> SlurpComponent v -> SlurpComponent v
|
||||
difference :: SlurpComponent -> SlurpComponent -> SlurpComponent
|
||||
difference c1 c2 = SlurpComponent {types = types', terms = terms', ctors = ctors'}
|
||||
where
|
||||
types' = types c1 `Set.difference` types c2
|
||||
terms' = terms c1 `Set.difference` terms c2
|
||||
ctors' = ctors c1 `Set.difference` ctors c2
|
||||
|
||||
intersection :: Ord v => SlurpComponent v -> SlurpComponent v -> SlurpComponent v
|
||||
intersection :: SlurpComponent -> SlurpComponent -> SlurpComponent
|
||||
intersection c1 c2 = SlurpComponent {types = types', terms = terms', ctors = ctors'}
|
||||
where
|
||||
types' = types c1 `Set.intersection` types c2
|
||||
terms' = terms c1 `Set.intersection` terms c2
|
||||
ctors' = ctors c1 `Set.intersection` ctors c2
|
||||
|
||||
instance Ord v => Semigroup (SlurpComponent v) where
|
||||
instance Semigroup SlurpComponent where
|
||||
c1 <> c2 =
|
||||
SlurpComponent
|
||||
{ types = types c1 <> types c2,
|
||||
@ -43,36 +66,35 @@ instance Ord v => Semigroup (SlurpComponent v) where
|
||||
ctors = ctors c1 <> ctors c2
|
||||
}
|
||||
|
||||
instance Ord v => Monoid (SlurpComponent v) where
|
||||
mempty = SlurpComponent {types = mempty, terms = mempty, ctors = mempty}
|
||||
instance Monoid SlurpComponent where
|
||||
mempty = empty
|
||||
|
||||
-- I'm calling this `closeWithDependencies` because it doesn't just compute
|
||||
-- the dependencies of the inputs, it mixes them together. Make sure this
|
||||
-- is what you want.
|
||||
closeWithDependencies ::
|
||||
forall v a.
|
||||
Ord v =>
|
||||
TypecheckedUnisonFile v a ->
|
||||
SlurpComponent v ->
|
||||
SlurpComponent v
|
||||
forall a.
|
||||
TypecheckedUnisonFile Symbol a ->
|
||||
SlurpComponent ->
|
||||
SlurpComponent
|
||||
closeWithDependencies uf inputs = seenDefns {ctors = constructorDeps}
|
||||
where
|
||||
seenDefns = foldl' termDeps (SlurpComponent {terms = mempty, types = seenTypes, ctors = mempty}) (terms inputs)
|
||||
seenTypes = foldl' typeDeps mempty (types inputs)
|
||||
|
||||
constructorDeps :: Set v
|
||||
constructorDeps :: Set Symbol
|
||||
constructorDeps = UF.constructorsForDecls seenTypes uf
|
||||
|
||||
termDeps :: SlurpComponent v -> v -> SlurpComponent v
|
||||
termDeps :: SlurpComponent -> Symbol -> SlurpComponent
|
||||
termDeps seen v | Set.member v (terms seen) = seen
|
||||
termDeps seen v = fromMaybe seen $ do
|
||||
term <- findTerm v
|
||||
let -- get the `v`s for the transitive dependency types
|
||||
-- (the ones for terms are just the `freeVars below`)
|
||||
-- although this isn't how you'd do it for a term that's already in codebase
|
||||
tdeps :: [v]
|
||||
tdeps :: [Symbol]
|
||||
tdeps = resolveTypes $ Term.dependencies term
|
||||
seenTypes :: Set v
|
||||
seenTypes :: Set Symbol
|
||||
seenTypes = foldl' typeDeps (types seen) tdeps
|
||||
seenTerms = Set.insert v (terms seen)
|
||||
pure $
|
||||
@ -85,7 +107,7 @@ closeWithDependencies uf inputs = seenDefns {ctors = constructorDeps}
|
||||
)
|
||||
(Term.freeVars term)
|
||||
|
||||
typeDeps :: Set v -> v -> Set v
|
||||
typeDeps :: Set Symbol -> Symbol -> Set Symbol
|
||||
typeDeps seen v | Set.member v seen = seen
|
||||
typeDeps seen v = fromMaybe seen $ do
|
||||
dd <-
|
||||
@ -93,25 +115,25 @@ closeWithDependencies uf inputs = seenDefns {ctors = constructorDeps}
|
||||
<|> fmap (DD.toDataDecl . snd) (Map.lookup v (UF.effectDeclarations' uf))
|
||||
pure $ foldl' typeDeps (Set.insert v seen) (resolveTypes $ DD.dependencies dd)
|
||||
|
||||
resolveTypes :: Set Reference -> [v]
|
||||
resolveTypes :: Set Reference -> [Symbol]
|
||||
resolveTypes rs = [v | r <- Set.toList rs, Just v <- [Map.lookup r typeNames]]
|
||||
|
||||
findTerm :: v -> Maybe (Term.Term v a)
|
||||
findTerm :: Symbol -> Maybe (Term.Term Symbol a)
|
||||
findTerm v = Map.lookup v allTerms
|
||||
|
||||
allTerms = UF.allTerms uf
|
||||
|
||||
typeNames :: Map Reference v
|
||||
typeNames :: Map Reference Symbol
|
||||
typeNames = invert (fst <$> UF.dataDeclarations' uf) <> invert (fst <$> UF.effectDeclarations' uf)
|
||||
|
||||
invert :: forall k v. Ord k => Ord v => Map k v -> Map v k
|
||||
invert m = Map.fromList (swap <$> Map.toList m)
|
||||
|
||||
fromTypes :: Ord v => Set v -> SlurpComponent v
|
||||
fromTypes :: Set Symbol -> SlurpComponent
|
||||
fromTypes vs = mempty {types = vs}
|
||||
|
||||
fromTerms :: Ord v => Set v -> SlurpComponent v
|
||||
fromTerms :: Set Symbol -> SlurpComponent
|
||||
fromTerms vs = mempty {terms = vs}
|
||||
|
||||
fromCtors :: Ord v => Set v -> SlurpComponent v
|
||||
fromCtors :: Set Symbol -> SlurpComponent
|
||||
fromCtors vs = mempty {ctors = vs}
|
||||
|
@ -33,6 +33,7 @@ import Unison.Name (Name)
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import qualified Unison.PrettyPrintEnv as PPE
|
||||
import Unison.Symbol (Symbol)
|
||||
import qualified Unison.Syntax.DeclPrinter as DeclPrinter
|
||||
import qualified Unison.Syntax.TypePrinter as TP
|
||||
import qualified Unison.UnisonFile as UF
|
||||
@ -52,36 +53,36 @@ data Aliases
|
||||
}
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data SlurpResult v = SlurpResult
|
||||
data SlurpResult = SlurpResult
|
||||
{ -- The file that we tried to add from
|
||||
originalFile :: UF.TypecheckedUnisonFile v Ann,
|
||||
originalFile :: UF.TypecheckedUnisonFile Symbol Ann,
|
||||
-- Extra definitions that were added to satisfy transitive closure,
|
||||
-- beyond what the user specified.
|
||||
extraDefinitions :: SlurpComponent v,
|
||||
extraDefinitions :: SlurpComponent,
|
||||
-- Previously existed only in the file; now added to the codebase.
|
||||
adds :: SlurpComponent v,
|
||||
adds :: SlurpComponent,
|
||||
-- Exists in the branch and the file, with the same name and contents.
|
||||
duplicates :: SlurpComponent v,
|
||||
duplicates :: SlurpComponent,
|
||||
-- Not added to codebase due to the name already existing
|
||||
-- in the branch with a different definition.
|
||||
-- I.e. an update is required but we're performing an add.
|
||||
collisions :: SlurpComponent v,
|
||||
collisions :: SlurpComponent,
|
||||
-- Names that already exist in the branch, but whose definitions
|
||||
-- in `originalFile` are treated as updates.
|
||||
updates :: SlurpComponent v,
|
||||
updates :: SlurpComponent,
|
||||
-- Names of terms in `originalFile` that couldn't be updated because
|
||||
-- they refer to existing constructors. (User should instead do a find/replace,
|
||||
-- a constructor rename, or refactor the type that the name comes from).
|
||||
termExistingConstructorCollisions :: Set v,
|
||||
constructorExistingTermCollisions :: Set v,
|
||||
termExistingConstructorCollisions :: Set Symbol,
|
||||
constructorExistingTermCollisions :: Set Symbol,
|
||||
-- -- Already defined in the branch, but with a different name.
|
||||
termAlias :: Map v Aliases,
|
||||
typeAlias :: Map v Aliases,
|
||||
defsWithBlockedDependencies :: SlurpComponent v
|
||||
termAlias :: Map Symbol Aliases,
|
||||
typeAlias :: Map Symbol Aliases,
|
||||
defsWithBlockedDependencies :: SlurpComponent
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
hasAddsOrUpdates :: Ord v => SlurpResult v -> Bool
|
||||
hasAddsOrUpdates :: SlurpResult -> Bool
|
||||
hasAddsOrUpdates s =
|
||||
-- We intentionally ignore constructors here since they are added as part of adding their
|
||||
-- types.
|
||||
@ -120,11 +121,9 @@ aliasesToShow :: Int
|
||||
aliasesToShow = 5
|
||||
|
||||
pretty ::
|
||||
forall v.
|
||||
Var v =>
|
||||
IsPastTense ->
|
||||
PPE.PrettyPrintEnv ->
|
||||
SlurpResult v ->
|
||||
SlurpResult ->
|
||||
P.Pretty P.ColorText
|
||||
pretty isPast ppe sr =
|
||||
let tms = UF.hashTerms (originalFile sr)
|
||||
@ -190,7 +189,7 @@ pretty isPast ppe sr =
|
||||
++ (if null newNames then mempty else [newMessage])
|
||||
|
||||
-- The second field in the result is an optional second column.
|
||||
okTerm :: v -> [(P.Pretty P.ColorText, Maybe (P.Pretty P.ColorText))]
|
||||
okTerm :: Symbol -> [(P.Pretty P.ColorText, Maybe (P.Pretty P.ColorText))]
|
||||
okTerm v = case Map.lookup v tms of
|
||||
Nothing ->
|
||||
[(P.bold (prettyVar v), Just $ P.red "(Unison bug, unknown term)")]
|
||||
@ -303,14 +302,14 @@ pretty isPast ppe sr =
|
||||
sr
|
||||
]
|
||||
|
||||
isOk :: Ord v => SlurpResult v -> Bool
|
||||
isOk :: SlurpResult -> Bool
|
||||
isOk SlurpResult {..} =
|
||||
SC.isEmpty collisions
|
||||
&& Set.null termExistingConstructorCollisions
|
||||
&& Set.null constructorExistingTermCollisions
|
||||
&& SC.isEmpty defsWithBlockedDependencies
|
||||
|
||||
isAllDuplicates :: Ord v => SlurpResult v -> Bool
|
||||
isAllDuplicates :: SlurpResult -> Bool
|
||||
isAllDuplicates SlurpResult {..} =
|
||||
emptyIgnoringConstructors adds
|
||||
&& emptyIgnoringConstructors updates
|
||||
@ -322,15 +321,14 @@ isAllDuplicates SlurpResult {..} =
|
||||
&& Set.null constructorExistingTermCollisions
|
||||
&& emptyIgnoringConstructors defsWithBlockedDependencies
|
||||
where
|
||||
emptyIgnoringConstructors :: SlurpComponent v -> Bool
|
||||
emptyIgnoringConstructors :: SlurpComponent -> Bool
|
||||
emptyIgnoringConstructors SlurpComponent {types, terms} =
|
||||
null types && null terms
|
||||
|
||||
filterUnisonFile ::
|
||||
Ord v =>
|
||||
SlurpResult v ->
|
||||
UF.TypecheckedUnisonFile v Ann ->
|
||||
UF.TypecheckedUnisonFile v Ann
|
||||
SlurpResult ->
|
||||
UF.TypecheckedUnisonFile Symbol Ann ->
|
||||
UF.TypecheckedUnisonFile Symbol Ann
|
||||
filterUnisonFile
|
||||
SlurpResult {adds, updates}
|
||||
( UF.TypecheckedUnisonFileId
|
||||
|
@ -5,9 +5,12 @@ module Unison.Codebase.Editor.UriParser
|
||||
writeGitRepo,
|
||||
deprecatedWriteGitRemotePath,
|
||||
writeRemotePath,
|
||||
parseReadRemoteNamespace,
|
||||
parseReadShareRemoteNamespace,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Bifunctor (first)
|
||||
import Data.Char (isAlphaNum, isDigit, isSpace)
|
||||
import Data.Sequence as Seq
|
||||
import qualified Data.Text as Text
|
||||
@ -27,12 +30,14 @@ import Unison.Codebase.Editor.RemoteRepo
|
||||
)
|
||||
import Unison.Codebase.Path (Path (..))
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Codebase.ShortBranchHash (ShortBranchHash (..))
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
|
||||
import qualified Unison.Hash as Hash
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import qualified Unison.NameSegment as NameSegment
|
||||
import Unison.Prelude
|
||||
import qualified Unison.Syntax.Lexer
|
||||
import qualified Unison.Util.Pretty as P
|
||||
import qualified Unison.Util.Pretty.MegaParsec as P
|
||||
|
||||
type P = P.Parsec Void Text.Text
|
||||
|
||||
@ -60,6 +65,16 @@ repoPath =
|
||||
fmap ReadRemoteNamespaceGit readGitRemoteNamespace
|
||||
<|> fmap ReadRemoteNamespaceShare readShareRemoteNamespace
|
||||
|
||||
parseReadRemoteNamespace :: String -> String -> Either (P.Pretty P.ColorText) ReadRemoteNamespace
|
||||
parseReadRemoteNamespace label input =
|
||||
let printError err = P.lines [P.string "I couldn't parse the repository address given above.", P.prettyPrintParseError input err]
|
||||
in first printError (P.parse repoPath label (Text.pack input))
|
||||
|
||||
parseReadShareRemoteNamespace :: String -> String -> Either (P.Pretty P.ColorText) ReadShareRemoteNamespace
|
||||
parseReadShareRemoteNamespace label input =
|
||||
let printError err = P.lines [P.string "I couldn't parse this as a share path.", P.prettyPrintParseError input err]
|
||||
in first printError (P.parse readShareRemoteNamespace label (Text.pack input))
|
||||
|
||||
-- >>> P.parseMaybe writeRemotePath "unisonweb.base._releases.M4"
|
||||
-- >>> P.parseMaybe writeRemotePath "git(git@github.com:unisonweb/base:v3)._releases.M3"
|
||||
-- Just (WriteRemotePathShare (WriteShareRemotePath {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}))
|
||||
@ -88,7 +103,7 @@ readShareRemoteNamespace = do
|
||||
P.label "read share remote namespace" $
|
||||
ReadShareRemoteNamespace
|
||||
<$> pure DefaultCodeserver
|
||||
-- <*> sbh <- P.optional shortBranchHash
|
||||
-- <*> sch <- P.optional shortBranchHash
|
||||
<*> (NameSegment.toText <$> nameSegment)
|
||||
<*> (Path.fromList <$> P.many (C.char '.' *> nameSegment))
|
||||
|
||||
@ -97,11 +112,11 @@ readShareRemoteNamespace = do
|
||||
-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)"
|
||||
-- >>> P.parseMaybe readGitRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3"
|
||||
-- >>> P.parseMaybe readGitRemoteNamespace "git( user@server:project.git:branch )#asdf.foo.bar"
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = })
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = })
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Nothing, path = })
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "git@github.com:unisonweb/base", ref = Just "v3"}, sbh = Nothing, path = _releases.M3})
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = foo.bar})
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = })
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = })
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Nothing, path = })
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "git@github.com:unisonweb/base", ref = Just "v3"}, sch = Nothing, path = _releases.M3})
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = foo.bar})
|
||||
readGitRemoteNamespace :: P ReadGitRemoteNamespace
|
||||
readGitRemoteNamespace = P.label "generic git repo" $ do
|
||||
C.string "git("
|
||||
@ -111,8 +126,8 @@ readGitRemoteNamespace = P.label "generic git repo" $ do
|
||||
C.string ")"
|
||||
nshashPath <- P.optional namespaceHashPath
|
||||
pure case nshashPath of
|
||||
Nothing -> ReadGitRemoteNamespace {repo, sbh = Nothing, path = Path.empty}
|
||||
Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path}
|
||||
Nothing -> ReadGitRemoteNamespace {repo, sch = Nothing, path = Path.empty}
|
||||
Just (sch, path) -> ReadGitRemoteNamespace {repo, sch, path}
|
||||
|
||||
-- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git)"
|
||||
-- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git:branch)"
|
||||
@ -321,11 +336,11 @@ parseGitProtocol =
|
||||
--
|
||||
-- >>> P.parseMaybe namespaceHashPath "."
|
||||
-- Just (Nothing,)
|
||||
namespaceHashPath :: P (Maybe ShortBranchHash, Path)
|
||||
namespaceHashPath :: P (Maybe ShortCausalHash, Path)
|
||||
namespaceHashPath = do
|
||||
sbh <- P.optional shortBranchHash
|
||||
sch <- P.optional shortCausalHash
|
||||
p <- P.optional absolutePath
|
||||
pure (sbh, fromMaybe Path.empty p)
|
||||
pure (sch, fromMaybe Path.empty p)
|
||||
|
||||
-- >>> P.parseMaybe absolutePath "."
|
||||
-- Just
|
||||
@ -349,8 +364,8 @@ gitTreeishSuffix = P.label "git treeish" . P.try $ do
|
||||
void $ C.char ':'
|
||||
P.takeWhile1P (Just "not close paren") (/= ')')
|
||||
|
||||
shortBranchHash :: P ShortBranchHash
|
||||
shortBranchHash = P.label "short branch hash" $ do
|
||||
shortCausalHash :: P ShortCausalHash
|
||||
shortCausalHash = P.label "short causal hash" $ do
|
||||
void $ C.char '#'
|
||||
ShortBranchHash
|
||||
ShortCausalHash
|
||||
<$> P.takeWhile1P (Just "base32hex chars") (`elem` Hash.validBase32HexChars)
|
||||
|
@ -1,5 +1,4 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.CommandLine.DisplayValues where
|
||||
@ -329,7 +328,7 @@ displayDoc pped terms typeOf evaluated types = go
|
||||
let ppe = PPE.declarationPPE pped ref
|
||||
in terms ref >>= \case
|
||||
Nothing -> pure $ "😶 Missing term source for: " <> termName ppe r
|
||||
Just tm -> pure . P.syntaxToColor $ P.group $ TP.prettyBinding ppe (PPE.termName ppe r) tm
|
||||
Just tm -> pure . P.syntaxToColor . P.group $ TP.prettyBinding ppe (PPE.termName ppe r) tm
|
||||
Referent.Con (ConstructorReference r _) _ -> prettyType r
|
||||
prettyType r =
|
||||
let ppe = PPE.declarationPPE pped r
|
||||
|
@ -11,7 +11,6 @@ import qualified Data.Map as Map
|
||||
import Data.Proxy (Proxy (..))
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import Data.Void (Void)
|
||||
import System.Console.Haskeline.Completion (Completion (Completion))
|
||||
import qualified Text.Megaparsec as P
|
||||
import qualified Unison.Codebase.Branch as Branch
|
||||
@ -20,8 +19,9 @@ import Unison.Codebase.Editor.Input (Input)
|
||||
import qualified Unison.Codebase.Editor.Input as Input
|
||||
import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push))
|
||||
import qualified Unison.Codebase.Editor.Output.PushPull as PushPull
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemotePath)
|
||||
import Unison.Codebase.Editor.RemoteRepo (WriteGitRepo, WriteRemotePath)
|
||||
import qualified Unison.Codebase.Editor.SlurpResult as SR
|
||||
import Unison.Codebase.Editor.UriParser (parseReadRemoteNamespace)
|
||||
import qualified Unison.Codebase.Editor.UriParser as UriParser
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.Codebase.Path.Parse as Path
|
||||
@ -1358,46 +1358,6 @@ loadPullRequest =
|
||||
_ -> Left (I.help loadPullRequest)
|
||||
)
|
||||
|
||||
parseReadRemoteNamespace :: String -> String -> Either (P.Pretty P.ColorText) ReadRemoteNamespace
|
||||
parseReadRemoteNamespace label input =
|
||||
let printError err = P.lines [P.string "I couldn't parse the repository address given above.", prettyPrintParseError input err]
|
||||
in first printError (P.parse UriParser.repoPath label (Text.pack input))
|
||||
|
||||
prettyPrintParseError :: String -> P.ParseErrorBundle Text Void -> P.Pretty P.ColorText
|
||||
prettyPrintParseError input errBundle =
|
||||
let (firstError, sp) = NE.head . fst $ P.attachSourcePos P.errorOffset (P.bundleErrors errBundle) (P.bundlePosState errBundle)
|
||||
in case firstError of
|
||||
P.TrivialError _errorOffset ue ee ->
|
||||
P.lines
|
||||
[ printLocation sp,
|
||||
P.newline,
|
||||
printTrivial ue ee
|
||||
]
|
||||
P.FancyError _errorOffset ee ->
|
||||
let errors = foldMap (P.string . mappend "\n" . showErrorFancy) ee
|
||||
in P.lines
|
||||
[ printLocation sp,
|
||||
errors
|
||||
]
|
||||
where
|
||||
printLocation :: P.SourcePos -> P.Pretty P.ColorText
|
||||
printLocation sp =
|
||||
let col = (P.unPos $ P.sourceColumn sp) - 1
|
||||
row = (P.unPos $ P.sourceLine sp) - 1
|
||||
errorLine = lines input !! row
|
||||
in P.lines
|
||||
[ P.newline,
|
||||
P.string errorLine,
|
||||
P.string $ replicate col ' ' <> "^-- This is where I gave up."
|
||||
]
|
||||
|
||||
printTrivial :: (Maybe (P.ErrorItem Char)) -> (Set (P.ErrorItem Char)) -> P.Pretty P.ColorText
|
||||
printTrivial ue ee =
|
||||
let expected = "I expected " <> foldMap (P.singleQuoted . P.string . showErrorItem) ee
|
||||
found = P.string . mappend "I found " . showErrorItem <$> ue
|
||||
message = [expected] <> catMaybes [found]
|
||||
in P.oxfordCommasWith "." message
|
||||
|
||||
parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitRepo
|
||||
parseWriteGitRepo label input = do
|
||||
first
|
||||
@ -2005,6 +1965,24 @@ debugDoctor =
|
||||
_ -> Left (showPatternHelp debugDoctor)
|
||||
)
|
||||
|
||||
debugNameDiff :: InputPattern
|
||||
debugNameDiff =
|
||||
InputPattern
|
||||
{ patternName = "debug.name-diff",
|
||||
aliases = [],
|
||||
visibility = I.Hidden,
|
||||
argTypes = [(Required, namespaceArg), (Required, namespaceArg)],
|
||||
help = P.wrap "List all name changes between two causal hashes. Does not detect patch or metadata changes.",
|
||||
parse =
|
||||
( \case
|
||||
[from, to] -> first fromString $ do
|
||||
fromSCH <- Input.parseShortCausalHash from
|
||||
toSCH <- Input.parseShortCausalHash to
|
||||
pure $ Input.DebugNameDiffI fromSCH toSCH
|
||||
_ -> Left (I.help debugNameDiff)
|
||||
)
|
||||
}
|
||||
|
||||
test :: InputPattern
|
||||
test =
|
||||
InputPattern
|
||||
@ -2412,6 +2390,7 @@ validInputs =
|
||||
debugClearWatchCache,
|
||||
debugDoctor,
|
||||
debugTabCompletion,
|
||||
debugNameDiff,
|
||||
gist,
|
||||
authLogin,
|
||||
printVersion
|
||||
|
@ -37,6 +37,7 @@ import Unison.CommandLine
|
||||
import Unison.CommandLine.Completion (haskelineTabComplete)
|
||||
import qualified Unison.CommandLine.InputPatterns as IP
|
||||
import Unison.CommandLine.OutputMessages (notifyNumbered, notifyUser)
|
||||
import Unison.CommandLine.Types (ShouldWatchFiles (..))
|
||||
import qualified Unison.CommandLine.Welcome as Welcome
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
@ -103,8 +104,9 @@ main ::
|
||||
UCMVersion ->
|
||||
(Branch IO -> STM ()) ->
|
||||
(Path.Absolute -> STM ()) ->
|
||||
ShouldWatchFiles ->
|
||||
IO ()
|
||||
main dir welcome initialPath (config, cancelConfig) initialInputs runtime sbRuntime codebase serverBaseUrl ucmVersion notifyBranchChange notifyPathChange = Ki.scoped \scope -> do
|
||||
main dir welcome initialPath (config, cancelConfig) initialInputs runtime sbRuntime codebase serverBaseUrl ucmVersion notifyBranchChange notifyPathChange shouldWatchFiles = Ki.scoped \scope -> do
|
||||
rootVar <- newEmptyTMVarIO
|
||||
initialRootCausalHash <- Codebase.getRootCausalHash codebase
|
||||
_ <- Ki.fork scope $ do
|
||||
@ -134,7 +136,9 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime sbRunt
|
||||
welcomeEvents <- Welcome.run codebase welcome
|
||||
initialInputsRef <- newIORef $ welcomeEvents ++ initialInputs
|
||||
pageOutput <- newIORef True
|
||||
cancelFileSystemWatch <- watchFileSystem eventQueue dir
|
||||
cancelFileSystemWatch <- case shouldWatchFiles of
|
||||
ShouldNotWatchFiles -> pure (pure ())
|
||||
ShouldWatchFiles -> watchFileSystem eventQueue dir
|
||||
credentialManager <- newCredentialManager
|
||||
let tokenProvider = AuthN.newTokenProvider credentialManager
|
||||
authHTTPClient <- AuthN.newAuthenticatedHTTPClient tokenProvider ucmVersion
|
||||
|
@ -37,6 +37,7 @@ import System.Directory
|
||||
getHomeDirectory,
|
||||
)
|
||||
import U.Codebase.Branch (NamespaceStats (..))
|
||||
import U.Codebase.Branch.Diff (NameChanges (..))
|
||||
import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion))
|
||||
import U.Util.Base32Hex (Base32Hex)
|
||||
import qualified U.Util.Base32Hex as Base32Hex
|
||||
@ -72,8 +73,9 @@ import qualified Unison.Codebase.Patch as Patch
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.Codebase.PushBehavior as PushBehavior
|
||||
import qualified Unison.Codebase.Runtime as Runtime
|
||||
import Unison.Codebase.ShortBranchHash (ShortBranchHash)
|
||||
import qualified Unison.Codebase.ShortBranchHash as SBH
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import qualified Unison.Codebase.ShortCausalHash as SCH
|
||||
import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv
|
||||
import Unison.Codebase.SqliteCodebase.GitError
|
||||
( GitSqliteCodebaseError (..),
|
||||
)
|
||||
@ -84,6 +86,7 @@ import Unison.CommandLine (bigproblem, note, tip)
|
||||
import Unison.CommandLine.InputPatterns (makeExample')
|
||||
import qualified Unison.CommandLine.InputPatterns as IP
|
||||
import Unison.ConstructorReference (GConstructorReference (..))
|
||||
import qualified Unison.ConstructorType as CT
|
||||
import qualified Unison.DataDeclaration as DD
|
||||
import qualified Unison.Hash as Hash
|
||||
import qualified Unison.HashQualified as HQ
|
||||
@ -296,21 +299,20 @@ notifyNumbered o = case o of
|
||||
else
|
||||
first
|
||||
( \p ->
|
||||
( P.lines
|
||||
[ P.wrap $
|
||||
"The changes summarized below are available for you to review,"
|
||||
<> "using the following command:",
|
||||
"",
|
||||
P.indentN 2 $
|
||||
IP.makeExampleNoBackticks
|
||||
IP.loadPullRequest
|
||||
[ (prettyReadRemoteNamespace baseRepo),
|
||||
(prettyReadRemoteNamespace headRepo)
|
||||
],
|
||||
"",
|
||||
p
|
||||
]
|
||||
)
|
||||
P.lines
|
||||
[ P.wrap $
|
||||
"The changes summarized below are available for you to review,"
|
||||
<> "using the following command:",
|
||||
"",
|
||||
P.indentN 2 $
|
||||
IP.makeExampleNoBackticks
|
||||
IP.loadPullRequest
|
||||
[ prettyReadRemoteNamespace baseRepo,
|
||||
prettyReadRemoteNamespace headRepo
|
||||
],
|
||||
"",
|
||||
p
|
||||
]
|
||||
)
|
||||
(showDiffNamespace HideNumbers ppe (absPathToBranchId Path.absoluteEmpty) (absPathToBranchId Path.absoluteEmpty) diff)
|
||||
-- todo: these numbers aren't going to work,
|
||||
@ -352,14 +354,14 @@ notifyNumbered o = case o of
|
||||
],
|
||||
numberedArgsForEndangerments ppeDecl endangerments
|
||||
)
|
||||
History _cap sbhLength history tail ->
|
||||
History _cap schLength history tail ->
|
||||
let (tailMsg, tailHashes) = handleTail (length history + 1)
|
||||
msg :: Pretty
|
||||
msg =
|
||||
P.lines
|
||||
[ note $ "The most recent namespace hash is immediately below this message.",
|
||||
"",
|
||||
P.sep "\n\n" [go i (toSBH h) diff | (i, (h, diff)) <- zip [1 ..] reversedHistory],
|
||||
P.sep "\n\n" [go i (toSCH h) diff | (i, (h, diff)) <- zip [1 ..] reversedHistory],
|
||||
"",
|
||||
tailMsg
|
||||
]
|
||||
@ -367,8 +369,8 @@ notifyNumbered o = case o of
|
||||
branchHashes = (fst <$> reversedHistory) <> tailHashes
|
||||
in (msg, displayBranchHash <$> branchHashes)
|
||||
where
|
||||
toSBH :: Branch.CausalHash -> ShortBranchHash
|
||||
toSBH h = SBH.fromHash sbhLength h
|
||||
toSCH :: Branch.CausalHash -> ShortCausalHash
|
||||
toSCH h = SCH.fromHash schLength h
|
||||
reversedHistory = reverse history
|
||||
showNum :: Int -> Pretty
|
||||
showNum n = P.shown n <> ". "
|
||||
@ -376,7 +378,7 @@ notifyNumbered o = case o of
|
||||
handleTail n = case tail of
|
||||
E.EndOfLog h ->
|
||||
( P.lines
|
||||
[ "□ " <> showNum n <> prettySBH (toSBH h) <> " (start of history)"
|
||||
[ "□ " <> showNum n <> prettySCH (toSCH h) <> " (start of history)"
|
||||
],
|
||||
[h]
|
||||
)
|
||||
@ -384,9 +386,9 @@ notifyNumbered o = case o of
|
||||
( P.lines
|
||||
[ P.wrap $ "This segment of history starts with a merge." <> ex,
|
||||
"",
|
||||
"⊙ " <> showNum n <> prettySBH (toSBH h),
|
||||
"⊙ " <> showNum n <> prettySCH (toSCH h),
|
||||
"⑃",
|
||||
P.lines (hs & imap \i h -> showNum (n + 1 + i) <> prettySBH (toSBH h))
|
||||
P.lines (hs & imap \i h -> showNum (n + 1 + i) <> prettySCH (toSCH h))
|
||||
],
|
||||
h : hs
|
||||
)
|
||||
@ -396,15 +398,15 @@ notifyNumbered o = case o of
|
||||
"",
|
||||
dots,
|
||||
"",
|
||||
"⊙ " <> showNum n <> prettySBH (toSBH h),
|
||||
"⊙ " <> showNum n <> prettySCH (toSCH h),
|
||||
""
|
||||
],
|
||||
[h]
|
||||
)
|
||||
dots = "⠇"
|
||||
go i sbh diff =
|
||||
go i sch diff =
|
||||
P.lines
|
||||
[ "⊙ " <> showNum i <> prettySBH sbh,
|
||||
[ "⊙ " <> showNum i <> prettySCH sch,
|
||||
"",
|
||||
P.indentN 2 $ prettyDiff diff
|
||||
]
|
||||
@ -594,13 +596,13 @@ notifyUser dir o = case o of
|
||||
<> P.group (P.plural hashes "hash" <> ":"),
|
||||
"",
|
||||
(P.indentN 2 . P.oxfordCommas)
|
||||
(map prettySBH $ toList hashes),
|
||||
(map prettySCH $ toList hashes),
|
||||
"",
|
||||
P.wrap $
|
||||
"and I'm not sure what to do about it."
|
||||
<> "The last root namespace hash that I knew about was:",
|
||||
"",
|
||||
P.indentN 2 $ prettySBH current,
|
||||
P.indentN 2 $ prettySCH current,
|
||||
"",
|
||||
P.wrap $ "Now might be a good time to make a backup of your codebase. 😬",
|
||||
"",
|
||||
@ -663,8 +665,8 @@ notifyUser dir o = case o of
|
||||
CachedTests 0 _ -> pure . P.callout "😶" $ "No tests to run."
|
||||
CachedTests n n'
|
||||
| n == n' ->
|
||||
pure $
|
||||
P.lines [cache, "", displayTestResults True ppe oks fails]
|
||||
pure $
|
||||
P.lines [cache, "", displayTestResults True ppe oks fails]
|
||||
CachedTests _n m ->
|
||||
pure $
|
||||
if m == 0
|
||||
@ -673,7 +675,6 @@ notifyUser dir o = case o of
|
||||
P.indentN 2 $
|
||||
P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "✅ "]
|
||||
where
|
||||
|
||||
NewlyComputed -> do
|
||||
clearCurrentLine
|
||||
pure $
|
||||
@ -687,7 +688,7 @@ notifyUser dir o = case o of
|
||||
TestIncrementalOutputStart ppe (n, total) r _src -> do
|
||||
putPretty' $
|
||||
P.shown (total - n) <> " tests left to run, current test: "
|
||||
<> (P.syntaxToColor $ prettyHashQualified (PPE.termName ppe $ Referent.Ref r))
|
||||
<> P.syntaxToColor (prettyHashQualified (PPE.termName ppe $ Referent.Ref r))
|
||||
pure mempty
|
||||
TestIncrementalOutputEnd _ppe (_n, _total) _r result -> do
|
||||
clearCurrentLine
|
||||
@ -1037,7 +1038,7 @@ notifyUser dir o = case o of
|
||||
P.bracket . P.lines $
|
||||
P.wrap "The watch expression(s) reference these definitions:" :
|
||||
"" :
|
||||
[ (P.syntaxToColor $ TermPrinter.prettyBinding ppe (HQ.unsafeFromVar v) b)
|
||||
[ P.syntaxToColor $ TermPrinter.prettyBinding ppe (HQ.unsafeFromVar v) b
|
||||
| (v, b) <- bindings
|
||||
]
|
||||
prettyWatches =
|
||||
@ -1235,15 +1236,15 @@ notifyUser dir o = case o of
|
||||
<> P.shown path
|
||||
<> "in the repository at"
|
||||
<> prettyReadGitRepo repo
|
||||
NoRemoteNamespaceWithHash repo sbh ->
|
||||
NoRemoteNamespaceWithHash repo sch ->
|
||||
P.wrap $
|
||||
"The repository at" <> prettyReadGitRepo repo
|
||||
<> "doesn't contain a namespace with the hash prefix"
|
||||
<> (P.blue . P.text . SBH.toText) sbh
|
||||
RemoteNamespaceHashAmbiguous repo sbh hashes ->
|
||||
<> (P.blue . P.text . SCH.toText) sch
|
||||
RemoteNamespaceHashAmbiguous repo sch hashes ->
|
||||
P.lines
|
||||
[ P.wrap $
|
||||
"The namespace hash" <> prettySBH sbh
|
||||
"The namespace hash" <> prettySCH sch
|
||||
<> "at"
|
||||
<> prettyReadGitRepo repo
|
||||
<> "is ambiguous."
|
||||
@ -1251,7 +1252,7 @@ notifyUser dir o = case o of
|
||||
"",
|
||||
P.indentN 2 $
|
||||
P.lines
|
||||
( prettySBH . SBH.fromHash ((Text.length . SBH.toText) sbh * 2)
|
||||
( prettySCH . SCH.fromHash ((Text.length . SCH.toText) sch * 2)
|
||||
<$> Set.toList hashes
|
||||
),
|
||||
"",
|
||||
@ -1402,10 +1403,10 @@ notifyUser dir o = case o of
|
||||
BranchHashAmbiguous h rs ->
|
||||
pure . P.callout "\129300" . P.lines $
|
||||
[ P.wrap $
|
||||
"The namespace hash" <> prettySBH h <> "is ambiguous."
|
||||
"The namespace hash" <> prettySCH h <> "is ambiguous."
|
||||
<> "Did you mean one of these hashes?",
|
||||
"",
|
||||
P.indentN 2 $ P.lines (prettySBH <$> Set.toList rs),
|
||||
P.indentN 2 $ P.lines (prettySCH <$> Set.toList rs),
|
||||
"",
|
||||
P.wrap "Try again with a few more hash characters to disambiguate."
|
||||
]
|
||||
@ -1444,7 +1445,7 @@ notifyUser dir o = case o of
|
||||
where
|
||||
header =
|
||||
case entries of
|
||||
(_head : (_, prevSBH, _) : _) ->
|
||||
(_head : (_, prevSCH, _) : _) ->
|
||||
P.lines
|
||||
[ P.wrap $
|
||||
"Here is a log of the root namespace hashes,"
|
||||
@ -1456,11 +1457,11 @@ notifyUser dir o = case o of
|
||||
[ ( IP.makeExample IP.forkLocal ["2", ".old"],
|
||||
""
|
||||
),
|
||||
( IP.makeExample IP.forkLocal [prettySBH prevSBH, ".old"],
|
||||
( IP.makeExample IP.forkLocal [prettySCH prevSCH, ".old"],
|
||||
"to make an old namespace accessible again,"
|
||||
),
|
||||
(mempty, mempty),
|
||||
( IP.makeExample IP.resetRoot [prettySBH prevSBH],
|
||||
( IP.makeExample IP.resetRoot [prettySCH prevSCH],
|
||||
"to reset the root namespace and its history to that of the specified"
|
||||
<> "namespace."
|
||||
)
|
||||
@ -1469,9 +1470,9 @@ notifyUser dir o = case o of
|
||||
""
|
||||
]
|
||||
_ -> mempty
|
||||
renderEntry3Column :: UTCTime -> (Maybe UTCTime, SBH.ShortBranchHash, Text) -> [Pretty]
|
||||
renderEntry3Column now (mayTime, sbh, reason) =
|
||||
[maybe "" (prettyHumanReadableTime now) mayTime, P.blue (prettySBH sbh), P.text $ truncateReason reason]
|
||||
renderEntry3Column :: UTCTime -> (Maybe UTCTime, SCH.ShortCausalHash, Text) -> [Pretty]
|
||||
renderEntry3Column now (mayTime, sch, reason) =
|
||||
[maybe "" (prettyHumanReadableTime now) mayTime, P.blue (prettySCH sch), P.text $ truncateReason reason]
|
||||
truncateReason :: Text -> Text
|
||||
truncateReason txt = case Text.splitAt 60 txt of
|
||||
(short, "") -> short
|
||||
@ -1805,6 +1806,20 @@ notifyUser dir o = case o of
|
||||
IntegrityCheck result -> pure $ case result of
|
||||
NoIntegrityErrors -> "🎉 No issues detected 🎉"
|
||||
IntegrityErrorDetected ns -> prettyPrintIntegrityErrors ns
|
||||
DisplayDebugNameDiff NameChanges {termNameAdds, termNameRemovals, typeNameAdds, typeNameRemovals} -> do
|
||||
let referentText =
|
||||
-- We don't use the constructor type in the actual output here, so there's no
|
||||
-- point in looking up the correct one.
|
||||
P.text . Referent.toText . runIdentity . Cv.referent2to1 (\_ref -> Identity CT.Data)
|
||||
let referenceText = P.text . Reference.toText . Cv.reference2to1
|
||||
pure $
|
||||
P.columnNHeader
|
||||
["Kind", "Name", "Change", "Ref"]
|
||||
( (termNameAdds <&> \(n, ref) -> ["Term", prettyName n, "Added", referentText ref])
|
||||
<> (termNameRemovals <&> \(n, ref) -> ["Term", prettyName n, "Removed", referentText ref])
|
||||
<> (typeNameAdds <&> \(n, ref) -> ["Type", prettyName n, "Added", referenceText ref])
|
||||
<> (typeNameRemovals <&> \(n, ref) -> ["Type", prettyName n, "Removed", referenceText ref])
|
||||
)
|
||||
DisplayDebugCompletions completions ->
|
||||
pure $
|
||||
P.column2
|
||||
@ -1890,7 +1905,7 @@ prettyPath' p' =
|
||||
|
||||
prettyBranchId :: Input.AbsBranchId -> Pretty
|
||||
prettyBranchId = \case
|
||||
Left sbh -> prettySBH sbh
|
||||
Left sch -> prettySCH sch
|
||||
Right absPath -> prettyAbsolute $ absPath
|
||||
|
||||
prettyRelative :: Path.Relative -> Pretty
|
||||
@ -1899,8 +1914,8 @@ prettyRelative = P.blue . P.shown
|
||||
prettyAbsolute :: Path.Absolute -> Pretty
|
||||
prettyAbsolute = P.blue . P.shown
|
||||
|
||||
prettySBH :: IsString s => ShortBranchHash -> P.Pretty s
|
||||
prettySBH hash = P.group $ "#" <> P.text (SBH.toText hash)
|
||||
prettySCH :: IsString s => ShortCausalHash -> P.Pretty s
|
||||
prettySCH hash = P.group $ "#" <> P.text (SCH.toText hash)
|
||||
|
||||
prettyCausalHash :: IsString s => Causal.CausalHash -> P.Pretty s
|
||||
prettyCausalHash hash = P.group $ "#" <> P.text (Hash.toBase32HexText . Causal.unCausalHash $ hash)
|
||||
@ -2062,9 +2077,10 @@ displayDefinitions outputLoc ppe types terms =
|
||||
case dt of
|
||||
MissingObject r -> missing n r
|
||||
BuiltinObject typ ->
|
||||
P.hang
|
||||
("builtin " <> prettyHashQualified n <> " :")
|
||||
(TypePrinter.prettySyntax (ppeBody n r) typ)
|
||||
(if isJust outputLoc then P.indent "-- " else id) $
|
||||
P.hang
|
||||
("builtin " <> prettyHashQualified n <> " :")
|
||||
(TypePrinter.prettySyntax (ppeBody n r) typ)
|
||||
UserObject tm -> TermPrinter.prettyBinding (ppeBody n r) n tm
|
||||
go2 ((n, r), dt) =
|
||||
case dt of
|
||||
@ -2149,7 +2165,7 @@ unsafePrettyTermResultSigFull' ppe = \case
|
||||
[ P.hiBlack "-- " <> greyHash (HQ.fromReferent r),
|
||||
P.group $
|
||||
P.commas (fmap greyHash $ hq : map HQ'.toHQ (toList aliases)) <> " : "
|
||||
<> (P.syntaxToColor $ TypePrinter.pretty0 ppe mempty (-1) typ),
|
||||
<> P.syntaxToColor (TypePrinter.prettySyntax ppe typ),
|
||||
mempty
|
||||
]
|
||||
_ -> error "Don't pass Nothing"
|
||||
@ -2447,7 +2463,7 @@ showDiffNamespace ::
|
||||
(Pretty, NumberedArgs)
|
||||
showDiffNamespace _ _ _ _ diffOutput
|
||||
| OBD.isEmpty diffOutput =
|
||||
("The namespaces are identical.", mempty)
|
||||
("The namespaces are identical.", mempty)
|
||||
showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
|
||||
(P.sepNonEmpty "\n\n" p, toList args)
|
||||
where
|
||||
@ -2847,7 +2863,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} =
|
||||
-- prefixBranchId ".base" "List.map" -> ".base.List.map"
|
||||
prefixBranchId :: Input.AbsBranchId -> Name -> String
|
||||
prefixBranchId branchId name = case branchId of
|
||||
Left sbh -> "#" <> SBH.toString sbh <> ":" <> Name.toString (Name.makeAbsolute name)
|
||||
Left sch -> "#" <> SCH.toString sch <> ":" <> Name.toString (Name.makeAbsolute name)
|
||||
Right pathPrefix -> Name.toString (Name.makeAbsolute . Path.prefixName pathPrefix $ name)
|
||||
|
||||
addNumberedArg' :: String -> Numbered Pretty
|
||||
|
6
unison-cli/src/Unison/CommandLine/Types.hs
Normal file
6
unison-cli/src/Unison/CommandLine/Types.hs
Normal file
@ -0,0 +1,6 @@
|
||||
module Unison.CommandLine.Types (ShouldWatchFiles (..)) where
|
||||
|
||||
data ShouldWatchFiles
|
||||
= ShouldWatchFiles
|
||||
| ShouldNotWatchFiles
|
||||
deriving (Show, Eq)
|
@ -12,6 +12,7 @@ import Unison.Codebase.Path (Path)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.Codebase.SyncMode as SyncMode
|
||||
import qualified Unison.Codebase.Verbosity as Verbosity
|
||||
import Unison.CommandLine.Types (ShouldWatchFiles (..))
|
||||
import Unison.NameSegment (NameSegment (NameSegment))
|
||||
import Unison.Prelude
|
||||
import qualified Unison.Util.Pretty as P
|
||||
@ -21,7 +22,8 @@ data Welcome = Welcome
|
||||
{ onboarding :: Onboarding, -- Onboarding States
|
||||
downloadBase :: DownloadBase,
|
||||
watchDir :: FilePath,
|
||||
unisonVersion :: Text
|
||||
unisonVersion :: Text,
|
||||
shouldWatchFiles :: ShouldWatchFiles
|
||||
}
|
||||
|
||||
data DownloadBase
|
||||
@ -47,9 +49,9 @@ data Onboarding
|
||||
| PreviouslyOnboarded
|
||||
deriving (Show, Eq)
|
||||
|
||||
welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> Text -> Welcome
|
||||
welcome initStatus downloadBase filePath unisonVersion =
|
||||
Welcome (Init initStatus) downloadBase filePath unisonVersion
|
||||
welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> Text -> ShouldWatchFiles -> Welcome
|
||||
welcome initStatus downloadBase filePath unisonVersion shouldWatchFiles =
|
||||
Welcome (Init initStatus) downloadBase filePath unisonVersion shouldWatchFiles
|
||||
|
||||
pullBase :: ReadShareRemoteNamespace -> Either Event Input
|
||||
pullBase ns =
|
||||
@ -66,7 +68,7 @@ pullBase ns =
|
||||
in Right pullRemote
|
||||
|
||||
run :: Codebase IO v a -> Welcome -> IO [Either Event Input]
|
||||
run codebase Welcome {onboarding = onboarding, downloadBase = downloadBase, watchDir = dir, unisonVersion = version} = do
|
||||
run codebase Welcome {onboarding = onboarding, downloadBase = downloadBase, watchDir = dir, unisonVersion = version, shouldWatchFiles} = do
|
||||
go onboarding []
|
||||
where
|
||||
go :: Onboarding -> [Either Event Input] -> IO [Either Event Input]
|
||||
@ -91,10 +93,10 @@ run codebase Welcome {onboarding = onboarding, downloadBase = downloadBase, watc
|
||||
authorMsg = toInput authorSuggestion
|
||||
-- These are our two terminal Welcome conditions, at the end we reverse the order of the desired input commands otherwise they come out backwards
|
||||
Finished -> do
|
||||
startMsg <- getStarted dir
|
||||
startMsg <- getStarted shouldWatchFiles dir
|
||||
pure $ reverse (toInput startMsg : acc)
|
||||
PreviouslyOnboarded -> do
|
||||
startMsg <- getStarted dir
|
||||
startMsg <- getStarted shouldWatchFiles dir
|
||||
pure $ reverse (toInput startMsg : acc)
|
||||
|
||||
toInput :: P.Pretty P.ColorText -> Either Event Input
|
||||
@ -107,7 +109,7 @@ determineFirstStep downloadBase codebase = do
|
||||
case downloadBase of
|
||||
DownloadBase ns
|
||||
| isEmptyCodebase ->
|
||||
pure $ DownloadingBase ns
|
||||
pure $ DownloadingBase ns
|
||||
_ ->
|
||||
pure PreviouslyOnboarded
|
||||
|
||||
@ -170,8 +172,8 @@ authorSuggestion =
|
||||
P.wrap $ P.blue "https://www.unison-lang.org/learn/tooling/configuration/"
|
||||
]
|
||||
|
||||
getStarted :: FilePath -> IO (P.Pretty P.ColorText)
|
||||
getStarted dir = do
|
||||
getStarted :: ShouldWatchFiles -> FilePath -> IO (P.Pretty P.ColorText)
|
||||
getStarted shouldWatchFiles dir = do
|
||||
earth <- (["🌎", "🌍", "🌏"] !!) <$> randomRIO (0, 2)
|
||||
|
||||
pure $
|
||||
@ -179,10 +181,13 @@ getStarted dir = do
|
||||
[ P.wrap "Get started:",
|
||||
P.indentN 2 $
|
||||
P.column2
|
||||
[ ("📖", "Type " <> P.hiBlue "help" <> " to list all commands, or " <> P.hiBlue "help <cmd>" <> " to view help for one command"),
|
||||
("🎨", "Type " <> P.hiBlue "ui" <> " to open the Codebase UI in your default browser"),
|
||||
("📚", "Read the official docs at " <> P.blue "https://www.unison-lang.org/learn/"),
|
||||
(earth, "Visit Unison Share at " <> P.blue "https://share.unison-lang.org" <> " to discover libraries"),
|
||||
("👀", "I'm watching for changes to " <> P.bold ".u" <> " files under " <> (P.group . P.blue $ P.string dir))
|
||||
]
|
||||
( [ ("📖", "Type " <> P.hiBlue "help" <> " to list all commands, or " <> P.hiBlue "help <cmd>" <> " to view help for one command"),
|
||||
("🎨", "Type " <> P.hiBlue "ui" <> " to open the Codebase UI in your default browser"),
|
||||
("📚", "Read the official docs at " <> P.blue "https://www.unison-lang.org/learn/"),
|
||||
(earth, "Visit Unison Share at " <> P.blue "https://share.unison-lang.org" <> " to discover libraries")
|
||||
]
|
||||
<> case shouldWatchFiles of
|
||||
ShouldWatchFiles -> [("👀", "I'm watching for changes to " <> P.bold ".u" <> " files under " <> (P.group . P.blue $ P.string dir))]
|
||||
ShouldNotWatchFiles -> [("📝", "File watching is disabled, use the 'load' command to parse and typecheck unison files.")]
|
||||
)
|
||||
]
|
||||
|
@ -8,7 +8,6 @@ module Unison.LSP where
|
||||
import Colog.Core (LogAction (LogAction))
|
||||
import qualified Colog.Core as Colog
|
||||
import Control.Monad.Reader
|
||||
import Data.Aeson hiding (Options, defaultOptions)
|
||||
import GHC.IO.Exception (ioe_errno)
|
||||
import qualified Ki
|
||||
import qualified Language.LSP.Logging as LSP
|
||||
@ -27,6 +26,8 @@ import Unison.Codebase.Runtime (Runtime)
|
||||
import qualified Unison.Debug as Debug
|
||||
import Unison.LSP.CancelRequest (cancelRequestHandler)
|
||||
import Unison.LSP.CodeAction (codeActionHandler)
|
||||
import Unison.LSP.Completion (completionHandler)
|
||||
import qualified Unison.LSP.Configuration as Config
|
||||
import qualified Unison.LSP.FileAnalysis as Analysis
|
||||
import Unison.LSP.FoldingRange (foldingRangeRequest)
|
||||
import qualified Unison.LSP.HandlerUtils as Handlers
|
||||
@ -65,7 +66,7 @@ spawnLsp codebase runtime latestBranch latestPath = TCP.withSocketsDo do
|
||||
case Errno <$> ioe_errno ioerr of
|
||||
Just errNo
|
||||
| errNo == eADDRINUSE -> do
|
||||
putStrLn $ "Note: Port " <> lspPort <> " is already bound by another process or another UCM. The LSP server will not be started."
|
||||
putStrLn $ "Note: Port " <> lspPort <> " is already bound by another process or another UCM. The LSP server will not be started."
|
||||
_ -> do
|
||||
Debug.debugM Debug.LSP "LSP Exception" ioerr
|
||||
Debug.debugM Debug.LSP "LSP Errno" (ioe_errno ioerr)
|
||||
@ -85,21 +86,14 @@ serverDefinition ::
|
||||
ServerDefinition Config
|
||||
serverDefinition vfsVar codebase runtime scope latestBranch latestPath =
|
||||
ServerDefinition
|
||||
{ defaultConfig = lspDefaultConfig,
|
||||
onConfigurationChange = lspOnConfigurationChange,
|
||||
{ defaultConfig = defaultLSPConfig,
|
||||
onConfigurationChange = Config.updateConfig,
|
||||
doInitialize = lspDoInitialize vfsVar codebase runtime scope latestBranch latestPath,
|
||||
staticHandlers = lspStaticHandlers,
|
||||
interpretHandler = lspInterpretHandler,
|
||||
options = lspOptions
|
||||
}
|
||||
|
||||
-- | Detect user LSP configuration changes.
|
||||
lspOnConfigurationChange :: Config -> Value -> Either Text Config
|
||||
lspOnConfigurationChange _ _ = pure Config
|
||||
|
||||
lspDefaultConfig :: Config
|
||||
lspDefaultConfig = Config
|
||||
|
||||
-- | Initialize any context needed by the LSP server
|
||||
lspDoInitialize ::
|
||||
MVar VFS ->
|
||||
@ -120,6 +114,7 @@ lspDoInitialize vfsVar codebase runtime scope latestBranch latestPath lspContext
|
||||
parseNamesCacheVar <- newTVarIO mempty
|
||||
currentPathCacheVar <- newTVarIO Path.absoluteEmpty
|
||||
cancellationMapVar <- newTVarIO mempty
|
||||
completionsVar <- newTVarIO mempty
|
||||
let env = Env {ppeCache = readTVarIO ppeCacheVar, parseNamesCache = readTVarIO parseNamesCacheVar, currentPathCache = readTVarIO currentPathCacheVar, ..}
|
||||
let lspToIO = flip runReaderT lspContext . unLspT . flip runReaderT env . runLspM
|
||||
Ki.fork scope (lspToIO Analysis.fileAnalysisWorker)
|
||||
@ -141,6 +136,7 @@ lspRequestHandlers =
|
||||
& SMM.insert STextDocumentHover (mkHandler hoverHandler)
|
||||
& SMM.insert STextDocumentCodeAction (mkHandler codeActionHandler)
|
||||
& SMM.insert STextDocumentFoldingRange (mkHandler foldingRangeRequest)
|
||||
& SMM.insert STextDocumentCompletion (mkHandler completionHandler)
|
||||
where
|
||||
defaultTimeout = 10_000 -- 10s
|
||||
mkHandler ::
|
||||
@ -167,6 +163,7 @@ lspNotificationHandlers =
|
||||
& SMM.insert STextDocumentDidChange (ClientMessageHandler VFS.lspChangeFile)
|
||||
& SMM.insert SInitialized (ClientMessageHandler Notifications.initializedHandler)
|
||||
& SMM.insert SCancelRequest (ClientMessageHandler $ Notifications.withDebugging cancelRequestHandler)
|
||||
& SMM.insert SWorkspaceDidChangeConfiguration (ClientMessageHandler Config.workspaceConfigurationChanged)
|
||||
|
||||
-- | A natural transformation into IO, required by the LSP lib.
|
||||
lspInterpretHandler :: Env -> Lsp <~> IO
|
||||
|
@ -4,122 +4,238 @@
|
||||
|
||||
module Unison.LSP.Completion where
|
||||
|
||||
import Control.Lens hiding (List)
|
||||
import Control.Comonad.Cofree
|
||||
import Control.Lens hiding (List, (:<))
|
||||
import Control.Monad.Reader
|
||||
import Data.String.Here.Uninterpolated (here)
|
||||
import Data.Bifunctor (second)
|
||||
import Data.List.Extra (nubOrdOn)
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import Language.LSP.Types
|
||||
import Language.LSP.Types.Lens
|
||||
import qualified Text.FuzzyFind as Fuzzy
|
||||
import Unison.Codebase.Path (Path)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.HashQualified' as HQ'
|
||||
import Unison.LSP.Types
|
||||
import qualified Unison.LSP.VFS as VFS
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
import qualified Unison.LabeledDependency as LD
|
||||
import Unison.Name (Name)
|
||||
import qualified Unison.Name as Name
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import qualified Unison.NameSegment as NameSegment
|
||||
import Unison.Names (Names (..))
|
||||
import Unison.Prelude
|
||||
import qualified Unison.Server.Endpoints.FuzzyFind as FZF
|
||||
import qualified Unison.Server.Syntax as Server
|
||||
import qualified Unison.Server.Types as Backend
|
||||
import qualified Unison.PrettyPrintEnv as PPE
|
||||
import qualified Unison.PrettyPrintEnvDecl as PPED
|
||||
import qualified Unison.Referent as Referent
|
||||
import qualified Unison.Util.Monoid as Monoid
|
||||
import qualified Unison.Util.Relation as Relation
|
||||
|
||||
-- | Rudimentary auto-completion handler
|
||||
--
|
||||
-- TODO:
|
||||
-- * Rewrite this to use an index rather than fuzzy searching ALL names
|
||||
-- * Respect ucm's current path
|
||||
-- * Provide namespaces as auto-complete targets
|
||||
-- * Auto-complete minimally suffixed names
|
||||
-- * Include docs in completion details?
|
||||
completionHandler :: RequestMessage 'TextDocumentCompletion -> (Either ResponseError (ResponseResult 'TextDocumentCompletion) -> Lsp ()) -> Lsp ()
|
||||
completionHandler m respond =
|
||||
respond =<< do
|
||||
mayPrefix <- VFS.completionPrefix (m ^. params)
|
||||
case mayPrefix of
|
||||
Nothing -> pure . Right . InL . List $ []
|
||||
Just (range, prefix) -> do
|
||||
matches <- expand range prefix
|
||||
let isIncomplete = True -- TODO: be smarter about this
|
||||
pure . Right . InR . CompletionList isIncomplete . List $ snippetCompletions prefix range <> matches
|
||||
respond . maybe (Right $ InL mempty) (Right . InR) =<< runMaybeT do
|
||||
(range, prefix) <- MaybeT $ VFS.completionPrefix (m ^. params)
|
||||
ppe <- PPED.suffixifiedPPE <$> lift globalPPE
|
||||
completions <- lift getCompletions
|
||||
Config {maxCompletions} <- lift getConfig
|
||||
let defMatches = matchCompletions completions prefix
|
||||
let (isIncomplete, defCompletions) =
|
||||
defMatches
|
||||
& nubOrdOn (\(p, _name, ref) -> (p, ref))
|
||||
& fmap (over _1 Path.toText)
|
||||
& case maxCompletions of
|
||||
Nothing -> (False,)
|
||||
Just n -> takeCompletions n
|
||||
let defCompletionItems =
|
||||
defCompletions
|
||||
& mapMaybe \(path, fqn, dep) ->
|
||||
let biasedPPE = PPE.biasTo [fqn] ppe
|
||||
hqName = LD.fold (PPE.types biasedPPE) (PPE.terms biasedPPE) dep
|
||||
in hqName <&> \hqName -> mkDefCompletionItem range (Name.toText fqn) path (HQ'.toText hqName) dep
|
||||
pure . CompletionList isIncomplete . List $ defCompletionItems
|
||||
where
|
||||
resultToCompletion :: Range -> Text -> FZF.FoundResult -> CompletionItem
|
||||
resultToCompletion range prefix = \case
|
||||
FZF.FoundTermResult (FZF.FoundTerm {namedTerm = Backend.NamedTerm {termName, termType}}) -> do
|
||||
(mkCompletionItem (HQ'.toText termName))
|
||||
{ _detail = (": " <>) . Text.pack . Server.toPlain <$> termType,
|
||||
_kind = Just CiVariable,
|
||||
_insertText = Text.stripPrefix prefix (HQ'.toText termName),
|
||||
_textEdit = Just $ CompletionEditText (TextEdit range (HQ'.toText termName))
|
||||
}
|
||||
FZF.FoundTypeResult (FZF.FoundType {namedType = Backend.NamedType {typeName, typeTag}}) ->
|
||||
let (detail, kind) = case typeTag of
|
||||
Backend.Ability -> ("Ability", CiInterface)
|
||||
Backend.Data -> ("Data", CiClass)
|
||||
in (mkCompletionItem (HQ'.toText typeName))
|
||||
{ _detail = Just detail,
|
||||
_kind = Just kind
|
||||
}
|
||||
expand :: Range -> Text -> Lsp [CompletionItem]
|
||||
expand range prefix = do
|
||||
-- We should probably write a different fzf specifically for completion, but for now, it
|
||||
-- expects the unique pieces of the query to be different "words".
|
||||
let query = Text.unwords . Text.splitOn "." $ prefix
|
||||
cb <- asks codebase
|
||||
lspBackend (FZF.serveFuzzyFind cb Nothing Nothing Nothing Nothing (Just $ Text.unpack query)) >>= \case
|
||||
Left _be -> pure []
|
||||
Right results ->
|
||||
pure . fmap (resultToCompletion range prefix . snd) . take 15 . sortOn (Fuzzy.score . fst) $ results
|
||||
-- Takes at most the specified number of completions, but also indicates with a boolean
|
||||
-- whether there were more completions remaining so we can pass that along to the client.
|
||||
takeCompletions :: Int -> [a] -> (Bool, [a])
|
||||
takeCompletions 0 xs = (not $ null xs, [])
|
||||
takeCompletions _ [] = (False, [])
|
||||
takeCompletions n (x : xs) = second (x :) $ takeCompletions (pred n) xs
|
||||
|
||||
snippetCompletions :: Text -> Range -> [CompletionItem]
|
||||
snippetCompletions prefix range =
|
||||
[ ("handler", handlerTemplate),
|
||||
("cases", casesTemplate),
|
||||
("match-with", matchWithTemplate)
|
||||
]
|
||||
& filter (Text.isPrefixOf prefix . fst)
|
||||
& fmap toCompletion
|
||||
where
|
||||
toCompletion :: (Text, Text) -> CompletionItem
|
||||
toCompletion (pat, snippet) =
|
||||
(mkCompletionItem pat)
|
||||
{ _insertTextFormat = Just Snippet,
|
||||
_insertTextMode = Just AdjustIndentation,
|
||||
_textEdit = Just $ CompletionEditText (TextEdit range snippet)
|
||||
}
|
||||
handlerTemplate =
|
||||
[here|
|
||||
handle${1:Ability} : Request (${1:Ability} ${2}) a -> a
|
||||
handle${1:Ability} = cases
|
||||
{${3} -> continue} -> do
|
||||
${4}
|
||||
|]
|
||||
casesTemplate =
|
||||
[here|
|
||||
cases
|
||||
${1} -> do
|
||||
${2}
|
||||
|]
|
||||
matchWithTemplate =
|
||||
[here|
|
||||
match ${1} with
|
||||
${2} -> do
|
||||
${3}
|
||||
|]
|
||||
|
||||
mkCompletionItem :: Text -> CompletionItem
|
||||
mkCompletionItem lbl =
|
||||
mkDefCompletionItem :: Range -> Text -> Text -> Text -> LabeledDependency -> CompletionItem
|
||||
mkDefCompletionItem range fqn path suffixified dep =
|
||||
CompletionItem
|
||||
{ _label = lbl,
|
||||
_kind = Nothing,
|
||||
_kind = case dep of
|
||||
LD.TypeReference _ref -> Just CiClass
|
||||
LD.TermReferent ref -> case ref of
|
||||
Referent.Con {} -> Just CiConstructor
|
||||
Referent.Ref {} -> Just CiValue,
|
||||
_tags = Nothing,
|
||||
_detail = Nothing,
|
||||
_detail = Just fqn,
|
||||
_documentation = Nothing,
|
||||
_deprecated = Nothing,
|
||||
_preselect = Nothing,
|
||||
_sortText = Nothing,
|
||||
_filterText = Nothing,
|
||||
_filterText = Just path,
|
||||
_insertText = Nothing,
|
||||
_insertTextFormat = Nothing,
|
||||
_insertTextMode = Nothing,
|
||||
_textEdit = Nothing,
|
||||
_textEdit = Just (CompletionEditText $ TextEdit range suffixified),
|
||||
_additionalTextEdits = Nothing,
|
||||
_commitCharacters = Nothing,
|
||||
_command = Nothing,
|
||||
_xdata = Nothing
|
||||
}
|
||||
where
|
||||
-- We should generally show the longer of the path or suffixified name in the label,
|
||||
-- it helps the user understand the difference between options which may otherwise look
|
||||
-- the same.
|
||||
--
|
||||
-- E.g. if I type "ma" then the suffixied options might be: List.map, Bag.map, but the
|
||||
-- path matches are just "map" and "map" since the query starts at that segment, so we
|
||||
-- show the suffixified version to disambiguate.
|
||||
--
|
||||
-- However, if the user types "base.List.ma" then the matching path is "base.List.map" and
|
||||
-- the suffixification is just "List.map", so we use the path in this case because it more
|
||||
-- closely matches what the user actually typed.
|
||||
--
|
||||
-- This is what's felt best to me, anecdotally.
|
||||
lbl =
|
||||
if Text.length path > Text.length suffixified
|
||||
then path
|
||||
else suffixified
|
||||
|
||||
-- | Generate a completion tree from a set of names.
|
||||
-- A completion tree is a suffix tree over the path segments of each name it contains.
|
||||
-- The goal is to allow fast completion of names by any partial path suffix.
|
||||
--
|
||||
-- The tree is generated by building a trie where all possible suffixes of a name are
|
||||
-- reachable from the root of the trie, with sharing over subtrees to improve memory
|
||||
-- residency.
|
||||
--
|
||||
-- Currently we don't "summarize" all of the children of a node in the node itself, and
|
||||
-- instead you have to crawl all the children to get the actual completions.
|
||||
--
|
||||
-- TODO: Would it be worthwhile to perform compression or include child summaries on the suffix tree?
|
||||
-- I suspect most namespace trees won't actually compress very well since each node is likely
|
||||
-- to have terms/types at it.
|
||||
--
|
||||
-- E.g. From the names:
|
||||
-- * alpha.beta.Nat
|
||||
-- * alpha.Text
|
||||
-- * foxtrot.Text
|
||||
--
|
||||
-- It will generate a tree like the following, where each bullet is a possible completion:
|
||||
--
|
||||
-- .
|
||||
-- ├── foxtrot
|
||||
-- │ └── Text
|
||||
-- │ └── * foxtrot.Text (##Text)
|
||||
-- ├── beta
|
||||
-- │ └── Nat
|
||||
-- │ └── * alpha.beta.Nat (##Nat)
|
||||
-- ├── alpha
|
||||
-- │ ├── beta
|
||||
-- │ │ └── Nat
|
||||
-- │ │ └── * alpha.beta.Nat (##Nat)
|
||||
-- │ └── Text
|
||||
-- │ └── * alpha.Text (##Text)
|
||||
-- ├── Text
|
||||
-- │ ├── * foxtrot.Text (##Text)
|
||||
-- │ └── * alpha.Text (##Text)
|
||||
-- └── Nat
|
||||
-- └── * alpha.beta.Nat (##Nat)
|
||||
namesToCompletionTree :: Names -> CompletionTree
|
||||
namesToCompletionTree Names {terms, types} =
|
||||
let typeCompls =
|
||||
Relation.domain types
|
||||
& ifoldMap
|
||||
( \name refs ->
|
||||
refs
|
||||
& Monoid.whenM (not . isDefinitionDoc $ name)
|
||||
& Set.map \ref -> (name, LD.typeRef ref)
|
||||
)
|
||||
termCompls =
|
||||
Relation.domain terms
|
||||
& ifoldMap
|
||||
( \name refs ->
|
||||
refs
|
||||
& Monoid.whenM (not . isDefinitionDoc $ name)
|
||||
& Set.map \ref -> (name, LD.referent ref)
|
||||
)
|
||||
in foldMap (uncurry nameToCompletionTree) (typeCompls <> termCompls)
|
||||
where
|
||||
-- It's annoying to see _all_ the definition docs in autocomplete so we filter them out.
|
||||
-- Special docs like "README" will still appear since they're not named 'doc'
|
||||
isDefinitionDoc name =
|
||||
case Name.reverseSegments name of
|
||||
("doc" :| _) -> True
|
||||
_ -> False
|
||||
|
||||
nameToCompletionTree :: Name -> LabeledDependency -> CompletionTree
|
||||
nameToCompletionTree name ref =
|
||||
let (lastSegment :| prefix) = Name.reverseSegments name
|
||||
complMap = helper (Map.singleton lastSegment (Set.singleton (name, ref) :< mempty)) prefix
|
||||
in CompletionTree (mempty :< complMap)
|
||||
where
|
||||
-- We build the tree bottom-up rather than top-down so we can take 'share' submaps for
|
||||
-- improved memory residency, each call is passed the submap that we built under the
|
||||
-- current reversed path prefix.
|
||||
helper ::
|
||||
Map
|
||||
NameSegment
|
||||
(Cofree (Map NameSegment) (Set (Name, LabeledDependency))) ->
|
||||
[NameSegment] ->
|
||||
Map
|
||||
NameSegment
|
||||
(Cofree (Map NameSegment) (Set (Name, LabeledDependency)))
|
||||
helper subMap revPrefix = case revPrefix of
|
||||
[] -> subMap
|
||||
(ns : rest) ->
|
||||
mergeSubmaps (helper (Map.singleton ns (mempty :< subMap)) rest) subMap
|
||||
where
|
||||
mergeSubmaps = Map.unionWith (\a b -> unCompletionTree $ CompletionTree a <> CompletionTree b)
|
||||
|
||||
-- | Crawl the completion tree and return all valid prefix-based completions alongside their
|
||||
-- Path from the provided prefix, and their full name.
|
||||
--
|
||||
-- E.g. if the term "alpha.beta.gamma.map (#abc)" exists in the completion map, and the query is "beta" the result would
|
||||
-- be:
|
||||
--
|
||||
-- @@
|
||||
-- [(["beta", "gamma", "map"], "alpha.beta.gamma.map", TermReferent #abc)]
|
||||
-- @@
|
||||
matchCompletions :: CompletionTree -> Text -> [(Path, Name, LabeledDependency)]
|
||||
matchCompletions (CompletionTree tree) txt =
|
||||
matchSegments segments (Set.toList <$> tree)
|
||||
where
|
||||
segments :: [Text]
|
||||
segments =
|
||||
Text.splitOn "." txt
|
||||
& filter (not . Text.null)
|
||||
matchSegments :: [Text] -> Cofree (Map NameSegment) [(Name, LabeledDependency)] -> [(Path, Name, LabeledDependency)]
|
||||
matchSegments xs (currentMatches :< subtreeMap) =
|
||||
case xs of
|
||||
[] ->
|
||||
let current = currentMatches <&> (\(name, def) -> (Path.empty, name, def))
|
||||
in (current <> mkDefMatches subtreeMap)
|
||||
[prefix] ->
|
||||
Map.dropWhileAntitone ((< prefix) . NameSegment.toText) subtreeMap
|
||||
& Map.takeWhileAntitone (Text.isPrefixOf prefix . NameSegment.toText)
|
||||
& \matchingSubtrees ->
|
||||
let subMatches = ifoldMap (\ns subTree -> matchSegments [] subTree & consPathPrefix ns) matchingSubtrees
|
||||
in subMatches
|
||||
(ns : rest) ->
|
||||
foldMap (matchSegments rest) (Map.lookup (NameSegment ns) subtreeMap)
|
||||
& consPathPrefix (NameSegment ns)
|
||||
consPathPrefix :: NameSegment -> ([(Path, Name, LabeledDependency)]) -> [(Path, Name, LabeledDependency)]
|
||||
consPathPrefix ns = over (mapped . _1) (Path.cons ns)
|
||||
mkDefMatches :: Map NameSegment (Cofree (Map NameSegment) [(Name, LabeledDependency)]) -> [(Path, Name, LabeledDependency)]
|
||||
mkDefMatches xs = do
|
||||
(ns, (matches :< rest)) <- Map.toList xs
|
||||
let childMatches = mkDefMatches rest <&> over _1 (Path.cons ns)
|
||||
let currentMatches = matches <&> \(name, dep) -> (Path.singleton ns, name, dep)
|
||||
currentMatches <> childMatches
|
||||
|
23
unison-cli/src/Unison/LSP/Configuration.hs
Normal file
23
unison-cli/src/Unison/LSP/Configuration.hs
Normal file
@ -0,0 +1,23 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
|
||||
module Unison.LSP.Configuration where
|
||||
|
||||
import Data.Aeson
|
||||
import qualified Data.Text as Text
|
||||
import Language.LSP.Types
|
||||
import qualified Unison.Debug as Debug
|
||||
import Unison.LSP.Types
|
||||
import Unison.Prelude
|
||||
|
||||
-- | Handle configuration changes
|
||||
updateConfig :: Config -> Value -> Either Text Config
|
||||
updateConfig _oldConfig newConfig = Debug.debug Debug.LSP "Configuration Change" $ case fromJSON newConfig of
|
||||
Error err -> Left $ Text.pack err
|
||||
Success a -> Right a
|
||||
|
||||
-- | We could use this notification to cancel/update work-in-progress,
|
||||
-- but we don't actually need to update the config here, that's handled by the lsp library
|
||||
-- automatically.
|
||||
workspaceConfigurationChanged :: NotificationMessage 'WorkspaceDidChangeConfiguration -> Lsp ()
|
||||
workspaceConfigurationChanged _m = do
|
||||
pure ()
|
@ -33,7 +33,7 @@ reportDiagnostics ::
|
||||
f Diagnostic ->
|
||||
Lsp ()
|
||||
reportDiagnostics docUri fileVersion diags = do
|
||||
let jsonRPC = "" -- TODO: what's this for?
|
||||
let jsonRPC = "2.0"
|
||||
let params = PublishDiagnosticsParams {_uri = docUri, _version = fromIntegral <$> fileVersion, _diagnostics = List . toList $ diags}
|
||||
sendNotification (NotificationMessage jsonRPC STextDocumentPublishDiagnostics params)
|
||||
|
||||
|
@ -250,7 +250,7 @@ analyseNotes fileUri ppe src notes = do
|
||||
refs <- liftIO $ Codebase.termsOfType codebase cleanedTyp
|
||||
forMaybe (toList refs) $ \ref -> runMaybeT $ do
|
||||
hqNameSuggestion <- MaybeT . pure $ PPE.terms ppe ref
|
||||
typ <- MaybeT . liftIO $ Codebase.getTypeOfReferent codebase ref
|
||||
typ <- MaybeT . liftIO . Codebase.runTransaction codebase $ Codebase.getTypeOfReferent codebase ref
|
||||
let prettyType = TypePrinter.prettyStr Nothing ppe typ
|
||||
let txtName = HQ'.toText hqNameSuggestion
|
||||
let ranges = (diags ^.. folded . range)
|
||||
|
@ -1,19 +1,28 @@
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE GADTs #-}
|
||||
{-# LANGUAGE PolyKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Unison.LSP.Types where
|
||||
|
||||
import Colog.Core hiding (Lens')
|
||||
import Control.Lens hiding (List)
|
||||
import Control.Comonad.Cofree (Cofree)
|
||||
import qualified Control.Comonad.Cofree as Cofree
|
||||
import Control.Lens hiding (List, (:<))
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Reader
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.ByteString.Lazy.Char8 as BSC
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.IntervalMap.Lazy (IntervalMap)
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Text as Text
|
||||
import qualified Ki
|
||||
import qualified Language.LSP.Logging as LSP
|
||||
import Language.LSP.Server
|
||||
import qualified Language.LSP.Server as LSP
|
||||
import Language.LSP.Types
|
||||
import Language.LSP.Types.Lens
|
||||
import Language.LSP.VFS
|
||||
@ -21,6 +30,9 @@ import Unison.Codebase
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Codebase.Runtime (Runtime)
|
||||
import Unison.LSP.Orphans ()
|
||||
import Unison.LabeledDependency (LabeledDependency)
|
||||
import Unison.Name (Name)
|
||||
import Unison.NameSegment (NameSegment)
|
||||
import Unison.NamesWithHistory (NamesWithHistory)
|
||||
import Unison.Parser.Ann
|
||||
import Unison.Prelude
|
||||
@ -65,9 +77,25 @@ data Env = Env
|
||||
dirtyFilesVar :: TVar (Set Uri),
|
||||
-- A map of request IDs to an action which kills that request.
|
||||
cancellationMapVar :: TVar (Map SomeLspId (IO ())),
|
||||
-- A lazily computed map of all valid completion suffixes from the current path.
|
||||
completionsVar :: TVar CompletionTree,
|
||||
scope :: Ki.Scope
|
||||
}
|
||||
|
||||
-- | A suffix tree over path segments of name completions.
|
||||
-- see 'namesToCompletionTree' for more on how this is built and the invariants it should have.
|
||||
newtype CompletionTree = CompletionTree
|
||||
{ unCompletionTree :: Cofree (Map NameSegment) (Set (Name, LabeledDependency))
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
instance Semigroup CompletionTree where
|
||||
CompletionTree (a Cofree.:< subtreeA) <> CompletionTree (b Cofree.:< subtreeB) =
|
||||
CompletionTree (a <> b Cofree.:< Map.unionWith (\a b -> unCompletionTree $ CompletionTree a <> CompletionTree b) subtreeA subtreeB)
|
||||
|
||||
instance Monoid CompletionTree where
|
||||
mempty = CompletionTree $ mempty Cofree.:< mempty
|
||||
|
||||
-- | A monotonically increasing file version tracked by the lsp client.
|
||||
type FileVersion = Int32
|
||||
|
||||
@ -88,6 +116,9 @@ data FileAnalysis = FileAnalysis
|
||||
getCurrentPath :: Lsp Path.Absolute
|
||||
getCurrentPath = asks currentPathCache >>= liftIO
|
||||
|
||||
getCompletions :: Lsp CompletionTree
|
||||
getCompletions = asks completionsVar >>= readTVarIO
|
||||
|
||||
globalPPE :: Lsp PrettyPrintEnvDecl
|
||||
globalPPE = asks ppeCache >>= liftIO
|
||||
|
||||
@ -95,6 +126,41 @@ getParseNames :: Lsp NamesWithHistory
|
||||
getParseNames = asks parseNamesCache >>= liftIO
|
||||
|
||||
data Config = Config
|
||||
{ -- 'Nothing' will load ALL available completions, which is slower, but may provide a better
|
||||
-- solution for some users.
|
||||
--
|
||||
-- 'Just n' will only fetch the first 'n' completions and will prompt the client to ask for
|
||||
-- more completions after more typing.
|
||||
maxCompletions :: Maybe Int
|
||||
}
|
||||
deriving stock (Show)
|
||||
|
||||
instance Aeson.FromJSON Config where
|
||||
parseJSON = Aeson.withObject "Config" \obj -> do
|
||||
maxCompletions <- obj Aeson..:! "maxCompletions" Aeson..!= maxCompletions defaultLSPConfig
|
||||
let invalidKeys = Set.fromList (HM.keys obj) `Set.difference` validKeys
|
||||
when (not . null $ invalidKeys) do
|
||||
fail . Text.unpack $
|
||||
"Unrecognized configuration key(s): "
|
||||
<> Text.intercalate ", " (Set.toList invalidKeys)
|
||||
<> ".\nThe default configuration is:\n"
|
||||
<> Text.pack defaultConfigExample
|
||||
pure Config {..}
|
||||
where
|
||||
validKeys = Set.fromList ["maxCompletions"]
|
||||
defaultConfigExample =
|
||||
BSC.unpack $ Aeson.encode defaultLSPConfig
|
||||
|
||||
instance Aeson.ToJSON Config where
|
||||
toJSON (Config maxCompletions) =
|
||||
Aeson.object
|
||||
[ "maxCompletions" Aeson..= maxCompletions
|
||||
]
|
||||
|
||||
defaultLSPConfig :: Config
|
||||
defaultLSPConfig = Config {..}
|
||||
where
|
||||
maxCompletions = Just 100
|
||||
|
||||
-- | Lift a backend computation into the Lsp monad.
|
||||
lspBackend :: Backend.Backend IO a -> Lsp (Either Backend.BackendError a)
|
||||
@ -142,3 +208,9 @@ includeEdits uri replacement ranges rca =
|
||||
_changeAnnotations = Nothing
|
||||
}
|
||||
in rca & codeAction . edit ?~ workspaceEdit
|
||||
|
||||
getConfig :: Lsp Config
|
||||
getConfig = LSP.getConfig
|
||||
|
||||
setConfig :: Config -> Lsp ()
|
||||
setConfig = LSP.setConfig
|
||||
|
@ -5,9 +5,11 @@ import qualified Unison.Codebase as Codebase
|
||||
import Unison.Codebase.Branch (Branch)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.Debug as Debug
|
||||
import Unison.LSP.Completion
|
||||
import Unison.LSP.Types
|
||||
import qualified Unison.LSP.VFS as VFS
|
||||
import Unison.NamesWithHistory (NamesWithHistory)
|
||||
import qualified Unison.NamesWithHistory as NamesWithHistory
|
||||
import Unison.PrettyPrintEnvDecl
|
||||
import qualified Unison.PrettyPrintEnvDecl.Names as PPE
|
||||
import qualified Unison.Server.Backend as Backend
|
||||
@ -21,7 +23,7 @@ ucmWorker ::
|
||||
STM Path.Absolute ->
|
||||
Lsp ()
|
||||
ucmWorker ppeVar parseNamesVar getLatestRoot getLatestPath = do
|
||||
Env {codebase} <- ask
|
||||
Env {codebase, completionsVar} <- ask
|
||||
let loop :: (Branch IO, Path.Absolute) -> Lsp a
|
||||
loop (currentRoot, currentPath) = do
|
||||
Debug.debugM Debug.LSP "LSP path: " currentPath
|
||||
@ -33,6 +35,8 @@ ucmWorker ppeVar parseNamesVar getLatestRoot getLatestPath = do
|
||||
writeTVar ppeVar ppe
|
||||
-- Re-check everything with the new names and ppe
|
||||
VFS.markAllFilesDirty
|
||||
atomically do
|
||||
writeTVar completionsVar (namesToCompletionTree $ NamesWithHistory.currentNames parseNames)
|
||||
latest <- atomically $ do
|
||||
latestRoot <- getLatestRoot
|
||||
latestPath <- getLatestPath
|
||||
|
@ -159,7 +159,22 @@ fastForwardPush httpClient unisonShareUrl connect path localHeadHash uploadedCal
|
||||
Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path))
|
||||
Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path))
|
||||
Right (Just (Share.hashJWTHash -> remoteHeadHash)) -> do
|
||||
let doLoadCausalSpineBetween = loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash)
|
||||
let doLoadCausalSpineBetween = do
|
||||
-- (Temporary?) optimization - perform the "is ancestor?" check within sqlite before reconstructing the
|
||||
-- actual path.
|
||||
let isBefore :: Sqlite.Transaction Bool
|
||||
isBefore = do
|
||||
maybeHashIds <-
|
||||
runMaybeT $
|
||||
(,)
|
||||
<$> MaybeT (Q.loadCausalHashIdByCausalHash (hash32ToCausalHash remoteHeadHash))
|
||||
<*> MaybeT (Q.loadCausalHashIdByCausalHash localHeadHash)
|
||||
case maybeHashIds of
|
||||
Nothing -> pure False
|
||||
Just (remoteHeadHashId, localHeadHashId) -> Q.before remoteHeadHashId localHeadHashId
|
||||
isBefore >>= \case
|
||||
False -> pure Nothing
|
||||
True -> loadCausalSpineBetween remoteHeadHash (causalHashToHash32 localHeadHash)
|
||||
(connect \conn -> Sqlite.runTransaction conn doLoadCausalSpineBetween) >>= \case
|
||||
-- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a
|
||||
-- fast-forward push, so we don't bother trying - just report the error now.
|
||||
|
@ -67,7 +67,7 @@ runTranscript (Codebase codebasePath fmt) transcript = do
|
||||
cbInit = case fmt of CodebaseFormat2 -> SC.init
|
||||
TR.withTranscriptRunner "Unison.Test.Ucm.runTranscript Invalid Version String" configFile $ \runner -> do
|
||||
result <- Codebase.Init.withOpenCodebase cbInit "transcript" codebasePath SC.DontMigrate \codebase -> do
|
||||
Codebase.installUcmDependencies codebase
|
||||
Codebase.runTransaction codebase (Codebase.installUcmDependencies codebase)
|
||||
let transcriptSrc = Text.pack . stripMargin $ unTranscript transcript
|
||||
output <- either err Text.unpack <$> runner "transcript" transcriptSrc (codebasePath, codebase)
|
||||
when debugTranscriptOutput $ traceM output
|
||||
|
@ -19,14 +19,14 @@ import Unison.Codebase.Editor.RemoteRepo
|
||||
import qualified Unison.Codebase.Editor.UriParser as UriParser
|
||||
import Unison.Codebase.Path (Path (..))
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Codebase.ShortBranchHash (ShortBranchHash (..))
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
|
||||
test :: Test ()
|
||||
test = scope "uriparser" . tests $ [testShare, testGit]
|
||||
|
||||
gitHelper :: (ReadGitRepo, Maybe ShortBranchHash, Path) -> ReadRemoteNamespace
|
||||
gitHelper (repo, sbh, path) = ReadRemoteNamespaceGit (ReadGitRemoteNamespace repo sbh path)
|
||||
gitHelper :: (ReadGitRepo, Maybe ShortCausalHash, Path) -> ReadRemoteNamespace
|
||||
gitHelper (repo, sch, path) = ReadRemoteNamespaceGit (ReadGitRemoteNamespace repo sch path)
|
||||
|
||||
testShare :: Test ()
|
||||
testShare =
|
||||
@ -49,13 +49,13 @@ testGit =
|
||||
gitHelper (ReadGitRepo "/srv/git/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(/srv/git/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "/srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
|
||||
gitHelper (ReadGitRepo "/srv/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
),
|
||||
( "git(srv/git/project.git)",
|
||||
gitHelper (ReadGitRepo "srv/git/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(srv/git/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
|
||||
gitHelper (ReadGitRepo "srv/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
)
|
||||
],
|
||||
-- File Protocol
|
||||
@ -65,13 +65,13 @@ testGit =
|
||||
gitHelper (ReadGitRepo "file:///srv/git/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(file:///srv/git/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "file:///srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
|
||||
gitHelper (ReadGitRepo "file:///srv/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
),
|
||||
( "git(file://srv/git/project.git)",
|
||||
gitHelper (ReadGitRepo "file://srv/git/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(file://srv/git/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "file://srv/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
|
||||
gitHelper (ReadGitRepo "file://srv/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
)
|
||||
],
|
||||
-- Smart / Dumb HTTP protocol
|
||||
@ -81,7 +81,7 @@ testGit =
|
||||
gitHelper (ReadGitRepo "https://example.com/git/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(https://user@example.com/git/project.git:abc)#def.hij.klm]",
|
||||
gitHelper (ReadGitRepo "https://user@example.com/git/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
|
||||
gitHelper (ReadGitRepo "https://user@example.com/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
)
|
||||
],
|
||||
-- SSH Protocol
|
||||
@ -91,7 +91,7 @@ testGit =
|
||||
gitHelper (ReadGitRepo "ssh://git@8.8.8.8:222/user/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(ssh://git@github.com/user/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "ssh://git@github.com/user/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
|
||||
gitHelper (ReadGitRepo "ssh://git@github.com/user/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
)
|
||||
],
|
||||
-- $ git clone [user@]server:project.git[:treeish][:[#hash][.path]]
|
||||
@ -103,7 +103,7 @@ testGit =
|
||||
gitHelper (ReadGitRepo "github.com:user/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(git@github.com:user/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "git@github.com:user/project.git" (Just "abc"), sbh "def", path ["hij", "klm"])
|
||||
gitHelper (ReadGitRepo "git@github.com:user/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
)
|
||||
]
|
||||
]
|
||||
@ -120,5 +120,5 @@ expectParseFailure s = void . scope (Text.unpack s) . expectLeft . P.parse UriPa
|
||||
path :: [Text] -> Path
|
||||
path = Path . Seq.fromList . fmap NameSegment
|
||||
|
||||
sbh :: Text -> Maybe ShortBranchHash
|
||||
sbh = Just . ShortBranchHash
|
||||
sch :: Text -> Maybe ShortCausalHash
|
||||
sch = Just . ShortCausalHash
|
||||
|
@ -68,11 +68,13 @@ library
|
||||
Unison.CommandLine.InputPatterns
|
||||
Unison.CommandLine.Main
|
||||
Unison.CommandLine.OutputMessages
|
||||
Unison.CommandLine.Types
|
||||
Unison.CommandLine.Welcome
|
||||
Unison.LSP
|
||||
Unison.LSP.CancelRequest
|
||||
Unison.LSP.CodeAction
|
||||
Unison.LSP.Completion
|
||||
Unison.LSP.Configuration
|
||||
Unison.LSP.Conversions
|
||||
Unison.LSP.Diagnostics
|
||||
Unison.LSP.FileAnalysis
|
||||
@ -141,6 +143,7 @@ library
|
||||
, exceptions
|
||||
, extra
|
||||
, filepath
|
||||
, free
|
||||
, friendly-time
|
||||
, fuzzyfind
|
||||
, generic-lens
|
||||
@ -185,6 +188,7 @@ library
|
||||
, unison-pretty-printer
|
||||
, unison-share-api
|
||||
, unison-sqlite
|
||||
, unison-syntax
|
||||
, unison-util
|
||||
, unison-util-base32hex
|
||||
, unison-util-relation
|
||||
@ -263,6 +267,7 @@ executable cli-integration-tests
|
||||
, exceptions
|
||||
, extra
|
||||
, filepath
|
||||
, free
|
||||
, friendly-time
|
||||
, fuzzyfind
|
||||
, generic-lens
|
||||
@ -308,6 +313,7 @@ executable cli-integration-tests
|
||||
, unison-pretty-printer
|
||||
, unison-share-api
|
||||
, unison-sqlite
|
||||
, unison-syntax
|
||||
, unison-util
|
||||
, unison-util-base32hex
|
||||
, unison-util-relation
|
||||
@ -379,6 +385,7 @@ executable transcripts
|
||||
, exceptions
|
||||
, extra
|
||||
, filepath
|
||||
, free
|
||||
, friendly-time
|
||||
, fuzzyfind
|
||||
, generic-lens
|
||||
@ -425,6 +432,7 @@ executable transcripts
|
||||
, unison-pretty-printer
|
||||
, unison-share-api
|
||||
, unison-sqlite
|
||||
, unison-syntax
|
||||
, unison-util
|
||||
, unison-util-base32hex
|
||||
, unison-util-relation
|
||||
@ -499,6 +507,7 @@ executable unison
|
||||
, exceptions
|
||||
, extra
|
||||
, filepath
|
||||
, free
|
||||
, friendly-time
|
||||
, fuzzyfind
|
||||
, generic-lens
|
||||
@ -548,6 +557,7 @@ executable unison
|
||||
, unison-pretty-printer
|
||||
, unison-share-api
|
||||
, unison-sqlite
|
||||
, unison-syntax
|
||||
, unison-util
|
||||
, unison-util-base32hex
|
||||
, unison-util-relation
|
||||
@ -627,6 +637,7 @@ test-suite cli-tests
|
||||
, exceptions
|
||||
, extra
|
||||
, filepath
|
||||
, free
|
||||
, friendly-time
|
||||
, fuzzyfind
|
||||
, generic-lens
|
||||
@ -674,6 +685,7 @@ test-suite cli-tests
|
||||
, unison-pretty-printer
|
||||
, unison-share-api
|
||||
, unison-sqlite
|
||||
, unison-syntax
|
||||
, unison-util
|
||||
, unison-util-base32hex
|
||||
, unison-util-relation
|
||||
|
@ -57,6 +57,7 @@ import System.Environment (lookupEnv)
|
||||
import Text.Read (readMaybe)
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import qualified Unison.Codebase.Path.Parse as Path
|
||||
import Unison.CommandLine.Types (ShouldWatchFiles (..))
|
||||
import qualified Unison.PrettyTerminal as PT
|
||||
import Unison.Server.CodebaseServer (CodebaseServerOpts (..))
|
||||
import qualified Unison.Server.CodebaseServer as Server
|
||||
@ -110,6 +111,7 @@ data Command
|
||||
ShouldDownloadBase
|
||||
-- Starting path
|
||||
(Maybe Path.Absolute)
|
||||
ShouldWatchFiles
|
||||
| PrintVersion
|
||||
| -- @deprecated in trunk after M2g. Remove the Init command completely after M2h has been released
|
||||
Init
|
||||
@ -347,7 +349,8 @@ launchParser envOpts isHeadless = do
|
||||
codebaseServerOpts <- codebaseServerOptsParser envOpts
|
||||
downloadBase <- downloadBaseFlag
|
||||
startingPath <- startingPathOption
|
||||
pure (Launch isHeadless codebaseServerOpts downloadBase startingPath)
|
||||
shouldWatchFiles <- noFileWatchFlag
|
||||
pure (Launch isHeadless codebaseServerOpts downloadBase startingPath shouldWatchFiles)
|
||||
|
||||
initParser :: Parser Command
|
||||
initParser = pure Init
|
||||
@ -405,6 +408,18 @@ startingPathOption =
|
||||
<> noGlobal
|
||||
in optional $ option readAbsolutePath meta
|
||||
|
||||
noFileWatchFlag :: Parser ShouldWatchFiles
|
||||
noFileWatchFlag =
|
||||
flag
|
||||
ShouldWatchFiles
|
||||
ShouldNotWatchFiles
|
||||
( long "no-file-watch"
|
||||
<> help noFileWatchHelp
|
||||
<> noGlobal
|
||||
)
|
||||
where
|
||||
noFileWatchHelp = "If set, ucm will not respond to changes in unison files. Instead, you can use the 'load' command."
|
||||
|
||||
readAbsolutePath :: ReadM Path.Absolute
|
||||
readAbsolutePath = do
|
||||
readPath' >>= \case
|
||||
|
@ -3,6 +3,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -Wno-partial-type-signatures #-}
|
||||
|
||||
@ -22,7 +23,7 @@ import ArgParse
|
||||
parseCLIArgs,
|
||||
)
|
||||
import Compat (defaultInterruptHandler, onWindows, withInterruptHandler)
|
||||
import Control.Concurrent (newEmptyMVar, takeMVar)
|
||||
import Control.Concurrent (newEmptyMVar, runInUnboundThread, takeMVar)
|
||||
import Control.Concurrent.STM
|
||||
import Control.Error.Safe (rightMay)
|
||||
import Control.Exception (evaluate)
|
||||
@ -37,10 +38,12 @@ import qualified Data.Text.IO as Text
|
||||
import GHC.Conc (setUncaughtExceptionHandler)
|
||||
import qualified GHC.Conc
|
||||
import qualified Ki
|
||||
import qualified Language.Haskell.TH as TH
|
||||
import qualified Language.Haskell.TH.Syntax as TH
|
||||
import qualified Network.HTTP.Client as HTTP
|
||||
import qualified Network.HTTP.Client.TLS as HTTP
|
||||
import System.Directory (canonicalizePath, getCurrentDirectory, removeDirectoryRecursive)
|
||||
import System.Environment (getProgName, withArgs)
|
||||
import System.Environment (getProgName, lookupEnv, withArgs)
|
||||
import qualified System.Exit as Exit
|
||||
import qualified System.FilePath as FP
|
||||
import System.IO (stderr)
|
||||
@ -55,6 +58,7 @@ import qualified Unison.Codebase as Codebase
|
||||
import Unison.Codebase.Branch (Branch)
|
||||
import qualified Unison.Codebase.Editor.Input as Input
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadShareRemoteNamespace)
|
||||
import Unison.Codebase.Editor.UriParser (parseReadShareRemoteNamespace)
|
||||
import qualified Unison.Codebase.Editor.VersionParser as VP
|
||||
import Unison.Codebase.Execute (execute)
|
||||
import Unison.Codebase.Init (CodebaseInitOptions (..), InitError (..), InitResult (..), SpecifiedCodebase (..))
|
||||
@ -66,6 +70,7 @@ import qualified Unison.Codebase.SqliteCodebase as SC
|
||||
import qualified Unison.Codebase.TranscriptParser as TR
|
||||
import Unison.CommandLine (plural', watchConfig)
|
||||
import qualified Unison.CommandLine.Main as CommandLine
|
||||
import qualified Unison.CommandLine.Types as CommandLine
|
||||
import Unison.CommandLine.Welcome (CodebaseInitStatus (..))
|
||||
import qualified Unison.CommandLine.Welcome as Welcome
|
||||
import qualified Unison.LSP as LSP
|
||||
@ -82,7 +87,7 @@ import UnliftIO.Directory (getHomeDirectory)
|
||||
import qualified Version
|
||||
|
||||
main :: IO ()
|
||||
main = withCP65001 . Ki.scoped $ \scope -> do
|
||||
main = withCP65001 . runInUnboundThread . Ki.scoped $ \scope -> do
|
||||
-- Replace the default exception handler with one that pretty-prints.
|
||||
setUncaughtExceptionHandler (pHPrint stderr)
|
||||
|
||||
@ -136,7 +141,20 @@ main = withCP65001 . Ki.scoped $ \scope -> do
|
||||
let noOpPathNotifier _ = pure ()
|
||||
let serverUrl = Nothing
|
||||
let startPath = Nothing
|
||||
launch currentDir config rt sbrt theCodebase [Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI] serverUrl startPath ShouldNotDownloadBase initRes noOpRootNotifier noOpPathNotifier
|
||||
launch
|
||||
currentDir
|
||||
config
|
||||
rt
|
||||
sbrt
|
||||
theCodebase
|
||||
[Left fileEvent, Right $ Input.ExecuteI mainName args, Right Input.QuitI]
|
||||
serverUrl
|
||||
startPath
|
||||
ShouldNotDownloadBase
|
||||
initRes
|
||||
noOpRootNotifier
|
||||
noOpPathNotifier
|
||||
CommandLine.ShouldNotWatchFiles
|
||||
Run (RunFromPipe mainName) args -> do
|
||||
e <- safeReadUtf8StdIn
|
||||
case e of
|
||||
@ -163,6 +181,7 @@ main = withCP65001 . Ki.scoped $ \scope -> do
|
||||
initRes
|
||||
noOpRootNotifier
|
||||
noOpPathNotifier
|
||||
CommandLine.ShouldNotWatchFiles
|
||||
Run (RunCompiled file) args ->
|
||||
BL.readFile file >>= \bs ->
|
||||
try (evaluate $ RTI.decodeStandalone bs) >>= \case
|
||||
@ -229,7 +248,7 @@ main = withCP65001 . Ki.scoped $ \scope -> do
|
||||
]
|
||||
Transcript shouldFork shouldSaveCodebase transcriptFiles ->
|
||||
runTranscripts renderUsageInfo shouldFork shouldSaveCodebase mCodePathOption transcriptFiles
|
||||
Launch isHeadless codebaseServerOpts downloadBase mayStartingPath -> do
|
||||
Launch isHeadless codebaseServerOpts downloadBase mayStartingPath shouldWatchFiles -> do
|
||||
getCodebaseOrExit mCodePathOption SC.MigrateAfterPrompt \(initRes, _, theCodebase) -> do
|
||||
runtime <- RTI.startRuntime False RTI.Persistent Version.gitDescribeWithDate
|
||||
rootVar <- newEmptyTMVarIO
|
||||
@ -271,7 +290,20 @@ main = withCP65001 . Ki.scoped $ \scope -> do
|
||||
takeMVar mvar
|
||||
WithCLI -> do
|
||||
PT.putPrettyLn $ P.string "Now starting the Unison Codebase Manager (UCM)..."
|
||||
launch currentDir config runtime sbRuntime theCodebase [] (Just baseUrl) mayStartingPath downloadBase initRes notifyOnRootChanges notifyOnPathChanges
|
||||
launch
|
||||
currentDir
|
||||
config
|
||||
runtime
|
||||
sbRuntime
|
||||
theCodebase
|
||||
[]
|
||||
(Just baseUrl)
|
||||
mayStartingPath
|
||||
downloadBase
|
||||
initRes
|
||||
notifyOnRootChanges
|
||||
notifyOnPathChanges
|
||||
shouldWatchFiles
|
||||
Exit -> do Exit.exitSuccess
|
||||
|
||||
-- | Set user agent and configure TLS on global http client.
|
||||
@ -422,8 +454,9 @@ launch ::
|
||||
InitResult ->
|
||||
(Branch IO -> STM ()) ->
|
||||
(Path.Absolute -> STM ()) ->
|
||||
CommandLine.ShouldWatchFiles ->
|
||||
IO ()
|
||||
launch dir config runtime sbRuntime codebase inputs serverBaseUrl mayStartingPath shouldDownloadBase initResult notifyRootChange notifyPathChange =
|
||||
launch dir config runtime sbRuntime codebase inputs serverBaseUrl mayStartingPath shouldDownloadBase initResult notifyRootChange notifyPathChange shouldWatchFiles =
|
||||
let downloadBase = case defaultBaseLib of
|
||||
Just remoteNS | shouldDownloadBase == ShouldDownloadBase -> Welcome.DownloadBase remoteNS
|
||||
_ -> Welcome.DontDownloadBase
|
||||
@ -432,7 +465,7 @@ launch dir config runtime sbRuntime codebase inputs serverBaseUrl mayStartingPat
|
||||
_ -> PreviouslyCreatedCodebase
|
||||
|
||||
(ucmVersion, _date) = Version.gitDescribe
|
||||
welcome = Welcome.welcome isNewCodebase downloadBase dir ucmVersion
|
||||
welcome = Welcome.welcome isNewCodebase downloadBase dir ucmVersion shouldWatchFiles
|
||||
in CommandLine.main
|
||||
dir
|
||||
welcome
|
||||
@ -446,6 +479,7 @@ launch dir config runtime sbRuntime codebase inputs serverBaseUrl mayStartingPat
|
||||
ucmVersion
|
||||
notifyRootChange
|
||||
notifyPathChange
|
||||
shouldWatchFiles
|
||||
|
||||
newtype MarkdownFile = MarkdownFile FilePath
|
||||
|
||||
@ -468,8 +502,14 @@ getConfigFilePath mcodepath = (FP.</> ".unisonConfig") <$> Codebase.getCodebaseD
|
||||
|
||||
defaultBaseLib :: Maybe ReadShareRemoteNamespace
|
||||
defaultBaseLib =
|
||||
rightMay $
|
||||
runParser VP.defaultBaseLib "version" gitRef
|
||||
let mayBaseSharePath =
|
||||
$( do
|
||||
mayPath <- TH.runIO (lookupEnv "UNISON_BASE_PATH")
|
||||
TH.lift mayPath
|
||||
)
|
||||
in mayBaseSharePath & \case
|
||||
Just s -> eitherToMaybe $ parseReadShareRemoteNamespace "UNISON_BASE_PATH" s
|
||||
Nothing -> rightMay $ runParser VP.defaultBaseLib "version" gitRef
|
||||
where
|
||||
(gitRef, _date) = Version.gitDescribe
|
||||
|
||||
|
@ -27,6 +27,7 @@ module Unison.ABT
|
||||
freshInBoth,
|
||||
visit,
|
||||
visit',
|
||||
visit_,
|
||||
visitPure,
|
||||
changeVars,
|
||||
allVars,
|
||||
@ -114,6 +115,7 @@ import U.Core.ABT
|
||||
unabs,
|
||||
visit,
|
||||
visit',
|
||||
visit_,
|
||||
visitPure,
|
||||
vmap,
|
||||
pattern AbsN',
|
||||
|
@ -25,19 +25,42 @@ isConstructor = \case
|
||||
|
||||
-- Parse a string like those described in Referent.fromText:
|
||||
-- examples:
|
||||
-- `##Text.take` — builtins don’t have cycles or cids
|
||||
-- `#2tWjVAuc7` — term ref, no cycle
|
||||
-- `#y9ycWkiC1.y9` — term ref, part of cycle
|
||||
-- `#cWkiC1x89#1` — constructor
|
||||
-- `#DCxrnCAPS.WD#0` — constructor of a type in a cycle
|
||||
--
|
||||
-- builtins don’t have cycles or cids
|
||||
-- >>> fromText "##Text.take"
|
||||
-- Just (Builtin "Text.take")
|
||||
--
|
||||
-- term ref, no cycle
|
||||
-- >>> fromText "#2tWjVAuc7"
|
||||
-- Just (ShortHash {prefix = "2tWjVAuc7", cycle = Nothing, cid = Nothing})
|
||||
--
|
||||
-- term ref, part of cycle
|
||||
-- >>> fromText "#y9ycWkiC1.y9"
|
||||
-- Just (ShortHash {prefix = "y9ycWkiC1", cycle = Just "y9", cid = Nothing})
|
||||
--
|
||||
-- constructor
|
||||
-- >>> fromText "#cWkiC1x89#1"
|
||||
-- Just (ShortHash {prefix = "cWkiC1x89", cycle = Nothing, cid = Just "1"})
|
||||
--
|
||||
-- constructor of a type in a cycle
|
||||
-- >>> fromText "#DCxrnCAPS.WD#0"
|
||||
-- Just (ShortHash {prefix = "DCxrnCAPS", cycle = Just "WD", cid = Just "0"})
|
||||
--
|
||||
-- A constructor ID on a builtin is ignored:
|
||||
-- e.g. ##FileIO#2 is parsed as ##FileIO
|
||||
-- >>> fromText "##FileIO#2"
|
||||
-- Just (Builtin "FileIO")
|
||||
--
|
||||
-- Anything to the left of the first # is
|
||||
-- e.g. foo#abc is parsed as #abc
|
||||
-- >>> fromText "foo#abc "
|
||||
-- Just (ShortHash {prefix = "abc ", cycle = Nothing, cid = Nothing})
|
||||
--
|
||||
-- Anything including and following a third # is ignored.
|
||||
-- e.g. foo#abc#2#hello is parsed as #abc#2
|
||||
-- >>> fromText "foo#abc#2#hello"
|
||||
-- Just (ShortHash {prefix = "abc", cycle = Nothing, cid = Just "2"})
|
||||
--
|
||||
-- Anything after a second . before a second # is ignored.
|
||||
-- e.g. foo#abc.1f.x is parsed as #abc.1f
|
||||
-- >>> fromText "foo#abc.1f.x"
|
||||
-- Just (ShortHash {prefix = "abc", cycle = Just "1f", cid = Nothing})
|
||||
fromText :: Text -> Maybe ShortHash
|
||||
fromText t = case Text.split (== '#') t of
|
||||
[_, "", b] -> Just $ Builtin b -- builtin starts with ##
|
||||
|
@ -38,7 +38,7 @@ import qualified Unison.NamesWithHistory as Names
|
||||
import Unison.Pattern (Pattern)
|
||||
import qualified Unison.Pattern as Pattern
|
||||
import Unison.Prelude
|
||||
import Unison.Reference (Reference, pattern Builtin)
|
||||
import Unison.Reference (Reference, TermReference, pattern Builtin)
|
||||
import qualified Unison.Reference as Reference
|
||||
import Unison.Referent (Referent)
|
||||
import qualified Unison.Referent as Referent
|
||||
@ -1169,7 +1169,7 @@ unReqOrCtor _ = Nothing
|
||||
dependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference
|
||||
dependencies t = Set.map (LD.fold id Referent.toReference) (labeledDependencies t)
|
||||
|
||||
termDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set Reference
|
||||
termDependencies :: (Ord v, Ord vt) => Term2 vt at ap v a -> Set TermReference
|
||||
termDependencies =
|
||||
Set.fromList
|
||||
. mapMaybe
|
||||
|
@ -1,8 +1,34 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.Var where
|
||||
module Unison.Var
|
||||
( Var (..),
|
||||
Type (..),
|
||||
InferenceType (..),
|
||||
blank,
|
||||
freshIn,
|
||||
inferAbility,
|
||||
inferInput,
|
||||
inferOther,
|
||||
inferOutput,
|
||||
inferPatternBindE,
|
||||
inferPatternBindV,
|
||||
inferPatternPureE,
|
||||
inferPatternPureV,
|
||||
inferTypeConstructor,
|
||||
inferTypeConstructorArg,
|
||||
joinDot,
|
||||
missingResult,
|
||||
name,
|
||||
nameStr,
|
||||
named,
|
||||
nameds,
|
||||
namespaced,
|
||||
rawName,
|
||||
reset,
|
||||
uncapitalize,
|
||||
universallyQuantifyIfFree,
|
||||
unnamedRef,
|
||||
unnamedTest,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Char (isLower, toLower)
|
||||
import Data.Text (pack)
|
||||
@ -169,9 +195,6 @@ joinDot prefix v2 =
|
||||
then named (name prefix `mappend` name v2)
|
||||
else named (name prefix `mappend` "." `mappend` name v2)
|
||||
|
||||
freshNamed :: Var v => Set v -> Text -> v
|
||||
freshNamed used n = ABT.freshIn used (named n)
|
||||
|
||||
universallyQuantifyIfFree :: forall v. Var v => v -> Bool
|
||||
universallyQuantifyIfFree v =
|
||||
ok (name $ reset v) && unqualified v == v
|
||||
|
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user