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

Merge pull request #5250 from unisonweb/update-defn-order

Browse Source
This commit is contained in:
Arya Irani 2024-08-02 22:22:37 +00:00 committed by GitHub
commit 97c9109291
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
41 changed files with 1313 additions and 924 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
lib/unison-util-relation/src/Unison/Util/BiMultimap.hs
View File

@ -3,6 +3,9 @@ module Unison.Util.BiMultimap
( BiMultimap,
Unison.Util.BiMultimap.empty,
-- ** Basic queries
isEmpty,
-- ** Lookup
memberDom,
lookupDom,
@ -32,6 +35,9 @@ module Unison.Util.BiMultimap
dom,
ran,
-- ** Relations
toRelation,
-- ** Insert
insert,
unsafeInsert,
@ -47,6 +53,8 @@ import Data.Set.NonEmpty (NESet)
import Data.Set.NonEmpty qualified as Set.NonEmpty
import Unison.Prelude
import Unison.Util.Map qualified as Map
import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as Relation
import Prelude hiding (filter)
-- | A left-unique relation.
@ -62,6 +70,11 @@ data BiMultimap a b = BiMultimap
empty :: (Ord a, Ord b) => BiMultimap a b
empty = BiMultimap mempty mempty
-- | Is a left-unique relation empty?
isEmpty :: BiMultimap a b -> Bool
isEmpty =
Map.null . domain
memberDom :: (Ord a) => a -> BiMultimap a b -> Bool
memberDom x =
Map.member x . domain
@ -200,6 +213,11 @@ ran :: BiMultimap a b -> Set b
ran =
Map.keysSet . toMapR
-- | Convert a left-unique relation to a relation (forgetting its left-uniqueness).
toRelation :: (Ord a, Ord b) => BiMultimap a b -> Relation a b
toRelation =
Relation.fromMultimap . Map.map Set.NonEmpty.toSet . domain
-- | Insert a pair into a left-unique relation, maintaining left-uniqueness, preferring the latest inserted element.
--
-- That is, if a left-unique relation already contains the pair @(x, y)@, then inserting the pair @(z, y)@ will cause

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

@ -86,6 +86,7 @@ module Unison.Codebase.Branch
-- ** Term/type queries
deepTerms,
deepTypes,
deepDefns,
deepEdits,
deepPaths,
deepReferents,
@ -112,6 +113,7 @@ import Unison.Codebase.Branch.Type
UnwrappedBranch,
branch0,
children,
deepDefns,
deepEdits,
deepPaths,
deepTerms,

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

@ -10,8 +10,8 @@ module Unison.Codebase.Branch.Type
Branch (..),
Branch0,
branch0,
terms,
types,
Unison.Codebase.Branch.Type.terms,
Unison.Codebase.Branch.Type.types,
children,
nonEmptyChildren,
history,
@ -19,6 +19,7 @@ module Unison.Codebase.Branch.Type
isEmpty0,
deepTerms,
deepTypes,
deepDefns,
deepPaths,
deepEdits,
Star,
@ -47,9 +48,11 @@ import Unison.NameSegment qualified as NameSegment
import Unison.Prelude hiding (empty)
import Unison.Reference (Reference, TypeReference)
import Unison.Referent (Referent)
import Unison.Util.Defns (Defns (..), DefnsF)
import Unison.Util.Monoid qualified as Monoid
import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as R
import Unison.Util.Relation qualified as Relation
import Unison.Util.Star2 qualified as Star2
import Prelude hiding (head, read, subtract)
@ -148,6 +151,13 @@ deepTerms = _deepTerms
deepTypes :: Branch0 m -> Relation TypeReference Name
deepTypes = _deepTypes
deepDefns :: Branch0 m -> DefnsF (Relation Name) Referent TypeReference
deepDefns branch =
Defns
{ terms = Relation.swap (deepTerms branch),
types = Relation.swap (deepTypes branch)
}
deepPaths :: Branch0 m -> Set Path
deepPaths = _deepPaths

23
parser-typechecker/src/Unison/PrettyPrintEnvDecl/Names.hs
View File

@ -1,8 +1,11 @@
module Unison.PrettyPrintEnvDecl.Names
( makePPED,
makeFilePPED,
makeCodebasePPED,
)
where
import Unison.Names (Names)
import Unison.PrettyPrintEnv.Names qualified as PPE
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (PrettyPrintEnvDecl))
@ -11,3 +14,23 @@ makePPED namer suffixifier =
PrettyPrintEnvDecl
(PPE.makePPE namer PPE.dontSuffixify)
(PPE.makePPE namer suffixifier)
-- | Make a PPED suitable for names in a Unison file.
--
-- Such names have special suffixification rules: aliases may *not* be referred to by a common suffix. For example, if
-- a file contains
--
-- one.foo = 6
-- two.foo = 6
--
-- then the suffix `foo` will *not* be accepted (currently). So, this PPE uses the "suffixify by name" strategy.
makeFilePPED :: Names -> PrettyPrintEnvDecl
makeFilePPED names =
makePPED (PPE.namer names) (PPE.suffixifyByName names)
-- | Make a PPED suitable for names in the codebase. These names are hash qualified and suffixified by hash.
makeCodebasePPED :: Names -> PrettyPrintEnvDecl
makeCodebasePPED names =
makePPED
(PPE.hqNamer 10 names)
(PPE.suffixifyByHash names)

29
parser-typechecker/src/Unison/UnisonFile.hs
View File

@ -36,6 +36,8 @@ module Unison.UnisonFile
typecheckedUnisonFile,
Unison.UnisonFile.rewrite,
prepareRewrite,
termNamespaceBindings,
typeNamespaceBindings,
)
where
@ -49,6 +51,7 @@ import Unison.ConstructorReference (GConstructorReference (..))
import Unison.ConstructorType qualified as CT
import Unison.DataDeclaration (DataDeclaration, EffectDeclaration (..))
import Unison.DataDeclaration qualified as DD
import Unison.DataDeclaration qualified as DataDeclaration
import Unison.Hash qualified as Hash
import Unison.Hashing.V2.Convert qualified as Hashing
import Unison.LabeledDependency (LabeledDependency)
@ -67,6 +70,7 @@ import Unison.Util.List qualified as List
import Unison.Var (Var)
import Unison.Var qualified as Var
import Unison.WatchKind (WatchKind, pattern TestWatch)
import Unison.WatchKind qualified as WatchKind
-- | An empty Unison file.
emptyUnisonFile :: UnisonFile v a
@ -390,3 +394,28 @@ constructorsForDecls types uf =
& fmap (DD.toDataDecl . snd)
& concatMap DD.constructorVars
in Set.fromList (dataConstructors <> effectConstructors)
-- | All bindings in the term namespace: terms, test watches (since those are the only watches that are actually stored
-- in the codebase), data constructors, and effect constructors.
termNamespaceBindings :: Ord v => TypecheckedUnisonFile v a -> Set v
termNamespaceBindings uf =
terms <> tests <> datacons <> effcons
where
terms = foldMap (Set.fromList . map (view _1)) uf.topLevelComponents'
tests =
uf.watchComponents & foldMap \case
(WatchKind.TestWatch, watches) -> Set.fromList (map (view _1) watches)
_ -> Set.empty
datacons = foldMap (Set.fromList . DataDeclaration.constructorVars . view _2) uf.dataDeclarationsId'
effcons =
foldMap
(Set.fromList . DataDeclaration.constructorVars . DataDeclaration.toDataDecl . view _2)
uf.effectDeclarationsId'
-- | All bindings in the term namespace: data declarations and effect declarations.
typeNamespaceBindings :: Ord v => TypecheckedUnisonFile v a -> Set v
typeNamespaceBindings uf =
datas <> effs
where
datas = Map.keysSet uf.dataDeclarationsId'
effs = Map.keysSet uf.effectDeclarationsId'

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

@ -79,6 +79,9 @@ module Unison.Cli.MonadUtils
expectLatestParsedFile,
getLatestTypecheckedFile,
expectLatestTypecheckedFile,
-- * Parsing env
makeParsingEnv,
)
where
@ -98,6 +101,7 @@ import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Q
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.UniqueTypeGuidLookup (loadUniqueTypeGuid)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch (..), Branch0)
import Unison.Codebase.Branch qualified as Branch
@ -122,9 +126,11 @@ import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
import Unison.Reference (TypeReference)
import Unison.Referent (Referent)
import Unison.Sqlite (Transaction)
import Unison.Sqlite qualified as Sqlite
import Unison.Symbol (Symbol)
import Unison.Syntax.Name qualified as Name (toText)
import Unison.Syntax.Parser (ParsingEnv (..))
import Unison.Term qualified as Term
import Unison.UnisonFile (TypecheckedUnisonFile, UnisonFile)
import Unison.UnisonFile qualified as UF
@ -554,3 +560,15 @@ getNamesFromLatestFile = do
expectLatestTypecheckedFile :: Cli (TypecheckedUnisonFile Symbol Ann)
expectLatestTypecheckedFile =
getLatestTypecheckedFile & onNothingM (Cli.returnEarly Output.NoUnisonFile)
-- @makeParsingEnv path names@ makes a parsing environment with @names@ in scope, which are all relative to @path@.
makeParsingEnv :: ProjectPath -> Names -> Cli (ParsingEnv Transaction)
makeParsingEnv path names = do
Cli.Env {generateUniqueName} <- ask
uniqueName <- liftIO generateUniqueName
pure do
ParsingEnv
{ uniqueNames = uniqueName,
uniqueTypeGuid = loadUniqueTypeGuid path,
names
}

363
unison-cli/src/Unison/Cli/UpdateUtils.hs Normal file
View File

@ -0,0 +1,363 @@
-- | This module contains functionality that is common to the general idea of "updating" a term in Unison, which is when
-- we reassign a name from one hash to another and then see if all dependents still typecheck.
--
-- This occurs in the `pull`, `merge`, `update`, and `upgrade` commands.
module Unison.Cli.UpdateUtils
( -- * Loading definitions
loadNamespaceDefinitions,
-- * Getting dependents in a namespace
getNamespaceDependentsOf,
getNamespaceDependentsOf2,
-- * Narrowing definitions
narrowDefns,
-- * Hydrating definitions
hydrateDefns,
-- * Rendering definitions
renderDefnsForUnisonFile,
-- * Parsing and typechecking
parseAndTypecheck,
)
where
import Control.Lens (mapped, _1)
import Control.Monad.Reader (ask)
import Control.Monad.Writer (Writer)
import Control.Monad.Writer qualified as Writer
import Data.Bifoldable (bifoldMap)
import Data.Bitraversable (bitraverse)
import Data.Foldable qualified as Foldable
import Data.List qualified as List
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.Map.Strict qualified as Map
import Data.Set qualified as Set
import Data.Set.NonEmpty (NESet)
import Data.Set.NonEmpty qualified as Set.NonEmpty
import U.Codebase.Branch qualified as V2
import U.Codebase.Causal qualified
import U.Codebase.Reference (TermReferenceId, TypeReferenceId)
import U.Codebase.Referent qualified as V2
import U.Codebase.Sqlite.Operations qualified as Operations
import Unison.Builtin.Decls qualified as Builtin.Decls
import Unison.Cli.Monad (Cli, Env (..))
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.TypeCheck (computeTypecheckingEnvironment)
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
import Unison.DataDeclaration (Decl)
import Unison.Debug qualified as Debug
import Unison.FileParsers qualified as FileParsers
import Unison.Hash (Hash)
import Unison.HashQualified qualified as HQ
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.Merge.DeclNameLookup (DeclNameLookup (..), expectConstructorNames)
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment
import Unison.Parser.Ann (Ann)
import Unison.Parsers qualified as Parsers
import Unison.Prelude
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
import Unison.Reference (Reference, TypeReference)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Result qualified as Result
import Unison.Sqlite (Transaction)
import Unison.Symbol (Symbol)
import Unison.Syntax.DeclPrinter (AccessorName)
import Unison.Syntax.DeclPrinter qualified as DeclPrinter
import Unison.Syntax.Parser qualified as Parser
import Unison.Syntax.TermPrinter qualified as TermPrinter
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.Typechecker qualified as Typechecker
import Unison.UnisonFile (TypecheckedUnisonFile)
import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Conflicted (Conflicted (..))
import Unison.Util.Defn (Defn (..))
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2)
import Unison.Util.Nametree (Nametree (..), traverseNametreeWithName, unflattenNametrees)
import Unison.Util.Pretty (ColorText, Pretty)
import Unison.Util.Pretty qualified as Pretty
import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as Relation
import Unison.Util.Set qualified as Set
import Unison.Var (Var)
import Prelude hiding (unzip, zip, zipWith)
import Unison.Names (Names)
import qualified Unison.Names as Names
------------------------------------------------------------------------------------------------------------------------
-- Loading definitions
-- Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined
-- in the "lib" namespace.
--
-- Fails if there is a conflicted name.
loadNamespaceDefinitions ::
forall m.
(Monad m) =>
(V2.Referent -> m Referent) ->
V2.Branch m ->
m
( Either
(Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
(Nametree (DefnsF (Map NameSegment) Referent TypeReference))
)
loadNamespaceDefinitions referent2to1 =
fmap assertNamespaceHasNoConflictedNames . go (Map.delete NameSegment.libSegment)
where
go ::
(forall x. Map NameSegment x -> Map NameSegment x) ->
V2.Branch m ->
m (Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference))
go f branch = do
terms <- for branch.terms (fmap (Set.NonEmpty.fromList . List.NonEmpty.fromList) . traverse referent2to1 . Map.keys)
let types = Map.map (Set.NonEmpty.unsafeFromSet . Map.keysSet) branch.types
children <-
for (f branch.children) \childCausal -> do
child <- childCausal.value
go id child
pure Nametree {value = Defns {terms, types}, children}
-- | Assert that there are no unconflicted names in a namespace.
assertNamespaceHasNoConflictedNames ::
Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference) ->
Either
(Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
(Nametree (DefnsF (Map NameSegment) Referent TypeReference))
assertNamespaceHasNoConflictedNames =
traverseNametreeWithName \segments defns -> do
let toName segment =
Name.fromReverseSegments (segment List.NonEmpty.:| segments)
terms <-
defns.terms & Map.traverseWithKey \segment ->
assertUnconflicted (TermDefn . Conflicted (toName segment))
types <-
defns.types & Map.traverseWithKey \segment ->
assertUnconflicted (TypeDefn . Conflicted (toName segment))
pure Defns {terms, types}
where
assertUnconflicted :: (NESet ref -> x) -> NESet ref -> Either x ref
assertUnconflicted conflicted refs
| Set.NonEmpty.size refs == 1 = Right (Set.NonEmpty.findMin refs)
| otherwise = Left (conflicted refs)
------------------------------------------------------------------------------------------------------------------------
-- Getting dependents in a namespace
-- | Given a namespace and a set of dependencies, return the subset of the namespace that consists of only the
-- (transitive) dependents of the dependencies.
getNamespaceDependentsOf ::
Names ->
Set Reference ->
Transaction (DefnsF (Relation Name) TermReferenceId TypeReferenceId)
getNamespaceDependentsOf names dependencies = do
dependents <- Operations.transitiveDependentsWithinScope (Names.referenceIds names) dependencies
pure (bimap (foldMap nameTerm) (foldMap nameType) dependents)
where
nameTerm :: TermReferenceId -> Relation Name TermReferenceId
nameTerm ref =
Relation.fromManyDom (Relation.lookupRan (Referent.fromTermReferenceId ref) (Names.terms names)) ref
nameType :: TypeReferenceId -> Relation Name TypeReferenceId
nameType ref =
Relation.fromManyDom (Relation.lookupRan (Reference.fromId ref) (Names.types names)) ref
-- | Given a namespace and a set of dependencies, return the subset of the namespace that consists of only the
-- (transitive) dependents of the dependencies.
getNamespaceDependentsOf2 ::
Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
Set Reference ->
Transaction (DefnsF (Map Name) TermReferenceId TypeReferenceId)
getNamespaceDependentsOf2 defns dependencies = do
let toTermScope = Set.mapMaybe Referent.toReferenceId . BiMultimap.dom
let toTypeScope = Set.mapMaybe Reference.toId . BiMultimap.dom
let scope = bifoldMap toTermScope toTypeScope defns
Operations.transitiveDependentsWithinScope scope dependencies
<&> bimap (Set.foldl' addTerms Map.empty) (Set.foldl' addTypes Map.empty)
where
addTerms :: Map Name TermReferenceId -> TermReferenceId -> Map Name TermReferenceId
addTerms acc0 ref =
let names = BiMultimap.lookupDom (Referent.fromTermReferenceId ref) defns.terms
in Set.foldl' (\acc name -> Map.insert name ref acc) acc0 names
addTypes :: Map Name TypeReferenceId -> TypeReferenceId -> Map Name TypeReferenceId
addTypes acc0 ref =
let names = BiMultimap.lookupDom (Reference.fromId ref) defns.types
in Set.foldl' (\acc name -> Map.insert name ref acc) acc0 names
------------------------------------------------------------------------------------------------------------------------
-- Narrowing definitions
-- | "Narrow" a namespace that may contain conflicted names, resulting in either a failure (if we find a conflicted
-- name), or the narrowed nametree without conflicted names.
narrowDefns ::
forall term typ.
(Ord term, Ord typ) =>
DefnsF (Relation Name) term typ ->
Either
( Defn
(Conflicted Name term)
(Conflicted Name typ)
)
(Nametree (DefnsF (Map NameSegment) term typ))
narrowDefns =
fmap unflattenNametrees
. bitraverse
(go (\name -> TermDefn . Conflicted name))
(go (\name -> TypeDefn . Conflicted name))
where
go :: forall ref x. (Ord ref) => (Name -> NESet ref -> x) -> Relation Name ref -> Either x (Map Name ref)
go conflicted =
Map.traverseWithKey unconflicted . Relation.domain
where
unconflicted :: Name -> Set ref -> Either x ref
unconflicted name refs0
| Set.NonEmpty.size refs == 1 = Right (Set.NonEmpty.findMin refs)
| otherwise = Left (conflicted name refs)
where
refs = Set.NonEmpty.unsafeFromSet refs0
------------------------------------------------------------------------------------------------------------------------
-- Hydrating definitions
-- | Hydrate term/type references to actual terms/types.
hydrateDefns ::
forall m name term typ.
(Monad m, Ord name) =>
(Hash -> m [term]) ->
(Hash -> m [typ]) ->
DefnsF (Map name) TermReferenceId TypeReferenceId ->
m (DefnsF (Map name) term (TypeReferenceId, typ))
hydrateDefns getTermComponent getTypeComponent = do
bitraverse hydrateTerms hydrateTypes
where
hydrateTerms :: Map name TermReferenceId -> m (Map name term)
hydrateTerms terms =
hydrateDefns_ getTermComponent terms \_ _ -> id
hydrateTypes :: Map name TypeReferenceId -> m (Map name (TypeReferenceId, typ))
hydrateTypes types =
hydrateDefns_ getTypeComponent types \_ -> (,)
hydrateDefns_ ::
forall a b name m.
(Monad m, Ord name) =>
(Hash -> m [a]) ->
Map name Reference.Id ->
(name -> Reference.Id -> a -> b) ->
m (Map name b)
hydrateDefns_ getComponent defns modify =
Foldable.foldlM f Map.empty (foldMap (Set.singleton . Reference.idToHash) defns)
where
f :: Map name b -> Hash -> m (Map name b)
f acc hash =
List.foldl' g acc . Reference.componentFor hash <$> getComponent hash
g :: Map name b -> (Reference.Id, a) -> Map name b
g acc (ref, thing) =
Set.foldl' (h ref thing) acc (BiMultimap.lookupDom ref defns2)
h :: Reference.Id -> a -> Map name b -> name -> Map name b
h ref thing acc name =
Map.insert name (modify name ref thing) acc
defns2 :: BiMultimap Reference.Id name
defns2 =
BiMultimap.fromRange defns
------------------------------------------------------------------------------------------------------------------------
-- Rendering definitions
-- | Render definitions destined for a Unison file.
--
-- This first renders the types (discovering which record accessors will be generated upon parsing), then renders the
-- terms (being careful not to render any record accessors, since those would cause duplicate binding errors upon
-- parsing).
renderDefnsForUnisonFile ::
forall a v.
(Var v, Monoid a) =>
DeclNameLookup ->
PrettyPrintEnvDecl ->
DefnsF (Map Name) (Term v a, Type v a) (TypeReferenceId, Decl v a) ->
DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)
renderDefnsForUnisonFile declNameLookup ppe defns =
let (types, accessorNames) = Writer.runWriter (Map.traverseWithKey renderType defns.types)
in Defns
{ terms = Map.mapMaybeWithKey (renderTerm accessorNames) defns.terms,
types
}
where
renderType :: Name -> (TypeReferenceId, Decl v a) -> Writer (Set AccessorName) (Pretty ColorText)
renderType name (ref, typ) =
fmap Pretty.syntaxToColor $
DeclPrinter.prettyDeclW
-- Sort of a hack; since the decl printer looks in the PPE for names of constructors,
-- we just delete all term names out and add back the constructors...
-- probably no need to wipe out the suffixified side but we do it anyway
(setPpedToConstructorNames declNameLookup name ref ppe)
(Reference.fromId ref)
(HQ.NameOnly name)
typ
renderTerm :: Set Name -> Name -> (Term v a, Type v a) -> Maybe (Pretty ColorText)
renderTerm accessorNames name (term, typ) = do
guard (not (Set.member name accessorNames))
let hqName = HQ.NameOnly name
let rendered
| Typechecker.isEqual (Builtin.Decls.testResultListType mempty) typ =
"test> " <> TermPrinter.prettyBindingWithoutTypeSignature ppe.suffixifiedPPE hqName term
| otherwise = TermPrinter.prettyBinding ppe.suffixifiedPPE hqName term
Just (Pretty.syntaxToColor rendered)
setPpedToConstructorNames :: DeclNameLookup -> Name -> TypeReferenceId -> PrettyPrintEnvDecl -> PrettyPrintEnvDecl
setPpedToConstructorNames declNameLookup name ref =
set (#unsuffixifiedPPE . #termNames) referentNames
. set (#suffixifiedPPE . #termNames) referentNames
where
constructorNameMap :: Map ConstructorReference Name
constructorNameMap =
Map.fromList
( name
& expectConstructorNames declNameLookup
& List.zip [0 ..]
& over (mapped . _1) (ConstructorReference (Reference.fromId ref))
)
referentNames :: Referent -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)]
referentNames = \case
Referent.Con conRef _ ->
case Map.lookup conRef constructorNameMap of
Nothing -> []
Just conName -> let hqConName = HQ'.NameOnly conName in [(hqConName, hqConName)]
Referent.Ref _ -> []
------------------------------------------------------------------------------------------------------------------------
-- Parsing and typechecking
-- TODO: find a better module for this function, as it's used in a couple places
parseAndTypecheck ::
Pretty Pretty.ColorText ->
Parser.ParsingEnv Transaction ->
Cli (Maybe (TypecheckedUnisonFile Symbol Ann))
parseAndTypecheck prettyUf parsingEnv = do
env <- ask
let stringUf = Pretty.toPlain 80 prettyUf
Debug.whenDebug Debug.Update do
liftIO do
putStrLn "--- Scratch ---"
putStrLn stringUf
Cli.runTransaction do
Parsers.parseFile "<update>" stringUf parsingEnv >>= \case
Left _ -> pure Nothing
Right uf -> do
typecheckingEnv <-
computeTypecheckingEnvironment (FileParsers.ShouldUseTndr'Yes parsingEnv) env.codebase [] uf
pure (Result.result (FileParsers.synthesizeFile typecheckingEnv uf))

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

@ -15,21 +15,14 @@ module Unison.Codebase.Editor.HandleInput.Merge2
)
where
import Control.Lens (mapped, _1)
import Control.Monad.Reader (ask)
import Control.Monad.Writer (Writer)
import Control.Monad.Writer qualified as Writer
import Data.Bifoldable (bifoldMap)
import Data.Bitraversable (bitraverse)
import Data.Foldable qualified as Foldable
import Data.List qualified as List
import Data.List.NonEmpty (pattern (:|))
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.Map.Strict qualified as Map
import Data.Semialign (align, unzip)
import Data.Semialign (align, unzip, zipWith)
import Data.Set qualified as Set
import Data.Set.NonEmpty (NESet)
import Data.Set.NonEmpty qualified as Set.NonEmpty
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import Data.These (These (..))
@ -41,30 +34,30 @@ import U.Codebase.Branch qualified as V2.Branch
import U.Codebase.Causal qualified as V2.Causal
import U.Codebase.HashTags (CausalHash, unCausalHash)
import U.Codebase.Reference (Reference, TermReferenceId, TypeReference, TypeReferenceId)
import U.Codebase.Referent qualified as V2 (Referent)
import U.Codebase.Sqlite.DbId (ProjectId)
import U.Codebase.Sqlite.Operations qualified as Operations
import U.Codebase.Sqlite.Project (Project (..))
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Builtin.Decls qualified as Builtin.Decls
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceAndTarget (..), MergeSourceOrTarget (..))
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Cli.UpdateUtils
( getNamespaceDependentsOf2,
hydrateDefns,
loadNamespaceDefinitions,
parseAndTypecheck,
renderDefnsForUnisonFile,
)
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch0)
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.Names qualified as Branch
import Unison.Codebase.BranchUtil qualified as BranchUtil
import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch
import Unison.Codebase.Editor.HandleInput.Update2
( getNamespaceDependentsOf2,
makeParsingEnv,
prettyParseTypecheck2,
typecheckedUnisonFileToBranchAdds,
)
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode (..))
import Unison.Codebase.Path (Path)
@ -74,16 +67,13 @@ import Unison.Codebase.ProjectPath qualified as PP
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions
import Unison.Codebase.SqliteCodebase.Operations qualified as Operations
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
import Unison.DataDeclaration (Decl)
import Unison.DataDeclaration qualified as DataDeclaration
import Unison.Debug qualified as Debug
import Unison.Hash (Hash)
import Unison.Hash qualified as Hash
import Unison.HashQualified qualified as HQ
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.Merge.CombineDiffs (CombinedDiffOp (..), combineDiffs)
import Unison.Merge.Database (MergeDatabase (..), makeMergeDatabase, referent2to1)
import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason (..), checkDeclCoherency, lenientCheckDeclCoherency)
import Unison.Merge.DeclCoherencyCheck (checkDeclCoherency, lenientCheckDeclCoherency)
import Unison.Merge.DeclNameLookup (DeclNameLookup (..), expectConstructorNames)
import Unison.Merge.Diff qualified as Merge
import Unison.Merge.DiffOp (DiffOp (..))
@ -105,44 +95,46 @@ import Unison.Merge.Unconflicts (Unconflicts (..))
import Unison.Merge.Unconflicts qualified as Unconflicts
import Unison.Merge.Updated (Updated (..))
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment qualified as NameSegment
import Unison.NameSegment.Internal (NameSegment (NameSegment))
import Unison.NameSegment.Internal qualified as NameSegment
import Unison.Names (Names)
import Unison.Names qualified as Names
import Unison.Parser.Ann (Ann)
import Unison.Prelude
import Unison.PrettyPrintEnv (PrettyPrintEnv (..))
import Unison.PrettyPrintEnv.Names qualified as PPE
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectBranchNameKind (..), ProjectName, Semver (..), classifyProjectBranchName)
import Unison.Project
( ProjectAndBranch (..),
ProjectBranchName,
ProjectBranchNameKind (..),
ProjectName,
Semver (..),
classifyProjectBranchName,
)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.ReferentPrime qualified as Referent'
import Unison.Sqlite (Transaction)
import Unison.Sqlite qualified as Sqlite
import Unison.Syntax.DeclPrinter (AccessorName)
import Unison.Syntax.DeclPrinter qualified as DeclPrinter
import Unison.Symbol (Symbol)
import Unison.Syntax.Name qualified as Name
import Unison.Syntax.TermPrinter qualified as TermPrinter
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.Typechecker qualified as Typechecker
import Unison.UnisonFile (TypecheckedUnisonFile)
import Unison.UnisonFile qualified as UnisonFile
import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF, DefnsF2, DefnsF3, alignDefnsWith, defnsAreEmpty, zipDefnsWith, zipDefnsWith3)
import Unison.Util.Monoid qualified as Monoid
import Unison.Util.Nametree (Nametree (..), flattenNametree, traverseNametreeWithName, unflattenNametree)
import Unison.Util.Nametree (Nametree (..), flattenNametrees, unflattenNametree)
import Unison.Util.Pretty (ColorText, Pretty)
import Unison.Util.Pretty qualified as Pretty
import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as Relation
import Unison.Util.Star2 (Star2)
import Unison.Util.Star2 qualified as Star2
import Unison.Util.SyntaxText (SyntaxText')
import Unison.Var (Var)
import Unison.WatchKind qualified as WatchKind
import Witch (unsafeFrom)
import Prelude hiding (unzip, zip, zipWith)
@ -251,23 +243,15 @@ doMerge info = do
(defns3, declNameLookups, lcaDeclNameLookup) <- do
let emptyNametree = Nametree {value = Defns Map.empty Map.empty, children = Map.empty}
let loadDefns branch =
Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName ->
done case conflictedName of
ConflictedName'Term name refs -> Output.MergeConflictedTermName name refs
ConflictedName'Type name refs -> Output.MergeConflictedTypeName name refs
Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch)
& onLeftM (done . Output.ConflictedDefn "merge")
let load = \case
Nothing -> pure (emptyNametree, DeclNameLookup Map.empty Map.empty)
Just (who, branch) -> do
defns <- loadDefns branch
declNameLookup <-
Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err ->
done case err of
IncoherentDeclReason'ConstructorAlias typeName conName1 conName2 ->
Output.MergeConstructorAlias who typeName conName1 conName2
IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName who name
IncoherentDeclReason'NestedDeclAlias shorterName longerName ->
Output.MergeNestedDeclAlias who shorterName longerName
IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor who name
Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns)
& onLeftM (done . Output.IncoherentDeclDuringMerge who)
pure (defns, declNameLookup)
(aliceDefns0, aliceDeclNameLookup) <- load (Just (mergeTarget, branches.alice))
@ -275,8 +259,7 @@ doMerge info = do
lcaDefns0 <- maybe (pure emptyNametree) loadDefns branches.lca
lcaDeclNameLookup <- Cli.runTransaction (lenientCheckDeclCoherency db.loadDeclNumConstructors lcaDefns0)
let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns)
let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0}
let defns3 = flattenNametrees <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0}
let declNameLookups = TwoWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup}
pure (defns3, declNameLookups, lcaDeclNameLookup)
@ -345,32 +328,14 @@ doMerge info = do
in (,) <$> hydrate conflicts1 <*> hydrate dependents1
let (renderedConflicts, renderedDependents) =
let honk declNameLookup ppe defns =
let (types, accessorNames) =
Writer.runWriter $
defns.types & Map.traverseWithKey \name (ref, typ) ->
renderTypeBinding
-- Sort of a hack; since the decl printer looks in the PPE for names of constructors,
-- we just delete all term names out and add back the constructors...
-- probably no need to wipe out the suffixified side but we do it anyway
(setPpedToConstructorNames declNameLookup name ref ppe)
name
ref
typ
terms =
defns.terms & Map.mapMaybeWithKey \name (term, typ) ->
if Set.member name accessorNames
then Nothing
else Just (renderTermBinding ppe.suffixifiedPPE name term typ)
in Defns {terms, types}
in unzip $
( \declNameLookup (conflicts, dependents) ppe ->
let honk1 = honk declNameLookup ppe
in (honk1 conflicts, honk1 dependents)
)
<$> declNameLookups
<*> hydratedThings
<*> ppes
unzip $
( \declNameLookup (conflicts, dependents) ppe ->
let honk1 = renderDefnsForUnisonFile declNameLookup ppe
in (honk1 conflicts, honk1 dependents)
)
<$> declNameLookups
<*> hydratedThings
<*> ppes
let prettyUnisonFile =
makePrettyUnisonFile
@ -400,8 +365,8 @@ doMerge info = do
then pure Nothing
else do
currentPath <- Cli.getCurrentProjectPath
parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch)
prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe
parsingEnv <- Cli.makeParsingEnv currentPath (Branch.toNames stageOneBranch)
parseAndTypecheck prettyUnisonFile parsingEnv
let parents =
(\causal -> (causal.causalHash, Codebase.expectBranchForHash codebase causal.causalHash)) <$> causals
@ -500,95 +465,6 @@ hasDefnsInLib branch = do
------------------------------------------------------------------------------------------------------------------------
-- Creating Unison files
hydrateDefns ::
(Monad m, Ord name) =>
(Hash -> m [term]) ->
(Hash -> m [typ]) ->
DefnsF (Map name) TermReferenceId TypeReferenceId ->
m (DefnsF (Map name) term (TypeReferenceId, typ))
hydrateDefns getTermComponent getTypeComponent = do
bitraverse (hydrateTerms getTermComponent) (hydrateTypes getTypeComponent)
hydrateTerms :: (Monad m, Ord name) => (Hash -> m [term]) -> Map name TermReferenceId -> m (Map name term)
hydrateTerms getTermComponent terms =
componenty getTermComponent terms \_ _ -> id
hydrateTypes ::
(Monad m, Ord name) =>
(Hash -> m [typ]) ->
Map name TypeReferenceId ->
m (Map name (TypeReferenceId, typ))
hydrateTypes getTypeComponent types =
componenty getTypeComponent types \_ -> (,)
componenty ::
forall a b name m.
(Monad m, Ord name) =>
(Hash -> m [a]) ->
Map name Reference.Id ->
(name -> Reference.Id -> a -> b) ->
m (Map name b)
componenty getComponent things modify =
Foldable.foldlM f Map.empty (foldMap (Set.singleton . Reference.idToHash) things)
where
f :: Map name b -> Hash -> m (Map name b)
f acc hash =
List.foldl' g acc . Reference.componentFor hash <$> getComponent hash
g :: Map name b -> (Reference.Id, a) -> Map name b
g acc (ref, thing) =
Set.foldl' (h ref thing) acc (BiMultimap.lookupDom ref things2)
h :: Reference.Id -> a -> Map name b -> name -> Map name b
h ref thing acc name =
Map.insert name (modify name ref thing) acc
things2 :: BiMultimap Reference.Id name
things2 =
BiMultimap.fromRange things
renderTermBinding :: (Monoid a, Var v) => PrettyPrintEnv -> Name -> Term v a -> Type v a -> Pretty ColorText
renderTermBinding ppe (HQ.NameOnly -> name) term typ =
Pretty.syntaxToColor rendered
where
rendered :: Pretty (SyntaxText' Reference)
rendered =
if Typechecker.isEqual (Builtin.Decls.testResultListType mempty) typ
then "test> " <> TermPrinter.prettyBindingWithoutTypeSignature ppe name term
else TermPrinter.prettyBinding ppe name term
renderTypeBinding ::
(Var v) =>
PrettyPrintEnvDecl ->
Name ->
TypeReferenceId ->
Decl v a ->
Writer (Set AccessorName) (Pretty ColorText)
renderTypeBinding ppe name ref decl =
Pretty.syntaxToColor <$> DeclPrinter.prettyDeclW ppe (Reference.fromId ref) (HQ.NameOnly name) decl
setPpedToConstructorNames :: DeclNameLookup -> Name -> TypeReferenceId -> PrettyPrintEnvDecl -> PrettyPrintEnvDecl
setPpedToConstructorNames declNameLookup name ref =
set (#unsuffixifiedPPE . #termNames) referentNames
. set (#suffixifiedPPE . #termNames) referentNames
where
constructorNameMap :: Map ConstructorReference Name
constructorNameMap =
Map.fromList
( name
& expectConstructorNames declNameLookup
& List.zip [0 ..]
& over (mapped . _1) (ConstructorReference (Reference.fromId ref))
)
referentNames :: Referent -> [(HQ'.HashQualified Name, HQ'.HashQualified Name)]
referentNames = \case
Referent.Con conRef _ ->
case Map.lookup conRef constructorNameMap of
Nothing -> []
Just conName -> let hqConName = HQ'.NameOnly conName in [(hqConName, hqConName)]
Referent.Ref _ -> []
makePrettyUnisonFile ::
TwoWay Text ->
TwoWay (DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText)) ->
@ -696,7 +572,7 @@ defnsAndLibdepsToBranch0 codebase defns libdeps =
let -- Unflatten the collection of terms into tree, ditto for types
nametrees :: DefnsF2 Nametree (Map NameSegment) Referent TypeReference
nametrees =
bimap go go defns
bimap unflattenNametree unflattenNametree defns
-- Align the tree of terms and tree of types into one tree
nametree :: Nametree (DefnsF (Map NameSegment) Referent TypeReference)
@ -715,10 +591,6 @@ defnsAndLibdepsToBranch0 codebase defns libdeps =
-- Awkward: we have a Branch Transaction but we need a Branch IO (because reasons)
branch2 = Branch.transform0 (Codebase.runTransaction codebase) branch1
in branch2
where
go :: (Ord v) => Map Name v -> Nametree (Map NameSegment v)
go =
unflattenNametree . BiMultimap.fromRange
nametreeToBranch0 :: Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> Branch0 m
nametreeToBranch0 nametree =
@ -894,55 +766,6 @@ findTemporaryBranchName projectId mergeSourceAndTarget = do
<> Text.Builder.char '.'
<> Text.Builder.decimal z
-- Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined
-- in the "lib" namespace.
--
-- Fails if there is a conflicted name.
loadNamespaceDefinitions ::
forall m.
(Monad m) =>
(V2.Referent -> m Referent) ->
V2.Branch m ->
m (Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference)))
loadNamespaceDefinitions referent2to1 =
fmap assertNamespaceHasNoConflictedNames . go (Map.delete NameSegment.libSegment)
where
go ::
(forall x. Map NameSegment x -> Map NameSegment x) ->
V2.Branch m ->
m (Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference))
go f branch = do
terms <- for branch.terms (fmap (Set.NonEmpty.fromList . List.NonEmpty.fromList) . traverse referent2to1 . Map.keys)
let types = Map.map (Set.NonEmpty.unsafeFromSet . Map.keysSet) branch.types
children <-
for (f branch.children) \childCausal -> do
child <- childCausal.value
go id child
pure Nametree {value = Defns {terms, types}, children}
data ConflictedName
= ConflictedName'Term !Name !(NESet Referent)
| ConflictedName'Type !Name !(NESet TypeReference)
-- | Assert that there are no unconflicted names in a namespace.
assertNamespaceHasNoConflictedNames ::
Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference) ->
Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference))
assertNamespaceHasNoConflictedNames =
traverseNametreeWithName \names defns -> do
terms <-
defns.terms & Map.traverseWithKey \name ->
assertUnconflicted (ConflictedName'Term (Name.fromReverseSegments (name :| names)))
types <-
defns.types & Map.traverseWithKey \name ->
assertUnconflicted (ConflictedName'Type (Name.fromReverseSegments (name :| names)))
pure Defns {terms, types}
where
assertUnconflicted :: (NESet ref -> ConflictedName) -> NESet ref -> Either ConflictedName ref
assertUnconflicted conflicted refs
| Set.NonEmpty.size refs == 1 = Right (Set.NonEmpty.findMin refs)
| otherwise = Left (conflicted refs)
-- @findConflictedAlias namespace diff@, given an old namespace and a diff to a new namespace, will return the first
-- "conflicted alias" encountered (if any), where a "conflicted alias" is a pair of names that referred to the same
-- thing in the old namespace, but different things in the new one.
@ -1043,6 +866,40 @@ libdepsToBranch0 db libdeps = do
branchCache <- Sqlite.unsafeIO newBranchCache
Conversions.branch2to1 branchCache db.loadDeclType branch
typecheckedUnisonFileToBranchAdds :: TypecheckedUnisonFile Symbol Ann -> [(Path, Branch0 m -> Branch0 m)]
typecheckedUnisonFileToBranchAdds tuf = do
declAdds ++ termAdds
where
declAdds :: [(Path, Branch0 m -> Branch0 m)]
declAdds = do
foldMap makeDataDeclAdds (Map.toList (UnisonFile.dataDeclarationsId' tuf))
++ foldMap makeEffectDeclUpdates (Map.toList (UnisonFile.effectDeclarationsId' tuf))
where
makeDataDeclAdds (symbol, (typeRefId, dataDecl)) = makeDeclAdds (symbol, (typeRefId, Right dataDecl))
makeEffectDeclUpdates (symbol, (typeRefId, effectDecl)) = makeDeclAdds (symbol, (typeRefId, Left effectDecl))
makeDeclAdds :: (Symbol, (TypeReferenceId, Decl Symbol Ann)) -> [(Path, Branch0 m -> Branch0 m)]
makeDeclAdds (symbol, (typeRefId, decl)) =
let insertTypeAction = BranchUtil.makeAddTypeName (splitVar symbol) (Reference.fromId typeRefId)
insertTypeConstructorActions =
zipWith
(\sym rid -> BranchUtil.makeAddTermName (splitVar sym) (Reference.fromId <$> rid))
(DataDeclaration.constructorVars (DataDeclaration.asDataDecl decl))
(DataDeclaration.declConstructorReferents typeRefId decl)
in insertTypeAction : insertTypeConstructorActions
termAdds :: [(Path, Branch0 m -> Branch0 m)]
termAdds =
tuf
& UnisonFile.hashTermsId
& Map.toList
& mapMaybe \(var, (_, ref, wk, _, _)) -> do
guard (WatchKind.watchKindShouldBeStoredInDatabase wk)
Just (BranchUtil.makeAddTermName (splitVar var) (Referent.fromTermReferenceId ref))
splitVar :: Symbol -> Path.Split
splitVar = Path.splitFromName . Name.unsafeParseVar
------------------------------------------------------------------------------------------------------------------------
-- Debugging by printing a bunch of stuff out

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

@ -3,44 +3,29 @@ module Unison.Codebase.Editor.HandleInput.Update2
( handleUpdate2,
-- * Misc helpers to be organized later
addDefinitionsToUnisonFile,
makeUnisonFile,
findCtorNames,
findCtorNamesMaybe,
forwardCtorNames,
makeParsingEnv,
prettyParseTypecheck,
prettyParseTypecheck2,
typecheckedUnisonFileToBranchUpdates,
typecheckedUnisonFileToBranchAdds,
getNamespaceDependentsOf,
getNamespaceDependentsOf2,
makeComplicatedPPE,
)
where
import Control.Lens qualified as Lens
import Control.Monad.RWS (ask)
import Data.Bifoldable (bifoldMap)
import Data.Foldable qualified as Foldable
import Data.List.NonEmpty qualified as NonEmpty
import Data.List.NonEmpty.Extra ((|>))
import Data.List qualified as List
import Data.Map qualified as Map
import Data.Maybe (fromJust)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.Lazy qualified as Lazy.Text
import Text.Pretty.Simple (pShow)
import U.Codebase.Reference (Reference, TermReferenceId)
import U.Codebase.Reference qualified as Reference
import U.Codebase.Sqlite.Operations qualified as Ops
import Unison.Builtin.Decls qualified as Decls
import Unison.Cli.Monad (Cli)
import U.Codebase.Sqlite.Operations qualified as Operations
import Unison.Cli.Monad (Cli, Env (..))
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.Pretty qualified as Pretty
import Unison.Cli.TypeCheck (computeTypecheckingEnvironment)
import Unison.Cli.UniqueTypeGuidLookup qualified as Cli
import Unison.Cli.UpdateUtils
( getNamespaceDependentsOf2,
hydrateDefns,
narrowDefns,
parseAndTypecheck,
renderDefnsForUnisonFile,
)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch (Branch0)
import Unison.Codebase.Branch qualified as Branch
@ -50,26 +35,15 @@ import Unison.Codebase.Editor.Output (Output)
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path (Path)
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath (ProjectPath)
import Unison.Codebase.Type (Codebase)
import Unison.ConstructorReference (GConstructorReference (ConstructorReference))
import Unison.DataDeclaration (DataDeclaration, Decl)
import Unison.Codebase.SqliteCodebase.Operations qualified as Operations
import Unison.DataDeclaration (Decl)
import Unison.DataDeclaration qualified as Decl
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Debug qualified as Debug
import Unison.FileParsers qualified as FileParsers
import Unison.Hash (Hash)
import Unison.Merge.DeclCoherencyCheck (checkDeclCoherency)
import Unison.Merge.DeclNameLookup (DeclNameLookup (..))
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.Name.Forward (ForwardName (..))
import Unison.Name.Forward qualified as ForwardName
import Unison.NameSegment qualified as NameSegment
import Unison.NameSegment.Internal (NameSegment (NameSegment))
import Unison.Names (Names (Names))
import Unison.Names (Names)
import Unison.Names qualified as Names
import Unison.Parser.Ann (Ann)
import Unison.Parser.Ann qualified as Ann
import Unison.Parsers qualified as Parsers
import Unison.Prelude
import Unison.PrettyPrintEnv.Names qualified as PPE
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl)
@ -77,137 +51,126 @@ import Unison.PrettyPrintEnvDecl qualified as PPED
import Unison.PrettyPrintEnvDecl.Names qualified as PPED
import Unison.Reference (TypeReference, TypeReferenceId)
import Unison.Reference qualified as Reference (fromId)
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Result qualified as Result
import Unison.Sqlite (Transaction)
import Unison.Symbol (Symbol)
import Unison.Syntax.Name qualified as Name
import Unison.Syntax.Parser qualified as Parser
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.Typechecker qualified as Typechecker
import Unison.UnisonFile (UnisonFile)
import Unison.UnisonFile qualified as UF
import Unison.UnisonFile.Names qualified as UF
import Unison.UnisonFile.Type (TypecheckedUnisonFile)
import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF)
import Unison.Util.Defns (Defns (..), DefnsF, defnsAreEmpty)
import Unison.Util.Monoid qualified as Monoid
import Unison.Util.Pretty (Pretty)
import Unison.Util.Nametree (flattenNametrees)
import Unison.Util.Pretty (ColorText, Pretty)
import Unison.Util.Pretty qualified as Pretty
import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as Relation
import Unison.Util.Set qualified as Set
import Unison.Var (Var)
import Unison.WatchKind qualified as WK
handleUpdate2 :: Cli ()
handleUpdate2 = do
Cli.Env {codebase, writeSource} <- ask
env <- ask
tuf <- Cli.expectLatestTypecheckedFile
let termAndDeclNames = getTermAndDeclNames tuf
pp <- Cli.getCurrentProjectPath
currentBranch0 <- Cli.getCurrentBranch0
let currentBranch0ExcludingLibdeps = Branch.deleteLibdeps currentBranch0
let namesIncludingLibdeps = Branch.toNames currentBranch0
let namesExcludingLibdeps = Branch.toNames (currentBranch0 & over Branch.children (Map.delete NameSegment.libSegment))
let ctorNames = forwardCtorNames namesExcludingLibdeps
-- Assert that the namespace doesn't have any conflicted names
defns <-
narrowDefns (Branch.deepDefns currentBranch0ExcludingLibdeps)
& onLeft (Cli.returnEarly . Output.ConflictedDefn "update")
-- Assert that the namespace doesn't have any incoherent decls
declNameLookup <-
Cli.runTransaction (checkDeclCoherency Operations.expectDeclNumConstructors defns)
& onLeftM (Cli.returnEarly . Output.IncoherentDeclDuringUpdate)
Cli.respond Output.UpdateLookingForDependents
(pped, bigUf) <- Cli.runTransactionWithRollback \abort -> do
dependents <-
getNamespaceDependentsOf namesExcludingLibdeps (getExistingReferencesNamed termAndDeclNames namesExcludingLibdeps)
hashLen <- Codebase.hashLength
bigUf <-
addDefinitionsToUnisonFile
abort
codebase
(findCtorNames Output.UOUUpdate namesExcludingLibdeps ctorNames)
dependents
(UF.discardTypes tuf)
pure (makeComplicatedPPE hashLen namesIncludingLibdeps (UF.typecheckedToNames tuf) dependents, bigUf)
-- If the new-unison-file-to-typecheck is the same as old-unison-file-that-we-already-typechecked, then don't bother
-- typechecking again.
(dependents, hydratedDependents) <-
Cli.runTransaction do
-- Get all dependents of things being updated
dependents0 <-
getNamespaceDependentsOf2
(flattenNametrees defns)
(getExistingReferencesNamed termAndDeclNames (Branch.toNames currentBranch0ExcludingLibdeps))
-- Throw away the dependents that are shadowed by the file itself
let dependents1 :: DefnsF (Map Name) TermReferenceId TypeReferenceId
dependents1 =
bimap
(`Map.withoutKeys` (Set.map Name.unsafeParseVar (UF.termNamespaceBindings tuf)))
(`Map.withoutKeys` (Set.map Name.unsafeParseVar (UF.typeNamespaceBindings tuf)))
dependents0
-- Hydrate the dependents for rendering
hydratedDependents <-
hydrateDefns
(Codebase.unsafeGetTermComponent env.codebase)
Operations.expectDeclComponent
dependents1
pure (dependents1, hydratedDependents)
secondTuf <- do
let smallUf = UF.discardTypes tuf
let noChanges =
and
[ Map.size (UF.dataDeclarationsId smallUf) == Map.size (UF.dataDeclarationsId bigUf),
Map.size (UF.effectDeclarationsId smallUf) == Map.size (UF.effectDeclarationsId bigUf),
Map.size (UF.terms smallUf) == Map.size (UF.terms bigUf),
Map.size (UF.watches smallUf) == Map.size (UF.watches bigUf)
]
if noChanges
then pure tuf
else do
case defnsAreEmpty dependents of
-- If there are no dependents of the updates, then just use the already-typechecked file.
True -> pure tuf
False -> do
Cli.respond Output.UpdateStartTypechecking
parsingEnv <- makeParsingEnv pp namesIncludingLibdeps
let prettyUnisonFile =
let ppe = makePPE 10 namesIncludingLibdeps (UF.typecheckedToNames tuf) dependents
in makePrettyUnisonFile
(Pretty.prettyUnisonFile ppe (UF.discardTypes tuf))
(renderDefnsForUnisonFile declNameLookup ppe hydratedDependents)
parsingEnv <- Cli.makeParsingEnv pp namesIncludingLibdeps
secondTuf <-
prettyParseTypecheck bigUf pped parsingEnv & onLeftM \prettyUf -> do
parseAndTypecheck prettyUnisonFile parsingEnv & onNothingM do
scratchFilePath <- fst <$> Cli.expectLatestFile
liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUf)
liftIO $ env.writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile)
Cli.returnEarly Output.UpdateTypecheckingFailure
Cli.respond Output.UpdateTypecheckingSuccess
pure secondTuf
saveTuf (findCtorNamesMaybe Output.UOUUpdate namesExcludingLibdeps ctorNames Nothing) secondTuf
Cli.respond Output.Success
-- TODO: find a better module for this function, as it's used in a couple places
prettyParseTypecheck ::
UnisonFile Symbol Ann ->
PrettyPrintEnvDecl ->
Parser.ParsingEnv Transaction ->
Cli (Either (Pretty Pretty.ColorText) (TypecheckedUnisonFile Symbol Ann))
prettyParseTypecheck bigUf pped =
prettyParseTypecheck2 (Pretty.prettyUnisonFile pped bigUf)
-- TODO: find a better module for this function, as it's used in a couple places
prettyParseTypecheck2 ::
Pretty Pretty.ColorText ->
Parser.ParsingEnv Transaction ->
Cli (Either (Pretty Pretty.ColorText) (TypecheckedUnisonFile Symbol Ann))
prettyParseTypecheck2 prettyUf parsingEnv = do
Cli.Env {codebase} <- ask
let stringUf = Pretty.toPlain 80 prettyUf
Debug.whenDebug Debug.Update do
liftIO do
putStrLn "--- Scratch ---"
putStrLn stringUf
Cli.runTransaction do
Parsers.parseFile "<update>" stringUf parsingEnv >>= \case
Left {} -> pure $ Left prettyUf
Right reparsedUf -> do
typecheckingEnv <-
computeTypecheckingEnvironment (FileParsers.ShouldUseTndr'Yes parsingEnv) codebase [] reparsedUf
pure case FileParsers.synthesizeFile typecheckingEnv reparsedUf of
Result.Result _notes (Just reparsedTuf) -> Right reparsedTuf
Result.Result _notes Nothing -> Left prettyUf
-- @makeParsingEnv path names@ makes a parsing environment with @names@ in scope, which are all relative to @path@.
makeParsingEnv :: ProjectPath -> Names -> Cli (Parser.ParsingEnv Transaction)
makeParsingEnv path names = do
Cli.Env {generateUniqueName} <- ask
uniqueName <- liftIO generateUniqueName
pure do
Parser.ParsingEnv
{ uniqueNames = uniqueName,
uniqueTypeGuid = Cli.loadUniqueTypeGuid path,
names
}
-- save definitions and namespace
saveTuf :: (Name -> Either Output (Maybe [Name])) -> TypecheckedUnisonFile Symbol Ann -> Cli ()
saveTuf getConstructors tuf = do
Cli.Env {codebase} <- ask
pp <- Cli.getCurrentProjectPath
path <- Cli.getCurrentProjectPath
branchUpdates <-
Cli.runTransactionWithRollback \abort -> do
Codebase.addDefsToCodebase codebase tuf
typecheckedUnisonFileToBranchUpdates abort getConstructors tuf
Cli.stepAt "update" (pp, Branch.batchUpdates branchUpdates)
Codebase.addDefsToCodebase env.codebase secondTuf
typecheckedUnisonFileToBranchUpdates
abort
(\typeName -> Right (Map.lookup typeName declNameLookup.declToConstructors))
secondTuf
Cli.stepAt "update" (path, Branch.batchUpdates branchUpdates)
Cli.respond Output.Success
makePrettyUnisonFile :: Pretty ColorText -> DefnsF (Map Name) (Pretty ColorText) (Pretty ColorText) -> Pretty ColorText
makePrettyUnisonFile originalFile dependents =
originalFile
<> Pretty.newline
<> Pretty.newline
<> "-- The definitions below no longer typecheck with the changes above."
<> Pretty.newline
<> "-- Please fix the errors and try `update` again."
<> Pretty.newline
<> Pretty.newline
<> ( dependents
& inAlphabeticalOrder
& let f = foldMap (\defn -> defn <> Pretty.newline <> Pretty.newline) in bifoldMap f f
)
where
inAlphabeticalOrder :: DefnsF (Map Name) a b -> DefnsF [] a b
inAlphabeticalOrder =
bimap f f
where
f = map snd . List.sortOn (Name.toText . fst) . Map.toList
-- @typecheckedUnisonFileToBranchUpdates getConstructors file@ returns a list of branch updates (suitable for passing
-- along to `batchUpdates` or some "step at" combinator) that corresponds to using all of the contents of @file@.
@ -246,7 +209,10 @@ typecheckedUnisonFileToBranchUpdates abort getConstructors tuf = do
-- some decls will be deleted, we want to delete their
-- constructors as well
deleteConstructorActions <-
(maybe [] (map (BranchUtil.makeAnnihilateTermName . Path.splitFromName)) <$> getConstructors (Name.unsafeParseVar symbol)) & onLeft abort
( maybe [] (map (BranchUtil.makeAnnihilateTermName . Path.splitFromName))
<$> getConstructors (Name.unsafeParseVar symbol)
)
& onLeft abort
let deleteTypeAction = BranchUtil.makeAnnihilateTypeName split
split = splitVar symbol
insertTypeAction = BranchUtil.makeAddTypeName split (Reference.fromId typeRefId)
@ -279,40 +245,6 @@ typecheckedUnisonFileToBranchUpdates abort getConstructors tuf = do
splitVar :: Symbol -> Path.Split
splitVar = Path.splitFromName . Name.unsafeParseVar
typecheckedUnisonFileToBranchAdds :: TypecheckedUnisonFile Symbol Ann -> [(Path, Branch0 m -> Branch0 m)]
typecheckedUnisonFileToBranchAdds tuf = do
declAdds ++ termAdds
where
declAdds :: [(Path, Branch0 m -> Branch0 m)]
declAdds = do
foldMap makeDataDeclAdds (Map.toList $ UF.dataDeclarationsId' tuf)
++ foldMap makeEffectDeclUpdates (Map.toList $ UF.effectDeclarationsId' tuf)
where
makeDataDeclAdds (symbol, (typeRefId, dataDecl)) = makeDeclAdds (symbol, (typeRefId, Right dataDecl))
makeEffectDeclUpdates (symbol, (typeRefId, effectDecl)) = makeDeclAdds (symbol, (typeRefId, Left effectDecl))
makeDeclAdds :: (Symbol, (TypeReferenceId, Decl Symbol Ann)) -> [(Path, Branch0 m -> Branch0 m)]
makeDeclAdds (symbol, (typeRefId, decl)) =
let insertTypeAction = BranchUtil.makeAddTypeName (splitVar symbol) (Reference.fromId typeRefId)
insertTypeConstructorActions =
zipWith
(\sym rid -> BranchUtil.makeAddTermName (splitVar sym) (Reference.fromId <$> rid))
(Decl.constructorVars (Decl.asDataDecl decl))
(Decl.declConstructorReferents typeRefId decl)
in insertTypeAction : insertTypeConstructorActions
termAdds :: [(Path, Branch0 m -> Branch0 m)]
termAdds =
tuf
& UF.hashTermsId
& Map.toList
& mapMaybe \(var, (_, ref, wk, _, _)) -> do
guard (WK.watchKindShouldBeStoredInDatabase wk)
Just (BranchUtil.makeAddTermName (splitVar var) (Referent.fromTermReferenceId ref))
splitVar :: Symbol -> Path.Split
splitVar = Path.splitFromName . Name.unsafeParseVar
-- | get references from `names` that have the same names as in `defns`
-- For constructors, we get the type reference.
getExistingReferencesNamed :: DefnsF Set Name Name -> Names -> Set Reference
@ -329,165 +261,6 @@ getExistingReferencesNamed defns names =
foldMap \name ->
Relation.lookupDom name (Names.types names)
makeUnisonFile ::
(forall void. Output -> Transaction void) ->
Codebase IO Symbol Ann ->
(Maybe Int -> Name -> Either Output.Output [Name]) ->
DefnsF (Relation Name) TermReferenceId TypeReferenceId ->
Transaction (UnisonFile Symbol Ann)
makeUnisonFile abort codebase doFindCtorNames defns = do
file <- foldM addTermComponent UF.emptyUnisonFile (Set.map Reference.idToHash (Relation.ran defns.terms))
foldM addDeclComponent file (Set.map Reference.idToHash (Relation.ran defns.types))
where
addTermComponent :: UnisonFile Symbol Ann -> Hash -> Transaction (UnisonFile Symbol Ann)
addTermComponent uf h = do
termComponent <- Codebase.unsafeGetTermComponent codebase h
pure $ foldl' addTermElement uf (zip termComponent [0 ..])
where
addTermElement :: UnisonFile Symbol Ann -> ((Term Symbol Ann, Type Symbol Ann), Reference.Pos) -> UnisonFile Symbol Ann
addTermElement uf ((tm, tp), i) = do
let termNames = Relation.lookupRan (Reference.Id h i) defns.terms
foldl' (addDefinition tm tp) uf termNames
addDefinition :: Term Symbol Ann -> Type Symbol Ann -> UnisonFile Symbol Ann -> Name -> UnisonFile Symbol Ann
addDefinition tm tp uf (Name.toVar -> v) =
let prependTerm to = (v, Ann.External, tm) : to
in if isTest tp
then uf & #watches . Lens.at WK.TestWatch . Lens.non [] Lens.%~ prependTerm
else uf & #terms Lens.%~ Map.insert v (Ann.External, tm)
isTest = Typechecker.isEqual (Decls.testResultListType mempty)
-- given a dependent hash, include that component in the scratch file
-- todo: wundefined: cut off constructor name prefixes
addDeclComponent :: UnisonFile Symbol Ann -> Hash -> Transaction (UnisonFile Symbol Ann)
addDeclComponent uf h = do
declComponent <- fromJust <$> Codebase.getDeclComponent h
foldM addDeclElement uf (zip declComponent [0 ..])
where
-- for each name a decl has, update its constructor names according to what exists in the namespace
addDeclElement :: UnisonFile Symbol Ann -> (Decl Symbol Ann, Reference.Pos) -> Transaction (UnisonFile Symbol Ann)
addDeclElement uf (decl, i) = do
let declNames = Relation.lookupRan (Reference.Id h i) defns.types
-- look up names for this decl's constructor based on the decl's name, and embed them in the decl definition.
foldM (addRebuiltDefinition decl) uf declNames
where
-- skip any definitions that already have names, we don't want to overwrite what the user has supplied
addRebuiltDefinition :: Decl Symbol Ann -> UnisonFile Symbol Ann -> Name -> Transaction (UnisonFile Symbol Ann)
addRebuiltDefinition decl uf name = case decl of
Left ed ->
overwriteConstructorNames name ed.toDataDecl <&> \ed' ->
uf
& #effectDeclarationsId
%~ Map.insertWith (\_new old -> old) (Name.toVar name) (Reference.Id h i, Decl.EffectDeclaration ed')
Right dd ->
overwriteConstructorNames name dd <&> \dd' ->
uf
& #dataDeclarationsId
%~ Map.insertWith (\_new old -> old) (Name.toVar name) (Reference.Id h i, dd')
-- Constructor names are bogus when pulled from the database, so we set them to what they should be here
overwriteConstructorNames :: Name -> DataDeclaration Symbol Ann -> Transaction (DataDeclaration Symbol Ann)
overwriteConstructorNames name dd =
let constructorNames :: Transaction [Symbol]
constructorNames =
case doFindCtorNames (Just $ Decl.constructorCount dd) name of
Left err -> abort err
Right array | all (isJust . Name.stripNamePrefix name) array -> pure (map Name.toVar array)
Right array -> do
traceM "I ran into a situation where a type's constructors didn't match its name,"
traceM "in a spot where I didn't expect to be discovering that.\n\n"
traceM "Type Name:"
traceM . Lazy.Text.unpack $ pShow name
traceM "Constructor Names:"
traceM . Lazy.Text.unpack $ pShow array
error "Sorry for crashing."
swapConstructorNames oldCtors =
let (annotations, _vars, types) = unzip3 oldCtors
in zip3 annotations <$> constructorNames <*> pure types
in Lens.traverseOf Decl.constructors_ swapConstructorNames dd
-- | @addDefinitionsToUnisonFile abort codebase doFindCtorNames definitions file@ adds all @definitions@ to @file@,
-- avoiding overwriting anything already in @file@. Every definition is put into the file with every naming it has in
-- @names@ "on the left-hand-side of the equals" (but yes type decls don't really have a LHS).
--
-- TODO: find a better module for this function, as it's used in a couple places
addDefinitionsToUnisonFile ::
(forall void. Output -> Transaction void) ->
Codebase IO Symbol Ann ->
(Maybe Int -> Name -> Either Output.Output [Name]) ->
DefnsF (Relation Name) TermReferenceId TypeReferenceId ->
UnisonFile Symbol Ann ->
Transaction (UnisonFile Symbol Ann)
addDefinitionsToUnisonFile abort codebase doFindCtorNames newDefns oldUF = do
newUF <- makeUnisonFile abort codebase doFindCtorNames newDefns
pure (oldUF `UF.leftBiasedMerge` newUF)
-- | O(r + c * d) touches all the referents (r), and all the NameSegments (d) of all of the Con referents (c)
forwardCtorNames :: Names -> Map ForwardName (Referent, Name)
forwardCtorNames names =
Map.fromList $
[ (ForwardName.fromName name, (r, name))
| (r@Referent.Con {}, rNames) <- Map.toList $ Relation.range names.terms,
name <- Foldable.toList rNames
]
-- | given a decl name, find names for all of its constructors, in order.
--
-- Precondition: 'n' is an element of 'names'
findCtorNames :: Output.UpdateOrUpgrade -> Names -> Map ForwardName (Referent, Name) -> Maybe Int -> Name -> Either Output.Output [Name]
findCtorNames operation names forwardCtorNames ctorCount n =
let declRef = case Set.lookupMin (Relation.lookupDom n names.types) of
Nothing -> error "[findCtorNames] precondition violation: n is not an element of names"
Just x -> x
f = ForwardName.fromName n
(_, centerRight) = Map.split f forwardCtorNames
(center, _) = Map.split (incrementLastSegmentChar f) centerRight
insertShortest :: Map ConstructorId Name -> (Referent, Name) -> Map ConstructorId Name
insertShortest m (Referent.Con (ConstructorReference r cid) _ct, newName) | r == declRef =
case Map.lookup cid m of
Just existingName
| length (Name.segments existingName) > length (Name.segments newName) ->
Map.insert cid newName m
Just {} -> m
Nothing -> Map.insert cid newName m
insertShortest m _ = m
m = foldl' insertShortest mempty (Foldable.toList center)
ctorCountGuess = fromMaybe (Map.size m) ctorCount
in if Map.size m == ctorCountGuess && all (isJust . flip Map.lookup m . fromIntegral) [0 .. ctorCountGuess - 1]
then Right $ Map.elems m
else Left $ Output.UpdateIncompleteConstructorSet operation n m ctorCount
findCtorNamesMaybe ::
Output.UpdateOrUpgrade ->
Names ->
Map ForwardName (Referent, Name) ->
Maybe Int ->
Name ->
Either Output.Output (Maybe [Name])
findCtorNamesMaybe operation names forwardCtorNames ctorCount name =
case Relation.memberDom name (Names.types names) of
True -> Just <$> findCtorNames operation names forwardCtorNames ctorCount name
False -> Right Nothing
-- Used by `findCtorNames` to filter `forwardCtorNames` to a narrow range which will be searched linearly.
-- >>> incrementLastSegmentChar $ ForwardName.fromName $ Name.unsafeFromText "foo.bar.quux"
-- ForwardName {toList = "foo" :| ["bar","quuy"]}
incrementLastSegmentChar :: ForwardName -> ForwardName
incrementLastSegmentChar (ForwardName segments) =
let (initSegments, lastSegment) = (NonEmpty.init segments, NonEmpty.last segments)
incrementedLastSegment = incrementLastCharInSegment lastSegment
in ForwardName $ maybe (NonEmpty.singleton incrementedLastSegment) (|> incrementedLastSegment) (NonEmpty.nonEmpty initSegments)
where
incrementLastCharInSegment :: NameSegment -> NameSegment
incrementLastCharInSegment (NameSegment text) =
let incrementedText =
if Text.null text
then text
else Text.init text `Text.append` Text.singleton (succ $ Text.last text)
in NameSegment incrementedText
-- @getTermAndDeclNames file@ returns the names of the terms and decls defined in a typechecked Unison file.
getTermAndDeclNames :: (Var v) => TypecheckedUnisonFile v a -> DefnsF Set Name Name
getTermAndDeclNames tuf =
@ -506,53 +279,6 @@ getTermAndDeclNames tuf =
keysToNames = Set.map Name.unsafeParseVar . Map.keysSet
ctorsToNames = Set.fromList . map Name.unsafeParseVar . Decl.constructorVars
-- | Given a namespace and a set of dependencies, return the subset of the namespace that consists of only the
-- (transitive) dependents of the dependencies.
getNamespaceDependentsOf ::
Names ->
Set Reference ->
Transaction (DefnsF (Relation Name) TermReferenceId TypeReferenceId)
getNamespaceDependentsOf names dependencies = do
dependents <- Ops.transitiveDependentsWithinScope (Names.referenceIds names) dependencies
pure (bimap (foldMap nameTerm) (foldMap nameType) dependents)
where
nameTerm :: TermReferenceId -> Relation Name TermReferenceId
nameTerm ref =
Relation.fromManyDom (Relation.lookupRan (Referent.fromTermReferenceId ref) (Names.terms names)) ref
nameType :: TypeReferenceId -> Relation Name TypeReferenceId
nameType ref =
Relation.fromManyDom (Relation.lookupRan (Reference.fromId ref) (Names.types names)) ref
-- | A better version of the above that operates on BiMultimaps rather than Relations.
getNamespaceDependentsOf2 ::
Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) ->
Set Reference ->
Transaction (DefnsF (Map Name) TermReferenceId TypeReferenceId)
getNamespaceDependentsOf2 defns dependencies = do
let toTermScope = Set.mapMaybe Referent.toReferenceId . BiMultimap.dom
let toTypeScope = Set.mapMaybe Reference.toId . BiMultimap.dom
let scope = bifoldMap toTermScope toTypeScope defns
dependents <-
Ops.transitiveDependentsWithinScope scope dependencies
pure
Defns
{ terms = Set.foldl' addTerms Map.empty dependents.terms,
types = Set.foldl' addTypes Map.empty dependents.types
}
where
addTerms :: Map Name TermReferenceId -> TermReferenceId -> Map Name TermReferenceId
addTerms acc0 ref =
let names = BiMultimap.lookupDom (Referent.fromTermReferenceId ref) defns.terms
in Set.foldl' (\acc name -> Map.insert name ref acc) acc0 names
addTypes :: Map Name TypeReferenceId -> TypeReferenceId -> Map Name TypeReferenceId
addTypes acc0 ref =
let names = BiMultimap.lookupDom (Reference.fromId ref) defns.types
in Set.foldl' (\acc name -> Map.insert name ref acc) acc0 names
-- The big picture behind PPE building, though there are many details:
--
-- * We are updating old references to new references by rendering old references as names that are then parsed
@ -573,19 +299,22 @@ getNamespaceDependentsOf2 defns dependencies = do
-- However, the following file will not fail to parse, if `one.foo` and `two.foo` are aliases in the codebase:
--
-- hey = foo + foo
makeComplicatedPPE ::
makePPE ::
Int ->
Names ->
Names ->
DefnsF (Relation Name) TermReferenceId TypeReferenceId ->
DefnsF (Map Name) TermReferenceId TypeReferenceId ->
PrettyPrintEnvDecl
makeComplicatedPPE hashLen names initialFileNames dependents =
PPED.makePPED (PPE.namer namesInTheFile) (PPE.suffixifyByName namesInTheFile)
`PPED.addFallback` PPED.makePPED (PPE.hqNamer hashLen namesInTheNamespace) (PPE.suffixifyByHash namesInTheNamespace)
where
namesInTheFile =
initialFileNames
<> Names
(Relation.mapRan Referent.fromTermReferenceId dependents.terms)
(Relation.mapRan Reference.fromId dependents.types)
namesInTheNamespace = Names.unionLeftName names initialFileNames
makePPE hashLen names initialFileNames dependents =
PPED.addFallback
(PPED.makeFilePPED (initialFileNames <> Names.fromUnconflictedReferenceIds dependents))
( PPED.makePPED
(PPE.hqNamer hashLen names)
-- We don't want to over-suffixify for a reference in the namespace. For example, say we have "foo.bar" in the
-- namespace and "oink.bar" in the file. "bar" may be a unique suffix among the namespace names, but would be
-- ambiguous in the context of namespace + file names.
--
-- So, we use `unionLeftName`, which starts with the LHS names (the namespace), and adds to it names from the
-- RHS (the initial file names, i.e. what was originally saved) that don't already exist in the LHS.
(PPE.suffixifyByHash (Names.unionLeftName names initialFileNames))
)

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

@ -4,60 +4,82 @@ module Unison.Codebase.Editor.HandleInput.Upgrade
)
where
import Control.Lens qualified as Lens
import Control.Monad.Reader (ask)
import Data.Char qualified as Char
import Data.Foldable qualified as Foldable
import Data.List.NonEmpty (pattern (:|))
import Data.List.NonEmpty qualified as List.NonEmpty
import Data.List.NonEmpty.Extra ((|>))
import Data.Map.Strict qualified as Map
import Data.Maybe (fromJust)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Data.Text.Lazy qualified as Text.Lazy
import Text.Builder qualified
import Text.Pretty.Simple (pShow)
import U.Codebase.Sqlite.DbId (ProjectId)
import Unison.Builtin.Decls qualified as Decls
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.Pretty qualified as Pretty
import Unison.Cli.ProjectUtils qualified as Cli
import Unison.Cli.UpdateUtils (getNamespaceDependentsOf, parseAndTypecheck)
import Unison.Codebase (Codebase)
import Unison.Codebase qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Branch.Names qualified as Branch
import Unison.Codebase.Editor.HandleInput.Branch (CreateFrom (..))
import Unison.Codebase.Editor.HandleInput.Branch qualified as HandleInput.Branch
import Unison.Codebase.Editor.HandleInput.Update2
( addDefinitionsToUnisonFile,
findCtorNames,
findCtorNamesMaybe,
forwardCtorNames,
getNamespaceDependentsOf,
makeComplicatedPPE,
makeParsingEnv,
prettyParseTypecheck,
typecheckedUnisonFileToBranchUpdates,
)
import Unison.Codebase.Editor.HandleInput.Update2 (typecheckedUnisonFileToBranchUpdates)
import Unison.Codebase.Editor.Output (Output)
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Path qualified as Path
import Unison.Codebase.ProjectPath qualified as PP
import Unison.ConstructorReference (GConstructorReference (..))
import Unison.DataDeclaration (DataDeclaration, Decl)
import Unison.DataDeclaration qualified as Decl
import Unison.DataDeclaration.ConstructorId (ConstructorId)
import Unison.Hash (Hash)
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.Name.Forward (ForwardName (..))
import Unison.Name.Forward qualified as ForwardName
import Unison.NameSegment (NameSegment)
import Unison.NameSegment qualified as NameSegment
import Unison.NameSegment.Internal (NameSegment (NameSegment))
import Unison.Names (Names (..))
import Unison.Names qualified as Names
import Unison.Parser.Ann (Ann)
import Unison.Parser.Ann qualified as Ann
import Unison.Prelude
import Unison.PrettyPrintEnv qualified as PPE
import Unison.PrettyPrintEnv.Names qualified as PPE
import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl (..))
import Unison.PrettyPrintEnvDecl qualified as PPED (addFallback)
import Unison.PrettyPrintEnvDecl.Names qualified as PPED (makeCodebasePPED, makeFilePPED)
import Unison.Project (ProjectBranchName)
import Unison.Reference (TermReference, TypeReference)
import Unison.Reference (TermReference, TermReferenceId, TypeReference, TypeReferenceId)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Sqlite (Transaction)
import Unison.Symbol (Symbol)
import Unison.Syntax.Name qualified as Name
import Unison.Syntax.NameSegment qualified as NameSegment (toEscapedText)
import Unison.Term (Term)
import Unison.Type (Type)
import Unison.Typechecker qualified as Typechecker
import Unison.UnisonFile (UnisonFile)
import Unison.UnisonFile qualified as UnisonFile
import Unison.Util.Defns (Defns (..), DefnsF)
import Unison.Util.Pretty qualified as Pretty
import Unison.Util.Relation (Relation)
import Unison.Util.Relation qualified as Relation
import Unison.Util.Set qualified as Set
import Unison.WatchKind qualified as WK
import Witch (unsafeFrom)
handleUpgrade :: NameSegment -> NameSegment -> Cli ()
@ -138,7 +160,6 @@ handleUpgrade oldName newName = do
(findCtorNames Output.UOUUpgrade currentLocalNames currentLocalConstructorNames)
dependents
UnisonFile.emptyUnisonFile
hashLength <- Codebase.hashLength
pure
( unisonFile,
makeOldDepPPE
@ -148,13 +169,15 @@ handleUpgrade oldName newName = do
(Branch.toNames oldNamespace)
(Branch.toNames oldLocalNamespace)
(Branch.toNames newLocalNamespace)
`PPED.addFallback` makeComplicatedPPE hashLength currentDeepNamesSansOld mempty dependents
`PPED.addFallback` PPED.makeFilePPED (Names.fromReferenceIds dependents)
`PPED.addFallback` PPED.makeCodebasePPED currentDeepNamesSansOld
)
pp@(PP.ProjectPath project projectBranch _path) <- Cli.getCurrentProjectPath
parsingEnv <- makeParsingEnv pp currentDeepNamesSansOld
typecheckedUnisonFile <-
prettyParseTypecheck unisonFile printPPE parsingEnv & onLeftM \prettyUnisonFile -> do
parsingEnv <- Cli.makeParsingEnv pp currentDeepNamesSansOld
typecheckedUnisonFile <- do
let prettyUnisonFile = Pretty.prettyUnisonFile printPPE unisonFile
parseAndTypecheck prettyUnisonFile parsingEnv & onNothingM do
let getTemporaryBranchName = findTemporaryBranchName (project ^. #projectId) oldName newName
(_temporaryBranchId, temporaryBranchName) <-
HandleInput.Branch.createBranch
@ -212,6 +235,100 @@ keepOldDeepTypesStillInUse oldDeepMinusLocalTypes currentDeepTypesSansOld =
Relation.dom oldDeepMinusLocalTypes
& Set.filter \typ -> not (Relation.memberDom typ currentDeepTypesSansOld)
-- | @addDefinitionsToUnisonFile abort codebase doFindCtorNames definitions file@ adds all @definitions@ to @file@,
-- avoiding overwriting anything already in @file@. Every definition is put into the file with every naming it has in
-- @names@ "on the left-hand-side of the equals" (but yes type decls don't really have a LHS).
--
-- TODO: find a better module for this function, as it's used in a couple places
addDefinitionsToUnisonFile ::
(forall void. Output -> Transaction void) ->
Codebase IO Symbol Ann ->
(Maybe Int -> Name -> Either Output.Output [Name]) ->
DefnsF (Relation Name) TermReferenceId TypeReferenceId ->
UnisonFile Symbol Ann ->
Transaction (UnisonFile Symbol Ann)
addDefinitionsToUnisonFile abort codebase doFindCtorNames newDefns oldUF = do
newUF <- makeUnisonFile abort codebase doFindCtorNames newDefns
pure (oldUF `UnisonFile.leftBiasedMerge` newUF)
makeUnisonFile ::
(forall void. Output -> Transaction void) ->
Codebase IO Symbol Ann ->
(Maybe Int -> Name -> Either Output.Output [Name]) ->
DefnsF (Relation Name) TermReferenceId TypeReferenceId ->
Transaction (UnisonFile Symbol Ann)
makeUnisonFile abort codebase doFindCtorNames defns = do
file <- foldM addTermComponent UnisonFile.emptyUnisonFile (Set.map Reference.idToHash (Relation.ran defns.terms))
foldM addDeclComponent file (Set.map Reference.idToHash (Relation.ran defns.types))
where
addTermComponent :: UnisonFile Symbol Ann -> Hash -> Transaction (UnisonFile Symbol Ann)
addTermComponent uf h = do
termComponent <- Codebase.unsafeGetTermComponent codebase h
pure $ foldl' addTermElement uf (zip termComponent [0 ..])
where
addTermElement :: UnisonFile Symbol Ann -> ((Term Symbol Ann, Type Symbol Ann), Reference.Pos) -> UnisonFile Symbol Ann
addTermElement uf ((tm, tp), i) = do
let termNames = Relation.lookupRan (Reference.Id h i) defns.terms
foldl' (addDefinition tm tp) uf termNames
addDefinition :: Term Symbol Ann -> Type Symbol Ann -> UnisonFile Symbol Ann -> Name -> UnisonFile Symbol Ann
addDefinition tm tp uf (Name.toVar -> v) =
let prependTerm to = (v, Ann.External, tm) : to
in if isTest tp
then uf & #watches . Lens.at WK.TestWatch . Lens.non [] Lens.%~ prependTerm
else uf & #terms Lens.%~ Map.insert v (Ann.External, tm)
isTest = Typechecker.isEqual (Decls.testResultListType mempty)
-- given a dependent hash, include that component in the scratch file
-- todo: wundefined: cut off constructor name prefixes
addDeclComponent :: UnisonFile Symbol Ann -> Hash -> Transaction (UnisonFile Symbol Ann)
addDeclComponent uf h = do
declComponent <- fromJust <$> Codebase.getDeclComponent h
foldM addDeclElement uf (zip declComponent [0 ..])
where
-- for each name a decl has, update its constructor names according to what exists in the namespace
addDeclElement :: UnisonFile Symbol Ann -> (Decl Symbol Ann, Reference.Pos) -> Transaction (UnisonFile Symbol Ann)
addDeclElement uf (decl, i) = do
let declNames = Relation.lookupRan (Reference.Id h i) defns.types
-- look up names for this decl's constructor based on the decl's name, and embed them in the decl definition.
foldM (addRebuiltDefinition decl) uf declNames
where
-- skip any definitions that already have names, we don't want to overwrite what the user has supplied
addRebuiltDefinition :: Decl Symbol Ann -> UnisonFile Symbol Ann -> Name -> Transaction (UnisonFile Symbol Ann)
addRebuiltDefinition decl uf name = case decl of
Left ed ->
overwriteConstructorNames name ed.toDataDecl <&> \ed' ->
uf
& #effectDeclarationsId
%~ Map.insertWith (\_new old -> old) (Name.toVar name) (Reference.Id h i, Decl.EffectDeclaration ed')
Right dd ->
overwriteConstructorNames name dd <&> \dd' ->
uf
& #dataDeclarationsId
%~ Map.insertWith (\_new old -> old) (Name.toVar name) (Reference.Id h i, dd')
-- Constructor names are bogus when pulled from the database, so we set them to what they should be here
overwriteConstructorNames :: Name -> DataDeclaration Symbol Ann -> Transaction (DataDeclaration Symbol Ann)
overwriteConstructorNames name dd =
let constructorNames :: Transaction [Symbol]
constructorNames =
case doFindCtorNames (Just $ Decl.constructorCount dd) name of
Left err -> abort err
Right array | all (isJust . Name.stripNamePrefix name) array -> pure (map Name.toVar array)
Right array -> do
traceM "I ran into a situation where a type's constructors didn't match its name,"
traceM "in a spot where I didn't expect to be discovering that.\n\n"
traceM "Type Name:"
traceM . Text.Lazy.unpack $ pShow name
traceM "Constructor Names:"
traceM . Text.Lazy.unpack $ pShow array
error "Sorry for crashing."
swapConstructorNames oldCtors =
let (annotations, _vars, types) = unzip3 oldCtors
in zip3 annotations <$> constructorNames <*> pure types
in Lens.traverseOf Decl.constructors_ swapConstructorNames dd
makeOldDepPPE ::
NameSegment ->
NameSegment ->
@ -287,3 +404,72 @@ findTemporaryBranchName projectId oldDepName newDepName = do
oldDepText = NameSegment.toEscapedText oldDepName
newDepText = NameSegment.toEscapedText newDepName
-- | O(r + c * d) touches all the referents (r), and all the NameSegments (d) of all of the Con referents (c)
forwardCtorNames :: Names -> Map ForwardName (Referent, Name)
forwardCtorNames names =
Map.fromList $
[ (ForwardName.fromName name, (r, name))
| (r@Referent.Con {}, rNames) <- Map.toList $ Relation.range names.terms,
name <- Foldable.toList rNames
]
-- | given a decl name, find names for all of its constructors, in order.
--
-- Precondition: 'n' is an element of 'names'
findCtorNames :: Output.UpdateOrUpgrade -> Names -> Map ForwardName (Referent, Name) -> Maybe Int -> Name -> Either Output.Output [Name]
findCtorNames operation names forwardCtorNames ctorCount n =
let declRef = case Set.lookupMin (Relation.lookupDom n names.types) of
Nothing -> error "[findCtorNames] precondition violation: n is not an element of names"
Just x -> x
f = ForwardName.fromName n
(_, centerRight) = Map.split f forwardCtorNames
(center, _) = Map.split (incrementLastSegmentChar f) centerRight
insertShortest :: Map ConstructorId Name -> (Referent, Name) -> Map ConstructorId Name
insertShortest m (Referent.Con (ConstructorReference r cid) _ct, newName) | r == declRef =
case Map.lookup cid m of
Just existingName
| length (Name.segments existingName) > length (Name.segments newName) ->
Map.insert cid newName m
Just {} -> m
Nothing -> Map.insert cid newName m
insertShortest m _ = m
m = foldl' insertShortest mempty (Foldable.toList center)
ctorCountGuess = fromMaybe (Map.size m) ctorCount
in if Map.size m == ctorCountGuess && all (isJust . flip Map.lookup m . fromIntegral) [0 .. ctorCountGuess - 1]
then Right $ Map.elems m
else Left $ Output.UpdateIncompleteConstructorSet operation n m ctorCount
findCtorNamesMaybe ::
Output.UpdateOrUpgrade ->
Names ->
Map ForwardName (Referent, Name) ->
Maybe Int ->
Name ->
Either Output.Output (Maybe [Name])
findCtorNamesMaybe operation names forwardCtorNames ctorCount name =
case Relation.memberDom name (Names.types names) of
True -> Just <$> findCtorNames operation names forwardCtorNames ctorCount name
False -> Right Nothing
-- Used by `findCtorNames` to filter `forwardCtorNames` to a narrow range which will be searched linearly.
-- >>> incrementLastSegmentChar $ ForwardName.fromName $ Name.unsafeFromText "foo.bar.quux"
-- ForwardName {toList = "foo" :| ["bar","quuy"]}
incrementLastSegmentChar :: ForwardName -> ForwardName
incrementLastSegmentChar (ForwardName segments) =
let (initSegments, lastSegment) = (List.NonEmpty.init segments, List.NonEmpty.last segments)
incrementedLastSegment = incrementLastCharInSegment lastSegment
in ForwardName $
maybe
(List.NonEmpty.singleton incrementedLastSegment)
(|> incrementedLastSegment)
(List.NonEmpty.nonEmpty initSegments)
where
incrementLastCharInSegment :: NameSegment -> NameSegment
incrementLastCharInSegment (NameSegment text) =
let incrementedText =
if Text.null text
then text
else Text.init text `Text.append` Text.singleton (succ $ Text.last text)
in NameSegment incrementedText

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

@ -57,7 +57,7 @@ import Unison.Hash (Hash)
import Unison.HashQualified qualified as HQ
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.LabeledDependency (LabeledDependency)
import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReasons (..))
import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason, IncoherentDeclReasons (..))
import Unison.Name (Name)
import Unison.NameSegment (NameSegment)
import Unison.Names (Names)
@ -84,6 +84,8 @@ import Unison.Term (Term)
import Unison.Type (Type)
import Unison.Typechecker.Context qualified as Context
import Unison.UnisonFile qualified as UF
import Unison.Util.Conflicted (Conflicted)
import Unison.Util.Defn (Defn)
import Unison.Util.Defns (DefnsF, defnsAreEmpty)
import Unison.Util.Pretty qualified as P
import Unison.Util.Relation (Relation)
@ -424,20 +426,17 @@ data Output
| MergeSuccess !MergeSourceAndTarget
| MergeSuccessFastForward !MergeSourceAndTarget
| MergeConflictedAliases !MergeSourceOrTarget !Name !Name
| MergeConflictedTermName !Name !(NESet Referent)
| MergeConflictedTypeName !Name !(NESet TypeReference)
| MergeConflictInvolvingBuiltin !Name
| MergeConstructorAlias !MergeSourceOrTarget !Name !Name !Name
| MergeDefnsInLib !MergeSourceOrTarget
| MergeMissingConstructorName !MergeSourceOrTarget !Name
| MergeNestedDeclAlias !MergeSourceOrTarget !Name !Name
| MergeStrayConstructor !MergeSourceOrTarget !Name
| InstalledLibdep !(ProjectAndBranch ProjectName ProjectBranchName) !NameSegment
| NoUpgradeInProgress
| UseLibInstallNotPull !(ProjectAndBranch ProjectName ProjectBranchName)
| PullIntoMissingBranch !(ReadRemoteNamespace Share.RemoteProjectBranch) !(ProjectAndBranch (Maybe ProjectName) ProjectBranchName)
| NoMergeInProgress
| Output'DebugSynhashTerm !TermReference !Hash !Text
| ConflictedDefn !Text {- what operation? -} !(Defn (Conflicted Name Referent) (Conflicted Name TypeReference))
| IncoherentDeclDuringMerge !MergeSourceOrTarget !IncoherentDeclReason
| IncoherentDeclDuringUpdate !IncoherentDeclReason
data MoreEntriesThanShown = MoreEntriesThanShown | AllEntriesShown
deriving (Eq, Show)
@ -665,20 +664,17 @@ isFailure o = case o of
MergeSuccess {} -> False
MergeSuccessFastForward {} -> False
MergeConflictedAliases {} -> True
MergeConflictedTermName {} -> True
MergeConflictedTypeName {} -> True
MergeConflictInvolvingBuiltin {} -> True
MergeConstructorAlias {} -> True
MergeDefnsInLib {} -> True
MergeMissingConstructorName {} -> True
MergeNestedDeclAlias {} -> True
MergeStrayConstructor {} -> True
InstalledLibdep {} -> False
NoUpgradeInProgress {} -> True
UseLibInstallNotPull {} -> False
PullIntoMissingBranch {} -> True
NoMergeInProgress {} -> True
Output'DebugSynhashTerm {} -> False
ConflictedDefn {} -> True
IncoherentDeclDuringMerge {} -> True
IncoherentDeclDuringUpdate {} -> True
isNumberedFailure :: NumberedOutput -> Bool
isNumberedFailure = \case

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

@ -85,7 +85,7 @@ import Unison.Hash32 (Hash32)
import Unison.HashQualified qualified as HQ
import Unison.HashQualifiedPrime qualified as HQ'
import Unison.LabeledDependency as LD
import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReasons (..))
import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason (..), IncoherentDeclReasons (..))
import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment qualified as NameSegment
@ -141,6 +141,8 @@ import Unison.Term (Term)
import Unison.Term qualified as Term
import Unison.Type (Type)
import Unison.UnisonFile qualified as UF
import Unison.Util.Conflicted (Conflicted (..))
import Unison.Util.Defn (Defn (..))
import Unison.Util.Defns (Defns (..))
import Unison.Util.List qualified as List
import Unison.Util.Monoid (intercalateMap)
@ -1359,12 +1361,6 @@ notifyUser dir = \case
<> P.newline
<> P.newline
<> P.wrap "and then try merging again."
MergeConflictedTermName name _refs ->
pure . P.wrap $
"The term name" <> prettyName name <> "is ambiguous. Please resolve the ambiguity before merging."
MergeConflictedTypeName name _refs ->
pure . P.wrap $
"The type name" <> prettyName name <> "is ambiguous. Please resolve the ambiguity before merging."
MergeConflictInvolvingBuiltin name ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the merge:",
@ -1381,22 +1377,6 @@ notifyUser dir = \case
<> "the same on both branches, or making neither of them a builtin, and then try the merge again."
)
]
-- Note [ConstructorAliasMessage] If you change this, also change the other similar one
MergeConstructorAlias aliceOrBob typeName conName1 conName2 ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the merge:",
"",
P.wrap $
"On"
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the type"
<> prettyName typeName
<> "has a constructor with multiple names, and I can't perform a merge in this situation:",
"",
P.indentN 2 (P.bulleted [prettyName conName1, prettyName conName2]),
"",
P.wrap "Please delete all but one name for each constructor, and then try merging again."
]
-- Note [DefnsInLibMessage] If you change this, also change the other similar one
MergeDefnsInLib aliceOrBob ->
pure . P.lines $
@ -1410,54 +1390,6 @@ notifyUser dir = \case
"",
P.wrap "Please move or remove it and then try merging again."
]
-- Note [MissingConstructorNameMessage] If you change this, also change the other similar one
MergeMissingConstructorName aliceOrBob name ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the merge:",
"",
P.wrap $
"On"
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the type"
<> prettyName name
<> "has some constructors with missing names, and I can't perform a merge in this situation.",
"",
P.wrap $
"You can use"
<> IP.makeExample IP.view [prettyName name]
<> "and"
<> IP.makeExample IP.aliasTerm ["<hash>", prettyName name <> ".<ConstructorName>"]
<> "to give names to each unnamed constructor, and then try the merge again."
]
-- Note [NestedDeclAliasMessage] If you change this, also change the other similar one
MergeNestedDeclAlias aliceOrBob shorterName longerName ->
pure . P.wrap $
"On"
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the type"
<> prettyName longerName
<> "is an alias of"
<> P.group (prettyName shorterName <> ".")
<> "I'm not able to perform a merge when a type exists nested under an alias of itself. Please separate them or"
<> "delete one copy, and then try merging again."
-- Note [StrayConstructorMessage] If you change this, also change the other similar one
MergeStrayConstructor aliceOrBob name ->
pure . P.lines $
[ P.wrap $
"Sorry, I wasn't able to perform the merge, because I need all constructor names to be nested somewhere"
<> "beneath the corresponding type name.",
"",
P.wrap $
"On"
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the constructor"
<> prettyName name
<> "is not nested beneath the corresponding type name. Please either use"
<> IP.makeExample' IP.moveAll
<> "to move it, or if it's an extra copy, you can simply"
<> IP.makeExample' IP.delete
<> "it. Then try the merge again."
]
PreviewMergeAlreadyUpToDate src dest ->
pure . P.callout "😶" $
P.wrap $
@ -2136,6 +2068,140 @@ notifyUser dir = \case
<> P.newline
<> "Synhash tokens: "
<> P.text filename
ConflictedDefn operation defn ->
pure . P.wrap $
( "This branch has more than one" <> case defn of
TermDefn (Conflicted name _refs) -> "term with the name" <> P.group (P.backticked (prettyName name) <> ".")
TypeDefn (Conflicted name _refs) -> "type with the name" <> P.group (P.backticked (prettyName name) <> ".")
)
<> P.newline
<> "Please delete or rename all but one of them, then try the"
<> P.text operation
<> "again."
IncoherentDeclDuringMerge aliceOrBob reason ->
case reason of
-- Note [ConstructorAliasMessage] If you change this, also change the other similar ones
IncoherentDeclReason'ConstructorAlias typeName conName1 conName2 ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the merge:",
"",
P.wrap $
"On"
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the type"
<> prettyName typeName
<> "has a constructor with multiple names, and I can't perform a merge in this situation:",
"",
P.indentN 2 (P.bulleted [prettyName conName1, prettyName conName2]),
"",
P.wrap "Please delete all but one name for each constructor, and then try merging again."
]
-- Note [MissingConstructorNameMessage] If you change this, also change the other similar ones
IncoherentDeclReason'MissingConstructorName name ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the merge:",
"",
P.wrap $
"On"
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the type"
<> prettyName name
<> "has some constructors with missing names, and I can't perform a merge in this situation.",
"",
P.wrap $
"You can use"
<> IP.makeExample IP.view [prettyName name]
<> "and"
<> IP.makeExample IP.aliasTerm ["<hash>", prettyName name <> ".<ConstructorName>"]
<> "to give names to each unnamed constructor, and then try the merge again."
]
-- Note [NestedDeclAliasMessage] If you change this, also change the other similar ones
IncoherentDeclReason'NestedDeclAlias shorterName longerName ->
pure . P.wrap $
"On"
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the type"
<> prettyName longerName
<> "is an alias of"
<> P.group (prettyName shorterName <> ".")
<> "I'm not able to perform a merge when a type exists nested under an alias of itself. Please separate them or"
<> "delete one copy, and then try merging again."
-- Note [StrayConstructorMessage] If you change this, also change the other similar ones
IncoherentDeclReason'StrayConstructor _typeRef name ->
pure . P.lines $
[ P.wrap $
"Sorry, I wasn't able to perform the merge, because I need all constructor names to be nested somewhere"
<> "beneath the corresponding type name.",
"",
P.wrap $
"On"
<> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",")
<> "the constructor"
<> prettyName name
<> "is not nested beneath the corresponding type name. Please either use"
<> IP.makeExample' IP.moveAll
<> "to move it, or if it's an extra copy, you can simply"
<> IP.makeExample' IP.delete
<> "it. Then try the merge again."
]
IncoherentDeclDuringUpdate reason ->
case reason of
-- Note [ConstructorAliasMessage] If you change this, also change the other similar ones
IncoherentDeclReason'ConstructorAlias typeName conName1 conName2 ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the update:",
"",
P.wrap $
"The type"
<> prettyName typeName
<> "has a constructor with multiple names, and I can't perform an update in this situation:",
"",
P.indentN 2 (P.bulleted [prettyName conName1, prettyName conName2]),
"",
P.wrap "Please delete all but one name for each constructor, and then try updating again."
]
-- Note [MissingConstructorNameMessage] If you change this, also change the other similar ones
IncoherentDeclReason'MissingConstructorName name ->
pure . P.lines $
[ P.wrap "Sorry, I wasn't able to perform the update:",
"",
P.wrap $
"The type"
<> prettyName name
<> "has some constructors with missing names, and I can't perform an update in this situation.",
"",
P.wrap $
"You can use"
<> IP.makeExample IP.view [prettyName name]
<> "and"
<> IP.makeExample IP.aliasTerm ["<hash>", prettyName name <> ".<ConstructorName>"]
<> "to give names to each unnamed constructor, and then try the update again."
]
-- Note [NestedDeclAliasMessage] If you change this, also change the other similar ones
IncoherentDeclReason'NestedDeclAlias shorterName longerName ->
pure . P.wrap $
"The type"
<> prettyName longerName
<> "is an alias of"
<> P.group (prettyName shorterName <> ".")
<> "I'm not able to perform an update when a type exists nested under an alias of itself. Please separate"
<> "them or delete one copy, and then try updating again."
-- Note [StrayConstructorMessage] If you change this, also change the other similar ones
IncoherentDeclReason'StrayConstructor _typeRef name ->
pure . P.lines $
[ P.wrap $
"Sorry, I wasn't able to perform the update, because I need all constructor names to be nested somewhere"
<> "beneath the corresponding type name.",
"",
P.wrap $
"The constructor"
<> prettyName name
<> "is not nested beneath the corresponding type name. Please either use"
<> IP.makeExample' IP.moveAll
<> "to move it, or if it's an extra copy, you can simply"
<> IP.makeExample' IP.delete
<> "it. Then try the update again."
]
prettyShareError :: ShareError -> Pretty
prettyShareError =
@ -2524,7 +2590,7 @@ renderNameConflicts hashLen conflictedNames = do
prettyConflictedTerms <- showConflictedNames "term" conflictedTermNames
pure $
Monoid.unlessM (null allConflictedNames) $
P.callout "❓" . P.sep "\n\n" . P.nonEmpty $
P.callout "❓" . P.linesSpaced . P.nonEmpty $
[ prettyConflictedTypes,
prettyConflictedTerms,
tip $
@ -2545,7 +2611,7 @@ renderNameConflicts hashLen conflictedNames = do
where
showConflictedNames :: Pretty -> Map Name [HQ.HashQualified Name] -> Numbered Pretty
showConflictedNames thingKind conflictedNames =
P.lines <$> do
P.linesSpaced <$> do
for (Map.toList conflictedNames) \(name, hashes) -> do
prettyConflicts <- for hashes \hash -> do
n <- addNumberedArg $ SA.HashQualified hash
@ -2676,7 +2742,7 @@ handleTodoOutput todo
things
& map
( \(typeName, prettyCon1, prettyCon2) ->
-- Note [ConstructorAliasMessage] If you change this, also change the other similar one
-- Note [ConstructorAliasMessage] If you change this, also change the other similar ones
P.wrap ("The type" <> prettyName typeName <> "has a constructor with multiple names.")
<> P.newline
<> P.newline
@ -2695,7 +2761,7 @@ handleTodoOutput todo
for types0 \typ -> do
n <- addNumberedArg (SA.Name typ)
pure (n, typ)
-- Note [MissingConstructorNameMessage] If you change this, also change the other similar one
-- Note [MissingConstructorNameMessage] If you change this, also change the other similar ones
pure $
P.wrap
"These types have some constructors with missing names."
@ -2728,7 +2794,7 @@ handleTodoOutput todo
n1 <- addNumberedArg (SA.Name short)
n2 <- addNumberedArg (SA.Name long)
pure (formatNum n1 <> prettyName short, formatNum n2 <> prettyName long)
-- Note [NestedDeclAliasMessage] If you change this, also change the other similar one
-- Note [NestedDeclAliasMessage] If you change this, also change the other similar ones
pure $
aliases1
& map
@ -2748,9 +2814,9 @@ handleTodoOutput todo
[] -> pure mempty
constructors -> do
nums <-
for constructors \constructor -> do
for constructors \(_typeRef, constructor) -> do
addNumberedArg (SA.Name constructor)
-- Note [StrayConstructorMessage] If you change this, also change the other similar one
-- Note [StrayConstructorMessage] If you change this, also change the other similar ones
pure $
P.wrap "These constructors are not nested beneath their corresponding type names:"
<> P.newline
@ -2759,7 +2825,7 @@ handleTodoOutput todo
2
( P.lines
( zipWith
(\n constructor -> formatNum n <> prettyName constructor)
(\n (_typeRef, constructor) -> formatNum n <> prettyName constructor)
nums
constructors
)

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

@ -47,6 +47,7 @@ library
Unison.Cli.Share.Projects.Types
Unison.Cli.TypeCheck
Unison.Cli.UniqueTypeGuidLookup
Unison.Cli.UpdateUtils
Unison.Codebase.Editor.AuthorInfo
Unison.Codebase.Editor.HandleInput
Unison.Codebase.Editor.HandleInput.AddRun

1
unison-core/package.yaml
View File

@ -77,6 +77,7 @@ default-extensions:
- LambdaCase
- MultiParamTypeClasses
- NamedFieldPuns
- OverloadedLabels
- OverloadedStrings
- OverloadedRecordDot
- PatternSynonyms

5
unison-core/src/Unison/ConstructorReference.hs
View File

@ -4,6 +4,7 @@ module Unison.ConstructorReference
ConstructorReference,
ConstructorReferenceId,
reference_,
toId,
toShortHash,
)
where
@ -29,6 +30,10 @@ reference_ :: Lens (GConstructorReference r) (GConstructorReference s) r s
reference_ =
lens (\(ConstructorReference r _) -> r) \(ConstructorReference _ i) r -> ConstructorReference r i
toId :: ConstructorReference -> Maybe ConstructorReferenceId
toId (ConstructorReference typeRef conId) =
ConstructorReference <$> Reference.toId typeRef <*> pure conId
toShortHash :: ConstructorReference -> ShortHash
toShortHash (ConstructorReference r i) =
case Reference.toShortHash r of

30
unison-core/src/Unison/Names.hs
View File

@ -12,6 +12,8 @@ module Unison.Names
filterByHQs,
filterBySHs,
filterTypes,
fromReferenceIds,
fromUnconflictedReferenceIds,
map,
makeAbsolute,
makeRelative,
@ -69,14 +71,12 @@ import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment (NameSegment)
import Unison.Prelude
import Unison.Reference (Reference, TermReference, TypeReference)
import Unison.Reference (Reference, TermReference, TermReferenceId, TypeReference, TypeReferenceId)
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.ShortHash (ShortHash)
import Unison.ShortHash qualified as SH
import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF)
import Unison.Util.Nametree (Nametree, unflattenNametree)
import Unison.Util.Relation (Relation)
@ -105,6 +105,22 @@ instance Monoid (Names) where
isEmpty :: Names -> Bool
isEmpty n = R.null n.terms && R.null n.types
-- | Construct a 'Names' from unconflicted reference ids.
fromReferenceIds :: DefnsF (Relation Name) TermReferenceId TypeReferenceId -> Names
fromReferenceIds defns =
Names
{ terms = Relation.mapRan Referent.fromTermReferenceId defns.terms,
types = Relation.mapRan Reference.fromId defns.types
}
-- | Construct a 'Names' from unconflicted reference ids.
fromUnconflictedReferenceIds :: DefnsF (Map Name) TermReferenceId TypeReferenceId -> Names
fromUnconflictedReferenceIds defns =
Names
{ terms = Relation.fromMap (Map.map Referent.fromTermReferenceId defns.terms),
types = Relation.fromMap (Map.map Reference.fromId defns.types)
}
map :: (Name -> Name) -> Names -> Names
map f (Names {terms, types}) = Names terms' types'
where
@ -544,10 +560,6 @@ lenientToNametree names =
where
lenientRelationToNametree :: (Ord a) => Relation Name a -> Nametree (Map NameSegment a)
lenientRelationToNametree =
unflattenNametree . lenientRelationToLeftUniqueRelation
lenientRelationToLeftUniqueRelation :: (Ord a, Ord b) => Relation a b -> BiMultimap b a
lenientRelationToLeftUniqueRelation =
-- The partial `Set.findMin` are fine here because Relation.domain only has non-empty Set values. A NESet would be
-- The partial `Set.findMin` is fine here because Relation.domain only has non-empty Set values. A NESet would be
-- better.
BiMultimap.fromRange . Map.map Set.findMin . Relation.domain
unflattenNametree . Map.map Set.findMin . Relation.domain

15
unison-core/src/Unison/Referent.hs
View File

@ -12,6 +12,8 @@ module Unison.Referent
toId,
toReference,
toReferenceId,
toConstructorReference,
toConstructorReferenceId,
toTermReference,
toTermReferenceId,
fromId,
@ -119,7 +121,16 @@ toReference = toReference'
toReferenceId :: Referent -> Maybe Reference.Id
toReferenceId = Reference.toId . toReference
toTermReference :: Referent -> Maybe TermReference
toConstructorReference :: Referent' r -> Maybe (GConstructorReference r)
toConstructorReference = \case
Con' r _ -> Just r
Ref' _ -> Nothing
toConstructorReferenceId :: Referent -> Maybe ConstructorReferenceId
toConstructorReferenceId =
toConstructorReference >=> ConstructorReference.toId
toTermReference :: Referent' r -> Maybe r
toTermReference = \case
Con' _ _ -> Nothing
Ref' reference -> Just reference
@ -129,7 +140,7 @@ toTermReferenceId r = toTermReference r >>= Reference.toId
-- | Inject a Term Reference into a Referent
fromTermReference :: TermReference -> Referent
fromTermReference r = Ref r
fromTermReference = Ref
fromTermReferenceId :: TermReferenceId -> Referent
fromTermReferenceId = fromTermReference . Reference.fromId

10
unison-core/src/Unison/Util/Conflicted.hs Normal file
View File

@ -0,0 +1,10 @@
module Unison.Util.Conflicted
( Conflicted (..),
)
where
import Data.Set.NonEmpty (NESet)
-- | A conflicted thing.
data Conflicted n a
= Conflicted !n !(NESet a)

9
unison-core/src/Unison/Util/Defn.hs Normal file
View File

@ -0,0 +1,9 @@
module Unison.Util.Defn
( Defn (..),
)
where
-- | A "definition" is either a term or a type.
data Defn term typ
= TermDefn term
| TypeDefn typ

30
unison-core/src/Unison/Util/Nametree.hs
View File

@ -6,7 +6,9 @@ module Unison.Util.Nametree
-- ** Flattening and unflattening
flattenNametree,
flattenNametrees,
unflattenNametree,
unflattenNametrees,
)
where
@ -21,6 +23,7 @@ import Unison.NameSegment (NameSegment)
import Unison.Prelude
import Unison.Util.BiMultimap (BiMultimap)
import Unison.Util.BiMultimap qualified as BiMultimap
import Unison.Util.Defns (Defns (..), DefnsF)
import Prelude hiding (zipWith)
-- | A nametree has a value, and a collection of children nametrees keyed by name segment.
@ -103,6 +106,17 @@ flattenNametree f =
)
(Map.toList children)
-- | Like 'flattenNametree', but works on both the types and terms namespace at once.
flattenNametrees ::
(Ord term, Ord typ) =>
Nametree (DefnsF (Map NameSegment) term typ) ->
Defns (BiMultimap term Name) (BiMultimap typ Name)
flattenNametrees defns =
Defns
{ terms = flattenNametree (view #terms) defns,
types = flattenNametree (view #types) defns
}
-- | 'unflattenNametree' organizes an association between names and definitions like
--
-- > {
@ -120,9 +134,9 @@ flattenNametree f =
-- > "baz" = #baz
-- > }
-- > }
unflattenNametree :: (Ord a) => BiMultimap a Name -> Nametree (Map NameSegment a)
unflattenNametree :: (Ord a) => Map Name a -> Nametree (Map NameSegment a)
unflattenNametree =
unfoldNametree unflattenLevel . map (first Name.segments) . Map.toList . BiMultimap.range
unfoldNametree unflattenLevel . map (first Name.segments) . Map.toList
where
unflattenLevel :: [(NonEmpty NameSegment, a)] -> (Map NameSegment a, Map NameSegment [(NonEmpty NameSegment, a)])
unflattenLevel =
@ -132,6 +146,18 @@ unflattenNametree =
(NameHere n, v) -> (Map.insert n v accValue, accChildren)
(NameThere n ns, v) -> (accValue, Map.insertWith (++) n [(ns, v)] accChildren)
-- | Like 'unflattenNametree', but works on both the types and terms namespace at once.
unflattenNametrees :: (Ord term, Ord typ) => DefnsF (Map Name) term typ -> Nametree (DefnsF (Map NameSegment) term typ)
unflattenNametrees defns =
alignWith
( \case
This terms -> Defns {terms, types = Map.empty}
That types -> Defns {terms = Map.empty, types}
These terms types -> Defns {terms, types}
)
(unflattenNametree defns.terms)
(unflattenNametree defns.types)
-- Helper patterns for switching on "name here" (1 name segment) or "name there" (2+ name segments)
pattern NameHere :: a -> NonEmpty a

4
unison-core/unison-core1.cabal
View File

@ -55,6 +55,8 @@ library
Unison.Type
Unison.Type.Names
Unison.Util.Components
Unison.Util.Conflicted
Unison.Util.Defn
Unison.Util.Defns
Unison.Util.Nametree
Unison.Var
@ -83,6 +85,7 @@ library
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
OverloadedLabels
OverloadedStrings
OverloadedRecordDot
PatternSynonyms
@ -152,6 +155,7 @@ test-suite tests
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
OverloadedLabels
OverloadedStrings
OverloadedRecordDot
PatternSynonyms

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

@ -111,6 +111,7 @@ import Unison.Name (Name)
import Unison.Name qualified as Name
import Unison.NameSegment (NameSegment)
import Unison.Prelude
import Unison.Reference qualified as Reference
import Unison.Referent (Referent)
import Unison.Referent qualified as Referent
import Unison.Util.Defns (Defns (..), DefnsF)
@ -130,32 +131,31 @@ data IncoherentDeclReason
-- Foo#Foo
-- Foo.Bar#Foo
IncoherentDeclReason'NestedDeclAlias !Name !Name -- shorter name, longer name
| IncoherentDeclReason'StrayConstructor !Name
| IncoherentDeclReason'StrayConstructor !TypeReferenceId !Name
deriving stock (Show)
checkDeclCoherency ::
forall m.
(Monad m) =>
(TypeReferenceId -> m Int) ->
Nametree (DefnsF (Map NameSegment) Referent TypeReference) ->
m (Either IncoherentDeclReason DeclNameLookup)
checkDeclCoherency loadDeclNumConstructors nametree =
Except.runExceptT
( checkDeclCoherencyWith
(lift . loadDeclNumConstructors)
OnIncoherentDeclReasons
{ onConstructorAlias = \x y z -> Except.throwError (IncoherentDeclReason'ConstructorAlias x y z), -- :: Name -> Name -> Name -> m (),
onMissingConstructorName = \x -> Except.throwError (IncoherentDeclReason'MissingConstructorName x), -- :: Name -> m (),
onNestedDeclAlias = \x y -> Except.throwError (IncoherentDeclReason'NestedDeclAlias x y), -- :: Name -> Name -> m (),
onStrayConstructor = \x -> Except.throwError (IncoherentDeclReason'StrayConstructor x) -- :: Name -> m ()
}
nametree
)
Except.runExceptT $
checkDeclCoherencyWith
(lift . loadDeclNumConstructors)
OnIncoherentDeclReasons
{ onConstructorAlias = \x y z -> Except.throwError (IncoherentDeclReason'ConstructorAlias x y z),
onMissingConstructorName = \x -> Except.throwError (IncoherentDeclReason'MissingConstructorName x),
onNestedDeclAlias = \x y -> Except.throwError (IncoherentDeclReason'NestedDeclAlias x y),
onStrayConstructor = \x y -> Except.throwError (IncoherentDeclReason'StrayConstructor x y)
}
nametree
data IncoherentDeclReasons = IncoherentDeclReasons
{ constructorAliases :: ![(Name, Name, Name)],
missingConstructorNames :: ![Name],
nestedDeclAliases :: ![(Name, Name)],
strayConstructors :: ![Name]
strayConstructors :: ![(TypeReferenceId, Name)]
}
deriving stock (Eq, Generic)
@ -180,7 +180,7 @@ checkAllDeclCoherency loadDeclNumConstructors nametree = do
{ onConstructorAlias = \x y z -> #constructorAliases %= ((x, y, z) :),
onMissingConstructorName = \x -> #missingConstructorNames %= (x :),
onNestedDeclAlias = \x y -> #nestedDeclAliases %= ((x, y) :),
onStrayConstructor = \x -> #strayConstructors %= (x :)
onStrayConstructor = \x y -> #strayConstructors %= ((x, y) :)
}
)
nametree
@ -202,7 +202,7 @@ data OnIncoherentDeclReasons m = OnIncoherentDeclReasons
{ onConstructorAlias :: Name -> Name -> Name -> m (),
onMissingConstructorName :: Name -> m (),
onNestedDeclAlias :: Name -> Name -> m (),
onStrayConstructor :: Name -> m ()
onStrayConstructor :: TypeReferenceId -> Name -> m ()
}
checkDeclCoherencyWith ::
@ -222,7 +222,12 @@ checkDeclCoherencyWith loadDeclNumConstructors callbacks =
(Nametree (DefnsF (Map NameSegment) Referent TypeReference)) ->
StateT DeclCoherencyCheckState m ()
go prefix (Nametree defns children) = do
for_ (Map.toList defns.terms) (checkDeclCoherencyWith_DoTerms callbacks prefix)
for_
(Map.toList defns.terms)
( checkDeclCoherencyWith_DoTerms
callbacks
prefix
)
childrenWeWentInto <-
forMaybe
(Map.toList defns.types)
@ -237,28 +242,25 @@ checkDeclCoherencyWith_DoTerms ::
[NameSegment] ->
(NameSegment, Referent) ->
StateT DeclCoherencyCheckState m ()
checkDeclCoherencyWith_DoTerms callbacks prefix = \case
(_, Referent.Ref _) -> pure ()
(_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure ()
(name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do
checkDeclCoherencyWith_DoTerms callbacks prefix (segment, ref) =
whenJust (Referent.toConstructorReferenceId ref) \(ConstructorReference typeRef conId) -> do
let f :: Maybe (Name, ConstructorNames) -> MaybeT m (Name, ConstructorNames)
f = \case
Nothing -> do
lift (callbacks.onStrayConstructor typeRef conName)
MaybeT (pure Nothing)
Just (typeName, expected) ->
case recordConstructorName conId conName expected of
Left existingName -> do
lift (callbacks.onConstructorAlias typeName existingName conName)
MaybeT (pure Nothing)
Right expected1 -> pure (typeName, expected1)
where
conName =
Name.fromReverseSegments (segment :| prefix)
state <- State.get
whenJustM (lift (runMaybeT (Map.upsertF f typeRef state.expectedConstructors))) \expectedConstructors1 ->
#expectedConstructors .= expectedConstructors1
where
f :: Maybe (Name, ConstructorNames) -> MaybeT m (Name, ConstructorNames)
f = \case
Nothing -> do
lift (callbacks.onStrayConstructor name1)
MaybeT (pure Nothing)
Just (typeName, expected) ->
case recordConstructorName conId name1 expected of
Left existingName -> do
lift (callbacks.onConstructorAlias typeName existingName name1)
MaybeT (pure Nothing)
Right expected1 -> pure (typeName, expected1)
where
name1 =
Name.fromReverseSegments (name :| prefix)
checkDeclCoherencyWith_DoTypes ::
forall m.
@ -273,55 +275,71 @@ checkDeclCoherencyWith_DoTypes ::
Map NameSegment (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) ->
(NameSegment, TypeReference) ->
StateT DeclCoherencyCheckState m (Maybe NameSegment)
checkDeclCoherencyWith_DoTypes loadDeclNumConstructors callbacks go prefix children = \case
(_, ReferenceBuiltin _) -> pure Nothing
(name, ReferenceDerived typeRef) -> do
state <- State.get
maybeWhatHappened <- do
let recordNewDecl ::
Maybe (Name, ConstructorNames) ->
Compose (MaybeT m) WhatHappened (Name, ConstructorNames)
recordNewDecl =
Compose . \case
Just (shorterTypeName, _) -> do
lift (callbacks.onNestedDeclAlias shorterTypeName typeName)
MaybeT (pure Nothing)
Nothing ->
lift (loadDeclNumConstructors typeRef) <&> \case
0 -> UninhabitedDecl
n -> InhabitedDecl (typeName, emptyConstructorNames n)
lift (runMaybeT (getCompose (Map.upsertF recordNewDecl typeRef state.expectedConstructors)))
case maybeWhatHappened of
Nothing -> pure Nothing
Just UninhabitedDecl -> do
#declNameLookup . #declToConstructors %= Map.insert typeName []
pure Nothing
Just (InhabitedDecl expectedConstructors1) -> do
case Map.lookup name children of
Nothing -> do
lift (callbacks.onMissingConstructorName typeName)
pure Nothing
Just child -> do
#expectedConstructors .= expectedConstructors1
go (name : prefix) child
state <- State.get
-- fromJust is safe here because we upserted `typeRef` key above
let (fromJust -> (_typeName, maybeConstructorNames), expectedConstructors1) =
Map.deleteLookup typeRef state.expectedConstructors
#expectedConstructors .= expectedConstructors1
case sequence (IntMap.elems maybeConstructorNames) of
Nothing -> lift (callbacks.onMissingConstructorName typeName)
Just constructorNames -> do
#declNameLookup . #constructorToDecl %= \constructorToDecl ->
List.foldl'
(\acc constructorName -> Map.insert constructorName typeName acc)
constructorToDecl
constructorNames
#declNameLookup . #declToConstructors %= Map.insert typeName constructorNames
pure (Just name)
where
typeName =
Name.fromReverseSegments (name :| prefix)
checkDeclCoherencyWith_DoTypes loadDeclNumConstructors callbacks go prefix children (name, ref) =
case Reference.toId ref of
Nothing -> pure Nothing
Just refId ->
checkDeclCoherencyWith_DoTypes2 loadDeclNumConstructors callbacks go prefix children name refId
checkDeclCoherencyWith_DoTypes2 ::
forall m.
(Monad m) =>
(TypeReferenceId -> m Int) ->
OnIncoherentDeclReasons m ->
( [NameSegment] ->
(Nametree (DefnsF (Map NameSegment) Referent TypeReference)) ->
StateT DeclCoherencyCheckState m ()
) ->
[NameSegment] ->
Map NameSegment (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) ->
NameSegment ->
TypeReferenceId ->
StateT DeclCoherencyCheckState m (Maybe NameSegment)
checkDeclCoherencyWith_DoTypes2 loadDeclNumConstructors callbacks go prefix children name typeRef = do
state <- State.get
lift (runMaybeT (getCompose (Map.upsertF recordNewDecl typeRef state.expectedConstructors))) >>= \case
Nothing -> pure Nothing
Just UninhabitedDecl -> do
#declNameLookup . #declToConstructors %= Map.insert typeName []
pure Nothing
Just (InhabitedDecl expectedConstructors1) -> do
case Map.lookup name children of
Nothing -> do
lift (callbacks.onMissingConstructorName typeName)
pure Nothing
Just child -> do
#expectedConstructors .= expectedConstructors1
go (name : prefix) child
state <- State.get
-- fromJust is safe here because we upserted `typeRef` key above
let (fromJust -> (_typeName, maybeConstructorNames), expectedConstructors1) =
Map.deleteLookup typeRef state.expectedConstructors
#expectedConstructors .= expectedConstructors1
case sequence (IntMap.elems maybeConstructorNames) of
Nothing -> lift (callbacks.onMissingConstructorName typeName)
Just constructorNames -> do
#declNameLookup . #constructorToDecl %= \constructorToDecl ->
List.foldl'
(\acc constructorName -> Map.insert constructorName typeName acc)
constructorToDecl
constructorNames
#declNameLookup . #declToConstructors %= Map.insert typeName constructorNames
pure (Just name)
where
typeName :: Name
typeName =
Name.fromReverseSegments (name :| prefix)
recordNewDecl :: Maybe (Name, ConstructorNames) -> Compose (MaybeT m) WhatHappened (Name, ConstructorNames)
recordNewDecl =
Compose . \case
Just (shorterTypeName, _) -> do
lift (callbacks.onNestedDeclAlias shorterTypeName typeName)
MaybeT (pure Nothing)
Nothing ->
lift (loadDeclNumConstructors typeRef) <&> \case
0 -> UninhabitedDecl
n -> InhabitedDecl (typeName, emptyConstructorNames n)
-- | A lenient variant of 'checkDeclCoherency' - so lenient it can't even fail! It returns partial decl name lookup,
-- which doesn't require a name for every constructor, and allows a constructor with a nameless decl.

4
unison-src/transcripts/diff-namespace.md
View File

@ -92,10 +92,14 @@ scratch/ns2> update
scratch/main> diff.namespace /ns1: /ns2:
scratch/ns2> alias.term d d'
scratch/ns2> alias.type A A'
scratch/ns2> alias.term A.A A'.A
scratch/ns2> alias.type X X'
scratch/ns2> alias.term X.x X'.x
scratch/main> diff.namespace /ns1: /ns2:
scratch/ns1> alias.type X X2
scratch/ns1> alias.term X.x X2.x
scratch/ns2> alias.type A' A''
scratch/ns2> alias.term A'.A A''.A
scratch/ns2> branch /ns3
scratch/ns2> alias.term fromJust' yoohoo
scratch/ns2> delete.term.verbose fromJust'

24
unison-src/transcripts/diff-namespace.output.md
View File

@ -199,10 +199,18 @@ scratch/ns2> alias.type A A'
Done.
scratch/ns2> alias.term A.A A'.A
Done.
scratch/ns2> alias.type X X'
Done.
scratch/ns2> alias.term X.x X'.x
Done.
scratch/main> diff.namespace /ns1: /ns2:
Resolved name conflicts:
@ -238,17 +246,29 @@ scratch/main> diff.namespace /ns1: /ns2:
16. X 17. X' (added)
18. fromJust' ┐ 19. fromJust#gjmq673r1v (removed)
20. fromJust#gjmq673r1v ┘
18. A.A 19. A'.A (added)
20. fromJust' ┐ 21. fromJust#gjmq673r1v (removed)
22. fromJust#gjmq673r1v ┘
23. X.x 24. X'.x (added)
scratch/ns1> alias.type X X2
Done.
scratch/ns1> alias.term X.x X2.x
Done.
scratch/ns2> alias.type A' A''
Done.
scratch/ns2> alias.term A'.A A''.A
Done.
scratch/ns2> branch /ns3
Done. I've created the ns3 branch based off of ns2.

5
unison-src/transcripts/update-on-conflict.md
View File

@ -1,6 +1,6 @@
# Update on conflict
Updating conflicted definitions works fine.
Conflicted definitions prevent `update` from succeeding.
```ucm:hide
scratch/main> builtins.merge lib.builtins
@ -21,7 +21,6 @@ scratch/main> delete.term temp
x = 3
```
```ucm
```ucm:error
scratch/main> update
scratch/main> view x
```

14
unison-src/transcripts/update-on-conflict.output.md
View File

@ -1,6 +1,6 @@
# Update on conflict
Updating conflicted definitions works fine.
Conflicted definitions prevent `update` from succeeding.
``` unison
x = 1
@ -59,14 +59,8 @@ x = 3
``` ucm
scratch/main> update
Okay, I'm searching the branch for code that needs to be
updated...
Done.
scratch/main> view x
x : Nat
x = 3
This branch has more than one term with the name `x`. Please
delete or rename all but one of them, then try the update
again.
```

6
unison-src/transcripts/update-suffixifies-properly.output.md
View File

@ -70,6 +70,11 @@ myproject/main> update
```
``` unison:added-by-ucm scratch.u
foo = +30
-- The definitions below no longer typecheck with the changes above.
-- Please fix the errors and try `update` again.
bar : Nat
bar =
use Nat +
@ -85,6 +90,5 @@ d.y.y.y.y =
use Nat +
foo + 10
foo = +30
```

8
unison-src/transcripts/update-term-with-dependent-to-different-type.output.md
View File

@ -68,12 +68,16 @@ scratch/main> update
```
``` unison:added-by-ucm scratch.u
foo : Int
foo = +5
-- The definitions below no longer typecheck with the changes above.
-- Please fix the errors and try `update` again.
bar : Nat
bar =
use Nat +
foo + 10
foo : Int
foo = +5
```

6
unison-src/transcripts/update-test-watch-roundtrip.output.md
View File

@ -51,10 +51,14 @@ scratch/main> update
```
``` unison:added-by-ucm scratch.u
foo n = "hello, world!"
-- The definitions below no longer typecheck with the changes above.
-- Please fix the errors and try `update` again.
test> mynamespace.foo.test =
n = 2
if foo n == 2 then [Ok "passed"] else [Fail "wat"]
foo n = "hello, world!"
```

5
unison-src/transcripts/update-type-constructor-alias.md
View File

@ -15,9 +15,6 @@ scratch/main> alias.term Foo.Bar Foo.BarAlias
unique type Foo = Bar Nat Nat
```
Bug: we leave `Foo.BarAlias` in the namespace with a nameless decl.
```ucm
```ucm:error
scratch/main> update
scratch/main> find.verbose
```

27
unison-src/transcripts/update-type-constructor-alias.output.md
View File

@ -45,27 +45,18 @@ unique type Foo = Bar Nat Nat
type Foo
```
Bug: we leave `Foo.BarAlias` in the namespace with a nameless decl.
``` ucm
scratch/main> update
Okay, I'm searching the branch for code that needs to be
updated...
Done.
scratch/main> find.verbose
1. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g
type Foo
2. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g#0
Foo.Bar : Nat -> Nat -> Foo
3. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60#0
Foo.BarAlias : Nat -> #b509v3eg4k
Sorry, I wasn't able to perform the update:
The type Foo has a constructor with multiple names, and I
can't perform an update in this situation:
* Foo.Bar
* Foo.BarAlias
Please delete all but one name for each constructor, and then
try updating again.
```

6
unison-src/transcripts/update-type-delete-constructor-with-dependent.output.md
View File

@ -65,11 +65,15 @@ scratch/main> update
```
``` unison:added-by-ucm scratch.u
type Foo = Bar Nat
-- The definitions below no longer typecheck with the changes above.
-- Please fix the errors and try `update` again.
foo : Foo -> Nat
foo = cases
Bar n -> n
Baz n m -> n Nat.+ m
type Foo = Bar Nat
```

6
unison-src/transcripts/update-type-delete-record-field.output.md
View File

@ -104,6 +104,11 @@ scratch/main> find.verbose
```
``` unison:added-by-ucm scratch.u
type Foo = { bar : Nat }
-- The definitions below no longer typecheck with the changes above.
-- Please fix the errors and try `update` again.
Foo.baz : Foo -> Int
Foo.baz = cases Foo _ baz -> baz
@ -113,6 +118,5 @@ Foo.baz.modify f = cases Foo bar baz -> Foo bar (f baz)
Foo.baz.set : Int -> Foo -> Foo
Foo.baz.set baz1 = cases Foo bar _ -> Foo bar baz1
type Foo = { bar : Nat }
```

12
unison-src/transcripts/update-type-missing-constructor.output.md
View File

@ -54,15 +54,13 @@ scratch/main> view Foo
scratch/main> update
Okay, I'm searching the branch for code that needs to be
updated...
I couldn't complete the update because the type Foo has
unnamed constructors. (I currently need each constructor to
have a name somewhere under the type name.)
Sorry, I wasn't able to perform the update:
The type Foo has some constructors with missing names, and I
can't perform an update in this situation.
You can use `view Foo` and
`alias.term <hash> Foo.<ConstructorName>` to give names to
each constructor, and then try the update again.
each unnamed constructor, and then try the update again.
```

4
unison-src/transcripts/update-type-nested-decl-aliases.md
View File

@ -17,10 +17,6 @@ scratch/main> add
unique type Foo = Bar Nat Nat
```
Bug: we want this update to be rejected earlier, because it violates the "decl coherency" precondition that there's
only one name for each constructor. We instead get too far in the update process, and are delivered a bogus scratch.u
file to stare at.
```ucm:error
scratch/main> update
```

24
unison-src/transcripts/update-type-nested-decl-aliases.output.md
View File

@ -48,28 +48,12 @@ unique type Foo = Bar Nat Nat
type Foo
```
Bug: we want this update to be rejected earlier, because it violates the "decl coherency" precondition that there's
only one name for each constructor. We instead get too far in the update process, and are delivered a bogus scratch.u
file to stare at.
``` ucm
scratch/main> update
Okay, I'm searching the branch for code that needs to be
updated...
That's done. Now I'm making sure everything typechecks...
Typechecking failed. I've updated your scratch file with the
definitions that need fixing. Once the file is compiling, try
`update` again.
The type A.B is an alias of A. I'm not able to perform an
update when a type exists nested under an alias of itself.
Please separate them or delete one copy, and then try updating
again.
```
``` unison:added-by-ucm scratch.u
structural type A = B.OneAlias Foo
structural type A.B = OneAlias Foo
type Foo = Bar Nat Nat
```

5
unison-src/transcripts/update-type-stray-constructor-alias.md
View File

@ -15,9 +15,6 @@ scratch/main> alias.term Foo.Bar Stray.BarAlias
unique type Foo = Bar Nat Nat
```
Bug: we leave `Stray.BarAlias` in the namespace with a nameless decl.
```ucm
```ucm:error
scratch/main> update
scratch/main> find.verbose
```

25
unison-src/transcripts/update-type-stray-constructor-alias.output.md
View File

@ -45,27 +45,16 @@ unique type Foo = Bar Nat Nat
type Foo
```
Bug: we leave `Stray.BarAlias` in the namespace with a nameless decl.
``` ucm
scratch/main> update
Okay, I'm searching the branch for code that needs to be
updated...
Done.
scratch/main> find.verbose
1. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g
type Foo
2. -- #8fk6k0j208th1ia4vnjtoc5fomd6le540prec255svg71bcfga9dofrvoq1d7v6010d6b6em4q51p8st5c5juhrev72cnnel8ko3o1g#0
Foo.Bar : Nat -> Nat -> Foo
3. -- #b509v3eg4kehsg29g6pvrogeb71ue32nm2fj9284n4i7lprsr7u9a7g6s695d09du0fsfti6rrsk1s62q5thpr1jjkqb3us3s0lrd60#0
Stray.BarAlias : Nat -> #b509v3eg4k
Sorry, I wasn't able to perform the update, because I need all
constructor names to be nested somewhere beneath the
corresponding type name.
The constructor Stray.BarAlias is not nested beneath the
corresponding type name. Please either use `move` to move it,
or if it's an extra copy, you can simply `delete` it. Then try
the update again.
```

12
unison-src/transcripts/update-type-stray-constructor.output.md
View File

@ -56,15 +56,13 @@ scratch/main> view Foo
scratch/main> update
Okay, I'm searching the branch for code that needs to be
updated...
I couldn't complete the update because the type Foo has
unnamed constructors. (I currently need each constructor to
have a name somewhere under the type name.)
Sorry, I wasn't able to perform the update:
The type Foo has some constructors with missing names, and I
can't perform an update in this situation.
You can use `view Foo` and
`alias.term <hash> Foo.<ConstructorName>` to give names to
each constructor, and then try the update again.
each unnamed constructor, and then try the update again.
```

6
unison-src/transcripts/update-type-with-dependent-term.output.md
View File

@ -60,9 +60,13 @@ scratch/main> update
```
``` unison:added-by-ucm scratch.u
type Foo = Bar Nat Nat
-- The definitions below no longer typecheck with the changes above.
-- Please fix the errors and try `update` again.
incrFoo : Foo -> Foo
incrFoo = cases Bar n -> Bar (n Nat.+ 1)
type Foo = Bar Nat Nat
```

6
unison-src/transcripts/update-type-with-dependent-type-to-different-kind.output.md
View File

@ -58,8 +58,12 @@ scratch/main> update
```
``` unison:added-by-ucm scratch.u
type Foo a = Bar Nat a
-- The definitions below no longer typecheck with the changes above.
-- Please fix the errors and try `update` again.
type Baz = Qux Foo
type Foo a = Bar Nat a
```