⅄ trunk → 22-11-04-remove-codebase-functions

This commit is contained in:
Mitchell Rosen 2022-11-16 13:36:58 -05:00
commit b5c2a01e06
26 changed files with 571 additions and 118 deletions

View File

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

View File

@ -635,7 +635,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
@ -652,7 +653,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

View File

@ -79,6 +79,7 @@ module U.Codebase.Sqlite.Queries
loadCausalByCausalHash,
expectCausalByCausalHash,
loadBranchObjectIdByCausalHashId,
loadBranchObjectIdByBranchHashId,
expectBranchObjectIdByCausalHashId,
expectBranchObjectIdByBranchHashId,
@ -1046,6 +1047,9 @@ loadBranchObjectIdByCausalHashIdSql =
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|

103
docs/configuration.md Normal file
View 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"
}
```

View File

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

View File

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

View File

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

View File

@ -330,9 +330,9 @@ sqliteCodebase debugName root localOrRemote migrationStrategy action = do
referentsByPrefix sh =
runTransaction (CodebaseOps.referentsByPrefix getDeclType sh)
updateNameLookup :: Path -> Maybe BranchHash -> BranchHash -> m ()
updateNameLookup pathPrefix fromBH toBH =
runTransaction (CodebaseOps.updateNameLookupIndex getDeclType pathPrefix fromBH toBH)
updateNameLookup :: Path -> Maybe BranchHash -> BranchHash -> Sqlite.Transaction ()
updateNameLookup =
CodebaseOps.updateNameLookupIndex getDeclType
let codebase =
C.Codebase

View File

@ -780,6 +780,8 @@ initializeNameLookupIndexFromV2Root getDeclType = do
pure (Map.mapKeys (NEList.:| reversedNamePrefix) shallowTermNames <> prefixedChildTerms, Map.mapKeys (NEList.:| reversedNamePrefix) shallowTypeNames <> prefixedChildTypes)
-- | 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

View File

@ -118,7 +118,7 @@ data Codebase m v a = Codebase
Maybe BranchHash ->
-- The new branch
BranchHash ->
m (),
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.

View File

@ -2159,7 +2159,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

View File

@ -1375,7 +1375,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))

View File

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

View File

@ -391,13 +391,14 @@ propagate patch b = case validatePatch patch of
doTerm r = do
when debugMode (traceM $ "Rewriting term: " <> show r)
componentMap <- unhashTermComponent codebase r
let componentMap' =
over
_2
(Term.updateDependencies termReplacements typeReplacements)
<$> componentMap
seen' = seen <> Set.fromList (view _1 <$> Map.elems componentMap)
mayComponent <- verifyTermComponent codebase componentMap' es
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")

View File

@ -38,6 +38,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
@ -104,8 +105,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.runTransaction codebase Operations.expectRootCausalHash
_ <- Ki.fork scope $ do
@ -135,7 +137,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

View File

@ -0,0 +1,6 @@
module Unison.CommandLine.Types (ShouldWatchFiles (..)) where
data ShouldWatchFiles
= ShouldWatchFiles
| ShouldNotWatchFiles
deriving (Show, Eq)

View File

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

View File

@ -67,6 +67,7 @@ library
Unison.CommandLine.InputPatterns
Unison.CommandLine.Main
Unison.CommandLine.OutputMessages
Unison.CommandLine.Types
Unison.CommandLine.Welcome
Unison.LSP
Unison.LSP.CancelRequest

View File

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

View File

@ -70,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
@ -140,7 +141,20 @@ main = withCP65001 . runInUnboundThread . 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
@ -167,6 +181,7 @@ main = withCP65001 . runInUnboundThread . Ki.scoped $ \scope -> do
initRes
noOpRootNotifier
noOpPathNotifier
CommandLine.ShouldNotWatchFiles
Run (RunCompiled file) args ->
BL.readFile file >>= \bs ->
try (evaluate $ RTI.decodeStandalone bs) >>= \case
@ -233,7 +248,7 @@ main = withCP65001 . runInUnboundThread . 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
@ -275,7 +290,20 @@ main = withCP65001 . runInUnboundThread . 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.
@ -426,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
@ -436,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
@ -450,6 +479,7 @@ launch dir config runtime sbRuntime codebase inputs serverBaseUrl mayStartingPat
ucmVersion
notifyRootChange
notifyPathChange
shouldWatchFiles
newtype MarkdownFile = MarkdownFile FilePath

View File

@ -561,7 +561,7 @@ lsBranch codebase b0 = do
pure (r, ns)
termEntries <- for (flattenRefs $ V2Branch.terms b0) $ \(r, ns) -> do
ShallowTermEntry <$> termListEntry codebase b0 (ExactName (coerce @V2Branch.NameSegment ns) r)
typeEntries <-
typeEntries <-
Codebase.runTransaction codebase do
for (flattenRefs $ V2Branch.types b0) \(r, ns) -> do
let v1Ref = Cv.reference2to1 r
@ -1009,7 +1009,7 @@ docsInBranchToHtmlFiles runtime codebase root currentPath directory = do
let allTerms = (R.toList . Branch.deepTerms . Branch.head) currentBranch
-- ignores docs inside lib namespace, recursively
let notLib (_, name) = "lib" `notElem` Name.segments name
(docTermsWithNames, hqLength) <-
(docTermsWithNames, hqLength) <-
Codebase.runTransaction codebase do
docTermsWithNames <- filterM (isDoc codebase . fst) (filter notLib allTerms)
hqLength <- Codebase.hashLength
@ -1172,6 +1172,12 @@ resolveRootBranchHashV2 codebase mayRoot = case mayRoot of
resolveCausalHashV2 codebase (Just h)
-- | Determines whether we include full cycles in the results, (e.g. if I search for `isEven`, will I find `isOdd` too?)
--
-- This was once used for both term and decl components, but now is only used for decl components, because 'update' does
-- The Right Thing for terms (i.e. propagates changes to all dependents, including component-mates, which are de facto
-- dependents).
--
-- Ticket of interest: https://github.com/unisonweb/unison/issues/3445
data IncludeCycles
= IncludeCycles
| DontIncludeCycles
@ -1188,16 +1194,7 @@ definitionsBySuffixes codebase nameSearch includeCycles query = do
QueryResult misses results <- hqNameQuery codebase nameSearch query
-- todo: remember to replace this with getting components directly,
-- and maybe even remove getComponentLength from Codebase interface altogether
terms <- do
let termRefsWithoutCycles = searchResultsToTermRefs results
termRefs <- case includeCycles of
IncludeCycles ->
Codebase.runTransaction codebase do
Monoid.foldMapM
Codebase.componentReferencesForReference
termRefsWithoutCycles
DontIncludeCycles -> pure termRefsWithoutCycles
Map.foldMapM (\ref -> (ref,) <$> displayTerm codebase ref) termRefs
terms <- Map.foldMapM (\ref -> (ref,) <$> displayTerm codebase ref) (searchResultsToTermRefs results)
types <- do
let typeRefsWithoutCycles = searchResultsToTypeRefs results
typeRefs <- case includeCycles of

View File

@ -287,6 +287,25 @@ test> Bytes.tests.fromBase64UrlUnpadded =
.> add
```
## `List` comparison
```unison:hide
test> checks [
compare [] [1,2,3] == -1,
compare [1,2,3] [1,2,3,4] == -1,
compare [1,2,3,4] [1,2,3] == +1,
compare [1,2,3] [1,2,3] == +0,
compare [3] [1,2,3] == +1,
compare [1,2,3] [1,2,4] == -1,
compare [1,2,2] [1,2,1,2] == +1,
compare [1,2,3,4] [3,2,1] == -1
]
```
```ucm:hide
.> add
```
## `Any` functions
```unison

View File

@ -260,6 +260,21 @@ test> Bytes.tests.fromBase64UrlUnpadded =
```
## `List` comparison
```unison
test> checks [
compare [] [1,2,3] == -1,
compare [1,2,3] [1,2,3,4] == -1,
compare [1,2,3,4] [1,2,3] == +1,
compare [1,2,3] [1,2,3] == +0,
compare [3] [1,2,3] == +1,
compare [1,2,3] [1,2,4] == -1,
compare [1,2,2] [1,2,1,2] == +1,
compare [1,2,3,4] [3,2,1] == -1
]
```
## `Any` functions
```unison
@ -371,13 +386,14 @@ Now that all the tests have been added to the codebase, let's view the test repo
◉ Sandbox.test1 Passed
◉ Sandbox.test2 Passed
◉ Sandbox.test3 Passed
◉ test.rtjqan7bcs Passed
◉ Text.tests.alignment Passed
◉ Text.tests.literalsEq Passed
◉ Text.tests.patterns Passed
◉ Text.tests.repeat Passed
◉ Text.tests.takeDropAppend Passed
✅ 22 test(s) passing
✅ 23 test(s) passing
Tip: Use view Any.test1 to view the source of a test.

View File

@ -0,0 +1,47 @@
First we'll set up two libraries, and then we'll use them in some projects and show what `names` are deep-loaded for them.
Our two "libraries":
```unison:hide
text.a = 1
text.b = 2
text.c = 3
http.x = 6
http.y = 7
http.z = 8
```
```ucm:hide
.> add
```
Our `app1` project includes the text library twice and the http library twice as direct dependencies.
```ucm
.app1> fork .text lib.text_v1
.app1> fork .text lib.text_v2
.app1> fork .http lib.http_v3
.app1> fork .http lib.http_v4
```
As such, we see two copies of `a` and two copies of `x` via these direct dependencies.
```ucm
.app1> names a
.app1> names x
```
Our `app2` project includes the `http` library twice as direct dependencies, and once as an indirect dependency via `webutil`.
It also includes the `text` library twice as indirect dependencies via `webutil`
```ucm
.app2> fork .http lib.http_v1
.app2> fork .http lib.http_v2
.app2> fork .text lib.webutil.lib.text_v1
.app2> fork .text lib.webutil.lib.text_v2
.app2> fork .http lib.webutil.lib.http
```
Now we see two copies of `x` via direct dependencies on `http`, and one copy of `a` via indirect dependency on `text` via `webutil`.
We see neither the second indirect copy of `a` nor the indirect copy of `x` via webutil because we already have names for them.
```ucm
.app2> names a
.app2> names x
```

View File

@ -0,0 +1,99 @@
First we'll set up two libraries, and then we'll use them in some projects and show what `names` are deep-loaded for them.
Our two "libraries":
```unison
text.a = 1
text.b = 2
text.c = 3
http.x = 6
http.y = 7
http.z = 8
```
Our `app1` project includes the text library twice and the http library twice as direct dependencies.
```ucm
☝️ The namespace .app1 is empty.
.app1> fork .text lib.text_v1
Done.
.app1> fork .text lib.text_v2
Done.
.app1> fork .http lib.http_v3
Done.
.app1> fork .http lib.http_v4
Done.
```
As such, we see two copies of `a` and two copies of `x` via these direct dependencies.
```ucm
.app1> names a
Term
Hash: #gjmq673r1v
Names: lib.text_v1.a lib.text_v2.a
Tip: Use `names.global` to see more results.
.app1> names x
Term
Hash: #nsmc4p1ra4
Names: lib.http_v3.x lib.http_v4.x
Tip: Use `names.global` to see more results.
```
Our `app2` project includes the `http` library twice as direct dependencies, and once as an indirect dependency via `webutil`.
It also includes the `text` library twice as indirect dependencies via `webutil`
```ucm
☝️ The namespace .app2 is empty.
.app2> fork .http lib.http_v1
Done.
.app2> fork .http lib.http_v2
Done.
.app2> fork .text lib.webutil.lib.text_v1
Done.
.app2> fork .text lib.webutil.lib.text_v2
Done.
.app2> fork .http lib.webutil.lib.http
Done.
```
Now we see two copies of `x` via direct dependencies on `http`, and one copy of `a` via indirect dependency on `text` via `webutil`.
We see neither the second indirect copy of `a` nor the indirect copy of `x` via webutil because we already have names for them.
```ucm
.app2> names a
Term
Hash: #gjmq673r1v
Names: lib.webutil.lib.text_v1.a
Tip: Use `names.global` to see more results.
.app2> names x
Term
Hash: #nsmc4p1ra4
Names: lib.http_v1.x lib.http_v2.x
Tip: Use `names.global` to see more results.
```

View File

@ -13,7 +13,7 @@ foo.lib.qux = 4
.> find foo
```
```ucm:error
```ucm
.> find bar
```