mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 02:25:39 +03:00
Merge pull request #5250 from unisonweb/update-defn-order
This commit is contained in:
commit
97c9109291
@ -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
|
||||
|
@ -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,
|
||||
|
@ -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
|
||||
|
||||
|
@ -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)
|
||||
|
@ -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'
|
||||
|
@ -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
363
unison-cli/src/Unison/Cli/UpdateUtils.hs
Normal 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))
|
@ -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
|
||||
|
||||
|
@ -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))
|
||||
)
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
)
|
||||
|
@ -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
|
||||
|
@ -77,6 +77,7 @@ default-extensions:
|
||||
- LambdaCase
|
||||
- MultiParamTypeClasses
|
||||
- NamedFieldPuns
|
||||
- OverloadedLabels
|
||||
- OverloadedStrings
|
||||
- OverloadedRecordDot
|
||||
- PatternSynonyms
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
10
unison-core/src/Unison/Util/Conflicted.hs
Normal 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
9
unison-core/src/Unison/Util/Defn.hs
Normal 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
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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.
|
||||
|
@ -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'
|
||||
|
@ -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.
|
||||
|
@ -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
|
||||
```
|
||||
|
@ -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.
|
||||
|
||||
```
|
||||
|
@ -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
|
||||
```
|
||||
|
||||
|
@ -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
|
||||
```
|
||||
|
||||
|
@ -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!"
|
||||
```
|
||||
|
||||
|
@ -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
|
||||
```
|
||||
|
@ -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.
|
||||
|
||||
```
|
||||
|
@ -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
|
||||
```
|
||||
|
||||
|
@ -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 }
|
||||
```
|
||||
|
||||
|
@ -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.
|
||||
|
||||
```
|
||||
|
@ -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
|
||||
```
|
||||
|
@ -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
|
||||
```
|
||||
|
||||
|
@ -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
|
||||
```
|
||||
|
@ -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.
|
||||
|
||||
```
|
||||
|
@ -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.
|
||||
|
||||
```
|
||||
|
@ -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
|
||||
```
|
||||
|
||||
|
@ -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
|
||||
```
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user