From e548c4cc257090c8c4fb808acf22c89ed51cc533 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 8 Feb 2024 10:22:31 -0800 Subject: [PATCH 01/82] Add diff types for terms --- unison-share-api/package.yaml | 1 + unison-share-api/src/Unison/Server/Types.hs | 24 ++++++++++++++++++++- unison-share-api/unison-share-api.cabal | 3 ++- 3 files changed, 26 insertions(+), 2 deletions(-) diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 1f187d691..6bea13f3d 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -17,6 +17,7 @@ dependencies: - bytes - bytestring - containers + - Diff - directory - errors - extra diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 3b80c071f..f14442f78 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -7,6 +7,7 @@ module Unison.Server.Types where import Control.Lens hiding ((.=)) import Data.Aeson import Data.Aeson qualified as Aeson +import Data.Algorithm.Diff qualified as Diff import Data.Bifoldable (Bifoldable (..)) import Data.Bitraversable (Bitraversable (..)) import Data.ByteString.Lazy qualified as LZ @@ -48,9 +49,10 @@ import Unison.Prelude import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) import Unison.Server.Doc (Doc) import Unison.Server.Orphans () -import Unison.Server.Syntax (SyntaxText) +import Unison.Server.Syntax (Element, SyntaxText) import Unison.ShortHash (ShortHash) import Unison.Syntax.HashQualified qualified as HQ (fromText) +import Unison.Util.AnnotatedText qualified as AnnotatedText import Unison.Util.Pretty (Width (..)) type APIHeaders x = @@ -234,6 +236,26 @@ data TermTag = Doc | Test | Plain | Constructor TypeTag data TypeTag = Ability | Data deriving (Eq, Ord, Show, Generic) +-- | A diff of the syntax of a term or type +newtype DiffedSyntaxText = DiffedSyntaxText (Seq (Diff.Diff (AnnotatedText.Segment Element))) + deriving stock (Eq, Show, Generic) + +-- | A diff of the syntax of a term or type +-- +-- It doesn't make sense to diff builtins with ABTs, so in that case we just provide the +-- undiffed syntax. +data DisplayObjectDiff + = DisplayObjectDiff (DisplayObject DiffedSyntaxText DiffedSyntaxText) + | MismatchedDisplayObjects (DisplayObject SyntaxText SyntaxText) (DisplayObject SyntaxText SyntaxText) + deriving stock (Show, Eq, Generic) + +data TermDiff = TermDiff + { fromTermDefinition :: TermDefinition, + toTermDefinition :: TermDefinition, + diff :: DisplayObjectDiff + } + deriving (Eq, Generic, Show) + data UnisonRef = TypeRef UnisonHash | TermRef UnisonHash diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index ca6396097..41cb68f79 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -82,7 +82,8 @@ library ImportQualifiedPost ghc-options: -Wall build-depends: - NanoID + Diff + , NanoID , aeson >=2.0.0.0 , async , base From f67052240349bdb27d2e34f26bfcf6050138a7bc Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 8 Feb 2024 10:41:50 -0800 Subject: [PATCH 02/82] JSON instances for diffs --- unison-share-api/src/Unison/Server/Types.hs | 54 +++++++++++++++++++-- 1 file changed, 51 insertions(+), 3 deletions(-) diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index f14442f78..08e5a6416 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -238,7 +238,18 @@ data TypeTag = Ability | Data -- | A diff of the syntax of a term or type newtype DiffedSyntaxText = DiffedSyntaxText (Seq (Diff.Diff (AnnotatedText.Segment Element))) - deriving stock (Eq, Show, Generic) + deriving stock (Eq, Show) + +instance ToJSON DiffedSyntaxText where + toJSON (DiffedSyntaxText diffs) = + ( diffs <&> \case + Diff.First a -> object ["diffTag" .= ("from" :: Text), "contents" .= a] + Diff.Second b -> object ["diffTag" .= ("to" :: Text), "contents" .= b] + -- Both values will be equal unless we're diffing on something other than pure + -- equality. + Diff.Both a _ -> object ["diffTag" .= ("both" :: Text), "contents" .= a] + ) + & toJSON -- | A diff of the syntax of a term or type -- @@ -247,14 +258,51 @@ newtype DiffedSyntaxText = DiffedSyntaxText (Seq (Diff.Diff (AnnotatedText.Segme data DisplayObjectDiff = DisplayObjectDiff (DisplayObject DiffedSyntaxText DiffedSyntaxText) | MismatchedDisplayObjects (DisplayObject SyntaxText SyntaxText) (DisplayObject SyntaxText SyntaxText) - deriving stock (Show, Eq, Generic) + deriving stock (Show, Eq) + +instance ToJSON DisplayObjectDiff where + toJSON = \case + DisplayObjectDiff objDiff -> + object + [ "diffKind" .= ("diffed" :: Text), + "diff" .= objDiff + ] + MismatchedDisplayObjects from to -> + object + [ "diffKind" .= ("mismatched" :: Text), + "from" .= from, + "to" .= to + ] data TermDiff = TermDiff { fromTermDefinition :: TermDefinition, toTermDefinition :: TermDefinition, diff :: DisplayObjectDiff } - deriving (Eq, Generic, Show) + deriving (Eq, Show) + +instance ToJSON TermDiff where + toJSON TermDiff {..} = + object + [ "from" .= fromTermDefinition, + "to" .= toTermDefinition, + "diff" .= diff + ] + +data TypeDiff = TypeDiff + { fromTypeDefinition :: TermDefinition, + toTypeDefinition :: TermDefinition, + diff :: DisplayObjectDiff + } + deriving (Eq, Show) + +instance ToJSON TypeDiff where + toJSON TypeDiff {..} = + object + [ "from" .= fromTypeDefinition, + "to" .= toTypeDefinition, + "diff" .= diff + ] data UnisonRef = TypeRef UnisonHash From c5aa6a0bf1432f38203314571b2abddef4610257 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 6 Mar 2024 17:47:26 -0800 Subject: [PATCH 03/82] definition diffs --- unison-share-api/src/Unison/Server/Backend.hs | 45 ++++++++++++------- .../Unison/Server/Backend/DefinitionDiff.hs | 20 +++++++++ .../src/Unison/Server/Local/Definitions.hs | 2 +- unison-share-api/src/Unison/Server/Types.hs | 41 +++++++++++------ unison-share-api/unison-share-api.cabal | 1 + 5 files changed, 79 insertions(+), 30 deletions(-) create mode 100644 unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 07a7eeefb..c506bdee2 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -14,6 +14,7 @@ module Unison.Server.Backend FoundRef (..), IncludeCycles (..), DefinitionResults (..), + SyntaxText, -- * Endpoints fuzzyFind, @@ -66,6 +67,7 @@ module Unison.Server.Backend -- * Re-exported for Share Server termsToSyntax, + termsToSyntaxOf, typesToSyntax, definitionResultsDependencies, evalDocRef, @@ -1113,19 +1115,41 @@ displayType codebase = \case decl <- Codebase.unsafeGetTypeDeclaration codebase rid pure (UserObject decl) +-- | Version of 'termsToSyntax' which works over arbitrary indexed traversals, e.g. +-- 'itraversed' +termsToSyntaxOf :: + (Var v) => + (Ord a) => + Suffixify -> + Width -> + PPED.PrettyPrintEnvDecl -> + IndexedTraversal Reference.Reference s t (DisplayObject (Type v a) (Term v a)) (DisplayObject SyntaxText SyntaxText) -> + s -> + t +termsToSyntaxOf suff width ppe0 trav s = + s & iover (iunsafePartsOf trav) (\refs displayObjs -> termsToSyntax suff width ppe0 (zip refs displayObjs)) + termsToSyntax :: (Var v) => (Ord a) => Suffixify -> Width -> PPED.PrettyPrintEnvDecl -> - Map Reference.Reference (DisplayObject (Type v a) (Term v a)) -> - Map Reference.Reference (DisplayObject SyntaxText SyntaxText) + [(Reference.Reference, (DisplayObject (Type v a) (Term v a)))] -> + [DisplayObject SyntaxText SyntaxText] termsToSyntax suff width ppe0 terms = - Map.fromList . map go . Map.toList $ - Map.mapKeys - (first (PPE.termName ppeDecl . Referent.Ref) . dupe) - terms + terms + <&> \(r, dispObj) -> + let n = PPE.termName ppeDecl . Referent.Ref $ r + in case dispObj of + DisplayObject.BuiltinObject typ -> + DisplayObject.BuiltinObject $ + formatType' (ppeBody r) width typ + DisplayObject.MissingObject sh -> DisplayObject.MissingObject sh + DisplayObject.UserObject tm -> + DisplayObject.UserObject + . Pretty.render width + $ TermPrinter.prettyBinding (ppeBody r) n tm where ppeBody r = if suffixified suff @@ -1133,15 +1157,6 @@ termsToSyntax suff width ppe0 terms = else PPE.declarationPPE ppe0 r ppeDecl = (if suffixified suff then PPED.suffixifiedPPE else PPED.unsuffixifiedPPE) ppe0 - go ((n, r), dt) = (r,) $ case dt of - DisplayObject.BuiltinObject typ -> - DisplayObject.BuiltinObject $ - formatType' (ppeBody r) width typ - DisplayObject.MissingObject sh -> DisplayObject.MissingObject sh - DisplayObject.UserObject tm -> - DisplayObject.UserObject - . Pretty.render width - $ TermPrinter.prettyBinding (ppeBody r) n tm typesToSyntax :: (Var v) => diff --git a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs new file mode 100644 index 000000000..f87f36fc5 --- /dev/null +++ b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs @@ -0,0 +1,20 @@ +module Unison.Server.Backend.DefinitionDiff (diffDisplayObjects) where + +import Data.Algorithm.Diff qualified as Diff +import Data.Foldable qualified as Foldable +import Data.Sequence qualified as Seq +import Unison.Codebase.Editor.DisplayObject (DisplayObject (..)) +import Unison.Server.Syntax (SyntaxText) +import Unison.Server.Types (DiffedSyntaxText (DiffedSyntaxText), DisplayObjectDiff (..), termDefinition) + +diffDisplayObjects :: DisplayObject SyntaxText SyntaxText -> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff +diffDisplayObjects from to = case (from, to) of + (BuiltinObject fromST, BuiltinObject toST) -> DisplayObjectDiff (BuiltinObject (diffSyntaxText fromST toST)) + (MissingObject fromSH, MissingObject toSH) + | fromSH == toSH -> DisplayObjectDiff (MissingObject fromSH) + | otherwise -> MismatchedDisplayObjects (MissingObject fromSH) (MissingObject toSH) + (UserObject fromST, UserObject toST) -> DisplayObjectDiff (UserObject (diffSyntaxText fromST toST)) + (l, r) -> MismatchedDisplayObjects l r + +diffSyntaxText :: SyntaxText -> SyntaxText -> DiffedSyntaxText +diffSyntaxText fromST toST = DiffedSyntaxText $ Seq.fromList $ Diff.getDiff (Foldable.toList fromST) (Foldable.toList toST) diff --git a/unison-share-api/src/Unison/Server/Local/Definitions.hs b/unison-share-api/src/Unison/Server/Local/Definitions.hs index 248dc12e9..41dad4121 100644 --- a/unison-share-api/src/Unison/Server/Local/Definitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Definitions.hs @@ -82,7 +82,7 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTypeName)) mkTypeDefinition codebase pped width ref docs tp termDefinitions <- - ifor (termsToSyntax suffixifyBindings width pped terms) \reference trm -> do + ifor (termsToSyntaxOf suffixifyBindings width pped itraversed terms) \reference trm -> do let referent = Referent.Ref reference let hqTermName = PPE.termNameOrHashOnly fqnPPE referent docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTermName)) diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 84e212073..286f19956 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -47,11 +47,10 @@ import Unison.Prelude import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) import Unison.Server.Doc (Doc) import Unison.Server.Orphans () -import Unison.Server.Syntax (Element, SyntaxText) +import Unison.Server.Syntax qualified as Syntax import Unison.ShortHash (ShortHash) import Unison.Syntax.HashQualified qualified as HQ (parseText) import Unison.Syntax.Name qualified as Name -import Unison.Util.AnnotatedText qualified as AnnotatedText import Unison.Util.Pretty (Width (..)) type APIHeaders x = @@ -193,6 +192,20 @@ instance ToJSON DefinitionDisplayResults where deriving instance ToSchema DefinitionDisplayResults +data TermDefinitionDiff = TermDefinitionDiff + { left :: TermDefinition, + right :: TermDefinition, + diff :: DisplayObjectDiff + } + deriving (Eq, Show, Generic) + +data TypeDefinitionDiff = TypeDefinitionDiff + { left :: TypeDefinition, + right :: TypeDefinition, + diff :: DisplayObjectDiff + } + deriving (Eq, Show, Generic) + newtype Suffixify = Suffixify {suffixified :: Bool} deriving (Eq, Ord, Show, Generic) @@ -200,8 +213,8 @@ data TermDefinition = TermDefinition { termNames :: [HashQualifiedName], bestTermName :: HashQualifiedName, defnTermTag :: TermTag, - termDefinition :: DisplayObject SyntaxText SyntaxText, - signature :: SyntaxText, + termDefinition :: DisplayObject Syntax.SyntaxText Syntax.SyntaxText, + signature :: Syntax.SyntaxText, termDocs :: [(HashQualifiedName, UnisonHash, Doc)] } deriving (Eq, Show, Generic) @@ -210,7 +223,7 @@ data TypeDefinition = TypeDefinition { typeNames :: [HashQualifiedName], bestTypeName :: HashQualifiedName, defnTypeTag :: TypeTag, - typeDefinition :: DisplayObject SyntaxText SyntaxText, + typeDefinition :: DisplayObject Syntax.SyntaxText Syntax.SyntaxText, typeDocs :: [(HashQualifiedName, UnisonHash, Doc)] } deriving (Eq, Show, Generic) @@ -236,7 +249,7 @@ data TypeTag = Ability | Data deriving (Eq, Ord, Show, Generic) -- | A diff of the syntax of a term or type -newtype DiffedSyntaxText = DiffedSyntaxText (Seq (Diff.Diff (AnnotatedText.Segment Element))) +newtype DiffedSyntaxText = DiffedSyntaxText (Seq (Diff.Diff Syntax.Element)) deriving stock (Eq, Show) instance ToJSON DiffedSyntaxText where @@ -256,7 +269,7 @@ instance ToJSON DiffedSyntaxText where -- undiffed syntax. data DisplayObjectDiff = DisplayObjectDiff (DisplayObject DiffedSyntaxText DiffedSyntaxText) - | MismatchedDisplayObjects (DisplayObject SyntaxText SyntaxText) (DisplayObject SyntaxText SyntaxText) + | MismatchedDisplayObjects (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) deriving stock (Show, Eq) instance ToJSON DisplayObjectDiff where @@ -273,30 +286,30 @@ instance ToJSON DisplayObjectDiff where "to" .= to ] -data TermDiff = TermDiff +data TermDiffResponse = TermDiffResponse { fromTermDefinition :: TermDefinition, toTermDefinition :: TermDefinition, diff :: DisplayObjectDiff } deriving (Eq, Show) -instance ToJSON TermDiff where - toJSON TermDiff {..} = +instance ToJSON TermDiffResponse where + toJSON TermDiffResponse {..} = object [ "from" .= fromTermDefinition, "to" .= toTermDefinition, "diff" .= diff ] -data TypeDiff = TypeDiff +data TypeDiffResponse = TypeDiffResponse { fromTypeDefinition :: TermDefinition, toTypeDefinition :: TermDefinition, diff :: DisplayObjectDiff } deriving (Eq, Show) -instance ToJSON TypeDiff where - toJSON TypeDiff {..} = +instance ToJSON TypeDiffResponse where + toJSON TypeDiffResponse {..} = object [ "from" .= fromTypeDefinition, "to" .= toTypeDefinition, @@ -317,7 +330,7 @@ data NamedTerm = NamedTerm { -- The name of the term, should be hash qualified if conflicted, otherwise name only. termName :: HQ'.HashQualified Name, termHash :: ShortHash, - termType :: Maybe SyntaxText, + termType :: Maybe Syntax.SyntaxText, termTag :: TermTag } deriving (Eq, Generic, Show) diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index 41cb68f79..3741a1861 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -18,6 +18,7 @@ source-repository head library exposed-modules: Unison.Server.Backend + Unison.Server.Backend.DefinitionDiff Unison.Server.CodebaseServer Unison.Server.Doc Unison.Server.Doc.AsHtml From ae3c01964c4d24cdc5001b8c9383025e48fd17e4 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 7 Mar 2024 10:47:55 -0800 Subject: [PATCH 04/82] Add single typeDefinition fetching helpers --- lib/unison-prelude/src/Unison/Util/Map.hs | 9 ++++ unison-share-api/src/Unison/Server/Backend.hs | 52 ++++++++++++------- .../Unison/Server/Backend/DefinitionDiff.hs | 2 +- .../src/Unison/Server/Local/Definitions.hs | 5 +- 4 files changed, 45 insertions(+), 23 deletions(-) diff --git a/lib/unison-prelude/src/Unison/Util/Map.hs b/lib/unison-prelude/src/Unison/Util/Map.hs index 9609cf8a5..06dc63b24 100644 --- a/lib/unison-prelude/src/Unison/Util/Map.hs +++ b/lib/unison-prelude/src/Unison/Util/Map.hs @@ -13,6 +13,7 @@ module Unison.Util.Map upsert, upsertF, valuesVector, + asList_, ) where @@ -36,6 +37,14 @@ bitraversed :: (Ord a', Ord k') => Traversal k k' a a' -> Traversal v v' a a' -> bitraversed keyT valT f m = bitraverse (keyT f) (valT f) m +-- | A 'Traversal' for the list of key-value pairs in a 'Map'. +asList_ :: Ord k' => Traversal (Map k v) (Map k' v') [(k, v)] [(k', v')] +asList_ f s = + s + & Map.toList + & f + <&> Map.fromList + -- | 'swap' throws away data if the input contains duplicate values swap :: (Ord b) => Map a b -> Map b a swap = diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index c506bdee2..31aa3217c 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -69,6 +69,7 @@ module Unison.Server.Backend termsToSyntax, termsToSyntaxOf, typesToSyntax, + typesToSyntaxOf, definitionResultsDependencies, evalDocRef, mkTermDefinition, @@ -90,7 +91,6 @@ import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding qualified as TextE import Data.Text.Lazy (toStrict) -import Data.Tuple.Extra (dupe) import Data.Yaml qualified as Yaml import Lucid qualified import System.Directory @@ -149,7 +149,7 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Project.Util qualified as ProjectUtils -import Unison.Reference (Reference, TermReference) +import Unison.Reference (Reference, TermReference, TypeReference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent @@ -1123,11 +1123,11 @@ termsToSyntaxOf :: Suffixify -> Width -> PPED.PrettyPrintEnvDecl -> - IndexedTraversal Reference.Reference s t (DisplayObject (Type v a) (Term v a)) (DisplayObject SyntaxText SyntaxText) -> + Traversal s t (TermReference, DisplayObject (Type v a) (Term v a)) (TermReference, DisplayObject SyntaxText SyntaxText) -> s -> t termsToSyntaxOf suff width ppe0 trav s = - s & iover (iunsafePartsOf trav) (\refs displayObjs -> termsToSyntax suff width ppe0 (zip refs displayObjs)) + s & over (unsafePartsOf trav) (\displayObjs -> termsToSyntax suff width ppe0 displayObjs) termsToSyntax :: (Var v) => @@ -1135,13 +1135,13 @@ termsToSyntax :: Suffixify -> Width -> PPED.PrettyPrintEnvDecl -> - [(Reference.Reference, (DisplayObject (Type v a) (Term v a)))] -> - [DisplayObject SyntaxText SyntaxText] + [(TermReference, (DisplayObject (Type v a) (Term v a)))] -> + [(TermReference, DisplayObject SyntaxText SyntaxText)] termsToSyntax suff width ppe0 terms = terms <&> \(r, dispObj) -> let n = PPE.termName ppeDecl . Referent.Ref $ r - in case dispObj of + in (r,) case dispObj of DisplayObject.BuiltinObject typ -> DisplayObject.BuiltinObject $ formatType' (ppeBody r) width typ @@ -1158,31 +1158,43 @@ termsToSyntax suff width ppe0 terms = ppeDecl = (if suffixified suff then PPED.suffixifiedPPE else PPED.unsuffixifiedPPE) ppe0 +-- | Version of 'termsToSyntax' which works over arbitrary indexed traversals, e.g. +-- 'itraversed' +typesToSyntaxOf :: + (Var v) => + (Ord a) => + Suffixify -> + Width -> + PPED.PrettyPrintEnvDecl -> + Traversal s t (TypeReference, DisplayObject () (DD.Decl v a)) (TypeReference, DisplayObject SyntaxText SyntaxText) -> + s -> + t +typesToSyntaxOf suff width ppe0 trav s = + s & over (unsafePartsOf trav) (typesToSyntax suff width ppe0) + typesToSyntax :: (Var v) => (Ord a) => Suffixify -> Width -> PPED.PrettyPrintEnvDecl -> - Map Reference.Reference (DisplayObject () (DD.Decl v a)) -> - Map Reference.Reference (DisplayObject SyntaxText SyntaxText) + [(TypeReference, (DisplayObject () (DD.Decl v a)))] -> + [(TypeReference, (DisplayObject SyntaxText SyntaxText))] typesToSyntax suff width ppe0 types = - Map.fromList $ - map go . Map.toList $ - Map.mapKeys - (first (PPE.typeName ppeDecl) . dupe) - types + types + <&> \(r, dispObj) -> + let n = PPE.typeName ppeDecl r + in (r,) $ case dispObj of + BuiltinObject _ -> BuiltinObject (formatTypeName' ppeDecl r) + MissingObject sh -> MissingObject sh + UserObject d -> + UserObject . Pretty.render width $ + DeclPrinter.prettyDecl (PPE.declarationPPEDecl ppe0 r) r n d where ppeDecl = if suffixified suff then PPED.suffixifiedPPE ppe0 else PPED.unsuffixifiedPPE ppe0 - go ((n, r), dt) = (r,) $ case dt of - BuiltinObject _ -> BuiltinObject (formatTypeName' ppeDecl r) - MissingObject sh -> MissingObject sh - UserObject d -> - UserObject . Pretty.render width $ - DeclPrinter.prettyDecl (PPE.declarationPPEDecl ppe0 r) r n d -- | Renders a type to its decl header, e.g. -- diff --git a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs index f87f36fc5..22c2afe1a 100644 --- a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs +++ b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs @@ -5,7 +5,7 @@ import Data.Foldable qualified as Foldable import Data.Sequence qualified as Seq import Unison.Codebase.Editor.DisplayObject (DisplayObject (..)) import Unison.Server.Syntax (SyntaxText) -import Unison.Server.Types (DiffedSyntaxText (DiffedSyntaxText), DisplayObjectDiff (..), termDefinition) +import Unison.Server.Types (DiffedSyntaxText (DiffedSyntaxText), DisplayObjectDiff (..)) diffDisplayObjects :: DisplayObject SyntaxText SyntaxText -> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff diffDisplayObjects from to = case (from, to) of diff --git a/unison-share-api/src/Unison/Server/Local/Definitions.hs b/unison-share-api/src/Unison/Server/Local/Definitions.hs index 41dad4121..97f9cd606 100644 --- a/unison-share-api/src/Unison/Server/Local/Definitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Definitions.hs @@ -26,6 +26,7 @@ import Unison.Server.Types import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Syntax.HashQualified qualified as HQ (toText) +import Unison.Util.Map qualified as Map import Unison.Util.Pretty (Width) -- | Renders a definition for the given name or hash alongside its documentation. @@ -77,12 +78,12 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings let fqnPPE = PPED.unsuffixifiedPPE pped typeDefinitions <- - ifor (typesToSyntax suffixifyBindings width pped types) \ref tp -> do + ifor (typesToSyntaxOf suffixifyBindings width pped (Map.asList_ . traversed) types) \ref tp -> do let hqTypeName = PPE.typeNameOrHashOnly fqnPPE ref docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTypeName)) mkTypeDefinition codebase pped width ref docs tp termDefinitions <- - ifor (termsToSyntaxOf suffixifyBindings width pped itraversed terms) \reference trm -> do + ifor (termsToSyntaxOf suffixifyBindings width pped (Map.asList_ . traversed) terms) \reference trm -> do let referent = Referent.Ref reference let hqTermName = PPE.termNameOrHashOnly fqnPPE referent docs <- liftIO $ (maybe (pure []) docResults (HQ.toName hqTermName)) From 2457dbf3c88893d9658204be57b17fd92830808f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 7 Mar 2024 11:24:34 -0800 Subject: [PATCH 05/82] Fix syntax text diffing --- unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs | 4 +++- unison-share-api/src/Unison/Server/Types.hs | 2 +- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs index 22c2afe1a..5bb50f48f 100644 --- a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs +++ b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs @@ -2,10 +2,12 @@ module Unison.Server.Backend.DefinitionDiff (diffDisplayObjects) where import Data.Algorithm.Diff qualified as Diff import Data.Foldable qualified as Foldable +import Data.Sequence (Seq) import Data.Sequence qualified as Seq import Unison.Codebase.Editor.DisplayObject (DisplayObject (..)) import Unison.Server.Syntax (SyntaxText) import Unison.Server.Types (DiffedSyntaxText (DiffedSyntaxText), DisplayObjectDiff (..)) +import Unison.Util.AnnotatedText (AnnotatedText (..)) diffDisplayObjects :: DisplayObject SyntaxText SyntaxText -> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff diffDisplayObjects from to = case (from, to) of @@ -17,4 +19,4 @@ diffDisplayObjects from to = case (from, to) of (l, r) -> MismatchedDisplayObjects l r diffSyntaxText :: SyntaxText -> SyntaxText -> DiffedSyntaxText -diffSyntaxText fromST toST = DiffedSyntaxText $ Seq.fromList $ Diff.getDiff (Foldable.toList fromST) (Foldable.toList toST) +diffSyntaxText (AnnotatedText fromST) (AnnotatedText toST) = DiffedSyntaxText $ Seq.fromList $ Diff.getDiff (Foldable.toList @Seq fromST) (Foldable.toList @Seq toST) diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 286f19956..d13640f7e 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -249,7 +249,7 @@ data TypeTag = Ability | Data deriving (Eq, Ord, Show, Generic) -- | A diff of the syntax of a term or type -newtype DiffedSyntaxText = DiffedSyntaxText (Seq (Diff.Diff Syntax.Element)) +newtype DiffedSyntaxText = DiffedSyntaxText (Seq (Diff.Diff Syntax.SyntaxSegment)) deriving stock (Eq, Show) instance ToJSON DiffedSyntaxText where From f59acef785b3adfe41c9484097305dfea2e719d4 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 8 Mar 2024 09:03:42 -0800 Subject: [PATCH 06/82] Clean unneeded pragma --- .../Unison/Server/Backend/DefinitionDiff.hs | 42 ++++++++++++-- unison-share-api/src/Unison/Server/Types.hs | 56 ++++++++++++++----- 2 files changed, 78 insertions(+), 20 deletions(-) diff --git a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs index 5bb50f48f..3e4d45c32 100644 --- a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs +++ b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs @@ -2,12 +2,15 @@ module Unison.Server.Backend.DefinitionDiff (diffDisplayObjects) where import Data.Algorithm.Diff qualified as Diff import Data.Foldable qualified as Foldable -import Data.Sequence (Seq) -import Data.Sequence qualified as Seq +import Data.Function +import Data.List qualified as List import Unison.Codebase.Editor.DisplayObject (DisplayObject (..)) +import Unison.Prelude import Unison.Server.Syntax (SyntaxText) -import Unison.Server.Types (DiffedSyntaxText (DiffedSyntaxText), DisplayObjectDiff (..)) +import Unison.Server.Syntax qualified as Syntax +import Unison.Server.Types (DisplayObjectDiff (..), SemanticSyntaxDiff (..)) import Unison.Util.AnnotatedText (AnnotatedText (..)) +import Unison.Util.AnnotatedText qualified as AT diffDisplayObjects :: DisplayObject SyntaxText SyntaxText -> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff diffDisplayObjects from to = case (from, to) of @@ -18,5 +21,34 @@ diffDisplayObjects from to = case (from, to) of (UserObject fromST, UserObject toST) -> DisplayObjectDiff (UserObject (diffSyntaxText fromST toST)) (l, r) -> MismatchedDisplayObjects l r -diffSyntaxText :: SyntaxText -> SyntaxText -> DiffedSyntaxText -diffSyntaxText (AnnotatedText fromST) (AnnotatedText toST) = DiffedSyntaxText $ Seq.fromList $ Diff.getDiff (Foldable.toList @Seq fromST) (Foldable.toList @Seq toST) +diffSyntaxText :: HasCallStack => SyntaxText -> SyntaxText -> [SemanticSyntaxDiff] +diffSyntaxText (AnnotatedText fromST) (AnnotatedText toST) = + Diff.getGroupedDiffBy + diffEq + (Foldable.toList @Seq fromST) + (Foldable.toList @Seq toST) + & parseGroups + where + diffEq :: AT.Segment Syntax.Element -> AT.Segment Syntax.Element -> Bool + diffEq (AT.Segment {segment = fromSegment, annotation = fromAnnotation}) (AT.Segment {segment = toSegment, annotation = toAnnotation}) = + fromSegment == toSegment || fromAnnotation == toAnnotation + parseGroups :: [Diff.Diff [AT.Segment (Syntax.Element)]] -> [SemanticSyntaxDiff] + parseGroups xs = + xs + & foldMap \case + Diff.First ys -> [From ys] + Diff.Second ys -> [To ys] + Diff.Both from to -> + zipWith go from to + & (flip List.foldr []) + ( \next acc -> case (acc, next) of + (Both xs : rest, Left seg) -> Both (seg : xs) : rest + (_, Left seg) -> Both [seg] : acc + (_, Right diff) -> diff : acc + ) + go :: AT.Segment Syntax.Element -> AT.Segment Syntax.Element -> Either (AT.Segment Syntax.Element) SemanticSyntaxDiff + go fromSegment toSegment + | fromSegment == toSegment = Left fromSegment + | AT.annotation fromSegment == AT.annotation toSegment = Right (SegmentChange (AT.segment fromSegment, AT.segment toSegment) (AT.annotation fromSegment)) + | AT.segment fromSegment == AT.segment toSegment = Right (AnnotationChange (AT.segment fromSegment) (AT.annotation fromSegment, AT.annotation toSegment)) + | otherwise = error "diffSyntaxText: found Syntax Elements in 'both' which have nothing in common." diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index d13640f7e..08516d111 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -7,7 +7,6 @@ module Unison.Server.Types where import Control.Lens hiding ((.=)) import Data.Aeson import Data.Aeson qualified as Aeson -import Data.Algorithm.Diff qualified as Diff import Data.Bifoldable (Bifoldable (..)) import Data.Bitraversable (Bitraversable (..)) import Data.ByteString.Lazy qualified as LZ @@ -248,27 +247,54 @@ data TermTag = Doc | Test | Plain | Constructor TypeTag data TypeTag = Ability | Data deriving (Eq, Ord, Show, Generic) --- | A diff of the syntax of a term or type -newtype DiffedSyntaxText = DiffedSyntaxText (Seq (Diff.Diff Syntax.SyntaxSegment)) - deriving stock (Eq, Show) +data SemanticSyntaxDiff + = From [Syntax.SyntaxSegment] + | To [Syntax.SyntaxSegment] + | Both [Syntax.SyntaxSegment] + | -- (fromSegment, toSegment) (shared annotation) + SegmentChange (String, String) (Maybe Syntax.Element) + | -- (shared segment) (fromAnnotation, toAnnotation) + AnnotationChange String (Maybe Syntax.Element, Maybe Syntax.Element) + deriving (Eq, Show) -instance ToJSON DiffedSyntaxText where - toJSON (DiffedSyntaxText diffs) = - ( diffs <&> \case - Diff.First a -> object ["diffTag" .= ("from" :: Text), "contents" .= a] - Diff.Second b -> object ["diffTag" .= ("to" :: Text), "contents" .= b] - -- Both values will be equal unless we're diffing on something other than pure - -- equality. - Diff.Both a _ -> object ["diffTag" .= ("both" :: Text), "contents" .= a] - ) - & toJSON +instance ToJSON SemanticSyntaxDiff where + toJSON = \case + From segments -> + object + [ "diffTag" .= ("from" :: Text), + "elements" .= segments + ] + To segments -> + object + [ "diffTag" .= ("to" :: Text), + "elements" .= segments + ] + Both segments -> + object + [ "diffTag" .= ("both" :: Text), + "elements" .= segments + ] + SegmentChange (fromSegment, toSegment) annotation -> + object + [ "diffTag" .= ("segmentChange" :: Text), + "fromSegment" .= fromSegment, + "toSegment" .= toSegment, + "annotation" .= annotation + ] + AnnotationChange segment (fromAnnotation, toAnnotation) -> + object + [ "diffTag" .= ("annotationChange" :: Text), + "segment" .= segment, + "fromAnnotation" .= fromAnnotation, + "toAnnotation" .= toAnnotation + ] -- | A diff of the syntax of a term or type -- -- It doesn't make sense to diff builtins with ABTs, so in that case we just provide the -- undiffed syntax. data DisplayObjectDiff - = DisplayObjectDiff (DisplayObject DiffedSyntaxText DiffedSyntaxText) + = DisplayObjectDiff (DisplayObject [SemanticSyntaxDiff] [SemanticSyntaxDiff]) | MismatchedDisplayObjects (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) deriving stock (Show, Eq) From 5a434d360cdd0765eacf4a0c9adc979dec9f0269 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 8 Mar 2024 09:18:38 -0800 Subject: [PATCH 07/82] Docs --- lib/unison-prelude/src/Unison/Util/Map.hs | 3 +- unison-share-api/src/Unison/Server/Backend.hs | 35 ++++++++++++++++--- .../Unison/Server/Backend/DefinitionDiff.hs | 27 +++++++++----- unison-share-api/src/Unison/Server/Types.hs | 3 ++ 4 files changed, 54 insertions(+), 14 deletions(-) diff --git a/lib/unison-prelude/src/Unison/Util/Map.hs b/lib/unison-prelude/src/Unison/Util/Map.hs index 06dc63b24..c46cc3fd7 100644 --- a/lib/unison-prelude/src/Unison/Util/Map.hs +++ b/lib/unison-prelude/src/Unison/Util/Map.hs @@ -37,7 +37,8 @@ bitraversed :: (Ord a', Ord k') => Traversal k k' a a' -> Traversal v v' a a' -> bitraversed keyT valT f m = bitraverse (keyT f) (valT f) m --- | A 'Traversal' for the list of key-value pairs in a 'Map'. +-- | Traverse a map as a list of key-value pairs. +-- Note: This can have unexpected results if the result contains duplicate keys. asList_ :: Ord k' => Traversal (Map k v) (Map k' v') [(k, v)] [(k', v')] asList_ f s = s diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 31aa3217c..de60cc969 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -1115,8 +1115,21 @@ displayType codebase = \case decl <- Codebase.unsafeGetTypeDeclaration codebase rid pure (UserObject decl) --- | Version of 'termsToSyntax' which works over arbitrary indexed traversals, e.g. --- 'itraversed' +-- | Version of 'termsToSyntax' which works over arbitrary traversals. +-- +-- E.g. +-- @@ +-- termsToSyntaxOf suff width pped traversed [(ref, dispObj)] +-- +-- or +-- +-- termsToSyntaxOf suff width pped id (ref, dispObj) +-- +-- or +-- +-- termsToSyntaxOf suff width pped Map.asList_ (Map.singleton ref dispObj) +-- @@ +-- e.g. 'traversed' termsToSyntaxOf :: (Var v) => (Ord a) => @@ -1129,6 +1142,7 @@ termsToSyntaxOf :: termsToSyntaxOf suff width ppe0 trav s = s & over (unsafePartsOf trav) (\displayObjs -> termsToSyntax suff width ppe0 displayObjs) +-- | Converts Type Display Objects into Syntax Text. termsToSyntax :: (Var v) => (Ord a) => @@ -1158,8 +1172,20 @@ termsToSyntax suff width ppe0 terms = ppeDecl = (if suffixified suff then PPED.suffixifiedPPE else PPED.unsuffixifiedPPE) ppe0 --- | Version of 'termsToSyntax' which works over arbitrary indexed traversals, e.g. --- 'itraversed' +-- | Version of 'typesToSyntax' which works over arbitrary traversals. +-- +-- E.g. +-- @@ +-- typesToSyntaxOf suff width pped traversed [(ref, dispObj)] +-- +-- or +-- +-- typesToSyntaxOf suff width pped id (ref, dispObj) +-- +-- or +-- +-- typesToSyntaxOf suff width pped Map.asList_ (Map.singleton ref dispObj) +-- @@ typesToSyntaxOf :: (Var v) => (Ord a) => @@ -1172,6 +1198,7 @@ typesToSyntaxOf :: typesToSyntaxOf suff width ppe0 trav s = s & over (unsafePartsOf trav) (typesToSyntax suff width ppe0) +-- | Converts Type Display Objects into Syntax Text. typesToSyntax :: (Var v) => (Ord a) => diff --git a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs index 3e4d45c32..e6a8dc6d1 100644 --- a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs +++ b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs @@ -1,4 +1,8 @@ -module Unison.Server.Backend.DefinitionDiff (diffDisplayObjects) where +-- | Utilities for displaying diffs between definitions. +module Unison.Server.Backend.DefinitionDiff + ( diffDisplayObjects, + ) +where import Data.Algorithm.Diff qualified as Diff import Data.Foldable qualified as Foldable @@ -12,7 +16,7 @@ import Unison.Server.Types (DisplayObjectDiff (..), SemanticSyntaxDiff (..)) import Unison.Util.AnnotatedText (AnnotatedText (..)) import Unison.Util.AnnotatedText qualified as AT -diffDisplayObjects :: DisplayObject SyntaxText SyntaxText -> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff +diffDisplayObjects :: HasCallStack => DisplayObject SyntaxText SyntaxText -> DisplayObject SyntaxText SyntaxText -> DisplayObjectDiff diffDisplayObjects from to = case (from, to) of (BuiltinObject fromST, BuiltinObject toST) -> DisplayObjectDiff (BuiltinObject (diffSyntaxText fromST toST)) (MissingObject fromSH, MissingObject toSH) @@ -21,33 +25,38 @@ diffDisplayObjects from to = case (from, to) of (UserObject fromST, UserObject toST) -> DisplayObjectDiff (UserObject (diffSyntaxText fromST toST)) (l, r) -> MismatchedDisplayObjects l r -diffSyntaxText :: HasCallStack => SyntaxText -> SyntaxText -> [SemanticSyntaxDiff] +diffSyntaxText :: SyntaxText -> SyntaxText -> [SemanticSyntaxDiff] diffSyntaxText (AnnotatedText fromST) (AnnotatedText toST) = Diff.getGroupedDiffBy diffEq (Foldable.toList @Seq fromST) (Foldable.toList @Seq toST) - & parseGroups + & expandSpecialCases where + -- We special-case situations where the name of a definition changed but its hash didn't; + -- and cases where the name didn't change but the hash did. + -- So, we treat these elements as equal then detect them in a post-processing step. diffEq :: AT.Segment Syntax.Element -> AT.Segment Syntax.Element -> Bool diffEq (AT.Segment {segment = fromSegment, annotation = fromAnnotation}) (AT.Segment {segment = toSegment, annotation = toAnnotation}) = fromSegment == toSegment || fromAnnotation == toAnnotation - parseGroups :: [Diff.Diff [AT.Segment (Syntax.Element)]] -> [SemanticSyntaxDiff] - parseGroups xs = + + expandSpecialCases :: [Diff.Diff [AT.Segment (Syntax.Element)]] -> [SemanticSyntaxDiff] + expandSpecialCases xs = xs & foldMap \case Diff.First ys -> [From ys] Diff.Second ys -> [To ys] Diff.Both from to -> - zipWith go from to + -- Each list should always be the same length. + zipWith detectSpecialCase from to & (flip List.foldr []) ( \next acc -> case (acc, next) of (Both xs : rest, Left seg) -> Both (seg : xs) : rest (_, Left seg) -> Both [seg] : acc (_, Right diff) -> diff : acc ) - go :: AT.Segment Syntax.Element -> AT.Segment Syntax.Element -> Either (AT.Segment Syntax.Element) SemanticSyntaxDiff - go fromSegment toSegment + detectSpecialCase :: AT.Segment Syntax.Element -> AT.Segment Syntax.Element -> Either (AT.Segment Syntax.Element) SemanticSyntaxDiff + detectSpecialCase fromSegment toSegment | fromSegment == toSegment = Left fromSegment | AT.annotation fromSegment == AT.annotation toSegment = Right (SegmentChange (AT.segment fromSegment, AT.segment toSegment) (AT.annotation fromSegment)) | AT.segment fromSegment == AT.segment toSegment = Right (AnnotationChange (AT.segment fromSegment) (AT.annotation fromSegment, AT.annotation toSegment)) diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 08516d111..81737db2c 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -247,6 +247,9 @@ data TermTag = Doc | Test | Plain | Constructor TypeTag data TypeTag = Ability | Data deriving (Eq, Ord, Show, Generic) +-- | A type for semantic diffing of definitions. +-- Includes special-cases for when the name in a definition has changed but the hash hasn't +-- (rename/alias), and when the hash has changed but the name hasn't (update propagation). data SemanticSyntaxDiff = From [Syntax.SyntaxSegment] | To [Syntax.SyntaxSegment] From fbd3d553971ce948181a9bd040ba7649c7150f75 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 8 Mar 2024 10:48:56 -0800 Subject: [PATCH 08/82] Remove unused diff responses --- unison-share-api/src/Unison/Server/Types.hs | 44 --------------------- 1 file changed, 44 deletions(-) diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 81737db2c..10d133f01 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -301,50 +301,6 @@ data DisplayObjectDiff | MismatchedDisplayObjects (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) deriving stock (Show, Eq) -instance ToJSON DisplayObjectDiff where - toJSON = \case - DisplayObjectDiff objDiff -> - object - [ "diffKind" .= ("diffed" :: Text), - "diff" .= objDiff - ] - MismatchedDisplayObjects from to -> - object - [ "diffKind" .= ("mismatched" :: Text), - "from" .= from, - "to" .= to - ] - -data TermDiffResponse = TermDiffResponse - { fromTermDefinition :: TermDefinition, - toTermDefinition :: TermDefinition, - diff :: DisplayObjectDiff - } - deriving (Eq, Show) - -instance ToJSON TermDiffResponse where - toJSON TermDiffResponse {..} = - object - [ "from" .= fromTermDefinition, - "to" .= toTermDefinition, - "diff" .= diff - ] - -data TypeDiffResponse = TypeDiffResponse - { fromTypeDefinition :: TermDefinition, - toTypeDefinition :: TermDefinition, - diff :: DisplayObjectDiff - } - deriving (Eq, Show) - -instance ToJSON TypeDiffResponse where - toJSON TypeDiffResponse {..} = - object - [ "from" .= fromTypeDefinition, - "to" .= toTypeDefinition, - "diff" .= diff - ] - data UnisonRef = TypeRef UnisonHash | TermRef UnisonHash From 6b6cd4581de0573235eb5b4e0b4179281ae3a67a Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 17 Apr 2024 15:20:08 -0700 Subject: [PATCH 09/82] Rename diffing primitives From/To -> Old/New --- .../src/Unison/Server/Backend/DefinitionDiff.hs | 4 ++-- unison-share-api/src/Unison/Server/Types.hs | 12 ++++++------ 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs index e6a8dc6d1..443f06454 100644 --- a/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs +++ b/unison-share-api/src/Unison/Server/Backend/DefinitionDiff.hs @@ -44,8 +44,8 @@ diffSyntaxText (AnnotatedText fromST) (AnnotatedText toST) = expandSpecialCases xs = xs & foldMap \case - Diff.First ys -> [From ys] - Diff.Second ys -> [To ys] + Diff.First ys -> [Old ys] + Diff.Second ys -> [New ys] Diff.Both from to -> -- Each list should always be the same length. zipWith detectSpecialCase from to diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 10d133f01..7df2845c3 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -251,8 +251,8 @@ data TypeTag = Ability | Data -- Includes special-cases for when the name in a definition has changed but the hash hasn't -- (rename/alias), and when the hash has changed but the name hasn't (update propagation). data SemanticSyntaxDiff - = From [Syntax.SyntaxSegment] - | To [Syntax.SyntaxSegment] + = Old [Syntax.SyntaxSegment] + | New [Syntax.SyntaxSegment] | Both [Syntax.SyntaxSegment] | -- (fromSegment, toSegment) (shared annotation) SegmentChange (String, String) (Maybe Syntax.Element) @@ -262,14 +262,14 @@ data SemanticSyntaxDiff instance ToJSON SemanticSyntaxDiff where toJSON = \case - From segments -> + Old segments -> object - [ "diffTag" .= ("from" :: Text), + [ "diffTag" .= ("old" :: Text), "elements" .= segments ] - To segments -> + New segments -> object - [ "diffTag" .= ("to" :: Text), + [ "diffTag" .= ("new" :: Text), "elements" .= segments ] Both segments -> From 6dcd616bcd9f23f277b35901c8e5a7b775bb966a Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 8 May 2024 11:57:58 -0400 Subject: [PATCH 10/82] pull up where we load a git-pulled branch into memory --- parser-typechecker/src/Unison/Codebase.hs | 35 ++++++------------- .../src/Unison/Codebase/GitError.hs | 3 +- .../Codebase/Editor/HandleInput/Pull.hs | 6 ++-- .../src/Unison/CommandLine/OutputMessages.hs | 7 ---- 4 files changed, 16 insertions(+), 35 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 3d81e9968..af2f3db5a 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -114,8 +114,6 @@ module Unison.Codebase ) where -import Control.Monad.Except (ExceptT (ExceptT), runExceptT) -import Control.Monad.Trans.Except (throwE) import Data.Map qualified as Map import Data.Set qualified as Set import U.Codebase.Branch qualified as V2 @@ -133,18 +131,12 @@ import Unison.Codebase.CodeLookup qualified as CL import Unison.Codebase.Editor.Git (withStatus) import Unison.Codebase.Editor.Git qualified as Git import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace) -import Unison.Codebase.GitError qualified as GitError import Unison.Codebase.Path import Unison.Codebase.Path qualified as Path import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Operations import Unison.Codebase.SyncMode (SyncMode) -import Unison.Codebase.Type - ( Codebase (..), - GitError (GitCodebaseError), - PushGitBranchOpts (..), - SyncToDir, - ) +import Unison.Codebase.Type (Codebase (..), GitError, PushGitBranchOpts (..), SyncToDir) import Unison.CodebasePath (CodebasePath, getCodebaseDir) import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) import Unison.DataDeclaration (Decl) @@ -168,7 +160,6 @@ import Unison.Typechecker.TypeLookup (TypeLookup (TypeLookup)) import Unison.Typechecker.TypeLookup qualified as TL import Unison.UnisonFile qualified as UF import Unison.Util.Relation qualified as Rel -import Unison.Util.Timing (time) import Unison.Var (Var) import Unison.WatchKind qualified as WK @@ -499,23 +490,19 @@ importRemoteBranch :: ReadGitRemoteNamespace -> SyncMode -> Preprocessing m -> - m (Either GitError (Branch m)) -importRemoteBranch codebase ns mode preprocess = runExceptT $ do - branchHash <- ExceptT . viewRemoteBranch' codebase ns Git.RequireExistingBranch $ \(branch, cacheDir) -> do - withStatus "Importing downloaded files into local codebase..." $ do + m (Either GitError CausalHash) +importRemoteBranch codebase ns mode preprocess = do + viewRemoteBranch' codebase ns Git.RequireExistingBranch \(branch, cacheDir) -> + withStatus "Importing downloaded files into local codebase..." do processedBranch <- preprocessOp branch - time "SyncFromDirectory" $ do - syncFromDirectory codebase cacheDir mode processedBranch - pure $ Branch.headHash processedBranch - time "load fresh local branch after sync" $ do - lift (getBranchForHash codebase branchHash) >>= \case - Nothing -> throwE . GitCodebaseError $ GitError.CouldntLoadSyncedBranch ns branchHash - Just result -> pure $ result + syncFromDirectory codebase cacheDir mode processedBranch + pure (Branch.headHash processedBranch) where preprocessOp :: Branch m -> m (Branch m) - preprocessOp = case preprocess of - Preprocessed f -> f - Unmodified -> pure + preprocessOp = + case preprocess of + Preprocessed f -> f + Unmodified -> pure -- | Pull a git branch and view it from the cache, without syncing into the -- local codebase. diff --git a/parser-typechecker/src/Unison/Codebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/GitError.hs index b44e41b12..fb404f6f7 100644 --- a/parser-typechecker/src/Unison/Codebase/GitError.hs +++ b/parser-typechecker/src/Unison/Codebase/GitError.hs @@ -2,7 +2,7 @@ module Unison.Codebase.GitError where -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo, WriteGitRepo) import Unison.Codebase.Path import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Prelude @@ -32,6 +32,5 @@ data GitCodebaseError h | RemoteNamespaceHashAmbiguous ReadGitRepo ShortCausalHash (Set h) | CouldntLoadRootBranch ReadGitRepo h | CouldntParseRemoteBranch ReadGitRepo String - | CouldntLoadSyncedBranch ReadGitRemoteNamespace h | CouldntFindRemoteBranch ReadGitRepo Path deriving (Show) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 4b17b0aef..2bf273a44 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -226,8 +226,10 @@ loadRemoteNamespaceIntoMemory syncMode pullMode remoteNamespace = do let preprocess = case pullMode of Input.PullWithHistory -> Unmodified Input.PullWithoutHistory -> Preprocessed $ pure . Branch.discardHistory - Cli.ioE (Codebase.importRemoteBranch codebase repo syncMode preprocess) \err -> - Cli.returnEarly (Output.GitError err) + causalHash <- + liftIO (Codebase.importRemoteBranch codebase repo syncMode preprocess) & onLeftM \err -> + Cli.returnEarly (Output.GitError err) + liftIO (Codebase.expectBranchForHash codebase causalHash) ReadShare'LooseCode repo -> loadShareLooseCodeIntoMemory repo ReadShare'ProjectBranch remoteBranch -> do projectBranchCausalHashJWT <- downloadShareProjectBranch (pullMode == Input.PullWithoutHistory) remoteBranch diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 8b400e19c..c19d13b74 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1351,13 +1351,6 @@ notifyUser dir = \case <> P.group ("(" <> P.text (Hash.toBase32HexText $ unCausalHash hash) <> ")") <> "from the repository at" <> prettyReadGitRepo repo - CouldntLoadSyncedBranch ns h -> - P.wrap $ - "I just finished importing the branch" - <> P.red (P.shown h) - <> "from" - <> P.red (prettyReadRemoteNamespaceWith absurd (RemoteRepo.ReadRemoteNamespaceGit ns)) - <> "but now I can't find it." CouldntFindRemoteBranch repo path -> P.wrap $ "I couldn't find the remote branch at" From cc4a91ae3fcd000abc89917cd898792bf32b60f7 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 9 May 2024 09:57:17 -0400 Subject: [PATCH 11/82] separate importing code from loading branches --- codebase2/codebase/package.yaml | 25 +++++++++ codebase2/codebase/unison-codebase.cabal | 27 +++++++++- parser-typechecker/package.yaml | 1 - .../src/Unison/Codebase/Branch.hs | 11 ++-- .../unison-parser-typechecker.cabal | 2 - .../Codebase/Editor/HandleInput/Pull.hs | 52 ++++++++++++------- 6 files changed, 89 insertions(+), 29 deletions(-) diff --git a/codebase2/codebase/package.yaml b/codebase2/codebase/package.yaml index 30763303e..1608bed83 100644 --- a/codebase2/codebase/package.yaml +++ b/codebase2/codebase/package.yaml @@ -21,8 +21,33 @@ library: other-modules: Paths_unison_codebase default-extensions: + - BangPatterns - BlockArguments + - DeriveAnyClass + - DeriveFunctor + - DeriveGeneric + - DeriveTraversable - DerivingStrategies + - DerivingVia + - DoAndIfThenElse + - DuplicateRecordFields + - FlexibleContexts + - FlexibleInstances + - GeneralizedNewtypeDeriving + - ImportQualifiedPost - LambdaCase + - MultiParamTypeClasses + - NamedFieldPuns + - OverloadedLabels + - OverloadedRecordDot + - OverloadedStrings + - PatternSynonyms + - RankNTypes + - ScopedTypeVariables + - StandaloneDeriving + - TupleSections + - TypeApplications + - TypeFamilies + - ViewPatterns language: GHC2021 diff --git a/codebase2/codebase/unison-codebase.cabal b/codebase2/codebase/unison-codebase.cabal index 7617d5446..4fcd1abb4 100644 --- a/codebase2/codebase/unison-codebase.cabal +++ b/codebase2/codebase/unison-codebase.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack @@ -31,9 +31,34 @@ library hs-source-dirs: ./ default-extensions: + BangPatterns BlockArguments + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DeriveTraversable DerivingStrategies + DerivingVia + DoAndIfThenElse + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GeneralizedNewtypeDeriving + ImportQualifiedPost LambdaCase + MultiParamTypeClasses + NamedFieldPuns + OverloadedLabels + OverloadedRecordDot + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeFamilies + ViewPatterns build-depends: base , containers diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index e84af99a6..8b96c56cf 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -164,7 +164,6 @@ tests: other-modules: Paths_unison_parser_typechecker default-extensions: - - ApplicativeDo - BangPatterns - BlockArguments - DeriveAnyClass diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index 56ecaff30..788f447b1 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -606,20 +606,17 @@ modifyAt path f = runIdentity . modifyAtM path (pure . f) -- Because it's a `Branch`, it overwrites the history at `path`. modifyAtM :: forall n m. - (Functor n) => - (Applicative m) => -- because `Causal.cons` uses `pure` + (Functor n, Applicative m) => Path -> (Branch m -> n (Branch m)) -> Branch m -> n (Branch m) modifyAtM path f b = case Path.uncons path of Nothing -> f b - Just (seg, path) -> do - -- Functor + Just (seg, path) -> let child = getChildBranch seg (head b) - child' <- modifyAtM path f child - -- step the branch by updating its children according to fixup - pure $ step (setChildBranch seg child') b + in -- step the branch by updating its children according to fixup + (\child' -> step (setChildBranch seg child') b) <$> modifyAtM path f child -- | Perform updates over many locations within a branch by batching up operations on -- sub-branches as much as possible without affecting semantics. diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index bf96bcb2f..e9b483c76 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -196,7 +196,6 @@ library hs-source-dirs: src default-extensions: - ApplicativeDo BangPatterns BlockArguments DeriveAnyClass @@ -388,7 +387,6 @@ test-suite parser-typechecker-tests hs-source-dirs: tests default-extensions: - ApplicativeDo BangPatterns BlockArguments DeriveAnyClass diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 2bf273a44..a9fc7d89b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -1,7 +1,6 @@ -- | @pull@ input handler module Unison.Codebase.Editor.HandleInput.Pull ( doPullRemoteBranch, - loadShareLooseCodeIntoMemory, loadPropagateDiffDefaultPatch, mergeBranchAndPropagateDefaultPatch, propagatePatch, @@ -17,7 +16,9 @@ import Data.List.NonEmpty qualified as Nel import Data.Text qualified as Text import Data.These import System.Console.Regions qualified as Console.Regions +import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Project qualified as Sqlite (Project) +import U.Codebase.Causal qualified import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) @@ -63,21 +64,37 @@ import Unison.Share.Types (codeserverBaseURL) import Unison.Sync.Common qualified as Common import Unison.Sync.Types qualified as Share import Witch (unsafeFrom) +import qualified U.Codebase.Sqlite.Operations as Operations +import qualified U.Codebase.Branch as V2.Branch doPullRemoteBranch :: PullSourceTarget -> SyncMode.SyncMode -> PullMode -> Verbosity.Verbosity -> Cli () doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do + Cli.Env {codebase} <- ask + let includeSquashed = case pullMode of Input.PullWithHistory -> Share.NoSquashedHead Input.PullWithoutHistory -> Share.IncludeSquashedHead + (source, target) <- resolveSourceAndTarget includeSquashed unresolvedSourceAndTarget - remoteBranchObject <- loadRemoteNamespaceIntoMemory syncMode pullMode source - when (Branch.isEmpty0 (Branch.head remoteBranchObject)) do - Cli.respond (PulledEmptyBranch source) + + remoteCausalHash <- importRemoteNamespaceIntoCodebase syncMode pullMode source + + remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash) + + remoteBranchIsEmpty <- + Cli.runTransaction do + causal <- Operations.expectCausalBranchByCausalHash remoteCausalHash + branch <- causal.value + V2.Branch.isEmpty branch + + when remoteBranchIsEmpty (Cli.respond (PulledEmptyBranch source)) + targetAbsolutePath <- case target of Left path -> Cli.resolvePath' path Right (ProjectAndBranch project branch) -> pure $ ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)) + let description = Text.unwords [ Text.pack . InputPattern.patternName $ @@ -89,9 +106,11 @@ doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do Left path -> Path.toText' path Right (ProjectAndBranch project branch) -> into @Text (ProjectAndBranch (project ^. #name) (branch ^. #name)) ] + case pullMode of Input.PullWithHistory -> do targetBranchObject <- Cli.getBranch0At targetAbsolutePath + if Branch.isEmpty0 targetBranchObject then do void $ Cli.updateAtM description targetAbsolutePath (const $ pure remoteBranchObject) @@ -111,6 +130,7 @@ doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do description targetAbsolutePath (\targetBranchObject -> pure $ remoteBranchObject `Branch.consBranchSnapshot` targetBranchObject) + Cli.respond if didUpdate then PullSuccessful source target @@ -214,27 +234,24 @@ resolveImplicitTarget = Nothing -> Left Path.currentPath Just (projectAndBranch, _restPath) -> Right projectAndBranch -loadRemoteNamespaceIntoMemory :: +importRemoteNamespaceIntoCodebase :: SyncMode -> PullMode -> ReadRemoteNamespace Share.RemoteProjectBranch -> - Cli (Branch IO) -loadRemoteNamespaceIntoMemory syncMode pullMode remoteNamespace = do + Cli CausalHash +importRemoteNamespaceIntoCodebase syncMode pullMode remoteNamespace = do Cli.Env {codebase} <- ask case remoteNamespace of ReadRemoteNamespaceGit repo -> do let preprocess = case pullMode of Input.PullWithHistory -> Unmodified Input.PullWithoutHistory -> Preprocessed $ pure . Branch.discardHistory - causalHash <- - liftIO (Codebase.importRemoteBranch codebase repo syncMode preprocess) & onLeftM \err -> - Cli.returnEarly (Output.GitError err) - liftIO (Codebase.expectBranchForHash codebase causalHash) - ReadShare'LooseCode repo -> loadShareLooseCodeIntoMemory repo + liftIO (Codebase.importRemoteBranch codebase repo syncMode preprocess) & onLeftM \err -> + Cli.returnEarly (Output.GitError err) + ReadShare'LooseCode repo -> importShareLooseCodeIntoCodebase repo ReadShare'ProjectBranch remoteBranch -> do projectBranchCausalHashJWT <- downloadShareProjectBranch (pullMode == Input.PullWithoutHistory) remoteBranch - let causalHash = Common.hash32ToCausalHash (Share.hashJWTHash projectBranchCausalHashJWT) - liftIO (Codebase.expectBranchForHash codebase causalHash) + pure (Common.hash32ToCausalHash (Share.hashJWTHash projectBranchCausalHashJWT)) -- | @downloadShareProjectBranch branch@ downloads the given branch. downloadShareProjectBranch :: HasCallStack => Bool -> Share.RemoteProjectBranch -> Cli HashJWT @@ -261,14 +278,13 @@ downloadShareProjectBranch useSquashedIfAvailable branch = do Cli.respond (Output.DownloadedEntities numDownloaded) pure causalHashJwt -loadShareLooseCodeIntoMemory :: ReadShareLooseCode -> Cli (Branch IO) -loadShareLooseCodeIntoMemory rrn@(ReadShareLooseCode {server, repo, path}) = do +importShareLooseCodeIntoCodebase :: ReadShareLooseCode -> Cli CausalHash +importShareLooseCodeIntoCodebase rrn@(ReadShareLooseCode {server, repo, path}) = do let codeserver = Codeserver.resolveCodeserver server let baseURL = codeserverBaseURL codeserver -- Auto-login to share if pulling from a non-public path when (not $ RemoteRepo.isPublic rrn) . void $ ensureAuthenticatedWithCodeserver codeserver let shareFlavoredPath = Share.Path (shareUserHandleToText repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) - Cli.Env {codebase} <- ask (causalHash, numDownloaded) <- Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do causalHash <- @@ -279,7 +295,7 @@ loadShareLooseCodeIntoMemory rrn@(ReadShareLooseCode {server, repo, path}) = do numDownloaded <- liftIO getNumDownloaded pure (causalHash, numDownloaded) Cli.respond (Output.DownloadedEntities numDownloaded) - liftIO (Codebase.expectBranchForHash codebase causalHash) + pure causalHash -- Provide the given action a callback that display to the terminal. withEntitiesDownloadedProgressCallback :: ((Int -> IO (), IO Int) -> IO a) -> IO a From 9a0ef3d7973b3a003dc742fea242250bd74eedb2 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 13 May 2024 13:15:00 -0400 Subject: [PATCH 12/82] merge work --- .../Codebase/Editor/HandleInput/Merge2.hs | 321 +++++++++++++++++- .../Codebase/Editor/HandleInput/Pull.hs | 23 +- .../src/Unison/Merge/TwoOrThreeWay.hs | 2 +- 3 files changed, 335 insertions(+), 11 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 18a707f17..8f852f4de 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -12,9 +12,12 @@ 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.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 (..)) @@ -22,7 +25,7 @@ import Text.ANSI qualified as Text import U.Codebase.Branch qualified as V2 (Branch (..), CausalBranch) import U.Codebase.Branch qualified as V2.Branch import U.Codebase.Causal qualified as V2.Causal -import U.Codebase.HashTags (unCausalHash) +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.Operations qualified as Operations @@ -324,6 +327,226 @@ handleMerge bobBranchName = do (\aliceBranch -> Branch.mergeNode stageTwoBranch aliceBranch bobBranch) Cli.respond (Output.MergeSuccess projectAndBranchNames.alice projectAndBranchNames.bob) +data MergeResult + = -- We didn't do anything because alice >= bob + MergeResult'AlreadyMerged + | -- We didn't do anything because alice < bob. The caller should set alice = bob + MergeResult'ShouldFastForward + | MergeResult'ConflictedName !CausalHash !ConflictedName + | MergeResult'DefnsInLib !CausalHash + | MergeResult'IncoherentDecl !CausalHash !IncoherentDeclReason + | MergeResult'ConflictedAliases !CausalHash !Name !Name + | MergeResult'ConflictInvolvingBuiltin !Name + +doBigMerge :: DebugFunctions -> TwoOrThreeWay CausalHash -> Cli MergeResult +doBigMerge debugFunctions causalHashes = do + Cli.label \done -> do + -- If alice == bob, or LCA == bob (so alice is ahead of bob), then we are done. + when (causalHashes.alice == causalHashes.bob || causalHashes.lca == Just causalHashes.bob) do + done MergeResult'AlreadyMerged + + -- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done. + when (causalHashes.lca == Just causalHashes.alice) do + done MergeResult'ShouldFastForward + + Cli.Env {codebase} <- ask + + -- Create a bunch of cached database lookup functions + db <- makeMergeDatabase codebase + + -- Load Alice/Bob/LCA causals + causals <- Cli.runTransaction (traverse Operations.expectCausalBranchByCausalHash causalHashes) + + liftIO (debugFunctions.debugCausals causals) + + -- Load Alice/Bob/LCA branches + branches <- + Cli.runTransaction do + alice <- causals.alice.value + bob <- causals.bob.value + lca <- for causals.lca \causal -> causal.value + pure TwoOrThreeWay {lca, alice, bob} + + -- Assert that neither Alice nor Bob have defns in lib + for_ [(causalHashes.alice, branches.alice), (causalHashes.bob, branches.bob)] \(causalHash, branch) -> do + libdeps <- + case Map.lookup NameSegment.libSegment branch.children of + Nothing -> pure V2.Branch.empty + Just libdeps -> Cli.runTransaction libdeps.value + when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do + done (MergeResult'DefnsInLib causalHash) + + -- Load Alice/Bob/LCA definitions and decl name lookups + (defns3, declNameLookups3) <- do + let load = \case + Nothing -> + pure + ( Nametree {value = Defns Map.empty Map.empty, children = Map.empty}, + DeclNameLookup Map.empty Map.empty + ) + Just (causalHash, branch) -> do + defns <- + Cli.runTransaction (loadNamespaceInfo_2 (referent2to1 db) branch) & onLeftM \err -> + done (MergeResult'ConflictedName causalHash err) + declNameLookup <- + Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err -> + done (MergeResult'IncoherentDecl causalHash err) + pure (defns, declNameLookup) + + (aliceDefns0, aliceDeclNameLookup) <- load (Just (causalHashes.alice, branches.alice)) + (bobDefns0, bobDeclNameLookup) <- load (Just (causalHashes.bob, branches.bob)) + (lcaDefns0, lcaDeclNameLookup) <- load ((,) <$> causalHashes.lca <*> branches.lca) + + let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns) + let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0} + let declNameLookups3 = ThreeWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup, lca = lcaDeclNameLookup} + + pure (defns3, declNameLookups3) + + let defns = ThreeWay.forgetLca defns3 + let declNameLookups = ThreeWay.forgetLca declNameLookups3 + + liftIO (debugFunctions.debugDefns defns3 declNameLookups3) + + -- Diff LCA->Alice and LCA->Bob + diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups3 defns3) + + liftIO (debugFunctions.debugDiffs diffs) + + -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias + do + let go causalHash diff = + whenJust (findConflictedAlias defns3.lca diff) \(name1, name2) -> + done (MergeResult'ConflictedAliases causalHash name1 name2) + go causalHashes.alice diffs.alice + go causalHashes.bob diffs.bob + + -- Combine the LCA->Alice and LCA->Bob diffs together + let diff = combineDiffs diffs + + liftIO (debugFunctions.debugCombinedDiff diff) + + -- Partition the combined diff into the conflicted things and the unconflicted things + (conflicts, unconflicts) <- + partitionCombinedDiffs defns declNameLookups diff & onLeft \name -> + done (MergeResult'ConflictInvolvingBuiltin name) + + liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts) + + -- -- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there + -- -- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are) + -- dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts) + + -- liftIO (debugFunctions.debugDependents dependents) + + -- let stageOne :: DefnsF (Map Name) Referent TypeReference + -- stageOne = + -- makeStageOne + -- declNameLookups + -- conflicts + -- unconflicts + -- dependents + -- (bimap BiMultimap.range BiMultimap.range defns3.lca) + + -- liftIO (debugFunctions.debugStageOne stageOne) + + -- -- Load and merge Alice's and Bob's libdeps + -- mergedLibdeps <- + -- Cli.runTransaction do + -- libdeps <- loadLibdeps branches + -- libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps) + + -- -- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names + -- let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl + -- mkPpes defnsNames libdepsNames = + -- defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier + -- where + -- suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames) + -- let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps) + + -- hydratedThings <- do + -- Cli.runTransaction do + -- for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) -> + -- let hydrate = hydrateDefns (Codebase.unsafeGetTermComponent codebase) Operations.expectDeclComponent + -- in (,) <$> hydrate conflicts1 <*> hydrate dependents1 + + -- let (renderedConflicts, renderedDependents) = + -- let honk declNameLookup ppe defns = + -- let (types, accessorNames) = + -- Writer.runWriter $ + -- defns.types & Map.traverseWithKey \name (ref, typ) -> + -- renderTypeBinding + -- -- Sort of a hack; since the decl printer looks in the PPE for names of constructors, + -- -- we just delete all term names out and add back the constructors... + -- -- probably no need to wipe out the suffixified side but we do it anyway + -- (setPpedToConstructorNames declNameLookup name ref ppe) + -- name + -- ref + -- typ + -- terms = + -- defns.terms & Map.mapMaybeWithKey \name (term, typ) -> + -- if Set.member name accessorNames + -- then Nothing + -- else Just (renderTermBinding ppe.suffixifiedPPE name term typ) + -- in Defns {terms, types} + -- in unzip $ + -- ( \declNameLookup (conflicts, dependents) ppe -> + -- let honk1 = honk declNameLookup ppe + -- in (honk1 conflicts, honk1 dependents) + -- ) + -- <$> declNameLookups + -- <*> hydratedThings + -- <*> ppes + + -- let prettyUnisonFile = makePrettyUnisonFile (into @Text <$> projectAndBranchNames) renderedConflicts renderedDependents + + -- let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps + + -- maybeTypecheckedUnisonFile <- + -- let thisMergeHasConflicts = + -- -- Eh, they'd either both be null, or neither, but just check both maps anyway + -- not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob) + -- in if thisMergeHasConflicts + -- then pure Nothing + -- else do + -- currentPath <- Cli.getCurrentPath + -- parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch) + -- prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe + + -- case maybeTypecheckedUnisonFile of + -- Nothing -> do + -- Cli.Env {writeSource} <- ask + -- aliceBranch <- Cli.getBranchAt info.paths.alice + -- bobBranch <- Cli.getBranchAt info.paths.bob + -- _temporaryBranchId <- + -- HandleInput.Branch.doCreateBranch' + -- (Branch.mergeNode stageOneBranch aliceBranch bobBranch) + -- Nothing + -- info.project + -- (findTemporaryBranchName info) + -- (textualDescriptionOfMerge info) + -- scratchFilePath <- + -- Cli.getLatestFile <&> \case + -- Nothing -> "scratch.u" + -- Just (file, _) -> file + -- liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) + -- Cli.respond $ + -- Output.MergeFailure + -- scratchFilePath + -- projectAndBranchNames.alice + -- projectAndBranchNames.bob + -- Just tuf -> do + -- Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) + -- bobBranch <- Cli.getBranchAt info.paths.bob + -- let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch + -- _ <- + -- Cli.updateAt + -- (textualDescriptionOfMerge info) + -- info.paths.alice + -- (\aliceBranch -> Branch.mergeNode stageTwoBranch aliceBranch bobBranch) + -- Cli.respond (Output.MergeSuccess projectAndBranchNames.alice projectAndBranchNames.bob) + undefined + mergeInfoToProjectAndBranchNames :: MergeInfo -> TwoWay (ProjectAndBranch ProjectName ProjectBranchName) mergeInfoToProjectAndBranchNames info = TwoWay @@ -793,6 +1016,18 @@ loadNamespaceInfo abort db branch = do defns <- loadNamespaceInfo0 (referent2to1 db) branch assertNamespaceHasNoConflictedNames defns & onLeft abort +-- Load namespace info into memory. +-- +-- Fails if: +-- * One name is associated with more than one reference. +loadNamespaceInfo_2 :: + Monad m => + (V2.Referent -> m Referent) -> + V2.Branch m -> + m (Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference))) +loadNamespaceInfo_2 referent2to1 branch = + assertNamespaceHasNoConflictedNames_2 <$> loadNamespaceInfo0_2 referent2to1 branch + -- | Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined -- in the "lib" namespace. loadNamespaceInfo0 :: @@ -812,6 +1047,30 @@ loadNamespaceInfo0 referent2to1 branch = do loadNamespaceInfo0_ referent2to1 childBranch pure Nametree {value = Defns {terms, types}, children} +-- | Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined +-- in the "lib" namespace. +loadNamespaceInfo0_2 :: + forall m. + Monad m => + (V2.Referent -> m Referent) -> + V2.Branch m -> + m (Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference)) +loadNamespaceInfo0_2 referent2to1 = + 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} + loadNamespaceInfo0_ :: (Monad m) => (V2.Referent -> m Referent) -> @@ -849,6 +1108,29 @@ assertNamespaceHasNoConflictedNames = Nothing -> Left (conflicted refs) Just ref -> Right ref +data ConflictedName + = ConflictedName'Term !Name !(NESet Referent) + | ConflictedName'Type !Name !(NESet TypeReference) + +-- | Assert that there are no unconflicted names in a namespace. +assertNamespaceHasNoConflictedNames_2 :: + Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference) -> + Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) +assertNamespaceHasNoConflictedNames_2 = + 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) + -- Convert a merge precondition violation to an output message. mergePreconditionViolationToOutput :: Merge.PreconditionViolation -> Output.Output mergePreconditionViolationToOutput = \case @@ -900,6 +1182,38 @@ assertNamespaceSatisfiesPreconditions db abort maybeBranchName branch defns = do IncoherentDeclReason'NestedDeclAlias shorterName longerName -> Merge.NestedDeclAlias shorterName longerName IncoherentDeclReason'StrayConstructor name -> Merge.StrayConstructor name +-- Assert that a namespace satisfies a few preconditions. +-- +-- Fails if: +-- * The "lib" namespace contains any top-level terms or decls. (Only child namespaces are expected here). +-- * Any type declarations are "incoherent" (see `checkDeclCoherency`) +assertNamespaceSatisfiesPreconditions_2 :: + MergeDatabase -> + (forall void. Merge.PreconditionViolation -> Transaction void) -> + Maybe ProjectBranchName -> + Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> + Transaction (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name), DeclNameLookup) +assertNamespaceSatisfiesPreconditions_2 db abort maybeBranchName defns = do + declNameLookup <- + checkDeclCoherency db.loadDeclNumConstructors defns + & onLeftM (abort . incoherentDeclReasonToMergePreconditionViolation) + + pure + ( Defns + { terms = flattenNametree (view #terms) defns, + types = flattenNametree (view #types) defns + }, + declNameLookup + ) + where + incoherentDeclReasonToMergePreconditionViolation :: IncoherentDeclReason -> Merge.PreconditionViolation + incoherentDeclReasonToMergePreconditionViolation = \case + IncoherentDeclReason'ConstructorAlias firstName secondName -> + Merge.ConstructorAlias maybeBranchName firstName secondName + IncoherentDeclReason'MissingConstructorName name -> Merge.MissingConstructorName name + IncoherentDeclReason'NestedDeclAlias shorterName longerName -> Merge.NestedDeclAlias shorterName longerName + IncoherentDeclReason'StrayConstructor name -> Merge.StrayConstructor name + findOneConflictedAlias :: TwoWay ProjectBranch -> Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> @@ -934,8 +1248,9 @@ findOneConflictedAlias projectBranchNames lcaDefns diffs = -- -- This function currently doesn't return whether the conflicted alias is a decl or a term, but it certainly could. findConflictedAlias :: - Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> - DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference -> + (Ord term, Ord typ) => + Defns (BiMultimap term Name) (BiMultimap typ Name) -> + DefnsF3 (Map Name) DiffOp Synhashed term typ -> Maybe (Name, Name) findConflictedAlias defns diff = asum [go defns.terms diff.terms, go defns.types diff.types] diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index a9fc7d89b..f7093ad57 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -16,9 +16,11 @@ import Data.List.NonEmpty qualified as Nel import Data.Text qualified as Text import Data.These import System.Console.Regions qualified as Console.Regions -import U.Codebase.HashTags (CausalHash) -import U.Codebase.Sqlite.Project qualified as Sqlite (Project) +import U.Codebase.Branch qualified as V2.Branch import U.Codebase.Causal qualified +import U.Codebase.HashTags (CausalHash) +import U.Codebase.Sqlite.Operations qualified as Operations +import U.Codebase.Sqlite.Project qualified as Sqlite (Project) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) @@ -64,8 +66,6 @@ import Unison.Share.Types (codeserverBaseURL) import Unison.Sync.Common qualified as Common import Unison.Sync.Types qualified as Share import Witch (unsafeFrom) -import qualified U.Codebase.Sqlite.Operations as Operations -import qualified U.Codebase.Branch as V2.Branch doPullRemoteBranch :: PullSourceTarget -> SyncMode.SyncMode -> PullMode -> Verbosity.Verbosity -> Cli () doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do @@ -77,12 +77,15 @@ doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do (source, target) <- resolveSourceAndTarget includeSquashed unresolvedSourceAndTarget + target1 <- + case target of + Left _ -> wundefined + Right target1 -> pure target1 + remoteCausalHash <- importRemoteNamespaceIntoCodebase syncMode pullMode source - remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash) - remoteBranchIsEmpty <- - Cli.runTransaction do + Cli.runTransaction do causal <- Operations.expectCausalBranchByCausalHash remoteCausalHash branch <- causal.value V2.Branch.isEmpty branch @@ -113,10 +116,14 @@ doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do if Branch.isEmpty0 targetBranchObject then do + remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash) void $ Cli.updateAtM description targetAbsolutePath (const $ pure remoteBranchObject) Cli.respond $ MergeOverEmpty target else do + remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash) + Cli.respond AboutToMerge + mergeBranchAndPropagateDefaultPatch Branch.RegularMerge description @@ -125,6 +132,8 @@ doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do (if Verbosity.isSilent verbosity then Nothing else Just target) targetAbsolutePath Input.PullWithoutHistory -> do + remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash) + didUpdate <- Cli.updateAtM description diff --git a/unison-merge/src/Unison/Merge/TwoOrThreeWay.hs b/unison-merge/src/Unison/Merge/TwoOrThreeWay.hs index c62000d6b..556ff0fd2 100644 --- a/unison-merge/src/Unison/Merge/TwoOrThreeWay.hs +++ b/unison-merge/src/Unison/Merge/TwoOrThreeWay.hs @@ -10,4 +10,4 @@ data TwoOrThreeWay a = TwoOrThreeWay alice :: a, bob :: a } - deriving stock (Functor, Generic) + deriving stock (Foldable, Functor, Generic, Traversable) From aee317a681d41e6d1222740166df885e252aad30 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 13 May 2024 13:52:32 -0400 Subject: [PATCH 13/82] explicitly ignore ignored return values --- parser-typechecker/src/Unison/Codebase/Editor/Git.hs | 2 +- .../src/Unison/Codebase/SqliteCodebase.hs | 2 +- .../SqliteCodebase/Migrations/MigrateSchema6To7.hs | 3 ++- parser-typechecker/src/Unison/Runtime/Interface.hs | 2 +- parser-typechecker/src/Unison/Syntax/TermParser.hs | 10 +++++----- parser-typechecker/src/Unison/Typechecker/Context.hs | 2 +- 6 files changed, 11 insertions(+), 10 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs index e6c36626e..61ec46c38 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs @@ -144,7 +144,7 @@ withRepo repo@(ReadGitRepo {url = uri, ref = mayGitRef}) branchBehavior action = throwExceptT $ checkForGit gitCachePath <- gitCacheDir uri -- Ensure we have the main branch in the cache dir no matter what - throwExceptT $ cloneIfMissing repo {ref = Nothing} gitCachePath + _ :: GitRepo <- throwExceptT $ cloneIfMissing repo {ref = Nothing} gitCachePath let gitCacheRepo = Bare gitCachePath gitRef <- case mayGitRef of Nothing -> fromMaybe "main" <$> getDefaultBranch gitCacheRepo diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 0c6de213a..fb63e710d 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -668,7 +668,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts behavior _syncMode) action = Unlif C.withConnection destCodebase \destConn -> doSync codebaseStatus destConn newBranch pure (Right newBranch) - for newBranchOrErr $ push pushStaging repo + for_ newBranchOrErr $ push pushStaging repo pure newBranchOrErr where readRepo :: ReadGitRepo diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs index 6e0b3d855..b62708f70 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/Migrations/MigrateSchema6To7.hs @@ -6,6 +6,7 @@ module Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema6To7 (migrateSchem import Control.Monad.Except import Control.Monad.State +import U.Codebase.Branch.Type (NamespaceStats) import U.Codebase.Sqlite.DbId qualified as DB import U.Codebase.Sqlite.DbId qualified as Db import U.Codebase.Sqlite.Operations qualified as Ops @@ -50,7 +51,7 @@ addStatsForBranch :: DB.BranchObjectId -> Sqlite.Transaction (Sync.TrySyncResult addStatsForBranch boId = do bhId <- Db.BranchHashId <$> Q.expectPrimaryHashIdForObject (Db.unBranchObjectId boId) -- "expectNamespaceStatsByHashId" computes stats if they are missing. - Ops.expectNamespaceStatsByHashId bhId + _ :: NamespaceStats <- Ops.expectNamespaceStatsByHashId bhId pure Sync.Done debugLog :: String -> Sqlite.Transaction () diff --git a/parser-typechecker/src/Unison/Runtime/Interface.hs b/parser-typechecker/src/Unison/Runtime/Interface.hs index c23e7098e..80b521d60 100644 --- a/parser-typechecker/src/Unison/Runtime/Interface.hs +++ b/parser-typechecker/src/Unison/Runtime/Interface.hs @@ -920,7 +920,7 @@ nativeCompileCodes executable codes base path = do BS.hPut pin . runPutS . putWord32be . fromIntegral $ BS.length bytes BS.hPut pin bytes UnliftIO.hClose pin - waitForProcess ph + _ <- waitForProcess ph pure () callout _ _ _ _ = fail "withCreateProcess didn't provide handles" ucrError (e :: IOException) = diff --git a/parser-typechecker/src/Unison/Syntax/TermParser.hs b/parser-typechecker/src/Unison/Syntax/TermParser.hs index 95b858bbf..45daba633 100644 --- a/parser-typechecker/src/Unison/Syntax/TermParser.hs +++ b/parser-typechecker/src/Unison/Syntax/TermParser.hs @@ -141,11 +141,11 @@ link :: (Monad m, Var v) => TermP v m link = termLink <|> typeLink where typeLink = do - P.try (reserved "typeLink") -- type opens a block, gotta use something else + _ <- P.try (reserved "typeLink") -- type opens a block, gotta use something else tok <- typeLink' pure $ Term.typeLink (ann tok) (L.payload tok) termLink = do - P.try (reserved "termLink") + _ <- P.try (reserved "termLink") tok <- termLink' pure $ Term.termLink (ann tok) (L.payload tok) @@ -200,7 +200,7 @@ matchCase = do unit ann = Pattern.Constructor ann (ConstructorReference DD.unitRef 0) [] pair p1 p2 = Pattern.Constructor (ann p1 <> ann p2) (ConstructorReference DD.pairRef 0) [p1, p2] let guardedBlocks = label "pattern guard" . some $ do - reserved "|" + _ <- reserved "|" guard <- asum [ Nothing <$ P.try (quasikeyword "otherwise"), @@ -289,7 +289,7 @@ parsePattern = label "pattern" root | Set.null s -> die tok s | Set.size s > 1 -> die tok s | otherwise -> -- matched ctor name, consume the token - do anyToken; pure (Set.findMin s <$ tok) + do _ <- anyToken; pure (Set.findMin s <$ tok) where isLower = Text.all Char.isLower . Text.take 1 . Name.toText die hq s = case L.payload hq of @@ -1054,7 +1054,7 @@ destructuringBind = do (p, boundVars) <- P.try do (p, boundVars) <- parsePattern let boundVars' = snd <$> boundVars - P.lookAhead (openBlockWith "=") + _ <- P.lookAhead (openBlockWith "=") pure (p, boundVars') (_spanAnn, scrute) <- block "=" -- Dwight K. Scrute ("The People's Scrutinee") let guard = Nothing diff --git a/parser-typechecker/src/Unison/Typechecker/Context.hs b/parser-typechecker/src/Unison/Typechecker/Context.hs index 208478e66..f249c0abd 100644 --- a/parser-typechecker/src/Unison/Typechecker/Context.hs +++ b/parser-typechecker/src/Unison/Typechecker/Context.hs @@ -2197,7 +2197,7 @@ coalesceWanted' keep ((loc, n) : new) old if keep u then pure (new, (loc, n) : old) else do - defaultAbility n + _ <- defaultAbility n pure (new, old) coalesceWanted new old | otherwise = coalesceWanted' keep new ((loc, n) : old) From 3e0e10edec3fdc62c6cd5c8a854e41a1945e33a4 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 13 May 2024 15:05:55 -0400 Subject: [PATCH 14/82] merge work --- .../Codebase/Editor/HandleInput/Merge2.hs | 313 ++++++++++-------- unison-merge/src/Unison/Merge/Database.hs | 23 +- 2 files changed, 198 insertions(+), 138 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index db59200ae..6dfb6b9a1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -323,27 +323,46 @@ handleMerge bobSpecifier = do (\aliceBranch -> Branch.mergeNode stageTwoBranch aliceBranch bobBranch) Cli.respond (Output.MergeSuccess projectAndBranchNames.alice projectAndBranchNames.bob) -data MergeResult - = -- We didn't do anything because alice >= bob - MergeResult'AlreadyMerged - | -- We didn't do anything because alice < bob. The caller should set alice = bob - MergeResult'ShouldFastForward - | MergeResult'ConflictedName !CausalHash !ConflictedName - | MergeResult'DefnsInLib !CausalHash - | MergeResult'IncoherentDecl !CausalHash !IncoherentDeclReason - | MergeResult'ConflictedAliases !CausalHash !Name !Name - | MergeResult'ConflictInvolvingBuiltin !Name +data MergeResult1 + = MergeResult1'Failure !MergeResultFailure1 + | MergeResult1'Success !MergeResultSuccess1 -doBigMerge :: DebugFunctions -> TwoOrThreeWay CausalHash -> Cli MergeResult -doBigMerge debugFunctions causalHashes = do +data MergeResultFailure1 + = -- We couldn't attempt to merge because we found a conflicted name + MergeResultFailure1'ConflictedName !CausalHash !ConflictedName + | -- We couldn't attempt to merge because we found defs in lib + MergeResultFailure1'DefnsInLib !(EitherWay ()) + | -- We couldn't attempt to merge because we found an incoherent decl + MergeResultFailure1'IncoherentDecl !CausalHash !IncoherentDeclReason + | -- We couldn't attempt to merge because we found conflicted aliases + MergeResultFailure1'ConflictedAliases !(EitherWay (Name, Name)) + | -- We couldn't attempt to merge because we found a conflict involving a builtin + MergeResultFailure1'ConflictInvolvingBuiltin !Name + +data MergeResultSuccess1 + = -- We didn't do anything because alice >= bob + MergeResultSuccess1'AlreadyMerged + | -- We didn't do anything because alice < bob. The caller should set alice = bob + MergeResultSuccess1'ShouldFastForward + | -- We got as far as diffing the namespace + MergeResultSuccess1'PerformedDiff + !MergeDatabase + !(TwoOrThreeWay (V2.Branch Transaction)) -- branches + !(ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))) -- defns + !(TwoWay DeclNameLookup) -- decl name lookups + !(TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId)) -- conflicts + !(DefnsF Unconflicts Referent TypeReference) -- unconflicts + +doBigMerge1 :: DebugFunctions -> TwoWay Text -> TwoOrThreeWay CausalHash -> Cli MergeResult1 +doBigMerge1 debugFunctions authors causalHashes = do Cli.label \done -> do -- If alice == bob, or LCA == bob (so alice is ahead of bob), then we are done. when (causalHashes.alice == causalHashes.bob || causalHashes.lca == Just causalHashes.bob) do - done MergeResult'AlreadyMerged + done (MergeResult1'Success MergeResultSuccess1'AlreadyMerged) -- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done. when (causalHashes.lca == Just causalHashes.alice) do - done MergeResult'ShouldFastForward + done (MergeResult1'Success MergeResultSuccess1'ShouldFastForward) Cli.Env {codebase} <- ask @@ -364,13 +383,13 @@ doBigMerge debugFunctions causalHashes = do pure TwoOrThreeWay {lca, alice, bob} -- Assert that neither Alice nor Bob have defns in lib - for_ [(causalHashes.alice, branches.alice), (causalHashes.bob, branches.bob)] \(causalHash, branch) -> do + for_ [(Alice (), branches.alice), (Bob (), branches.bob)] \(who, branch) -> do libdeps <- case Map.lookup NameSegment.libSegment branch.children of Nothing -> pure V2.Branch.empty Just libdeps -> Cli.runTransaction libdeps.value when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do - done (MergeResult'DefnsInLib causalHash) + done (MergeResult1'Failure (MergeResultFailure1'DefnsInLib who)) -- Load Alice/Bob/LCA definitions and decl name lookups (defns3, declNameLookups3) <- do @@ -383,10 +402,10 @@ doBigMerge debugFunctions causalHashes = do Just (causalHash, branch) -> do defns <- Cli.runTransaction (loadNamespaceInfo_2 (referent2to1 db) branch) & onLeftM \err -> - done (MergeResult'ConflictedName causalHash err) + done (MergeResult1'Failure (MergeResultFailure1'ConflictedName causalHash err)) declNameLookup <- Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err -> - done (MergeResult'IncoherentDecl causalHash err) + done (MergeResult1'Failure (MergeResultFailure1'IncoherentDecl causalHash err)) pure (defns, declNameLookup) (aliceDefns0, aliceDeclNameLookup) <- load (Just (causalHashes.alice, branches.alice)) @@ -411,11 +430,11 @@ doBigMerge debugFunctions causalHashes = do -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias do - let go causalHash diff = - whenJust (findConflictedAlias defns3.lca diff) \(name1, name2) -> - done (MergeResult'ConflictedAliases causalHash name1 name2) - go causalHashes.alice diffs.alice - go causalHashes.bob diffs.bob + let go who diff = + whenJust (findConflictedAlias defns3.lca diff) \names -> + done (MergeResult1'Failure (MergeResultFailure1'ConflictedAliases (who names))) + go Alice diffs.alice + go Bob diffs.bob -- Combine the LCA->Alice and LCA->Bob diffs together let diff = combineDiffs diffs @@ -425,123 +444,148 @@ doBigMerge debugFunctions causalHashes = do -- Partition the combined diff into the conflicted things and the unconflicted things (conflicts, unconflicts) <- partitionCombinedDiffs defns declNameLookups diff & onLeft \name -> - done (MergeResult'ConflictInvolvingBuiltin name) + done (MergeResult1'Failure (MergeResultFailure1'ConflictInvolvingBuiltin name)) liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts) - -- -- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there - -- -- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are) - -- dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts) + pure $ + MergeResult1'Success $ + MergeResultSuccess1'PerformedDiff + db + branches + defns3 + (ThreeWay.forgetLca declNameLookups3) + conflicts + unconflicts - -- liftIO (debugFunctions.debugDependents dependents) +doBigMerge2 :: + DebugFunctions -> + TwoWay Text -> + MergeDatabase -> + TwoOrThreeWay (V2.Branch Transaction) -> + ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> + TwoWay DeclNameLookup -> + TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) -> + DefnsF Unconflicts Referent TypeReference -> + Cli () +doBigMerge2 debugFunctions authors db branches defns3 declNameLookups conflicts unconflicts = do + Cli.Env {codebase} <- ask - -- let stageOne :: DefnsF (Map Name) Referent TypeReference - -- stageOne = - -- makeStageOne - -- declNameLookups - -- conflicts - -- unconflicts - -- dependents - -- (bimap BiMultimap.range BiMultimap.range defns3.lca) + let defns = ThreeWay.forgetLca defns3 - -- liftIO (debugFunctions.debugStageOne stageOne) + -- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there + -- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are) + dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts) - -- -- Load and merge Alice's and Bob's libdeps - -- mergedLibdeps <- - -- Cli.runTransaction do - -- libdeps <- loadLibdeps branches - -- libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps) + liftIO (debugFunctions.debugDependents dependents) - -- -- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names - -- let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl - -- mkPpes defnsNames libdepsNames = - -- defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier - -- where - -- suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames) - -- let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps) + let stageOne :: DefnsF (Map Name) Referent TypeReference + stageOne = + makeStageOne + declNameLookups + conflicts + unconflicts + dependents + (bimap BiMultimap.range BiMultimap.range defns3.lca) - -- hydratedThings <- do - -- Cli.runTransaction do - -- for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) -> - -- let hydrate = hydrateDefns (Codebase.unsafeGetTermComponent codebase) Operations.expectDeclComponent - -- in (,) <$> hydrate conflicts1 <*> hydrate dependents1 + liftIO (debugFunctions.debugStageOne stageOne) - -- 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 + -- Load and merge Alice's and Bob's libdeps + mergedLibdeps <- + Cli.runTransaction do + libdeps <- loadLibdeps branches + libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps) - -- let prettyUnisonFile = makePrettyUnisonFile (into @Text <$> projectAndBranchNames) renderedConflicts renderedDependents + -- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names + let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl + mkPpes defnsNames libdepsNames = + defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier + where + suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames) + let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps) - -- let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps + hydratedThings <- do + Cli.runTransaction do + for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) -> + let hydrate = hydrateDefns db.loadV1TermComponent db.loadV1DeclComponent + in (,) <$> hydrate conflicts1 <*> hydrate dependents1 - -- maybeTypecheckedUnisonFile <- - -- let thisMergeHasConflicts = - -- -- Eh, they'd either both be null, or neither, but just check both maps anyway - -- not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob) - -- in if thisMergeHasConflicts - -- then pure Nothing - -- else do - -- currentPath <- Cli.getCurrentPath - -- parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch) - -- prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe + let (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 - -- case maybeTypecheckedUnisonFile of - -- Nothing -> do - -- Cli.Env {writeSource} <- ask - -- aliceBranch <- Cli.getBranchAt info.paths.alice - -- bobBranch <- Cli.getBranchAt info.paths.bob - -- _temporaryBranchId <- - -- HandleInput.Branch.doCreateBranch' - -- (Branch.mergeNode stageOneBranch aliceBranch bobBranch) - -- Nothing - -- info.project - -- (findTemporaryBranchName info) - -- (textualDescriptionOfMerge info) - -- scratchFilePath <- - -- Cli.getLatestFile <&> \case - -- Nothing -> "scratch.u" - -- Just (file, _) -> file - -- liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) - -- Cli.respond $ - -- Output.MergeFailure - -- scratchFilePath - -- projectAndBranchNames.alice - -- projectAndBranchNames.bob - -- Just tuf -> do - -- Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) - -- bobBranch <- Cli.getBranchAt info.paths.bob - -- let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch - -- _ <- - -- Cli.updateAt - -- (textualDescriptionOfMerge info) - -- info.paths.alice - -- (\aliceBranch -> Branch.mergeNode stageTwoBranch aliceBranch bobBranch) - -- Cli.respond (Output.MergeSuccess projectAndBranchNames.alice projectAndBranchNames.bob) - undefined + let prettyUnisonFile = makePrettyUnisonFile authors renderedConflicts renderedDependents + + let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps + + maybeTypecheckedUnisonFile <- + let thisMergeHasConflicts = + -- Eh, they'd either both be null, or neither, but just check both maps anyway + not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob) + in if thisMergeHasConflicts + then pure Nothing + else do + currentPath <- Cli.getCurrentPath + parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch) + prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe + + -- case maybeTypecheckedUnisonFile of + -- Nothing -> do + -- Cli.Env {writeSource} <- ask + -- aliceBranch <- Cli.getBranchAt info.paths.alice + -- bobBranch <- Cli.getBranchAt info.paths.bob + -- _temporaryBranchId <- + -- HandleInput.Branch.doCreateBranch' + -- (Branch.mergeNode stageOneBranch aliceBranch bobBranch) + -- Nothing + -- info.project + -- (findTemporaryBranchName info) + -- (textualDescriptionOfMerge info) + -- scratchFilePath <- + -- Cli.getLatestFile <&> \case + -- Nothing -> "scratch.u" + -- Just (file, _) -> file + -- liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) + -- Cli.respond $ + -- Output.MergeFailure + -- scratchFilePath + -- projectAndBranchNames.alice + -- projectAndBranchNames.bob + -- Just tuf -> do + -- Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) + -- bobBranch <- Cli.getBranchAt info.paths.bob + -- let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch + -- _ <- + -- Cli.updateAt + -- (textualDescriptionOfMerge info) + -- info.paths.alice + -- (\aliceBranch -> Branch.mergeNode stageTwoBranch aliceBranch bobBranch) + -- Cli.respond (Output.MergeSuccess projectAndBranchNames.alice projectAndBranchNames.bob) + undefined ------------------------------------------------------------------------------------------------------------------------ -- Loading basic info out of the database @@ -724,13 +768,16 @@ makePrettyUnisonFile authors conflicts dependents = bob = prettyBinding (Just (Pretty.text authors.bob)) in bifoldMap f f ), - if TwoWay.or (not . defnsAreEmpty <$> dependents) - then - fold - [ "-- The definitions below are not conflicted, but they each depend on one or more\n", - "-- conflicted definitions above.\n\n" - ] - else mempty, + -- Show message that delineates where conflicts end and dependents begin only when there are both conflicts and + -- dependents + let thereAre defns = TwoWay.or (not . defnsAreEmpty <$> defns) + in if thereAre conflicts && thereAre dependents + then + fold + [ "-- The definitions below are not conflicted, but they each depend on one or more\n", + "-- conflicted definitions above.\n\n" + ] + else mempty, dependents -- Merge dependents together into one map (they are disjoint) & TwoWay.twoWay (zipDefnsWith Map.union Map.union) diff --git a/unison-merge/src/Unison/Merge/Database.hs b/unison-merge/src/Unison/Merge/Database.hs index 9ee91cf33..28cc05c93 100644 --- a/unison-merge/src/Unison/Merge/Database.hs +++ b/unison-merge/src/Unison/Merge/Database.hs @@ -16,11 +16,12 @@ import U.Codebase.Sqlite.Operations qualified as Operations import Unison.Builtin qualified as Builtins import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase -import Unison.Codebase.Branch qualified as V1 +import Unison.Codebase.SqliteCodebase.Operations qualified as Operations (expectDeclComponent) import Unison.ConstructorReference (GConstructorReference (..)) import Unison.ConstructorType (ConstructorType) import Unison.DataDeclaration qualified as V1 (Decl) import Unison.DataDeclaration qualified as V1.Decl +import Unison.Hash (Hash) import Unison.Parser.Ann qualified as V1 (Ann) import Unison.Prelude import Unison.Referent qualified as V1 (Referent) @@ -29,6 +30,7 @@ import Unison.Sqlite (Transaction) import Unison.Sqlite qualified as Sqlite import Unison.Symbol qualified as V1 (Symbol) import Unison.Term qualified as V1 (Term) +import Unison.Type qualified as V1 (Type) import Unison.Util.Cache qualified as Cache ------------------------------------------------------------------------------------------------------------------------ @@ -39,9 +41,10 @@ data MergeDatabase = MergeDatabase { loadCausal :: CausalHash -> Transaction (CausalBranch Transaction), loadDeclNumConstructors :: TypeReferenceId -> Transaction Int, loadDeclType :: TypeReference -> Transaction ConstructorType, - loadV1Branch :: CausalHash -> Transaction (V1.Branch Transaction), loadV1Decl :: TypeReferenceId -> Transaction (V1.Decl V1.Symbol V1.Ann), - loadV1Term :: TermReferenceId -> Transaction (V1.Term V1.Symbol V1.Ann) + loadV1DeclComponent :: Hash -> Transaction [V1.Decl V1.Symbol V1.Ann], + loadV1Term :: TermReferenceId -> Transaction (V1.Term V1.Symbol V1.Ann), + loadV1TermComponent :: Hash -> Transaction [(V1.Term V1.Symbol V1.Ann, V1.Type V1.Symbol V1.Ann)] } makeMergeDatabase :: MonadIO m => Codebase IO V1.Symbol V1.Ann -> m MergeDatabase @@ -53,7 +56,6 @@ makeMergeDatabase codebase = liftIO do loadDeclNumConstructors <- do cache <- Cache.semispaceCache 1024 pure (Sqlite.cacheTransaction cache Operations.expectDeclNumConstructors) - let loadV1Branch = undefined -- Codebase.expectBranchForHash codebase loadV1Decl <- do cache <- Cache.semispaceCache 1024 pure (Sqlite.cacheTransaction cache (Codebase.unsafeGetTypeDeclaration codebase)) @@ -67,7 +69,18 @@ makeMergeDatabase codebase = liftIO do loadV1Term <- do cache <- Cache.semispaceCache 1024 pure (Sqlite.cacheTransaction cache (Codebase.unsafeGetTerm codebase)) - pure MergeDatabase {loadCausal, loadDeclNumConstructors, loadDeclType, loadV1Branch, loadV1Decl, loadV1Term} + let loadV1TermComponent = Codebase.unsafeGetTermComponent codebase + let loadV1DeclComponent = Operations.expectDeclComponent + pure + MergeDatabase + { loadCausal, + loadDeclNumConstructors, + loadDeclType, + loadV1Decl, + loadV1DeclComponent, + loadV1Term, + loadV1TermComponent + } -- Convert a v2 referent (missing decl type) to a v1 referent. referent2to1 :: MergeDatabase -> Referent -> Transaction V1.Referent From a41e8d0bd7f5ea953eb83aa7339bd9ca038b3532 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Mon, 13 May 2024 14:41:13 -0600 Subject: [PATCH 15/82] Use `NumberedArgs` type consistently MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit As the type is changing to be more structured, we can’t use `[String]` in its place. --- unison-cli/src/Unison/CommandLine.hs | 5 +++-- unison-cli/src/Unison/CommandLine/Main.hs | 4 ++-- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine.hs b/unison-cli/src/Unison/CommandLine.hs index f97a25e33..38d53a4a8 100644 --- a/unison-cli/src/Unison/CommandLine.hs +++ b/unison-cli/src/Unison/CommandLine.hs @@ -46,6 +46,7 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.Input (Event (..), Input (..)) +import Unison.Codebase.Editor.Output (NumberedArgs) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Watch qualified as Watch import Unison.CommandLine.FZFResolvers qualified as FZFResolvers @@ -123,7 +124,7 @@ parseInput :: -- | Current path from root Path.Absolute -> -- | Numbered arguments - [String] -> + NumberedArgs -> -- | Input Pattern Map Map String InputPattern -> -- | command:arguments @@ -168,7 +169,7 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do ] -- Expand a numeric argument like `1` or a range like `3-9` -expandNumber :: [String] -> String -> [String] +expandNumber :: NumberedArgs -> String -> [String] expandNumber numberedArgs s = case expandedNumber of Nothing -> [s] Just nums -> diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index de0d7e12f..0e948b5da 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -33,7 +33,7 @@ import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.HandleInput qualified as HandleInput import Unison.Codebase.Editor.Input (Event, Input (..)) -import Unison.Codebase.Editor.Output (Output) +import Unison.Codebase.Editor.Output (NumberedArgs, Output) import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Runtime qualified as Runtime @@ -61,7 +61,7 @@ getUserInput :: Codebase IO Symbol Ann -> AuthenticatedHttpClient -> Path.Absolute -> - [String] -> + NumberedArgs -> IO Input getUserInput codebase authHTTPClient currentPath numberedArgs = Line.runInputT From a77c10a34221dc8e8e108d22c51e62509a367300 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 13 May 2024 20:45:10 -0400 Subject: [PATCH 16/82] merge work (not compiling) --- .../src/Unison/Codebase/Branch.hs | 13 +- .../Codebase/Editor/HandleInput/Merge2.hs | 546 ++++-------------- .../src/Unison/Codebase/Editor/Output.hs | 4 +- .../src/Unison/CommandLine/OutputMessages.hs | 4 +- 4 files changed, 138 insertions(+), 429 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Branch.hs b/parser-typechecker/src/Unison/Codebase/Branch.hs index 788f447b1..b9a0e625a 100644 --- a/parser-typechecker/src/Unison/Codebase/Branch.hs +++ b/parser-typechecker/src/Unison/Codebase/Branch.hs @@ -476,13 +476,18 @@ cons :: (Applicative m) => Branch0 m -> Branch m -> Branch m cons = step . const -- | Construct a two-parent merge node. -mergeNode :: forall m. Applicative m => Branch0 m -> Branch m -> Branch m -> Branch m +mergeNode :: + forall m. + Applicative m => + Branch0 m -> + (CausalHash, m (Branch m)) -> + (CausalHash, m (Branch m)) -> + Branch m mergeNode child parent1 parent2 = Branch (Causal.mergeNode child (Map.fromList [f parent1, f parent2])) where - f :: Branch m -> (CausalHash, m (Causal m (Branch0 m))) - f parent = - (headHash parent, pure (_history parent)) + f (hash, getBranch) = + (hash, _history <$> getBranch) isOne :: Branch m -> Bool isOne (Branch Causal.One {}) = True diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 6dfb6b9a1..262fd3dd9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -33,6 +33,7 @@ import U.Codebase.Referent qualified as V2 (Referent) 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.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -50,7 +51,6 @@ import Unison.Codebase.Editor.HandleInput.Update2 prettyParseTypecheck2, typecheckedUnisonFileToBranchAdds, ) -import Unison.Codebase.Editor.Output (Output) import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache) @@ -126,6 +126,10 @@ import Unison.Util.SyntaxText (SyntaxText') import Unison.Var (Var) import Witch (unsafeFrom) import Prelude hiding (unzip, zip, zipWith) +import U.Codebase.Sqlite.DbId (ProjectId) + +data BobBranch + = BobBranch'ProjectAndBranchNames (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleMerge bobSpecifier = do @@ -136,37 +140,68 @@ handleMerge bobSpecifier = do Cli.Env {codebase} <- ask + (aliceProjectAndBranch, _path) <- Cli.expectCurrentProjectBranch + let alicePath = + Cli.projectBranchPath $ + ProjectAndBranch + aliceProjectAndBranch.project.projectId + aliceProjectAndBranch.branch.branchId + + let projectAndBranchToInfo :: ProjectAndBranch Project ProjectBranch -> Cli (CausalHash, ProjectAndBranch ProjectName ProjectBranchName) + projectAndBranchToInfo (ProjectAndBranch project branch) = do + let path = Cli.projectBranchPath (ProjectAndBranch project.projectId branch.branchId) + causal <- Cli.runTransaction (Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path)) + pure (causal.causalHash, ProjectAndBranch project.name branch.name) + + (aliceCausalHash, aliceBranchNames) <- projectAndBranchToInfo aliceProjectAndBranch + + (bobCausalHash, bobBranchNames) <- + case BobBranch'ProjectAndBranchNames bobSpecifier of + BobBranch'ProjectAndBranchNames (ProjectAndBranch maybeBobProjectName bobBranchName) -> do + bobProject <- + case maybeBobProjectName of + Nothing -> pure aliceProjectAndBranch.project + Just bobProjectName + | bobProjectName == aliceProjectAndBranch.project.name -> pure aliceProjectAndBranch.project + | otherwise -> do + Cli.runTransaction (Queries.loadProjectByName bobProjectName) + & onNothingM (Cli.returnEarly (Output.LocalProjectDoesntExist bobProjectName)) + bobProjectBranch <- Cli.expectProjectBranchByName bobProject bobBranchName + projectAndBranchToInfo (ProjectAndBranch bobProject bobProjectBranch) + + lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash bobCausalHash) + + let causalHashes :: TwoOrThreeWay CausalHash + causalHashes = + TwoOrThreeWay {alice = aliceCausalHash, bob = bobCausalHash, lca = lcaCausalHash} + + let branchNames :: TwoWay (ProjectAndBranch ProjectName ProjectBranchName) + branchNames = + TwoWay {alice = aliceBranchNames, bob = bobBranchNames} + + let textualDescriptionOfMerge :: Text + textualDescriptionOfMerge = + "merge " <> into @Text branchNames.bob + + --- + + -- If alice == bob, or LCA == bob (so alice is ahead of bob), then we are done. + when (causalHashes.alice == causalHashes.bob || causalHashes.lca == Just causalHashes.bob) do + Cli.returnEarly (Output.MergeAlreadyUpToDate (Right branchNames.bob) (Right branchNames.alice)) + + -- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done. + when (causalHashes.lca == Just causalHashes.alice) do + bobBranch <- liftIO (Codebase.expectBranchForHash codebase causalHashes.bob) + _ <- Cli.updateAt textualDescriptionOfMerge alicePath (\_aliceBranch -> bobBranch) + Cli.returnEarly (Output.MergeSuccessFastForward branchNames.alice branchNames.bob) + + --- + -- Create a bunch of cached database lookup functions db <- makeMergeDatabase codebase - -- Load the current project branch ("Alice"), and the branch from the same project to merge in ("Bob") - info <- loadMergeInfo bobSpecifier - let projectAndBranchNames = (\x -> ProjectAndBranch x.project.name x.branch.name) <$> info.branches - -- Load Alice/Bob/LCA causals - causals <- - Cli.runTransaction do - alice <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute info.paths.alice) - bob <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute info.paths.bob) - lca <- - Operations.lca alice.causalHash bob.causalHash >>= \case - Nothing -> pure Nothing - Just lcaCausalHash -> Just <$> db.loadCausal lcaCausalHash - pure TwoOrThreeWay {lca, alice, bob} - - -- If alice == bob, then we are done. - when (causals.alice == causals.bob) do - Cli.returnEarly (Output.MergeAlreadyUpToDate (Right info.branches.bob) (Right info.branches.alice)) - - -- Otherwise, if LCA == bob, then we are ahead of bob, so we are done. - when (causals.lca == Just causals.bob) do - Cli.returnEarly (Output.MergeAlreadyUpToDate (Right info.branches.bob) (Right info.branches.alice)) - - -- Otherwise, if LCA == alice, then we can fast forward to bob, and we're done. - when (causals.lca == Just causals.alice) do - bobBranch <- Cli.getBranchAt info.paths.bob - _ <- Cli.updateAt (textualDescriptionOfMerge info) info.paths.alice (\_aliceBranch -> bobBranch) - Cli.returnEarly (Output.MergeSuccessFastForward projectAndBranchNames.alice projectAndBranchNames.bob) + causals <- Cli.runTransaction (traverse Operations.expectCausalBranchByCausalHash causalHashes) liftIO (debugFunctions.debugCausals causals) @@ -178,25 +213,60 @@ handleMerge bobSpecifier = do lca <- for causals.lca \causal -> causal.value pure TwoOrThreeWay {lca, alice, bob} + -- Assert that neither Alice nor Bob have defns in lib + for_ [(branchNames.alice, branches.alice), (branchNames.bob, branches.bob)] \(who, branch) -> do + libdeps <- + case Map.lookup NameSegment.libSegment branch.children of + Nothing -> pure V2.Branch.empty + Just libdeps -> Cli.runTransaction libdeps.value + when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do + Cli.returnEarly Output.MergeDefnsInLib + -- Load Alice/Bob/LCA definitions and decl name lookups - (defns3, declNameLookups3) <- - Cli.runTransactionWithRollback \abort -> do - loadDefns abort db (view #branch <$> info.branches) branches + (defns3, declNameLookups3) <- do + let load = \case + Nothing -> + pure + ( Nametree {value = Defns Map.empty Map.empty, children = Map.empty}, + DeclNameLookup Map.empty Map.empty + ) + Just (causalHash, branch) -> do + defns <- + Cli.runTransaction (loadNamespaceInfo_2 (referent2to1 db) branch) & onLeftM \err -> + Cli.returnEarly wundefined -- (MergeResult1'Failure (MergeResultFailure1'ConflictedName causalHash err)) + declNameLookup <- + Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err -> + Cli.returnEarly wundefined -- (MergeResult1'Failure (MergeResultFailure1'IncoherentDecl causalHash err)) + pure (defns, declNameLookup) + + (aliceDefns0, aliceDeclNameLookup) <- load (Just (causalHashes.alice, branches.alice)) + (bobDefns0, bobDeclNameLookup) <- load (Just (causalHashes.bob, branches.bob)) + (lcaDefns0, lcaDeclNameLookup) <- load ((,) <$> causalHashes.lca <*> branches.lca) + + let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns) + let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0} + let declNameLookups3 = ThreeWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup, lca = lcaDeclNameLookup} + + pure (defns3, declNameLookups3) + let defns = ThreeWay.forgetLca defns3 let declNameLookups = ThreeWay.forgetLca declNameLookups3 liftIO (debugFunctions.debugDefns defns3 declNameLookups3) -- Diff LCA->Alice and LCA->Bob - diffs <- - Cli.runTransaction do - Merge.nameBasedNamespaceDiff db declNameLookups3 defns3 + diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups3 defns3) liftIO (debugFunctions.debugDiffs diffs) -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias - whenJust (findOneConflictedAlias (view #branch <$> info.branches) defns3.lca diffs) \violation -> - Cli.returnEarly (mergePreconditionViolationToOutput violation) + do + let go who diff = + whenJust (findConflictedAlias defns3.lca diff) \names -> + -- Cli.returnEarly (mergePreconditionViolationToOutput violation) + Cli.returnEarly wundefined -- (MergeResult1'Failure (MergeResultFailure1'ConflictedAliases (who names))) + go Alice diffs.alice + go Bob diffs.bob -- Combine the LCA->Alice and LCA->Bob diffs together let diff = combineDiffs diffs @@ -275,7 +345,7 @@ handleMerge bobSpecifier = do <*> hydratedThings <*> ppes - let prettyUnisonFile = makePrettyUnisonFile (into @Text <$> projectAndBranchNames) renderedConflicts renderedDependents + let prettyUnisonFile = makePrettyUnisonFile (into @Text <$> branchNames) renderedConflicts renderedDependents let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps @@ -290,18 +360,19 @@ handleMerge bobSpecifier = do parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch) prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe + let parents = + (\causal -> (causal.causalHash, Codebase.expectBranchForHash codebase causal.causalHash)) <$> causals + case maybeTypecheckedUnisonFile of Nothing -> do Cli.Env {writeSource} <- ask - aliceBranch <- Cli.getBranchAt info.paths.alice - bobBranch <- Cli.getBranchAt info.paths.bob _temporaryBranchId <- HandleInput.Branch.doCreateBranch' - (Branch.mergeNode stageOneBranch aliceBranch bobBranch) + (Branch.mergeNode stageOneBranch parents.alice parents.bob) Nothing - info.branches.alice.project - (findTemporaryBranchName info) - (textualDescriptionOfMerge info) + aliceProjectAndBranch.project + (findTemporaryBranchName aliceProjectAndBranch.project.projectId (view #branch <$> branchNames)) + textualDescriptionOfMerge scratchFilePath <- Cli.getLatestFile <&> \case Nothing -> "scratch.u" @@ -310,328 +381,21 @@ handleMerge bobSpecifier = do Cli.respond $ Output.MergeFailure scratchFilePath - projectAndBranchNames.alice - projectAndBranchNames.bob + branchNames.alice + branchNames.bob Just tuf -> do Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) - bobBranch <- Cli.getBranchAt info.paths.bob let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch _ <- Cli.updateAt - (textualDescriptionOfMerge info) - info.paths.alice - (\aliceBranch -> Branch.mergeNode stageTwoBranch aliceBranch bobBranch) - Cli.respond (Output.MergeSuccess projectAndBranchNames.alice projectAndBranchNames.bob) - -data MergeResult1 - = MergeResult1'Failure !MergeResultFailure1 - | MergeResult1'Success !MergeResultSuccess1 - -data MergeResultFailure1 - = -- We couldn't attempt to merge because we found a conflicted name - MergeResultFailure1'ConflictedName !CausalHash !ConflictedName - | -- We couldn't attempt to merge because we found defs in lib - MergeResultFailure1'DefnsInLib !(EitherWay ()) - | -- We couldn't attempt to merge because we found an incoherent decl - MergeResultFailure1'IncoherentDecl !CausalHash !IncoherentDeclReason - | -- We couldn't attempt to merge because we found conflicted aliases - MergeResultFailure1'ConflictedAliases !(EitherWay (Name, Name)) - | -- We couldn't attempt to merge because we found a conflict involving a builtin - MergeResultFailure1'ConflictInvolvingBuiltin !Name - -data MergeResultSuccess1 - = -- We didn't do anything because alice >= bob - MergeResultSuccess1'AlreadyMerged - | -- We didn't do anything because alice < bob. The caller should set alice = bob - MergeResultSuccess1'ShouldFastForward - | -- We got as far as diffing the namespace - MergeResultSuccess1'PerformedDiff - !MergeDatabase - !(TwoOrThreeWay (V2.Branch Transaction)) -- branches - !(ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name))) -- defns - !(TwoWay DeclNameLookup) -- decl name lookups - !(TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId)) -- conflicts - !(DefnsF Unconflicts Referent TypeReference) -- unconflicts - -doBigMerge1 :: DebugFunctions -> TwoWay Text -> TwoOrThreeWay CausalHash -> Cli MergeResult1 -doBigMerge1 debugFunctions authors causalHashes = do - Cli.label \done -> do - -- If alice == bob, or LCA == bob (so alice is ahead of bob), then we are done. - when (causalHashes.alice == causalHashes.bob || causalHashes.lca == Just causalHashes.bob) do - done (MergeResult1'Success MergeResultSuccess1'AlreadyMerged) - - -- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done. - when (causalHashes.lca == Just causalHashes.alice) do - done (MergeResult1'Success MergeResultSuccess1'ShouldFastForward) - - Cli.Env {codebase} <- ask - - -- Create a bunch of cached database lookup functions - db <- makeMergeDatabase codebase - - -- Load Alice/Bob/LCA causals - causals <- Cli.runTransaction (traverse Operations.expectCausalBranchByCausalHash causalHashes) - - liftIO (debugFunctions.debugCausals causals) - - -- Load Alice/Bob/LCA branches - branches <- - Cli.runTransaction do - alice <- causals.alice.value - bob <- causals.bob.value - lca <- for causals.lca \causal -> causal.value - pure TwoOrThreeWay {lca, alice, bob} - - -- Assert that neither Alice nor Bob have defns in lib - for_ [(Alice (), branches.alice), (Bob (), branches.bob)] \(who, branch) -> do - libdeps <- - case Map.lookup NameSegment.libSegment branch.children of - Nothing -> pure V2.Branch.empty - Just libdeps -> Cli.runTransaction libdeps.value - when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do - done (MergeResult1'Failure (MergeResultFailure1'DefnsInLib who)) - - -- Load Alice/Bob/LCA definitions and decl name lookups - (defns3, declNameLookups3) <- do - let load = \case - Nothing -> - pure - ( Nametree {value = Defns Map.empty Map.empty, children = Map.empty}, - DeclNameLookup Map.empty Map.empty - ) - Just (causalHash, branch) -> do - defns <- - Cli.runTransaction (loadNamespaceInfo_2 (referent2to1 db) branch) & onLeftM \err -> - done (MergeResult1'Failure (MergeResultFailure1'ConflictedName causalHash err)) - declNameLookup <- - Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err -> - done (MergeResult1'Failure (MergeResultFailure1'IncoherentDecl causalHash err)) - pure (defns, declNameLookup) - - (aliceDefns0, aliceDeclNameLookup) <- load (Just (causalHashes.alice, branches.alice)) - (bobDefns0, bobDeclNameLookup) <- load (Just (causalHashes.bob, branches.bob)) - (lcaDefns0, lcaDeclNameLookup) <- load ((,) <$> causalHashes.lca <*> branches.lca) - - let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns) - let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0} - let declNameLookups3 = ThreeWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup, lca = lcaDeclNameLookup} - - pure (defns3, declNameLookups3) - - let defns = ThreeWay.forgetLca defns3 - let declNameLookups = ThreeWay.forgetLca declNameLookups3 - - liftIO (debugFunctions.debugDefns defns3 declNameLookups3) - - -- Diff LCA->Alice and LCA->Bob - diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups3 defns3) - - liftIO (debugFunctions.debugDiffs diffs) - - -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias - do - let go who diff = - whenJust (findConflictedAlias defns3.lca diff) \names -> - done (MergeResult1'Failure (MergeResultFailure1'ConflictedAliases (who names))) - go Alice diffs.alice - go Bob diffs.bob - - -- Combine the LCA->Alice and LCA->Bob diffs together - let diff = combineDiffs diffs - - liftIO (debugFunctions.debugCombinedDiff diff) - - -- Partition the combined diff into the conflicted things and the unconflicted things - (conflicts, unconflicts) <- - partitionCombinedDiffs defns declNameLookups diff & onLeft \name -> - done (MergeResult1'Failure (MergeResultFailure1'ConflictInvolvingBuiltin name)) - - liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts) - - pure $ - MergeResult1'Success $ - MergeResultSuccess1'PerformedDiff - db - branches - defns3 - (ThreeWay.forgetLca declNameLookups3) - conflicts - unconflicts - -doBigMerge2 :: - DebugFunctions -> - TwoWay Text -> - MergeDatabase -> - TwoOrThreeWay (V2.Branch Transaction) -> - ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> - TwoWay DeclNameLookup -> - TwoWay (DefnsF (Map Name) TermReferenceId TypeReferenceId) -> - DefnsF Unconflicts Referent TypeReference -> - Cli () -doBigMerge2 debugFunctions authors db branches defns3 declNameLookups conflicts unconflicts = do - Cli.Env {codebase} <- ask - - let defns = ThreeWay.forgetLca defns3 - - -- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there - -- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are) - dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts) - - liftIO (debugFunctions.debugDependents dependents) - - let stageOne :: DefnsF (Map Name) Referent TypeReference - stageOne = - makeStageOne - declNameLookups - conflicts - unconflicts - dependents - (bimap BiMultimap.range BiMultimap.range defns3.lca) - - liftIO (debugFunctions.debugStageOne stageOne) - - -- Load and merge Alice's and Bob's libdeps - mergedLibdeps <- - Cli.runTransaction do - libdeps <- loadLibdeps branches - libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps) - - -- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names - let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl - mkPpes defnsNames libdepsNames = - defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier - where - suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames) - let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps) - - hydratedThings <- do - Cli.runTransaction do - for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) -> - let hydrate = hydrateDefns db.loadV1TermComponent db.loadV1DeclComponent - in (,) <$> hydrate conflicts1 <*> hydrate dependents1 - - let (renderedConflicts, renderedDependents) = - let honk declNameLookup ppe defns = - let (types, accessorNames) = - Writer.runWriter $ - defns.types & Map.traverseWithKey \name (ref, typ) -> - renderTypeBinding - -- Sort of a hack; since the decl printer looks in the PPE for names of constructors, - -- we just delete all term names out and add back the constructors... - -- probably no need to wipe out the suffixified side but we do it anyway - (setPpedToConstructorNames declNameLookup name ref ppe) - name - ref - typ - terms = - defns.terms & Map.mapMaybeWithKey \name (term, typ) -> - if Set.member name accessorNames - then Nothing - else Just (renderTermBinding ppe.suffixifiedPPE name term typ) - in Defns {terms, types} - in unzip $ - ( \declNameLookup (conflicts, dependents) ppe -> - let honk1 = honk declNameLookup ppe - in (honk1 conflicts, honk1 dependents) - ) - <$> declNameLookups - <*> hydratedThings - <*> ppes - - let prettyUnisonFile = makePrettyUnisonFile authors renderedConflicts renderedDependents - - let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps - - maybeTypecheckedUnisonFile <- - let thisMergeHasConflicts = - -- Eh, they'd either both be null, or neither, but just check both maps anyway - not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob) - in if thisMergeHasConflicts - then pure Nothing - else do - currentPath <- Cli.getCurrentPath - parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch) - prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe - - -- case maybeTypecheckedUnisonFile of - -- Nothing -> do - -- Cli.Env {writeSource} <- ask - -- aliceBranch <- Cli.getBranchAt info.paths.alice - -- bobBranch <- Cli.getBranchAt info.paths.bob - -- _temporaryBranchId <- - -- HandleInput.Branch.doCreateBranch' - -- (Branch.mergeNode stageOneBranch aliceBranch bobBranch) - -- Nothing - -- info.project - -- (findTemporaryBranchName info) - -- (textualDescriptionOfMerge info) - -- scratchFilePath <- - -- Cli.getLatestFile <&> \case - -- Nothing -> "scratch.u" - -- Just (file, _) -> file - -- liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) - -- Cli.respond $ - -- Output.MergeFailure - -- scratchFilePath - -- projectAndBranchNames.alice - -- projectAndBranchNames.bob - -- Just tuf -> do - -- Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) - -- bobBranch <- Cli.getBranchAt info.paths.bob - -- let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch - -- _ <- - -- Cli.updateAt - -- (textualDescriptionOfMerge info) - -- info.paths.alice - -- (\aliceBranch -> Branch.mergeNode stageTwoBranch aliceBranch bobBranch) - -- Cli.respond (Output.MergeSuccess projectAndBranchNames.alice projectAndBranchNames.bob) - undefined + textualDescriptionOfMerge + alicePath + (\_ -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) + Cli.respond (Output.MergeSuccess branchNames.alice branchNames.bob) ------------------------------------------------------------------------------------------------------------------------ -- Loading basic info out of the database -loadMergeInfo :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli MergeInfo -loadMergeInfo (ProjectAndBranch maybeBobProjectName bobBranchName) = do - (aliceProjectBranch, _path) <- Cli.expectCurrentProjectBranch - bobProjectBranch <- - Cli.expectProjectAndBranchByTheseNames case maybeBobProjectName of - Nothing -> That bobBranchName - Just bobProjectName -> These bobProjectName bobBranchName - let alicePath = Cli.projectBranchPath (ProjectAndBranch aliceProjectBranch.project.projectId aliceProjectBranch.branch.branchId) - let bobPath = Cli.projectBranchPath (ProjectAndBranch bobProjectBranch.project.projectId bobProjectBranch.branch.branchId) - pure - MergeInfo - { paths = TwoWay alicePath bobPath, - branches = TwoWay aliceProjectBranch bobProjectBranch - } - -loadDefns :: - (forall a. Output -> Transaction a) -> - MergeDatabase -> - TwoWay ProjectBranch -> - TwoOrThreeWay (V2.Branch Transaction) -> - Transaction - ( ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)), - ThreeWay DeclNameLookup - ) -loadDefns abort0 db projectBranches branches = do - lcaDefns0 <- - case branches.lca of - Nothing -> pure Nametree {value = Defns Map.empty Map.empty, children = Map.empty} - Just lcaBranch -> loadNamespaceInfo abort db lcaBranch - aliceDefns0 <- loadNamespaceInfo abort db branches.alice - bobDefns0 <- loadNamespaceInfo abort db branches.bob - - lca <- assertNamespaceSatisfiesPreconditions db abort Nothing (fromMaybe V2.Branch.empty branches.lca) lcaDefns0 - alice <- assertNamespaceSatisfiesPreconditions db abort (Just projectBranches.alice.name) branches.alice aliceDefns0 - bob <- assertNamespaceSatisfiesPreconditions db abort (Just projectBranches.bob.name) branches.bob bobDefns0 - - pure (unzip ThreeWay {lca, alice, bob}) - where - abort :: Merge.PreconditionViolation -> Transaction void - abort = - abort0 . mergePreconditionViolationToOutput - loadLibdeps :: TwoOrThreeWay (V2.Branch Transaction) -> Transaction (ThreeWay (Map NameSegment (V2.CausalBranch Transaction))) @@ -891,17 +655,6 @@ nametreeToBranch0 nametree = rel2star rel = Star2.Star2 {fact = Relation.dom rel, d1 = rel, d2 = Relation.empty} -data MergeInfo = MergeInfo - { paths :: !(TwoWay Path.Absolute), - branches :: !(TwoWay (ProjectAndBranch Project ProjectBranch)) - } - deriving stock (Generic) - -textualDescriptionOfMerge :: MergeInfo -> Text -textualDescriptionOfMerge info = - let bobBranchText = into @Text (ProjectAndBranch info.branches.bob.project.name info.branches.bob.branch.name) - in "merge " <> bobBranchText - -- FIXME: let's come up with a better term for "dependencies" in the implementation of this function identifyDependents :: TwoWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> @@ -1019,17 +772,17 @@ defnsToNames defns = types = Relation.fromMap (BiMultimap.range defns.types) } -findTemporaryBranchName :: MergeInfo -> Transaction ProjectBranchName -findTemporaryBranchName info = do - Cli.findTemporaryBranchName info.branches.alice.project.projectId preferred +findTemporaryBranchName :: ProjectId -> TwoWay ProjectBranchName -> Transaction ProjectBranchName +findTemporaryBranchName projectId branchNames = do + Cli.findTemporaryBranchName projectId preferred where preferred :: ProjectBranchName preferred = unsafeFrom @Text $ "merge-" - <> mangle info.branches.bob.branch.name + <> mangle branchNames.bob <> "-into-" - <> mangle info.branches.alice.branch.name + <> mangle branchNames.alice mangle :: ProjectBranchName -> Text mangle = @@ -1051,19 +804,6 @@ findTemporaryBranchName info = do <> Text.Builder.char '.' <> Text.Builder.decimal z --- Load namespace info into memory. --- --- Fails if: --- * One name is associated with more than one reference. -loadNamespaceInfo :: - (forall void. Merge.PreconditionViolation -> Transaction void) -> - MergeDatabase -> - V2.Branch Transaction -> - Transaction (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -loadNamespaceInfo abort db branch = do - defns <- loadNamespaceInfo0 (referent2to1 db) branch - assertNamespaceHasNoConflictedNames defns & onLeft abort - -- Load namespace info into memory. -- -- Fails if: @@ -1076,25 +816,6 @@ loadNamespaceInfo_2 :: loadNamespaceInfo_2 referent2to1 branch = assertNamespaceHasNoConflictedNames_2 <$> loadNamespaceInfo0_2 referent2to1 branch --- | Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined --- in the "lib" namespace. -loadNamespaceInfo0 :: - Monad m => - (V2.Referent -> m Referent) -> - V2.Branch m -> - m (Nametree (DefnsF2 (Map NameSegment) Set Referent TypeReference)) -loadNamespaceInfo0 referent2to1 branch = do - terms <- - branch.terms - & Map.map Map.keysSet - & traverse (Set.traverse referent2to1) - let types = Map.map Map.keysSet branch.types - children <- - for (Map.delete NameSegment.libSegment branch.children) \childCausal -> do - childBranch <- childCausal.value - loadNamespaceInfo0_ referent2to1 childBranch - pure Nametree {value = Defns {terms, types}, children} - -- | Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined -- in the "lib" namespace. loadNamespaceInfo0_2 :: @@ -1119,23 +840,6 @@ loadNamespaceInfo0_2 referent2to1 = go id child pure Nametree {value = Defns {terms, types}, children} -loadNamespaceInfo0_ :: - (Monad m) => - (V2.Referent -> m Referent) -> - V2.Branch m -> - m (Nametree (DefnsF2 (Map NameSegment) Set Referent TypeReference)) -loadNamespaceInfo0_ referent2to1 branch = do - terms <- - branch.terms - & Map.map Map.keysSet - & traverse (Set.traverse referent2to1) - let types = Map.map Map.keysSet branch.types - children <- - for branch.children \childCausal -> do - childBranch <- childCausal.value - loadNamespaceInfo0_ referent2to1 childBranch - pure Nametree {value = Defns {terms, types}, children} - -- | Assert that there are no unconflicted names in a namespace. assertNamespaceHasNoConflictedNames :: Nametree (DefnsF2 (Map NameSegment) Set Referent TypeReference) -> diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 1efe4a9b7..6e89bb396 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -291,8 +291,8 @@ data Output | -- | Indicates a trivial merge where the destination was empty and was just replaced. MergeOverEmpty (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) | MergeAlreadyUpToDate - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + (Either Path' (ProjectAndBranch ProjectName ProjectBranchName)) + (Either Path' (ProjectAndBranch ProjectName ProjectBranchName)) | PreviewMergeAlreadyUpToDate (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index c19d13b74..e3f27f179 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1635,9 +1635,9 @@ notifyUser dir = \case MergeAlreadyUpToDate src dest -> pure . P.callout "😶" $ P.wrap $ - prettyNamespaceKey dest + either prettyPath' prettyProjectAndBranchName dest <> "was already up-to-date with" - <> P.group (prettyNamespaceKey src <> ".") + <> P.group (either prettyPath' prettyProjectAndBranchName src <> ".") MergeConflictedAliases branch name1 name2 -> pure . P.wrap $ "On" From 88f4ff15cd48d489751ee16912f1feaf2ab639a7 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 14 May 2024 09:08:09 -0400 Subject: [PATCH 17/82] fix compiler error --- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index e56856b1c..cd0ccc5bb 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -434,8 +434,11 @@ loop e = do let destp = looseCodeOrProjectToPath dest0 srcb <- Cli.expectBranchAtPath' srcp dest <- Cli.resolvePath' destp - -- todo: fixme: use project and branch names - let err = Just $ MergeAlreadyUpToDate src0 dest0 + let err = + Just $ + MergeAlreadyUpToDate + ((\x -> ProjectAndBranch x.project.name x.branch.name) <$> src0) + ((\x -> ProjectAndBranch x.project.name x.branch.name) <$> dest0) mergeBranchAndPropagateDefaultPatch mergeMode description err srcb (Just dest0) dest PreviewMergeLocalBranchI src0 dest0 -> do Cli.Env {codebase} <- ask From 5dcf56dc78dd25f626223e98ce3fb639be376265 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 14 May 2024 09:29:29 -0400 Subject: [PATCH 18/82] fix up undefineds --- .../Codebase/Editor/HandleInput/Merge2.hs | 189 +++--------------- .../src/Unison/Codebase/Editor/Output.hs | 13 +- .../src/Unison/CommandLine/OutputMessages.hs | 6 +- .../src/Unison/Merge/PreconditionViolation.hs | 39 ---- unison-merge/unison-merge.cabal | 1 - 5 files changed, 41 insertions(+), 207 deletions(-) delete mode 100644 unison-merge/src/Unison/Merge/PreconditionViolation.hs diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 262fd3dd9..f77cac5f0 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -30,6 +30,7 @@ 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 (..)) @@ -74,7 +75,6 @@ import Unison.Merge.EitherWayI (EitherWayI (..)) import Unison.Merge.EitherWayI qualified as EitherWayI import Unison.Merge.Libdeps qualified as Merge import Unison.Merge.PartitionCombinedDiffs (partitionCombinedDiffs) -import Unison.Merge.PreconditionViolation qualified as Merge import Unison.Merge.Synhashed (Synhashed (..)) import Unison.Merge.Synhashed qualified as Synhashed import Unison.Merge.ThreeWay (ThreeWay (..)) @@ -119,14 +119,12 @@ 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.Util.Star2 (Star2) import Unison.Util.Star2 qualified as Star2 import Unison.Util.SyntaxText (SyntaxText') import Unison.Var (Var) import Witch (unsafeFrom) import Prelude hiding (unzip, zip, zipWith) -import U.Codebase.Sqlite.DbId (ProjectId) data BobBranch = BobBranch'ProjectAndBranchNames (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) @@ -214,13 +212,13 @@ handleMerge bobSpecifier = do pure TwoOrThreeWay {lca, alice, bob} -- Assert that neither Alice nor Bob have defns in lib - for_ [(branchNames.alice, branches.alice), (branchNames.bob, branches.bob)] \(who, branch) -> do + for_ [(branchNames.alice.branch, branches.alice), (branchNames.bob.branch, branches.bob)] \(who, branch) -> do libdeps <- case Map.lookup NameSegment.libSegment branch.children of Nothing -> pure V2.Branch.empty Just libdeps -> Cli.runTransaction libdeps.value when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do - Cli.returnEarly Output.MergeDefnsInLib + Cli.returnEarly (Output.MergeDefnsInLib who) -- Load Alice/Bob/LCA definitions and decl name lookups (defns3, declNameLookups3) <- do @@ -230,18 +228,26 @@ handleMerge bobSpecifier = do ( Nametree {value = Defns Map.empty Map.empty, children = Map.empty}, DeclNameLookup Map.empty Map.empty ) - Just (causalHash, branch) -> do + Just (maybeBranchName, branch) -> do defns <- - Cli.runTransaction (loadNamespaceInfo_2 (referent2to1 db) branch) & onLeftM \err -> - Cli.returnEarly wundefined -- (MergeResult1'Failure (MergeResultFailure1'ConflictedName causalHash err)) + Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName -> + Cli.returnEarly case conflictedName of + ConflictedName'Term name refs -> Output.MergeConflictedTermName name refs + ConflictedName'Type name refs -> Output.MergeConflictedTypeName name refs declNameLookup <- Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err -> - Cli.returnEarly wundefined -- (MergeResult1'Failure (MergeResultFailure1'IncoherentDecl causalHash err)) + Cli.returnEarly case err of + IncoherentDeclReason'ConstructorAlias name1 name2 -> + Output.MergeConstructorAlias maybeBranchName name1 name2 + IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName name + IncoherentDeclReason'NestedDeclAlias shorterName longerName -> + Output.MergeNestedDeclAlias shorterName longerName + IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor name pure (defns, declNameLookup) - (aliceDefns0, aliceDeclNameLookup) <- load (Just (causalHashes.alice, branches.alice)) - (bobDefns0, bobDeclNameLookup) <- load (Just (causalHashes.bob, branches.bob)) - (lcaDefns0, lcaDeclNameLookup) <- load ((,) <$> causalHashes.lca <*> branches.lca) + (aliceDefns0, aliceDeclNameLookup) <- load (Just (Just branchNames.alice.branch, branches.alice)) + (bobDefns0, bobDeclNameLookup) <- load (Just (Just branchNames.bob.branch, branches.bob)) + (lcaDefns0, lcaDeclNameLookup) <- load ((Nothing,) <$> branches.lca) let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns) let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0} @@ -260,13 +266,9 @@ handleMerge bobSpecifier = do liftIO (debugFunctions.debugDiffs diffs) -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias - do - let go who diff = - whenJust (findConflictedAlias defns3.lca diff) \names -> - -- Cli.returnEarly (mergePreconditionViolationToOutput violation) - Cli.returnEarly wundefined -- (MergeResult1'Failure (MergeResultFailure1'ConflictedAliases (who names))) - go Alice diffs.alice - go Bob diffs.bob + for_ ((,) <$> branchNames <*> diffs) \(names, diff) -> + whenJust (findConflictedAlias defns3.lca diff) \(name1, name2) -> + Cli.returnEarly (Output.MergeConflictedAliases names.branch name1 name2) -- Combine the LCA->Alice and LCA->Bob diffs together let diff = combineDiffs diffs @@ -276,7 +278,7 @@ handleMerge bobSpecifier = do -- Partition the combined diff into the conflicted things and the unconflicted things (conflicts, unconflicts) <- partitionCombinedDiffs defns declNameLookups diff & onLeft \name -> - Cli.returnEarly (mergePreconditionViolationToOutput (Merge.ConflictInvolvingBuiltin name)) + Cli.returnEarly (Output.MergeConflictInvolvingBuiltin name) liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts) @@ -804,28 +806,18 @@ findTemporaryBranchName projectId branchNames = do <> Text.Builder.char '.' <> Text.Builder.decimal z --- Load namespace info into memory. --- --- Fails if: --- * One name is associated with more than one reference. -loadNamespaceInfo_2 :: - Monad m => - (V2.Referent -> m Referent) -> - V2.Branch m -> - m (Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference))) -loadNamespaceInfo_2 referent2to1 branch = - assertNamespaceHasNoConflictedNames_2 <$> loadNamespaceInfo0_2 referent2to1 branch - --- | Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined +-- Load all "namespace definitions" of a branch, which are all terms and type declarations *except* those defined -- in the "lib" namespace. -loadNamespaceInfo0_2 :: +-- +-- Fails if there is a conflicted name. +loadNamespaceDefinitions :: forall m. Monad m => (V2.Referent -> m Referent) -> V2.Branch m -> - m (Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference)) -loadNamespaceInfo0_2 referent2to1 = - go (Map.delete NameSegment.libSegment) + 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) -> @@ -840,35 +832,15 @@ loadNamespaceInfo0_2 referent2to1 = 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) Set Referent TypeReference) -> - Either Merge.PreconditionViolation (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -assertNamespaceHasNoConflictedNames = - traverseNametreeWithName \names defns -> do - terms <- - defns.terms & Map.traverseWithKey \name -> - assertUnconflicted (Merge.ConflictedTermName (Name.fromReverseSegments (name :| names))) - types <- - defns.types & Map.traverseWithKey \name -> - assertUnconflicted (Merge.ConflictedTypeName (Name.fromReverseSegments (name :| names))) - pure Defns {terms, types} - where - assertUnconflicted :: (Set ref -> Merge.PreconditionViolation) -> Set ref -> Either Merge.PreconditionViolation ref - assertUnconflicted conflicted refs = - case Set.asSingleton refs of - Nothing -> Left (conflicted refs) - Just ref -> Right ref - data ConflictedName = ConflictedName'Term !Name !(NESet Referent) | ConflictedName'Type !Name !(NESet TypeReference) -- | Assert that there are no unconflicted names in a namespace. -assertNamespaceHasNoConflictedNames_2 :: +assertNamespaceHasNoConflictedNames :: Nametree (DefnsF2 (Map NameSegment) NESet Referent TypeReference) -> Either ConflictedName (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -assertNamespaceHasNoConflictedNames_2 = +assertNamespaceHasNoConflictedNames = traverseNametreeWithName \names defns -> do terms <- defns.terms & Map.traverseWithKey \name -> @@ -883,105 +855,6 @@ assertNamespaceHasNoConflictedNames_2 = | Set.NonEmpty.size refs == 1 = Right (Set.NonEmpty.findMin refs) | otherwise = Left (conflicted refs) --- Convert a merge precondition violation to an output message. -mergePreconditionViolationToOutput :: Merge.PreconditionViolation -> Output.Output -mergePreconditionViolationToOutput = \case - Merge.ConflictedAliases branch name1 name2 -> Output.MergeConflictedAliases branch name1 name2 - Merge.ConflictedTermName name refs -> Output.MergeConflictedTermName name refs - Merge.ConflictedTypeName name refs -> Output.MergeConflictedTypeName name refs - Merge.ConflictInvolvingBuiltin name -> Output.MergeConflictInvolvingBuiltin name - Merge.ConstructorAlias maybeBranch name1 name2 -> Output.MergeConstructorAlias maybeBranch name1 name2 - Merge.DefnsInLib -> Output.MergeDefnsInLib - Merge.MissingConstructorName name -> Output.MergeMissingConstructorName name - Merge.NestedDeclAlias shorterName longerName -> Output.MergeNestedDeclAlias shorterName longerName - Merge.StrayConstructor name -> Output.MergeStrayConstructor name - --- Assert that a namespace satisfies a few preconditions. --- --- Fails if: --- * The "lib" namespace contains any top-level terms or decls. (Only child namespaces are expected here). --- * Any type declarations are "incoherent" (see `checkDeclCoherency`) -assertNamespaceSatisfiesPreconditions :: - MergeDatabase -> - (forall void. Merge.PreconditionViolation -> Transaction void) -> - Maybe ProjectBranchName -> - V2.Branch Transaction -> - Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> - Transaction (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name), DeclNameLookup) -assertNamespaceSatisfiesPreconditions db abort maybeBranchName branch defns = do - whenJust (Map.lookup NameSegment.libSegment branch.children) \libdepsCausal -> do - libdepsBranch <- libdepsCausal.value - when (not (Map.null libdepsBranch.terms) || not (Map.null libdepsBranch.types)) do - abort Merge.DefnsInLib - - declNameLookup <- - checkDeclCoherency db.loadDeclNumConstructors defns - & onLeftM (abort . incoherentDeclReasonToMergePreconditionViolation) - - pure - ( Defns - { terms = flattenNametree (view #terms) defns, - types = flattenNametree (view #types) defns - }, - declNameLookup - ) - where - incoherentDeclReasonToMergePreconditionViolation :: IncoherentDeclReason -> Merge.PreconditionViolation - incoherentDeclReasonToMergePreconditionViolation = \case - IncoherentDeclReason'ConstructorAlias firstName secondName -> - Merge.ConstructorAlias maybeBranchName firstName secondName - IncoherentDeclReason'MissingConstructorName name -> Merge.MissingConstructorName name - IncoherentDeclReason'NestedDeclAlias shorterName longerName -> Merge.NestedDeclAlias shorterName longerName - IncoherentDeclReason'StrayConstructor name -> Merge.StrayConstructor name - --- Assert that a namespace satisfies a few preconditions. --- --- Fails if: --- * The "lib" namespace contains any top-level terms or decls. (Only child namespaces are expected here). --- * Any type declarations are "incoherent" (see `checkDeclCoherency`) -assertNamespaceSatisfiesPreconditions_2 :: - MergeDatabase -> - (forall void. Merge.PreconditionViolation -> Transaction void) -> - Maybe ProjectBranchName -> - Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> - Transaction (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name), DeclNameLookup) -assertNamespaceSatisfiesPreconditions_2 db abort maybeBranchName defns = do - declNameLookup <- - checkDeclCoherency db.loadDeclNumConstructors defns - & onLeftM (abort . incoherentDeclReasonToMergePreconditionViolation) - - pure - ( Defns - { terms = flattenNametree (view #terms) defns, - types = flattenNametree (view #types) defns - }, - declNameLookup - ) - where - incoherentDeclReasonToMergePreconditionViolation :: IncoherentDeclReason -> Merge.PreconditionViolation - incoherentDeclReasonToMergePreconditionViolation = \case - IncoherentDeclReason'ConstructorAlias firstName secondName -> - Merge.ConstructorAlias maybeBranchName firstName secondName - IncoherentDeclReason'MissingConstructorName name -> Merge.MissingConstructorName name - IncoherentDeclReason'NestedDeclAlias shorterName longerName -> Merge.NestedDeclAlias shorterName longerName - IncoherentDeclReason'StrayConstructor name -> Merge.StrayConstructor name - -findOneConflictedAlias :: - TwoWay ProjectBranch -> - Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name) -> - TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> - Maybe Merge.PreconditionViolation -findOneConflictedAlias projectBranchNames lcaDefns diffs = - aliceConflictedAliases <|> bobConflictedAliases - where - aliceConflictedAliases = - findConflictedAlias lcaDefns diffs.alice <&> \(name1, name2) -> - Merge.ConflictedAliases projectBranchNames.alice.name name1 name2 - - bobConflictedAliases = - findConflictedAlias lcaDefns diffs.bob <&> \(name1, name2) -> - Merge.ConflictedAliases projectBranchNames.bob.name name1 name2 - -- @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. diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 6e89bb396..ba846f9d3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -62,7 +62,7 @@ import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPE import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName, Semver) -import Unison.Reference (Reference, TermReferenceId) +import Unison.Reference (Reference, TermReferenceId, TypeReference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Server.Backend (ShallowListEntry (..)) @@ -398,13 +398,12 @@ data Output | MergeFailure !FilePath !(ProjectAndBranch ProjectName ProjectBranchName) !(ProjectAndBranch ProjectName ProjectBranchName) | MergeSuccess !(ProjectAndBranch ProjectName ProjectBranchName) !(ProjectAndBranch ProjectName ProjectBranchName) | MergeSuccessFastForward !(ProjectAndBranch ProjectName ProjectBranchName) !(ProjectAndBranch ProjectName ProjectBranchName) - | -- These are all merge precondition violations. See PreconditionViolation for more docs. - MergeConflictedAliases !ProjectBranchName !Name !Name - | MergeConflictedTermName !Name !(Set Referent) - | MergeConflictedTypeName !Name !(Set Reference.TypeReference) + | MergeConflictedAliases !ProjectBranchName !Name !Name + | MergeConflictedTermName !Name !(NESet Referent) + | MergeConflictedTypeName !Name !(NESet TypeReference) | MergeConflictInvolvingBuiltin !Name | MergeConstructorAlias !(Maybe ProjectBranchName) !Name !Name - | MergeDefnsInLib + | MergeDefnsInLib !ProjectBranchName | MergeMissingConstructorName !Name | MergeNestedDeclAlias !Name !Name | MergeStrayConstructor !Name @@ -645,7 +644,7 @@ isFailure o = case o of MergeConflictedTypeName {} -> True MergeConflictInvolvingBuiltin {} -> True MergeConstructorAlias {} -> True - MergeDefnsInLib -> True + MergeDefnsInLib {} -> True MergeMissingConstructorName {} -> True MergeNestedDeclAlias {} -> True MergeStrayConstructor {} -> True diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index e3f27f179..c6746bc90 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1667,9 +1667,11 @@ notifyUser dir = \case <> "and" <> prettyName name2 <> "are aliases. Every type declaration must have exactly one name for each constructor." - MergeDefnsInLib -> + MergeDefnsInLib name -> pure . P.wrap $ - "There's a type or term directly in the `lib` namespace, but I expected only library dependencies to be in there." + "On" + <> P.group (prettyProjectBranchName name <> ",") + <> "there's a type or term directly in the `lib` namespace, but I expected only library dependencies to be in there." <> "Please remove it before merging." MergeMissingConstructorName name -> pure . P.wrap $ diff --git a/unison-merge/src/Unison/Merge/PreconditionViolation.hs b/unison-merge/src/Unison/Merge/PreconditionViolation.hs deleted file mode 100644 index d43cfdee6..000000000 --- a/unison-merge/src/Unison/Merge/PreconditionViolation.hs +++ /dev/null @@ -1,39 +0,0 @@ -module Unison.Merge.PreconditionViolation - ( PreconditionViolation (..), - ) -where - -import U.Codebase.Reference (TypeReference) -import Unison.Core.Project (ProjectBranchName) -import Unison.Name (Name) -import Unison.Prelude -import Unison.Referent (Referent) - --- | A reason that a merge could not be performed. -data PreconditionViolation - = -- | @ConflictedAliases branch foo bar@: in project branch @branch@, @foo@ and @bar@ refer to different things, - -- but at one time (in the LCA of another branch, in fact) they referred to the same thing. - ConflictedAliases !ProjectBranchName !Name !Name - | -- | @ConflictedTermName name refs@: @name@ refers to 2+ referents @refs@. - ConflictedTermName !Name !(Set Referent) - | -- | @ConflictedTypeName name refs@: @name@ refers to 2+ type references @refs@. - ConflictedTypeName !Name !(Set TypeReference) - | -- | @ConflictInvolvingBuiltin name@: @name@ is involved in a conflict, but it refers to a builtin (on at least one - -- side). Since we can't put a builtin in a scratch file, we bomb in these cases. - ConflictInvolvingBuiltin !Name - | -- | A second naming of a constructor was discovered underneath a decl's name, e.g. - -- - -- Foo#Foo - -- Foo.Bar#Foo#0 - -- Foo.Some.Other.Name.For.Bar#Foo#0 - -- - -- If the project branch name is missing, it means the LCA is in violation. - ConstructorAlias !(Maybe ProjectBranchName) !Name !Name -- first name we found, second name we found - | -- | There were some definitions at the top level of lib.*, which we don't like - DefnsInLib - | -- | This type name is missing a name for one of its constructors. - MissingConstructorName !Name - | -- | This type name is a nested alias, e.g. "Foo.Bar.Baz" which is an alias of "Foo" or "Foo.Bar". - NestedDeclAlias !Name !Name -- shorter name, longer name - | StrayConstructor !Name - deriving stock (Show) diff --git a/unison-merge/unison-merge.cabal b/unison-merge/unison-merge.cabal index 8aaac5bff..84baab088 100644 --- a/unison-merge/unison-merge.cabal +++ b/unison-merge/unison-merge.cabal @@ -27,7 +27,6 @@ library Unison.Merge.EitherWayI Unison.Merge.Libdeps Unison.Merge.PartitionCombinedDiffs - Unison.Merge.PreconditionViolation Unison.Merge.Synhash Unison.Merge.Synhashed Unison.Merge.ThreeWay From f80b07db81339f9a8dc0f4cd8ff62fae3d203cd4 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 14 May 2024 09:30:23 -0400 Subject: [PATCH 19/82] regenerate merge.md output --- unison-src/transcripts/merge.output.md | 12 +++--------- 1 file changed, 3 insertions(+), 9 deletions(-) diff --git a/unison-src/transcripts/merge.output.md b/unison-src/transcripts/merge.output.md index 5b70d7417..ac9bcd238 100644 --- a/unison-src/transcripts/merge.output.md +++ b/unison-src/transcripts/merge.output.md @@ -491,9 +491,6 @@ project/alice> merge /bob ``` ```unison:added-by-ucm scratch.u --- The definitions below are not conflicted, but they each depend on one or more --- conflicted definitions above. - bar : Text bar = use Text ++ @@ -535,9 +532,6 @@ project/alice> merge /bob ``` ```unison:added-by-ucm scratch.u --- The definitions below are not conflicted, but they each depend on one or more --- conflicted definitions above. - bar : Text bar = use Text ++ @@ -1143,8 +1137,8 @@ bob = 100 ```ucm project/alice> merge /bob - There's a type or term directly in the `lib` namespace, but I - expected only library dependencies to be in there. Please - remove it before merging. + On alice, there's a type or term directly in the `lib` + namespace, but I expected only library dependencies to be in + there. Please remove it before merging. ``` From af71ab201f89c70965af7ce60ad40cb89cef3bae Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 14 May 2024 10:04:11 -0400 Subject: [PATCH 20/82] begin forming merge API for pull to call --- .../Codebase/Editor/HandleInput/Merge2.hs | 175 ++++++++++++------ 1 file changed, 114 insertions(+), 61 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index f77cac5f0..ad0fa3755 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -1,5 +1,12 @@ module Unison.Codebase.Editor.HandleInput.Merge2 ( handleMerge, + + -- * API exported for @pull@ + MergeInfo (..), + AliceMergeInfo (..), + BobMergeInfo (..), + LcaMergeInfo (..), + doMerge, ) where @@ -126,80 +133,126 @@ import Unison.Var (Var) import Witch (unsafeFrom) import Prelude hiding (unzip, zip, zipWith) -data BobBranch - = BobBranch'ProjectAndBranchNames (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () -handleMerge bobSpecifier = do +handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do + -- Assert that Alice (us) is on a project branch, and grab the causal hash. + (ProjectAndBranch aliceProject aliceProjectBranch, _path) <- Cli.expectCurrentProjectBranch + aliceCausalHash <- Cli.runTransaction (projectBranchToCausalHash aliceProjectBranch) + + -- Resolve Bob's maybe-project-name + branch-name to the info the merge algorithm needs: the project name, branch + -- name, and causal hash. + bobProject <- + case maybeBobProjectName of + Nothing -> pure aliceProject + Just bobProjectName + | bobProjectName == aliceProject.name -> pure aliceProject + | otherwise -> do + Cli.runTransaction (Queries.loadProjectByName bobProjectName) + & onNothingM (Cli.returnEarly (Output.LocalProjectDoesntExist bobProjectName)) + bobProjectBranch <- Cli.expectProjectBranchByName bobProject bobBranchName + bobCausalHash <- Cli.runTransaction (projectBranchToCausalHash bobProjectBranch) + + -- Using Alice and Bob's causal hashes, find the LCA (if it exists) + lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash bobCausalHash) + + -- Do the merge! + doMerge + MergeInfo + { alice = + AliceMergeInfo + { causalHash = aliceCausalHash, + project = aliceProject, + projectBranch = aliceProjectBranch + }, + bob = + BobMergeInfo + { causalHash = bobCausalHash, + projectName = bobProject.name, + projectBranchName = bobBranchName + }, + lca = + LcaMergeInfo + { causalHash = lcaCausalHash + }, + description = "merge " <> into @Text (ProjectAndBranch bobProject.name bobBranchName) + } + where + projectBranchToCausalHash :: ProjectBranch -> Transaction CausalHash + projectBranchToCausalHash branch = do + let path = Cli.projectBranchPath (ProjectAndBranch branch.projectId branch.branchId) + causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path) + pure causal.causalHash + +--- + +data MergeInfo = MergeInfo + { alice :: !AliceMergeInfo, + bob :: !BobMergeInfo, + lca :: !LcaMergeInfo, + -- How should we describe this merge in the reflog? + description :: !Text + } + +data AliceMergeInfo = AliceMergeInfo + { causalHash :: !CausalHash, + project :: !Project, + projectBranch :: !ProjectBranch + } + +data BobMergeInfo = BobMergeInfo + { causalHash :: !CausalHash, + -- Bob's project and branch names are just for display purposes; they don't necessarily correspond to a real local + -- project. For example, if we `pull @unison/base/bugfix`, then we'll use project name `@unison/base` and branch + -- name `bugfix`, even though we're just pulling the branch into the current one, with no relationship to any local + -- project/branch named `@unison/base/bugfix`. + projectName :: !ProjectName, + projectBranchName :: !ProjectBranchName + } + +newtype LcaMergeInfo = LcaMergeInfo + { causalHash :: Maybe CausalHash + } + +doMerge :: MergeInfo -> Cli () +doMerge info = do let debugFunctions = if Debug.shouldDebug Debug.Merge then realDebugFunctions else fakeDebugFunctions + let alicePath = + Cli.projectBranchPath (ProjectAndBranch info.alice.project.projectId info.alice.projectBranch.branchId) + + let branchNames = + TwoWay + { alice = ProjectAndBranch info.alice.project.name info.alice.projectBranch.name, + bob = ProjectAndBranch info.bob.projectName info.bob.projectBranchName + } + Cli.Env {codebase} <- ask - (aliceProjectAndBranch, _path) <- Cli.expectCurrentProjectBranch - let alicePath = - Cli.projectBranchPath $ - ProjectAndBranch - aliceProjectAndBranch.project.projectId - aliceProjectAndBranch.branch.branchId - - let projectAndBranchToInfo :: ProjectAndBranch Project ProjectBranch -> Cli (CausalHash, ProjectAndBranch ProjectName ProjectBranchName) - projectAndBranchToInfo (ProjectAndBranch project branch) = do - let path = Cli.projectBranchPath (ProjectAndBranch project.projectId branch.branchId) - causal <- Cli.runTransaction (Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path)) - pure (causal.causalHash, ProjectAndBranch project.name branch.name) - - (aliceCausalHash, aliceBranchNames) <- projectAndBranchToInfo aliceProjectAndBranch - - (bobCausalHash, bobBranchNames) <- - case BobBranch'ProjectAndBranchNames bobSpecifier of - BobBranch'ProjectAndBranchNames (ProjectAndBranch maybeBobProjectName bobBranchName) -> do - bobProject <- - case maybeBobProjectName of - Nothing -> pure aliceProjectAndBranch.project - Just bobProjectName - | bobProjectName == aliceProjectAndBranch.project.name -> pure aliceProjectAndBranch.project - | otherwise -> do - Cli.runTransaction (Queries.loadProjectByName bobProjectName) - & onNothingM (Cli.returnEarly (Output.LocalProjectDoesntExist bobProjectName)) - bobProjectBranch <- Cli.expectProjectBranchByName bobProject bobBranchName - projectAndBranchToInfo (ProjectAndBranch bobProject bobProjectBranch) - - lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash bobCausalHash) - - let causalHashes :: TwoOrThreeWay CausalHash - causalHashes = - TwoOrThreeWay {alice = aliceCausalHash, bob = bobCausalHash, lca = lcaCausalHash} - - let branchNames :: TwoWay (ProjectAndBranch ProjectName ProjectBranchName) - branchNames = - TwoWay {alice = aliceBranchNames, bob = bobBranchNames} - - let textualDescriptionOfMerge :: Text - textualDescriptionOfMerge = - "merge " <> into @Text branchNames.bob - - --- - -- If alice == bob, or LCA == bob (so alice is ahead of bob), then we are done. - when (causalHashes.alice == causalHashes.bob || causalHashes.lca == Just causalHashes.bob) do + when (info.alice.causalHash == info.bob.causalHash || info.lca.causalHash == Just info.bob.causalHash) do Cli.returnEarly (Output.MergeAlreadyUpToDate (Right branchNames.bob) (Right branchNames.alice)) -- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done. - when (causalHashes.lca == Just causalHashes.alice) do - bobBranch <- liftIO (Codebase.expectBranchForHash codebase causalHashes.bob) - _ <- Cli.updateAt textualDescriptionOfMerge alicePath (\_aliceBranch -> bobBranch) + when (info.lca.causalHash == Just info.alice.causalHash) do + bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash) + _ <- Cli.updateAt info.description alicePath (\_aliceBranch -> bobBranch) Cli.returnEarly (Output.MergeSuccessFastForward branchNames.alice branchNames.bob) - --- - -- Create a bunch of cached database lookup functions db <- makeMergeDatabase codebase -- Load Alice/Bob/LCA causals - causals <- Cli.runTransaction (traverse Operations.expectCausalBranchByCausalHash causalHashes) + causals <- Cli.runTransaction do + traverse + Operations.expectCausalBranchByCausalHash + TwoOrThreeWay + { alice = info.alice.causalHash, + bob = info.bob.causalHash, + lca = info.lca.causalHash + } liftIO (debugFunctions.debugCausals causals) @@ -372,9 +425,9 @@ handleMerge bobSpecifier = do HandleInput.Branch.doCreateBranch' (Branch.mergeNode stageOneBranch parents.alice parents.bob) Nothing - aliceProjectAndBranch.project - (findTemporaryBranchName aliceProjectAndBranch.project.projectId (view #branch <$> branchNames)) - textualDescriptionOfMerge + info.alice.project + (findTemporaryBranchName info.alice.project.projectId (view #branch <$> branchNames)) + info.description scratchFilePath <- Cli.getLatestFile <&> \case Nothing -> "scratch.u" @@ -390,9 +443,9 @@ handleMerge bobSpecifier = do let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch _ <- Cli.updateAt - textualDescriptionOfMerge + info.description alicePath - (\_ -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) + (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) Cli.respond (Output.MergeSuccess branchNames.alice branchNames.bob) ------------------------------------------------------------------------------------------------------------------------ From 75e0e3c8d3cc6c6e7637c18e562d0fe52cc0a722 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 14 May 2024 11:17:18 -0400 Subject: [PATCH 21/82] make pull perform a new merge, not an old merge --- .../src/Unison/Codebase/Editor/HandleInput.hs | 2 +- .../Codebase/Editor/HandleInput/Merge2.hs | 6 +- .../Codebase/Editor/HandleInput/Pull.hs | 91 ++++++++++++------- .../src/Unison/Codebase/Editor/Input.hs | 3 +- .../src/Unison/CommandLine/InputPatterns.hs | 23 ++--- 5 files changed, 67 insertions(+), 58 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index cd0ccc5bb..2e71dca16 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1026,7 +1026,7 @@ loop e = do pped <- Cli.currentPrettyPrintEnvDecl let suffixifiedPPE = PPED.suffixifiedPPE pped Cli.respondNumbered $ ListEdits patch suffixifiedPPE - PullRemoteBranchI sourceTarget sMode pMode verbosity -> doPullRemoteBranch sourceTarget sMode pMode verbosity + PullRemoteBranchI sourceTarget sMode pMode -> doPullRemoteBranch sourceTarget sMode pMode PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput ListDependentsI hq -> handleDependents hq ListDependenciesI hq -> handleDependencies hq diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index ad0fa3755..13320385d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -183,13 +183,11 @@ handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path) pure causal.causalHash ---- - data MergeInfo = MergeInfo { alice :: !AliceMergeInfo, bob :: !BobMergeInfo, lca :: !LcaMergeInfo, - -- How should we describe this merge in the reflog? + -- | How should we describe this merge in the reflog? description :: !Text } @@ -201,7 +199,7 @@ data AliceMergeInfo = AliceMergeInfo data BobMergeInfo = BobMergeInfo { causalHash :: !CausalHash, - -- Bob's project and branch names are just for display purposes; they don't necessarily correspond to a real local + -- | Bob's project and branch names are just for display purposes; they don't necessarily correspond to a real local -- project. For example, if we `pull @unison/base/bugfix`, then we'll use project name `@unison/base` and branch -- name `bugfix`, even though we're just pulling the branch into the current one, with no relationship to any local -- project/branch named `@unison/base/bugfix`. diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index f7093ad57..1b95c5f52 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -10,7 +10,6 @@ module Unison.Codebase.Editor.HandleInput.Pull where import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO) -import Control.Lens ((^.)) import Control.Monad.Reader (ask) import Data.List.NonEmpty qualified as Nel import Data.Text qualified as Text @@ -20,8 +19,8 @@ import U.Codebase.Branch qualified as V2.Branch import U.Codebase.Causal qualified import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Operations qualified as Operations -import U.Codebase.Sqlite.Project qualified as Sqlite (Project) -import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch) +import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..)) +import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -35,6 +34,7 @@ import Unison.Codebase.Branch (Branch (..)) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Branch.Merge qualified as Branch import Unison.Codebase.Editor.HandleInput.AuthLogin (ensureAuthenticatedWithCodeserver) +import Unison.Codebase.Editor.HandleInput.Merge2 (AliceMergeInfo (..), BobMergeInfo (..), LcaMergeInfo (..), MergeInfo (..), doMerge) import Unison.Codebase.Editor.HandleInput.NamespaceDiffUtils (diffHelper) import Unison.Codebase.Editor.Input import Unison.Codebase.Editor.Input qualified as Input @@ -49,7 +49,6 @@ import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.SyncMode (SyncMode) import Unison.Codebase.SyncMode qualified as SyncMode -import Unison.Codebase.Verbosity qualified as Verbosity import Unison.CommandLine.InputPattern qualified as InputPattern import Unison.CommandLine.InputPatterns qualified as InputPatterns import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName)) @@ -67,8 +66,8 @@ import Unison.Sync.Common qualified as Common import Unison.Sync.Types qualified as Share import Witch (unsafeFrom) -doPullRemoteBranch :: PullSourceTarget -> SyncMode.SyncMode -> PullMode -> Verbosity.Verbosity -> Cli () -doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do +doPullRemoteBranch :: PullSourceTarget -> SyncMode.SyncMode -> PullMode -> Cli () +doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode = do Cli.Env {codebase} <- ask let includeSquashed = case pullMode of @@ -77,11 +76,6 @@ doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do (source, target) <- resolveSourceAndTarget includeSquashed unresolvedSourceAndTarget - target1 <- - case target of - Left _ -> wundefined - Right target1 -> pure target1 - remoteCausalHash <- importRemoteNamespaceIntoCodebase syncMode pullMode source remoteBranchIsEmpty <- @@ -96,7 +90,7 @@ doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do case target of Left path -> Cli.resolvePath' path Right (ProjectAndBranch project branch) -> - pure $ ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)) + pure $ ProjectUtils.projectBranchPath (ProjectAndBranch project.projectId branch.branchId) let description = Text.unwords @@ -104,10 +98,10 @@ doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do case pullMode of PullWithoutHistory -> InputPatterns.pullWithoutHistory PullWithHistory -> InputPatterns.pull, - printReadRemoteNamespace (\remoteBranch -> into @Text (ProjectAndBranch (remoteBranch ^. #projectName) (remoteBranch ^. #branchName))) source, + printReadRemoteNamespace (\remoteBranch -> into @Text (ProjectAndBranch remoteBranch.projectName remoteBranch.branchName)) source, case target of Left path -> Path.toText' path - Right (ProjectAndBranch project branch) -> into @Text (ProjectAndBranch (project ^. #name) (branch ^. #name)) + Right (ProjectAndBranch project branch) -> into @Text (ProjectAndBranch project.name branch.name) ] case pullMode of @@ -120,17 +114,46 @@ doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do void $ Cli.updateAtM description targetAbsolutePath (const $ pure remoteBranchObject) Cli.respond $ MergeOverEmpty target else do - remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash) + ProjectAndBranch bobProjectName bobProjectBranchName <- + case source of + ReadRemoteNamespaceGit _ -> error "can't pull from git" + ReadShare'LooseCode _ -> error "can't pull from loose code" + ReadShare'ProjectBranch remoteBranch -> pure (ProjectAndBranch remoteBranch.projectName remoteBranch.branchName) + + ProjectAndBranch aliceProject aliceProjectBranch <- + case target of + Left _ -> error "can't pull into path" + Right target1 -> pure target1 Cli.respond AboutToMerge - mergeBranchAndPropagateDefaultPatch - Branch.RegularMerge - description - (Just (PullAlreadyUpToDate source target)) - remoteBranchObject - (if Verbosity.isSilent verbosity then Nothing else Just target) - targetAbsolutePath + aliceCausalHash <- + Cli.runTransaction do + causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute targetAbsolutePath) + pure causal.causalHash + + lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash remoteCausalHash) + + doMerge + MergeInfo + { alice = + AliceMergeInfo + { causalHash = aliceCausalHash, + project = aliceProject, + projectBranch = aliceProjectBranch + }, + bob = + BobMergeInfo + { causalHash = remoteCausalHash, + projectName = bobProjectName, + projectBranchName = bobProjectBranchName + }, + lca = + LcaMergeInfo + { causalHash = lcaCausalHash + }, + description + } Input.PullWithoutHistory -> do remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash) @@ -165,8 +188,8 @@ resolveImplicitSource includeSquashed = Just (localProjectAndBranch, _restPath) -> do (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <- Cli.runTransactionWithRollback \rollback -> do - let localProjectId = localProjectAndBranch ^. #project . #projectId - let localBranchId = localProjectAndBranch ^. #branch . #branchId + let localProjectId = localProjectAndBranch.project.projectId + let localBranchId = localProjectAndBranch.branch.branchId Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId >>= \case Just (remoteProjectId, Just remoteBranchId) -> do remoteProjectName <- Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri @@ -193,7 +216,7 @@ resolveExplicitSource includeSquashed = \case ReadShare'LooseCode namespace -> pure (ReadShare'LooseCode namespace) ReadShare'ProjectBranch (This remoteProjectName) -> do remoteProject <- ProjectUtils.expectRemoteProjectByName remoteProjectName - let remoteProjectId = remoteProject ^. #projectId + let remoteProjectId = remoteProject.projectId let remoteBranchName = unsafeFrom @Text "main" remoteProjectBranch <- ProjectUtils.expectRemoteProjectBranchByName @@ -202,8 +225,8 @@ resolveExplicitSource includeSquashed = \case pure (ReadShare'ProjectBranch remoteProjectBranch) ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do (ProjectAndBranch localProject localBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch - let localProjectId = localProject ^. #projectId - let localBranchId = localBranch ^. #branchId + let localProjectId = localProject.projectId + let localBranchId = localBranch.branchId Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case Just (remoteProjectId, _maybeProjectBranchId) -> do remoteProjectName <- Cli.runTransaction (Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri) @@ -217,10 +240,10 @@ resolveExplicitSource includeSquashed = \case Cli.returnEarly $ Output.NoAssociatedRemoteProject Share.hardCodedUri - (ProjectAndBranch (localProject ^. #name) (localBranch ^. #name)) + (ProjectAndBranch localProject.name localBranch.name) ReadShare'ProjectBranch (These projectName branchNameOrLatestRelease) -> do remoteProject <- ProjectUtils.expectRemoteProjectByName projectName - let remoteProjectId = remoteProject ^. #projectId + let remoteProjectId = remoteProject.projectId branchName <- resolveRemoteBranchName projectName branchNameOrLatestRelease remoteProjectBranch <- ProjectUtils.expectRemoteProjectBranchByName @@ -233,7 +256,7 @@ resolveExplicitSource includeSquashed = \case ProjectBranchNameOrLatestRelease'Name branchName -> pure branchName ProjectBranchNameOrLatestRelease'LatestRelease -> do remoteProject <- ProjectUtils.expectRemoteProjectByName projectName - case remoteProject ^. #latestRelease of + case remoteProject.latestRelease of Nothing -> Cli.returnEarly (Output.ProjectHasNoReleases projectName) Just semver -> pure (UnsafeProjectBranchName ("releases/" <> into @Text semver)) @@ -265,14 +288,14 @@ importRemoteNamespaceIntoCodebase syncMode pullMode remoteNamespace = do -- | @downloadShareProjectBranch branch@ downloads the given branch. downloadShareProjectBranch :: HasCallStack => Bool -> Share.RemoteProjectBranch -> Cli HashJWT downloadShareProjectBranch useSquashedIfAvailable branch = do - let remoteProjectBranchName = branch ^. #branchName - let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch (branch ^. #projectName) remoteProjectBranchName)) + let remoteProjectBranchName = branch.branchName + let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName)) causalHashJwt <- if useSquashedIfAvailable - then case (branch ^. #squashedBranchHead) of + then case branch.squashedBranchHead of Nothing -> Cli.returnEarly (Output.ShareError ShareExpectedSquashedHead) Just squashedHead -> pure squashedHead - else pure (branch ^. #branchHead) + else pure branch.branchHead exists <- Cli.runTransaction (Queries.causalExistsByHash32 (Share.hashJWTHash causalHashJwt)) when (not exists) do (result, numDownloaded) <- diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 88aa2b881..cab1f296b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -42,7 +42,6 @@ import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.SyncMode (SyncMode) -import Unison.Codebase.Verbosity (Verbosity) import Unison.CommandLine.BranchRelativePath (BranchRelativePath, parseBranchRelativePath) import Unison.HashQualified qualified as HQ import Unison.Name (Name) @@ -115,7 +114,7 @@ data Input MergeLocalBranchI LooseCodeOrProject LooseCodeOrProject Branch.MergeMode | PreviewMergeLocalBranchI LooseCodeOrProject LooseCodeOrProject | DiffNamespaceI BranchId BranchId -- old new - | PullRemoteBranchI PullSourceTarget SyncMode PullMode Verbosity + | PullRemoteBranchI PullSourceTarget SyncMode PullMode | PushRemoteBranchI PushRemoteBranchInput | ResetRootI (Either ShortCausalHash Path') | ResetI diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 1bbc39081..a6d4e83a0 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -42,8 +42,6 @@ import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.PushBehavior qualified as PushBehavior import Unison.Codebase.SyncMode qualified as SyncMode -import Unison.Codebase.Verbosity (Verbosity) -import Unison.Codebase.Verbosity qualified as Verbosity import Unison.CommandLine import Unison.CommandLine.BranchRelativePath (parseBranchRelativePath, parseIncrementalBranchRelativePath) import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath @@ -1301,22 +1299,18 @@ resetRoot = pull :: InputPattern pull = - pullImpl "pull" ["pull.silent"] Verbosity.Silent Input.PullWithHistory "without listing the merged entities" - -pullVerbose :: InputPattern -pullVerbose = pullImpl "pull.verbose" [] Verbosity.Verbose Input.PullWithHistory "and lists the merged entities" + pullImpl "pull" [] Input.PullWithHistory "" pullWithoutHistory :: InputPattern pullWithoutHistory = pullImpl "pull.without-history" [] - Verbosity.Silent Input.PullWithoutHistory "without including the remote's history. This usually results in smaller codebase sizes." -pullImpl :: String -> [String] -> Verbosity -> Input.PullMode -> P.Pretty CT.ColorText -> InputPattern -pullImpl name aliases verbosity pullMode addendum = do +pullImpl :: String -> [String] -> Input.PullMode -> P.Pretty CT.ColorText -> InputPattern +pullImpl name aliases pullMode addendum = do self where self = @@ -1362,10 +1356,10 @@ pullImpl name aliases verbosity pullMode addendum = do ], parse = maybeToEither (I.help self) . \case - [] -> Just $ Input.PullRemoteBranchI Input.PullSourceTarget0 SyncMode.ShortCircuit pullMode verbosity + [] -> Just $ Input.PullRemoteBranchI Input.PullSourceTarget0 SyncMode.ShortCircuit pullMode [sourceString] -> do source <- parsePullSource (Text.pack sourceString) - Just $ Input.PullRemoteBranchI (Input.PullSourceTarget1 source) SyncMode.ShortCircuit pullMode verbosity + Just $ Input.PullRemoteBranchI (Input.PullSourceTarget1 source) SyncMode.ShortCircuit pullMode [sourceString, targetString] -> do source <- parsePullSource (Text.pack sourceString) target <- parseLooseCodeOrProject targetString @@ -1374,7 +1368,6 @@ pullImpl name aliases verbosity pullMode addendum = do (Input.PullSourceTarget2 source target) SyncMode.ShortCircuit pullMode - verbosity _ -> Nothing } @@ -1390,7 +1383,7 @@ pullExhaustive = "The " <> makeExample' pullExhaustive <> "command can be used in place of" - <> makeExample' pullVerbose + <> makeExample' pull <> "to complete namespaces" <> "which were pulled incompletely due to a bug in UCM" <> "versions M1l and earlier. It may be extra slow!" @@ -1403,7 +1396,6 @@ pullExhaustive = Input.PullSourceTarget0 SyncMode.Complete Input.PullWithHistory - Verbosity.Verbose [sourceString] -> do source <- parsePullSource (Text.pack sourceString) Just $ @@ -1411,7 +1403,6 @@ pullExhaustive = (Input.PullSourceTarget1 source) SyncMode.Complete Input.PullWithHistory - Verbosity.Verbose [sourceString, targetString] -> do source <- parsePullSource (Text.pack sourceString) target <- parseLooseCodeOrProject targetString @@ -1420,7 +1411,6 @@ pullExhaustive = (Input.PullSourceTarget2 source target) SyncMode.Complete Input.PullWithHistory - Verbosity.Verbose _ -> Nothing ) @@ -3100,7 +3090,6 @@ validInputs = projectsInputPattern, pull, pullExhaustive, - pullVerbose, pullWithoutHistory, push, pushCreate, From 06b743a1491be52a48d193b71a40fbc09241e1cd Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 14 May 2024 11:30:40 -0400 Subject: [PATCH 22/82] slightly better error messages --- .../Codebase/Editor/HandleInput/Merge2.hs | 6 ++-- .../src/Unison/Codebase/Editor/Output.hs | 6 ++-- .../src/Unison/CommandLine/OutputMessages.hs | 28 +++++++++++++------ unison-src/transcripts/merge.output.md | 10 +++---- 4 files changed, 31 insertions(+), 19 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 13320385d..7cf2da00e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -290,10 +290,10 @@ doMerge info = do Cli.returnEarly case err of IncoherentDeclReason'ConstructorAlias name1 name2 -> Output.MergeConstructorAlias maybeBranchName name1 name2 - IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName name + IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName maybeBranchName name IncoherentDeclReason'NestedDeclAlias shorterName longerName -> - Output.MergeNestedDeclAlias shorterName longerName - IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor name + Output.MergeNestedDeclAlias maybeBranchName shorterName longerName + IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor maybeBranchName name pure (defns, declNameLookup) (aliceDefns0, aliceDeclNameLookup) <- load (Just (Just branchNames.alice.branch, branches.alice)) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index ba846f9d3..8db09a5b1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -404,9 +404,9 @@ data Output | MergeConflictInvolvingBuiltin !Name | MergeConstructorAlias !(Maybe ProjectBranchName) !Name !Name | MergeDefnsInLib !ProjectBranchName - | MergeMissingConstructorName !Name - | MergeNestedDeclAlias !Name !Name - | MergeStrayConstructor !Name + | MergeMissingConstructorName !(Maybe ProjectBranchName) !Name + | MergeNestedDeclAlias !(Maybe ProjectBranchName) !Name !Name + | MergeStrayConstructor !(Maybe ProjectBranchName) !Name data UpdateOrUpgrade = UOUUpdate | UOUUpgrade diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index c6746bc90..28b64a21c 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1667,27 +1667,39 @@ notifyUser dir = \case <> "and" <> prettyName name2 <> "are aliases. Every type declaration must have exactly one name for each constructor." - MergeDefnsInLib name -> + MergeDefnsInLib branch -> pure . P.wrap $ "On" - <> P.group (prettyProjectBranchName name <> ",") + <> P.group (prettyProjectBranchName branch <> ",") <> "there's a type or term directly in the `lib` namespace, but I expected only library dependencies to be in there." <> "Please remove it before merging." - MergeMissingConstructorName name -> + MergeMissingConstructorName maybeBranch name -> pure . P.wrap $ - "The type" + "On" + <> case maybeBranch of + Nothing -> "the LCA," + Just branch -> P.group (prettyProjectBranchName branch <> ",") + <> "the type" <> prettyName name <> "is missing a name for one of its constructors. Please add one before merging." - MergeNestedDeclAlias shorterName longerName -> + MergeNestedDeclAlias maybeBranch shorterName longerName -> pure . P.wrap $ - "The type" + "On" + <> case maybeBranch of + Nothing -> "the LCA," + Just branch -> P.group (prettyProjectBranchName branch <> ",") + <> "the type" <> prettyName longerName <> "is an alias of" <> P.group (prettyName shorterName <> ".") <> "Type aliases cannot be nested. Please make them disjoint before merging." - MergeStrayConstructor name -> + MergeStrayConstructor maybeBranch name -> pure . P.wrap $ - "The constructor" + "On" + <> case maybeBranch of + Nothing -> "the LCA," + Just branch -> P.group (prettyProjectBranchName branch <> ",") + <> "the constructor" <> prettyName name <> "is not in a subnamespace of a name of its type." <> "Please either delete it or rename it before merging." diff --git a/unison-src/transcripts/merge.output.md b/unison-src/transcripts/merge.output.md index ac9bcd238..3aa43eee1 100644 --- a/unison-src/transcripts/merge.output.md +++ b/unison-src/transcripts/merge.output.md @@ -1047,8 +1047,8 @@ bob = 100 ```ucm project/alice> merge /bob - The type Foo is missing a name for one of its constructors. - Please add one before merging. + On alice, the type Foo is missing a name for one of its + constructors. Please add one before merging. ``` ### Nested decl alias @@ -1080,8 +1080,8 @@ bob = 100 ```ucm project/alice> merge /bob - The type A.inner.X is an alias of A. Type aliases cannot be - nested. Please make them disjoint before merging. + On alice, the type A.inner.X is an alias of A. Type aliases + cannot be nested. Please make them disjoint before merging. ``` ### Stray constructor alias @@ -1113,7 +1113,7 @@ project/bob> add ```ucm project/alice> merge bob - The constructor AliasOutsideFooNamespace is not in a + On alice, the constructor AliasOutsideFooNamespace is not in a subnamespace of a name of its type. Please either delete it or rename it before merging. From 1ccb97861c6d83d7de91f598a7ee30b28281bf64 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 16 May 2024 16:58:28 -0400 Subject: [PATCH 23/82] disallow pulling into an arbitrary path --- .../src/Unison/Codebase/Editor/HandleInput.hs | 4 +- .../Codebase/Editor/HandleInput/Pull.hs | 42 ++++++++---------- .../src/Unison/Codebase/Editor/Input.hs | 4 +- .../src/Unison/Codebase/Editor/Output.hs | 6 +-- .../src/Unison/CommandLine/InputPatterns.hs | 44 +++++++++---------- .../src/Unison/CommandLine/OutputMessages.hs | 16 ++++--- 6 files changed, 58 insertions(+), 58 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index a497d5631..e784f8024 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1027,7 +1027,7 @@ loop e = do pped <- Cli.currentPrettyPrintEnvDecl let suffixifiedPPE = PPED.suffixifiedPPE pped Cli.respondNumbered $ ListEdits patch suffixifiedPPE - PullRemoteBranchI sourceTarget pMode -> handlePull sourceTarget pMode + PullI sourceTarget pullMode -> handlePull sourceTarget pullMode PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput ListDependentsI hq -> handleDependents hq ListDependenciesI hq -> handleDependencies hq @@ -1393,7 +1393,7 @@ inputDescription input = ProjectRenameI {} -> wat ProjectSwitchI {} -> wat ProjectsI -> wat - PullRemoteBranchI {} -> wat + PullI {} -> wat PushRemoteBranchI {} -> wat QuitI {} -> wat ReleaseDraftI {} -> wat diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index a58e53778..dc9a9b5e5 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -85,11 +85,8 @@ handlePull unresolvedSourceAndTarget pullMode = do when remoteBranchIsEmpty (Cli.respond (PulledEmptyBranch source)) - targetAbsolutePath <- - case target of - Left path -> Cli.resolvePath' path - Right (ProjectAndBranch project branch) -> - pure $ ProjectUtils.projectBranchPath (ProjectAndBranch project.projectId branch.branchId) + let targetAbsolutePath = + ProjectUtils.projectBranchPath (ProjectAndBranch target.project.projectId target.branch.branchId) let description = Text.unwords @@ -99,8 +96,7 @@ handlePull unresolvedSourceAndTarget pullMode = do PullWithHistory -> InputPatterns.pull, printReadRemoteNamespace (\remoteBranch -> into @Text (ProjectAndBranch remoteBranch.projectName remoteBranch.branchName)) source, case target of - Left path -> Path.toText' path - Right (ProjectAndBranch project branch) -> into @Text (ProjectAndBranch project.name branch.name) + ProjectAndBranch project branch -> into @Text (ProjectAndBranch project.name branch.name) ] case pullMode of @@ -116,15 +112,10 @@ handlePull unresolvedSourceAndTarget pullMode = do else do ProjectAndBranch bobProjectName bobProjectBranchName <- case source of - ReadRemoteNamespaceGit _ -> error "can't pull from git" - ReadShare'LooseCode _ -> error "can't pull from loose code" + ReadRemoteNamespaceGit _ -> wundefined "can't pull from git" + ReadShare'LooseCode _ -> wundefined "can't pull from loose code" ReadShare'ProjectBranch remoteBranch -> pure (ProjectAndBranch remoteBranch.projectName remoteBranch.branchName) - ProjectAndBranch aliceProject aliceProjectBranch <- - case target of - Left _ -> error "can't pull into path" - Right target1 -> pure target1 - Cli.respond AboutToMerge aliceCausalHash <- @@ -139,8 +130,8 @@ handlePull unresolvedSourceAndTarget pullMode = do { alice = AliceMergeInfo { causalHash = aliceCausalHash, - project = aliceProject, - projectBranch = aliceProjectBranch + project = target.project, + projectBranch = target.branch }, bob = BobMergeInfo @@ -174,13 +165,19 @@ resolveSourceAndTarget :: PullSourceTarget -> Cli ( ReadRemoteNamespace Share.RemoteProjectBranch, - Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) + ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch ) resolveSourceAndTarget includeSquashed = \case Input.PullSourceTarget0 -> liftA2 (,) (resolveImplicitSource includeSquashed) resolveImplicitTarget Input.PullSourceTarget1 source -> liftA2 (,) (resolveExplicitSource includeSquashed source) resolveImplicitTarget Input.PullSourceTarget2 source target -> - liftA2 (,) (resolveExplicitSource includeSquashed source) (ProjectUtils.expectLooseCodeOrProjectBranch target) + liftA2 + (,) + (resolveExplicitSource includeSquashed source) + ( ProjectUtils.expectProjectAndBranchByTheseNames case target of + ProjectAndBranch Nothing branch -> That branch + ProjectAndBranch (Just project) branch -> These project branch + ) resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch) resolveImplicitSource includeSquashed = @@ -260,11 +257,10 @@ resolveExplicitSource includeSquashed = \case (ProjectAndBranch (remoteProjectId, projectName) branchName) pure (ReadShare'ProjectBranch remoteProjectBranch) -resolveImplicitTarget :: Cli (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) -resolveImplicitTarget = - ProjectUtils.getCurrentProjectBranch <&> \case - Nothing -> Left Path.currentPath - Just (projectAndBranch, _restPath) -> Right projectAndBranch +resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) +resolveImplicitTarget = do + (projectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch + pure projectAndBranch -- | supply `dest0` if you want to print diff messages -- supply unchangedMessage if you want to display it if merge had no effect diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index f7f469257..17008b8e0 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -113,7 +113,7 @@ data Input MergeLocalBranchI LooseCodeOrProject LooseCodeOrProject Branch.MergeMode | PreviewMergeLocalBranchI LooseCodeOrProject LooseCodeOrProject | DiffNamespaceI BranchId BranchId -- old new - | PullRemoteBranchI PullSourceTarget PullMode + | PullI !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput | ResetRootI (Either ShortCausalHash Path') | ResetI @@ -275,7 +275,7 @@ data GistInput = GistInput data PullSourceTarget = PullSourceTarget0 | PullSourceTarget1 (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) - | PullSourceTarget2 (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) LooseCodeOrProject + | PullSourceTarget2 (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) deriving stock (Eq, Show) data PushSource diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 2e6238ee3..a45e7ef4a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -283,13 +283,13 @@ data Output | ShowReflog [(Maybe UTCTime, SCH.ShortCausalHash, Text)] | PullAlreadyUpToDate (ReadRemoteNamespace Share.RemoteProjectBranch) - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) | PullSuccessful (ReadRemoteNamespace Share.RemoteProjectBranch) - (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) | AboutToMerge | -- | Indicates a trivial merge where the destination was empty and was just replaced. - MergeOverEmpty (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) + MergeOverEmpty (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) | MergeAlreadyUpToDate (Either Path' (ProjectAndBranch ProjectName ProjectBranchName)) (Either Path' (ProjectAndBranch ProjectName ProjectBranchName)) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 35194c63c..d6bbac933 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1347,37 +1347,36 @@ pullImpl name aliases pullMode addendum = do { patternName = name, aliases = aliases, visibility = I.Visible, - args = [("remote location to pull", Optional, remoteNamespaceArg), ("destination namespace", Optional, namespaceArg)], + args = + [ ("remote namespace to pull", Optional, remoteNamespaceArg), + ( "destination branch", + Optional, + projectBranchNameArg + ProjectBranchSuggestionsConfig + { showProjectCompletions = True, + projectInclusion = AllProjects, + branchInclusion = ExcludeCurrentBranch + } + ) + ], help = P.lines [ P.wrap $ "The" <> makeExample' self - <> "command merges a remote namespace into a local namespace" + <> "command merges a remote namespace into a local branch" <> addendum, "", P.wrapColumn2 [ ( makeExample self ["@unison/base/main"], "merges the branch `main`" <> "of the Unison Share hosted project `@unison/base`" - <> "into the current namespace" + <> "into the current branch" ), ( makeExample self ["@unison/base/main", "my-base/topic"], "merges the branch `main`" <> "of the Unison Share hosted project `@unison/base`" <> "into the branch `topic` of the local `my-base` project" - ), - ( makeExample self ["remote", "local"], - "merges the remote namespace `remote`" - <> "into the local namespace `local" - ), - ( makeExample self ["remote"], - "merges the remote namespace `remote`" - <> "into the current namespace" - ), - ( makeExample' self, - "merges the remote namespace configured in `.unisonConfig`" - <> "at the key `RemoteMappings.` where `` is the current namespace," ) ], "", @@ -1385,17 +1384,18 @@ pullImpl name aliases pullMode addendum = do ], parse = maybeToEither (I.help self) . \case - [] -> Just $ Input.PullRemoteBranchI Input.PullSourceTarget0 pullMode + [] -> Just $ Input.PullI Input.PullSourceTarget0 pullMode [sourceString] -> do source <- parsePullSource (Text.pack sourceString) - Just $ Input.PullRemoteBranchI (Input.PullSourceTarget1 source) pullMode + Just $ Input.PullI (Input.PullSourceTarget1 source) pullMode [sourceString, targetString] -> do source <- parsePullSource (Text.pack sourceString) - target <- parseLooseCodeOrProject targetString - Just $ - Input.PullRemoteBranchI - (Input.PullSourceTarget2 source target) - pullMode + target <- + eitherToMaybe $ + tryInto + @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + (Text.pack targetString) + Just $ Input.PullI (Input.PullSourceTarget2 source target) pullMode _ -> Nothing } diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index e9db00fcb..4764bcd39 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -38,6 +38,8 @@ import U.Codebase.Branch.Diff (NameChanges (..)) import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Reference qualified as Reference import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) +import U.Codebase.Sqlite.Project (Project (..)) +import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import Unison.ABT qualified as ABT import Unison.Auth.Types qualified as Auth import Unison.Builtin.Decls qualified as DD @@ -72,9 +74,7 @@ import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv -import Unison.Codebase.SqliteCodebase.GitError - ( GitSqliteCodebaseError (..), - ) +import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..)) import Unison.Codebase.TermEdit qualified as TermEdit import Unison.Codebase.Type (GitError (GitCodebaseError, GitProtocolError, GitSqliteCodebaseError)) import Unison.Codebase.TypeEdit qualified as TypeEdit @@ -1605,21 +1605,25 @@ notifyUser dir = \case PullAlreadyUpToDate ns dest -> pure . P.callout "😶" $ P.wrap $ - prettyNamespaceKey dest + prettyProjectAndBranchName (ProjectAndBranch dest.project.name dest.branch.name) <> "was already up-to-date with" <> P.group (prettyReadRemoteNamespace ns <> ".") PullSuccessful ns dest -> pure . P.okCallout $ P.wrap $ "Successfully updated" - <> prettyNamespaceKey dest + <> prettyProjectAndBranchName (ProjectAndBranch dest.project.name dest.branch.name) <> "from" <> P.group (prettyReadRemoteNamespace ns <> ".") AboutToMerge -> pure "Merging..." MergeOverEmpty dest -> pure . P.okCallout $ P.wrap $ - "Successfully pulled into " <> P.group (prettyNamespaceKey dest <> ", which was empty.") + "Successfully pulled into " + <> P.group + ( prettyProjectAndBranchName (ProjectAndBranch dest.project.name dest.branch.name) + <> ", which was empty." + ) MergeAlreadyUpToDate src dest -> pure . P.callout "😶" $ P.wrap $ From 61ecd6ed7309127525f67fc4e46c9f1d971f38eb Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 16 May 2024 14:55:35 -0700 Subject: [PATCH 24/82] Add missing api instances --- .../src/Unison/Server/CodebaseServer.hs | 71 ++++++++++++++-- unison-share-api/src/Unison/Server/Types.hs | 85 ++++++++++++++++++- .../src/Unison/Share/API/Projects.hs | 1 + 3 files changed, 150 insertions(+), 7 deletions(-) diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index edad8053d..e9460de19 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -48,6 +48,7 @@ import Servant serve, throwError, ) +import Servant qualified as Servant import Servant.API ( Accept (..), Capture, @@ -60,11 +61,13 @@ import Servant.API ) import Servant.Docs ( DocIntro (DocIntro), + ToParam (..), ToSample (..), docsWithIntros, markdown, singleSample, ) +import Servant.Docs qualified as Servant import Servant.OpenApi (HasOpenApi (toOpenApi)) import Servant.Server ( Application, @@ -106,11 +109,15 @@ import Unison.Server.Local.Endpoints.NamespaceDetails qualified as NamespaceDeta import Unison.Server.Local.Endpoints.NamespaceListing qualified as NamespaceListing import Unison.Server.Local.Endpoints.Projects (ListProjectBranchesEndpoint, ListProjectsEndpoint, projectBranchListingEndpoint, projectListingEndpoint) import Unison.Server.Local.Endpoints.UCM (UCMAPI, ucmServer) -import Unison.Server.Types (mungeString, setCacheControl) +import Unison.Server.Types (TermDiffResponse, TypeDiffResponse, mungeString, setCacheControl) +import Unison.Share.API.Projects (BranchName) import Unison.ShortHash qualified as ShortHash import Unison.Symbol (Symbol) import Unison.Syntax.NameSegment qualified as NameSegment +-- | Fail the route with a reasonable error if the query param is missing. +type RequiredQueryParam = Servant.QueryParam' '[Servant.Required, Servant.Strict] + -- HTML content type data HTML = HTML @@ -143,8 +150,49 @@ type CodebaseServerAPI = type ProjectsAPI = ListProjectsEndpoint - :<|> (Capture "project-name" ProjectName :> "branches" :> ListProjectBranchesEndpoint) - :<|> (Capture "project-name" ProjectName :> "branches" :> Capture "branch-name" ProjectBranchName :> CodebaseServerAPI) + :<|> ( Capture "project-name" ProjectName + :> "branches" + :> ( ListProjectBranchesEndpoint + :<|> (Capture "branch-name" ProjectBranchName :> CodebaseServerAPI) + :<|> ( "diff" + :> ( "terms" :> ProjectDiffTermsEndpoint + :<|> "types" :> ProjectDiffTypesEndpoint + ) + ) + ) + ) + +type ProjectDiffTermsEndpoint = + RequiredQueryParam "oldBranchRef" BranchName + :> RequiredQueryParam "newBranchRef" BranchName + :> RequiredQueryParam "oldTerm" Name + :> RequiredQueryParam "newTerm" Name + :> Get '[JSON] TermDiffResponse + +type ProjectDiffTypesEndpoint = + RequiredQueryParam "oldBranchRef" BranchName + :> RequiredQueryParam "newBranchRef" BranchName + :> RequiredQueryParam "oldType" Name + :> RequiredQueryParam "newType" Name + :> Get '[JSON] TypeDiffResponse + +instance ToParam (Servant.QueryParam' mods "oldBranchRef" a) where + toParam _ = Servant.DocQueryParam "oldBranchRef" ["main"] "The name of the old branch" Servant.Normal + +instance ToParam (Servant.QueryParam' mods "newBranchRef" a) where + toParam _ = Servant.DocQueryParam "newBranchRef" ["main"] "The name of the new branch" Servant.Normal + +instance ToParam (Servant.QueryParam' mods "oldTerm" a) where + toParam _ = Servant.DocQueryParam "oldTerm" ["main"] "The name of the old term" Servant.Normal + +instance ToParam (Servant.QueryParam' mods "newTerm" a) where + toParam _ = Servant.DocQueryParam "newTerm" ["main"] "The name of the new term" Servant.Normal + +instance ToParam (Servant.QueryParam' mods "oldType" a) where + toParam _ = Servant.DocQueryParam "oldType" ["main"] "The name of the old type" Servant.Normal + +instance ToParam (Servant.QueryParam' mods "newType" a) where + toParam _ = Servant.DocQueryParam "newType" ["main"] "The name of the new type" Servant.Normal type WebUI = CaptureAll "route" Text :> Get '[HTML] RawHtml @@ -558,11 +606,24 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName) Just ch -> pure (Right ch) +serveProjectDiffTermsEndpoint :: Codebase m v a -> ProjectName -> BranchName -> BranchName -> Name -> Name -> Backend IO TermDiffResponse +serveProjectDiffTermsEndpoint projectName oldBranchRef newBranchRef oldTerm newTerm = do + undefined + +serveProjectDiffTypesEndpoint :: Codebase m v a -> ProjectName -> BranchName -> BranchName -> Name -> Name -> Backend IO TypeDiffResponse +serveProjectDiffTypesEndpoint projectName oldBranchRef newBranchRef oldType newType = do + undefined + serveProjectsAPI :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ServerT ProjectsAPI (Backend IO) serveProjectsAPI codebase rt = projectListingEndpoint codebase - :<|> projectBranchListingEndpoint codebase - :<|> serveProjectsCodebaseServerAPI codebase rt + :<|> ( \projectName -> + projectBranchListingEndpoint codebase projectName + :<|> serveProjectsCodebaseServerAPI codebase rt projectName + :<|> ( serveProjectDiffTermsEndpoint codebase projectName + :<|> serveProjectDiffTypesEndpoint codebase projectName + ) + ) serveUnisonLocal :: BackendEnv -> diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 7df2845c3..9d2eb6cbf 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -47,6 +47,7 @@ import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) import Unison.Server.Doc (Doc) import Unison.Server.Orphans () import Unison.Server.Syntax qualified as Syntax +import Unison.Share.API.Projects (BranchName) import Unison.ShortHash (ShortHash) import Unison.Syntax.HashQualified qualified as HQ (parseText) import Unison.Syntax.Name qualified as Name @@ -258,7 +259,9 @@ data SemanticSyntaxDiff SegmentChange (String, String) (Maybe Syntax.Element) | -- (shared segment) (fromAnnotation, toAnnotation) AnnotationChange String (Maybe Syntax.Element, Maybe Syntax.Element) - deriving (Eq, Show) + deriving (Eq, Show, Generic) + +deriving instance ToSchema SemanticSyntaxDiff instance ToJSON SemanticSyntaxDiff where toJSON = \case @@ -299,7 +302,9 @@ instance ToJSON SemanticSyntaxDiff where data DisplayObjectDiff = DisplayObjectDiff (DisplayObject [SemanticSyntaxDiff] [SemanticSyntaxDiff]) | MismatchedDisplayObjects (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) (DisplayObject Syntax.SyntaxText Syntax.SyntaxText) - deriving stock (Show, Eq) + deriving stock (Show, Eq, Generic) + +deriving instance ToSchema DisplayObjectDiff data UnisonRef = TypeRef UnisonHash @@ -459,3 +464,79 @@ instance Docs.ToCapture (Capture "project-and-branch" ProjectBranchNameParam) wh DocCapture "project-and-branch" "The name of a project and branch e.g. `@unison%2Fbase%2Fmain` or `@unison%2Fbase%2F@runarorama%2Fmain`" + +data TermDiffResponse = TermDiffResponse + { project :: ProjectName, + oldBranch :: BranchName, + newBranch :: BranchName, + oldTerm :: TermDefinition, + newTerm :: TermDefinition, + diff :: DisplayObjectDiff + } + deriving (Eq, Show, Generic) + +deriving instance ToSchema TermDiffResponse + +instance Docs.ToSample TermDiffResponse where + toSamples _ = [] + +instance ToJSON TermDiffResponse where + toJSON (TermDiffResponse {diff, project, oldBranch, newBranch, oldTerm, newTerm}) = + case diff of + DisplayObjectDiff dispDiff -> + object + [ "diff" .= dispDiff, + "diffKind" .= ("diff" :: Text), + "project" .= project, + "oldBranchRef" .= oldBranch, + "newBranchRef" .= newBranch, + "oldTerm" .= oldTerm, + "newTerm" .= newTerm + ] + MismatchedDisplayObjects {} -> + object + [ "diffKind" .= ("mismatched" :: Text), + "project" .= project, + "oldBranchRef" .= oldBranch, + "newBranchRef" .= newBranch, + "oldTerm" .= oldTerm, + "newTerm" .= newTerm + ] + +data TypeDiffResponse = TypeDiffResponse + { project :: ProjectName, + oldBranch :: BranchName, + newBranch :: BranchName, + oldType :: TypeDefinition, + newType :: TypeDefinition, + diff :: DisplayObjectDiff + } + deriving (Eq, Show, Generic) + +deriving instance ToSchema TypeDiffResponse + +instance Docs.ToSample TypeDiffResponse where + toSamples _ = [] + +instance ToJSON TypeDiffResponse where + toJSON (TypeDiffResponse {diff, project, oldBranch, newBranch, oldType, newType}) = + case diff of + DisplayObjectDiff dispDiff -> + object + [ "diff" .= dispDiff, + "diffKind" .= ("diff" :: Text), + "project" .= project, + "oldBranchRef" .= oldBranch, + "newBranchRef" .= newBranch, + "oldType" .= oldType, + "newType" .= newType + ] + MismatchedDisplayObjects {} -> + object + [ "diffKind" .= ("mismatched" :: Text), + "project" .= project, + "oldBranchRef" .= oldBranch, + "newBranchRef" .= newBranch, + "oldType" .= oldType, + "newType" .= newType + ] diff --git a/unison-share-projects-api/src/Unison/Share/API/Projects.hs b/unison-share-projects-api/src/Unison/Share/API/Projects.hs index 86dae3cf3..b326aec35 100644 --- a/unison-share-projects-api/src/Unison/Share/API/Projects.hs +++ b/unison-share-projects-api/src/Unison/Share/API/Projects.hs @@ -34,6 +34,7 @@ module Unison.Share.API.Projects ProjectBranchIds (..), NotFound (..), Unauthorized (..), + BranchName, ) where From 3e3f59333d3e3274fd26712f4a106f2f71c43600 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 16 May 2024 15:30:03 -0700 Subject: [PATCH 25/82] Implement termDefinitionByName --- .../Unison/Codebase/Editor/DisplayObject.hs | 22 +++++++++ unison-share-api/src/Unison/Server/Backend.hs | 11 ++--- .../src/Unison/Server/CodebaseServer.hs | 6 ++- .../src/Unison/Server/Local/Definitions.hs | 48 ++++++++++++++++++- 4 files changed, 78 insertions(+), 9 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs b/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs index 733c9fa1b..cc75bc31e 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/DisplayObject.hs @@ -4,8 +4,19 @@ module Unison.Codebase.Editor.DisplayObject where import Data.Bifoldable import Data.Bitraversable +import Data.Set qualified as Set +import U.Codebase.Reference (TermReference, TypeReference) +import Unison.DataDeclaration qualified as DD +import Unison.DataDeclaration.Dependencies qualified as DD +import Unison.LabeledDependency qualified as LD +import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.ShortHash (ShortHash) +import Unison.Symbol (Symbol) +import Unison.Term (Term) +import Unison.Term qualified as Term +import Unison.Type (Type) +import Unison.Type qualified as Type data DisplayObject b a = BuiltinObject b | MissingObject ShortHash | UserObject a deriving (Eq, Ord, Show, Functor, Generic, Foldable, Traversable) @@ -27,3 +38,14 @@ toMaybe :: DisplayObject b a -> Maybe a toMaybe = \case UserObject a -> Just a _ -> Nothing + +termDisplayObjectLabeledDependencies :: TermReference -> DisplayObject (Type Symbol Ann) (Term Symbol Ann) -> (Set LD.LabeledDependency) +termDisplayObjectLabeledDependencies termRef displayObject = do + displayObject + & bifoldMap (Type.labeledDependencies) (Term.labeledDependencies) + & Set.insert (LD.TermReference termRef) + +typeDisplayObjectLabeledDependencies :: TypeReference -> DisplayObject () (DD.Decl Symbol Ann) -> Set LD.LabeledDependency +typeDisplayObjectLabeledDependencies typeRef displayObject = do + displayObject + & foldMap (DD.labeledDeclDependenciesIncludingSelfAndFieldAccessors typeRef) diff --git a/unison-share-api/src/Unison/Server/Backend.hs b/unison-share-api/src/Unison/Server/Backend.hs index 7f6bc34b7..10cd18867 100644 --- a/unison-share-api/src/Unison/Server/Backend.hs +++ b/unison-share-api/src/Unison/Server/Backend.hs @@ -842,14 +842,13 @@ docsForDefinitionName :: NameSearch Sqlite.Transaction -> Names.SearchType -> Name -> - IO [TermReference] + Sqlite.Transaction [TermReference] docsForDefinitionName codebase (NameSearch {termSearch}) searchType name = do let potentialDocNames = [name, name Cons.:> "doc"] - Codebase.runTransaction codebase do - refs <- - potentialDocNames & foldMapM \name -> - lookupRelativeHQRefs' termSearch searchType (HQ'.NameOnly name) - filterForDocs (toList refs) + refs <- + potentialDocNames & foldMapM \name -> + lookupRelativeHQRefs' termSearch searchType (HQ'.NameOnly name) + filterForDocs (toList refs) where filterForDocs :: [Referent] -> Sqlite.Transaction [TermReference] filterForDocs rs = do diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index e9460de19..f2acc4277 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -109,7 +109,7 @@ import Unison.Server.Local.Endpoints.NamespaceDetails qualified as NamespaceDeta import Unison.Server.Local.Endpoints.NamespaceListing qualified as NamespaceListing import Unison.Server.Local.Endpoints.Projects (ListProjectBranchesEndpoint, ListProjectsEndpoint, projectBranchListingEndpoint, projectListingEndpoint) import Unison.Server.Local.Endpoints.UCM (UCMAPI, ucmServer) -import Unison.Server.Types (TermDiffResponse, TypeDiffResponse, mungeString, setCacheControl) +import Unison.Server.Types (TermDefinition (..), TermDiffResponse, TypeDiffResponse, mungeString, setCacheControl) import Unison.Share.API.Projects (BranchName) import Unison.ShortHash qualified as ShortHash import Unison.Symbol (Symbol) @@ -608,7 +608,9 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do serveProjectDiffTermsEndpoint :: Codebase m v a -> ProjectName -> BranchName -> BranchName -> Name -> Name -> Backend IO TermDiffResponse serveProjectDiffTermsEndpoint projectName oldBranchRef newBranchRef oldTerm newTerm = do - undefined + oldTerm@(TermDefinition {termDefinition = oldDisplayObj}) <- getTermDefinition authZReceipt project oldShortHand oldTermName `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("Term not found: " <> IDs.toText oldShortHand <> ":" <> Name.toText oldTermName)) + newTerm@(TermDefinition {termDefinition = newDisplayObj}) <- getTermDefinition authZReceipt project newShortHand newTermName `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("Term not found: " <> IDs.toText newShortHand <> ":" <> Name.toText newTermName)) + let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects oldDisplayObj newDisplayObj serveProjectDiffTypesEndpoint :: Codebase m v a -> ProjectName -> BranchName -> BranchName -> Name -> Name -> Backend IO TypeDiffResponse serveProjectDiffTypesEndpoint projectName oldBranchRef newBranchRef oldType newType = do diff --git a/unison-share-api/src/Unison/Server/Local/Definitions.hs b/unison-share-api/src/Unison/Server/Local/Definitions.hs index 97f9cd606..342fd1382 100644 --- a/unison-share-api/src/Unison/Server/Local/Definitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Definitions.hs @@ -2,15 +2,21 @@ module Unison.Server.Local.Definitions (prettyDefinitionsForHQName) where import Control.Lens hiding ((??)) import Control.Monad.Except +import Control.Monad.Trans.Maybe (mapMaybeT) import Data.Map qualified as Map +import Data.Set.NonEmpty qualified as NESet import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal +import U.Codebase.Reference (TermReference) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase +import Unison.Codebase.Editor.DisplayObject (DisplayObject) import Unison.Codebase.Path (Path) import Unison.Codebase.Runtime qualified as Rt import Unison.HashQualified qualified as HQ +import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) +import Unison.NamesWithHistory qualified as NS import Unison.NamesWithHistory qualified as Names import Unison.Parser.Ann (Ann) import Unison.Prelude @@ -19,13 +25,19 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.Server.Backend +import Unison.Server.Backend qualified as Backend import Unison.Server.Doc qualified as Doc import Unison.Server.Local qualified as Local +import Unison.Server.NameSearch (NameSearch) +import Unison.Server.NameSearch qualified as NS +import Unison.Server.NameSearch qualified as NameSearch import Unison.Server.NameSearch.FromNames (makeNameSearch) import Unison.Server.Types import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Syntax.HashQualified qualified as HQ (toText) +import Unison.Term (Term) +import Unison.Type (Type) import Unison.Util.Map qualified as Map import Unison.Util.Pretty (Width) @@ -71,7 +83,7 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings let width = mayDefaultWidth renderWidth let docResults :: Name -> IO [(HashQualifiedName, UnisonHash, Doc.Doc)] docResults name = do - docRefs <- docsForDefinitionName codebase nameSearch Names.ExactName name + docRefs <- Codebase.runTransaction codebase $ docsForDefinitionName codebase nameSearch Names.ExactName name renderDocRefs pped width codebase rt docRefs -- local server currently ignores doc eval errors <&> fmap \(hqn, h, doc, _errs) -> (hqn, h, doc) @@ -96,3 +108,37 @@ prettyDefinitionsForHQName perspective shallowRoot renderWidth suffixifyBindings renderedDisplayTerms renderedDisplayTypes renderedMisses + +-- | Find the term referenced by the given name and return a display object for it. +termDisplayObjectByName :: Codebase m Symbol Ann -> NameSearch Sqlite.Transaction -> Name -> Sqlite.Transaction (Maybe (TermReference, DisplayObject (Type Symbol Ann) (Term Symbol Ann))) +termDisplayObjectByName codebase nameSearch name = runMaybeT do + refs <- lift $ NameSearch.lookupRelativeHQRefs' (NS.termSearch nameSearch) NS.ExactName (HQ'.NameOnly name) + ref <- fmap NESet.findMin . hoistMaybe $ NESet.nonEmptySet refs + case ref of + Referent.Ref r -> (r,) <$> lift (Backend.displayTerm codebase r) + Referent.Con _ _ -> + -- TODO: Should we error here or some other sensible thing rather than returning no + -- result? + empty + +termDefinitionByName :: + Codebase IO Symbol Ann -> + PPED.PrettyPrintEnvDecl -> + NameSearch Sqlite.Transaction -> + Width -> + Rt.Runtime Symbol -> + Name -> + Backend IO (Maybe TermDefinition) +termDefinitionByName codebase pped nameSearch width rt name = runMaybeT $ do + let biasedPPED = PPED.biasTo [name] pped + (ref, displayObject, docRefs) <- mapMaybeT (liftIO . Codebase.runTransaction codebase) $ do + (ref, displayObject) <- MaybeT $ termDisplayObjectByName codebase nameSearch name + docRefs <- lift $ Backend.docsForDefinitionName codebase nameSearch NS.ExactName name + pure (ref, displayObject, docRefs) + renderedDocs <- + liftIO $ + renderDocRefs pped width codebase rt docRefs + -- local server currently ignores doc eval errors + <&> fmap \(hqn, h, doc, _errs) -> (hqn, h, doc) + let (_ref, syntaxDO) = Backend.termsToSyntaxOf (Suffixify False) width pped id (ref, displayObject) + lift $ Backend.mkTermDefinition codebase biasedPPED width ref renderedDocs syntaxDO From aa93ac1d585d22671ddfe772fc2616196273b026 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 16 May 2024 15:32:55 -0700 Subject: [PATCH 26/82] Implement typeDefinitionByName --- .../src/Unison/Server/Local/Definitions.hs | 32 ++++++++++++++++++- 1 file changed, 31 insertions(+), 1 deletion(-) diff --git a/unison-share-api/src/Unison/Server/Local/Definitions.hs b/unison-share-api/src/Unison/Server/Local/Definitions.hs index 342fd1382..767b276fc 100644 --- a/unison-share-api/src/Unison/Server/Local/Definitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Definitions.hs @@ -7,12 +7,13 @@ import Data.Map qualified as Map import Data.Set.NonEmpty qualified as NESet import U.Codebase.Branch qualified as V2Branch import U.Codebase.Causal qualified as V2Causal -import U.Codebase.Reference (TermReference) +import U.Codebase.Reference (TermReference, TypeReference) import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.DisplayObject (DisplayObject) import Unison.Codebase.Path (Path) import Unison.Codebase.Runtime qualified as Rt +import Unison.DataDeclaration qualified as DD import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) @@ -142,3 +143,32 @@ termDefinitionByName codebase pped nameSearch width rt name = runMaybeT $ do <&> fmap \(hqn, h, doc, _errs) -> (hqn, h, doc) let (_ref, syntaxDO) = Backend.termsToSyntaxOf (Suffixify False) width pped id (ref, displayObject) lift $ Backend.mkTermDefinition codebase biasedPPED width ref renderedDocs syntaxDO + +-- | Find the type referenced by the given name and return a display object for it. +typeDisplayObjectByName :: Codebase m Symbol Ann -> NameSearch Sqlite.Transaction -> Name -> Sqlite.Transaction (Maybe (TypeReference, DisplayObject () (DD.Decl Symbol Ann))) +typeDisplayObjectByName codebase nameSearch name = runMaybeT do + refs <- lift $ NameSearch.lookupRelativeHQRefs' (NS.typeSearch nameSearch) NS.ExactName (HQ'.NameOnly name) + ref <- fmap NESet.findMin . hoistMaybe $ NESet.nonEmptySet refs + fmap (ref,) . lift $ Backend.displayType ref + +typeDefinitionByName :: + Codebase IO Symbol Ann -> + PPED.PrettyPrintEnvDecl -> + NameSearch Sqlite.Transaction -> + Width -> + Rt.Runtime Symbol -> + Name -> + Backend IO (Maybe TypeDefinition) +typeDefinitionByName codebase pped nameSearch width rt name = runMaybeT $ do + let biasedPPED = PPED.biasTo [name] pped + (ref, displayObject, docRefs) <- mapMaybeT (liftIO . Codebase.runTransaction codebase) $ do + (ref, displayObject) <- MaybeT $ typeDisplayObjectByName codebase nameSearch name + docRefs <- lift $ Backend.docsForDefinitionName codebase nameSearch NS.ExactName name + pure (ref, displayObject, docRefs) + renderedDocs <- + liftIO $ + renderDocRefs pped width codebase rt docRefs + -- local server currently ignores doc eval errors + <&> fmap \(hqn, h, doc, _errs) -> (hqn, h, doc) + let (_ref, syntaxDO) = Backend.typesToSyntaxOf (Suffixify False) width pped id (ref, displayObject) + lift $ Backend.mkTypeDefinition codebase biasedPPED width ref renderedDocs syntaxDO From 33ab40c454f2916536e999fb983bcdb34ccd52d3 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Thu, 16 May 2024 15:55:48 -0700 Subject: [PATCH 27/82] Implement defn diff endpoints --- .../src/Unison/Server/CodebaseServer.hs | 118 ++++++++++++------ .../src/Unison/Server/Local/Definitions.hs | 7 +- unison-share-api/src/Unison/Server/Types.hs | 12 +- 3 files changed, 95 insertions(+), 42 deletions(-) diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index f2acc4277..e63266d7e 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -88,17 +88,24 @@ import System.Random.MWC (createSystemRandom) import U.Codebase.HashTags (CausalHash) 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.Path qualified as Path import Unison.Codebase.Runtime qualified as Rt -import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.HashQualified +import Unison.HashQualified qualified as HQ import Unison.Name as Name (Name, segments) import Unison.Parser.Ann (Ann) import Unison.Prelude +import Unison.PrettyPrintEnv.Names qualified as PPE +import Unison.PrettyPrintEnvDecl (PrettyPrintEnvDecl) +import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Server.Backend (Backend, BackendEnv, runBackend) import Unison.Server.Backend qualified as Backend +import Unison.Server.Backend.DefinitionDiff qualified as DefinitionDiff import Unison.Server.Errors (backendError) +import Unison.Server.Local.Definitions qualified as Defn import Unison.Server.Local.Endpoints.DefinitionSummary (TermSummaryAPI, TypeSummaryAPI, serveTermSummary, serveTypeSummary) import Unison.Server.Local.Endpoints.FuzzyFind (FuzzyFindAPI, serveFuzzyFind) import Unison.Server.Local.Endpoints.GetDefinitions @@ -109,11 +116,14 @@ import Unison.Server.Local.Endpoints.NamespaceDetails qualified as NamespaceDeta import Unison.Server.Local.Endpoints.NamespaceListing qualified as NamespaceListing import Unison.Server.Local.Endpoints.Projects (ListProjectBranchesEndpoint, ListProjectsEndpoint, projectBranchListingEndpoint, projectListingEndpoint) import Unison.Server.Local.Endpoints.UCM (UCMAPI, ucmServer) -import Unison.Server.Types (TermDefinition (..), TermDiffResponse, TypeDiffResponse, mungeString, setCacheControl) -import Unison.Share.API.Projects (BranchName) +import Unison.Server.NameSearch (NameSearch (..)) +import Unison.Server.NameSearch.FromNames qualified as Names +import Unison.Server.Types (TermDefinition (..), TermDiffResponse (..), TypeDefinition (..), TypeDiffResponse (..), mungeString, setCacheControl) import Unison.ShortHash qualified as ShortHash +import Unison.Sqlite qualified as Sqlite import Unison.Symbol (Symbol) import Unison.Syntax.NameSegment qualified as NameSegment +import Unison.Util.Pretty qualified as Pretty -- | Fail the route with a reasonable error if the query param is missing. type RequiredQueryParam = Servant.QueryParam' '[Servant.Required, Servant.Strict] @@ -163,15 +173,15 @@ type ProjectsAPI = ) type ProjectDiffTermsEndpoint = - RequiredQueryParam "oldBranchRef" BranchName - :> RequiredQueryParam "newBranchRef" BranchName + RequiredQueryParam "oldBranchRef" ProjectBranchName + :> RequiredQueryParam "newBranchRef" ProjectBranchName :> RequiredQueryParam "oldTerm" Name :> RequiredQueryParam "newTerm" Name :> Get '[JSON] TermDiffResponse type ProjectDiffTypesEndpoint = - RequiredQueryParam "oldBranchRef" BranchName - :> RequiredQueryParam "newBranchRef" BranchName + RequiredQueryParam "oldBranchRef" ProjectBranchName + :> RequiredQueryParam "newBranchRef" ProjectBranchName :> RequiredQueryParam "oldType" Name :> RequiredQueryParam "newType" Name :> Get '[JSON] TypeDiffResponse @@ -577,44 +587,82 @@ serveProjectsCodebaseServerAPI codebase rt projectName branchName = do where projectAndBranchName = ProjectAndBranch projectName branchName namespaceListingEndpoint _rootParam rel name = do - root <- resolveProjectRoot - setCacheControl <$> NamespaceListing.serve codebase (Just root) rel name + root <- resolveProjectRoot codebase projectAndBranchName + setCacheControl <$> NamespaceListing.serve codebase (Just . Right $ root) rel name namespaceDetailsEndpoint namespaceName _rootParam renderWidth = do - root <- resolveProjectRoot - setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just root) renderWidth + root <- resolveProjectRoot codebase projectAndBranchName + setCacheControl <$> NamespaceDetails.namespaceDetails rt codebase namespaceName (Just . Right $ root) renderWidth serveDefinitionsEndpoint _rootParam relativePath rawHqns renderWidth suff = do - root <- resolveProjectRoot - setCacheControl <$> serveDefinitions rt codebase (Just root) relativePath rawHqns renderWidth suff + root <- resolveProjectRoot codebase projectAndBranchName + setCacheControl <$> serveDefinitions rt codebase (Just . Right $ root) relativePath rawHqns renderWidth suff serveFuzzyFindEndpoint _rootParam relativePath limit renderWidth query = do - root <- resolveProjectRoot - setCacheControl <$> serveFuzzyFind codebase (Just root) relativePath limit renderWidth query + root <- resolveProjectRoot codebase projectAndBranchName + setCacheControl <$> serveFuzzyFind codebase (Just . Right $ root) relativePath limit renderWidth query serveTermSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do - root <- resolveProjectRoot - setCacheControl <$> serveTermSummary codebase shortHash mayName (Just root) relativeTo renderWidth + root <- resolveProjectRoot codebase projectAndBranchName + setCacheControl <$> serveTermSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth serveTypeSummaryEndpoint shortHash mayName _rootParam relativeTo renderWidth = do - root <- resolveProjectRoot - setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just root) relativeTo renderWidth + root <- resolveProjectRoot codebase projectAndBranchName + setCacheControl <$> serveTypeSummary codebase shortHash mayName (Just . Right $ root) relativeTo renderWidth - resolveProjectRoot :: Backend IO (Either ShortCausalHash CausalHash) - resolveProjectRoot = do - mayCH <- liftIO . Codebase.runTransaction codebase $ Backend.causalHashForProjectBranchName @IO projectAndBranchName - case mayCH of - Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName) - Just ch -> pure (Right ch) +resolveProjectRoot :: (Codebase IO v a) -> (ProjectAndBranch ProjectName ProjectBranchName) -> Backend IO CausalHash +resolveProjectRoot codebase projectAndBranchName@(ProjectAndBranch projectName branchName) = do + mayCH <- liftIO . Codebase.runTransaction codebase $ Backend.causalHashForProjectBranchName @IO projectAndBranchName + case mayCH of + Nothing -> throwError (Backend.ProjectBranchNameNotFound projectName branchName) + Just ch -> pure ch -serveProjectDiffTermsEndpoint :: Codebase m v a -> ProjectName -> BranchName -> BranchName -> Name -> Name -> Backend IO TermDiffResponse -serveProjectDiffTermsEndpoint projectName oldBranchRef newBranchRef oldTerm newTerm = do - oldTerm@(TermDefinition {termDefinition = oldDisplayObj}) <- getTermDefinition authZReceipt project oldShortHand oldTermName `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("Term not found: " <> IDs.toText oldShortHand <> ":" <> Name.toText oldTermName)) - newTerm@(TermDefinition {termDefinition = newDisplayObj}) <- getTermDefinition authZReceipt project newShortHand newTermName `whenNothingM` respondError (EntityMissing (ErrorID "term-not-found") ("Term not found: " <> IDs.toText newShortHand <> ":" <> Name.toText newTermName)) - let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects oldDisplayObj newDisplayObj +serveProjectDiffTermsEndpoint :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ProjectName -> ProjectBranchName -> ProjectBranchName -> Name -> Name -> Backend IO TermDiffResponse +serveProjectDiffTermsEndpoint codebase rt projectName oldBranchRef newBranchRef oldTerm newTerm = do + (oldPPED, oldNameSearch) <- contextForProjectBranch codebase projectName oldBranchRef + (newPPED, newNameSearch) <- contextForProjectBranch codebase projectName newBranchRef + oldTerm@TermDefinition {termDefinition = oldTermDispObject} <- Defn.termDefinitionByName codebase oldPPED oldNameSearch width rt oldTerm `whenNothingM` throwError (Backend.NoSuchDefinition (HQ.NameOnly oldTerm)) + newTerm@TermDefinition {termDefinition = newTermDisplayObj} <- Defn.termDefinitionByName codebase newPPED newNameSearch width rt newTerm `whenNothingM` throwError (Backend.NoSuchDefinition (HQ.NameOnly newTerm)) + let termDiffDisplayObject = DefinitionDiff.diffDisplayObjects oldTermDispObject newTermDisplayObj + pure + TermDiffResponse + { project = projectName, + oldBranch = oldBranchRef, + newBranch = newBranchRef, + oldTerm = oldTerm, + newTerm = newTerm, + diff = termDiffDisplayObject + } + where + width = Pretty.Width 80 -serveProjectDiffTypesEndpoint :: Codebase m v a -> ProjectName -> BranchName -> BranchName -> Name -> Name -> Backend IO TypeDiffResponse -serveProjectDiffTypesEndpoint projectName oldBranchRef newBranchRef oldType newType = do - undefined +contextForProjectBranch :: (Codebase IO v a) -> ProjectName -> ProjectBranchName -> Backend IO (PrettyPrintEnvDecl, NameSearch Sqlite.Transaction) +contextForProjectBranch codebase projectName branchName = do + projectRootHash <- resolveProjectRoot codebase (ProjectAndBranch projectName branchName) + projectRootBranch <- liftIO $ Codebase.expectBranchForHash codebase projectRootHash + hashLength <- liftIO $ Codebase.runTransaction codebase $ Codebase.hashLength + let names = Branch.toNames (Branch.head projectRootBranch) + let pped = PPED.makePPED (PPE.hqNamer hashLength names) (PPE.suffixifyByHash names) + let nameSearch = Names.makeNameSearch hashLength names + pure (pped, nameSearch) + +serveProjectDiffTypesEndpoint :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ProjectName -> ProjectBranchName -> ProjectBranchName -> Name -> Name -> Backend IO TypeDiffResponse +serveProjectDiffTypesEndpoint codebase rt projectName oldBranchRef newBranchRef oldType newType = do + (oldPPED, oldNameSearch) <- contextForProjectBranch codebase projectName oldBranchRef + (newPPED, newNameSearch) <- contextForProjectBranch codebase projectName newBranchRef + oldType@TypeDefinition {typeDefinition = oldTypeDispObj} <- Defn.typeDefinitionByName codebase oldPPED oldNameSearch width rt oldType `whenNothingM` throwError (Backend.NoSuchDefinition (HQ.NameOnly oldType)) + newType@TypeDefinition {typeDefinition = newTypeDisplayObj} <- Defn.typeDefinitionByName codebase newPPED newNameSearch width rt newType `whenNothingM` throwError (Backend.NoSuchDefinition (HQ.NameOnly newType)) + let typeDiffDisplayObject = DefinitionDiff.diffDisplayObjects oldTypeDispObj newTypeDisplayObj + pure + TypeDiffResponse + { project = projectName, + oldBranch = oldBranchRef, + newBranch = newBranchRef, + oldType = oldType, + newType = newType, + diff = typeDiffDisplayObject + } + where + width = Pretty.Width 80 serveProjectsAPI :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ServerT ProjectsAPI (Backend IO) serveProjectsAPI codebase rt = @@ -622,8 +670,8 @@ serveProjectsAPI codebase rt = :<|> ( \projectName -> projectBranchListingEndpoint codebase projectName :<|> serveProjectsCodebaseServerAPI codebase rt projectName - :<|> ( serveProjectDiffTermsEndpoint codebase projectName - :<|> serveProjectDiffTypesEndpoint codebase projectName + :<|> ( serveProjectDiffTermsEndpoint codebase rt projectName + :<|> serveProjectDiffTypesEndpoint codebase rt projectName ) ) diff --git a/unison-share-api/src/Unison/Server/Local/Definitions.hs b/unison-share-api/src/Unison/Server/Local/Definitions.hs index 767b276fc..7f7f72c5f 100644 --- a/unison-share-api/src/Unison/Server/Local/Definitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Definitions.hs @@ -1,4 +1,9 @@ -module Unison.Server.Local.Definitions (prettyDefinitionsForHQName) where +module Unison.Server.Local.Definitions + ( prettyDefinitionsForHQName, + termDefinitionByName, + typeDefinitionByName, + ) +where import Control.Lens hiding ((??)) import Control.Monad.Except diff --git a/unison-share-api/src/Unison/Server/Types.hs b/unison-share-api/src/Unison/Server/Types.hs index 9d2eb6cbf..48f9ace2b 100644 --- a/unison-share-api/src/Unison/Server/Types.hs +++ b/unison-share-api/src/Unison/Server/Types.hs @@ -38,16 +38,16 @@ import U.Codebase.HashTags import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.DisplayObject (DisplayObject) import Unison.Codebase.Path qualified as Path +import Unison.Core.Project (ProjectBranchName) import Unison.Hash qualified as Hash import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Prelude -import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) +import Unison.Project (ProjectAndBranch, ProjectName) import Unison.Server.Doc (Doc) import Unison.Server.Orphans () import Unison.Server.Syntax qualified as Syntax -import Unison.Share.API.Projects (BranchName) import Unison.ShortHash (ShortHash) import Unison.Syntax.HashQualified qualified as HQ (parseText) import Unison.Syntax.Name qualified as Name @@ -467,8 +467,8 @@ instance Docs.ToCapture (Capture "project-and-branch" ProjectBranchNameParam) wh data TermDiffResponse = TermDiffResponse { project :: ProjectName, - oldBranch :: BranchName, - newBranch :: BranchName, + oldBranch :: ProjectBranchName, + newBranch :: ProjectBranchName, oldTerm :: TermDefinition, newTerm :: TermDefinition, diff :: DisplayObjectDiff @@ -505,8 +505,8 @@ instance ToJSON TermDiffResponse where data TypeDiffResponse = TypeDiffResponse { project :: ProjectName, - oldBranch :: BranchName, - newBranch :: BranchName, + oldBranch :: ProjectBranchName, + newBranch :: ProjectBranchName, oldType :: TypeDefinition, newType :: TypeDefinition, diff :: DisplayObjectDiff From c4dce53fd234c10b9c67c2e0620e0313467eb720 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 17 May 2024 09:19:44 -0700 Subject: [PATCH 28/82] Build definition diff api --- unison-cli/src/Unison/Codebase/Editor/HandleInput.hs | 7 ++++--- unison-cli/src/Unison/LSP/Queries.hs | 2 +- unison-share-api/src/Unison/Server/Local/Definitions.hs | 2 +- 3 files changed, 6 insertions(+), 5 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 9556d3f82..110a5e62d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -536,11 +536,12 @@ loop e = do DocToMarkdownI docName -> do names <- Cli.currentNames pped <- Cli.prettyPrintEnvDeclFromNames names - hqLength <- Cli.runTransaction Codebase.hashLength - let nameSearch = NameSearch.makeNameSearch hqLength names Cli.Env {codebase, runtime} <- ask + docRefs <- Cli.runTransaction do + hqLength <- Codebase.hashLength + let nameSearch = NameSearch.makeNameSearch hqLength names + Backend.docsForDefinitionName codebase nameSearch Names.IncludeSuffixes docName mdText <- liftIO $ do - docRefs <- Backend.docsForDefinitionName codebase nameSearch Names.IncludeSuffixes docName for docRefs \docRef -> do Identity (_, _, doc, _evalErrs) <- Backend.renderDocRefs pped (Pretty.Width 80) codebase runtime (Identity docRef) pure . Md.toText $ Md.toMarkdown doc diff --git a/unison-cli/src/Unison/LSP/Queries.hs b/unison-cli/src/Unison/LSP/Queries.hs index 9eeaac3fb..b6e87497c 100644 --- a/unison-cli/src/Unison/LSP/Queries.hs +++ b/unison-cli/src/Unison/LSP/Queries.hs @@ -389,7 +389,7 @@ markdownDocsForFQN fileUri fqn = nameSearch <- lift $ getNameSearch Env {codebase, runtime} <- ask liftIO $ do - docRefs <- Backend.docsForDefinitionName codebase nameSearch ExactName name + docRefs <- Codebase.runTransaction codebase $ Backend.docsForDefinitionName codebase nameSearch ExactName name for docRefs $ \docRef -> do Identity (_, _, doc, _evalErrs) <- Backend.renderDocRefs pped (Pretty.Width 80) codebase runtime (Identity docRef) pure . Md.toText $ Md.toMarkdown doc diff --git a/unison-share-api/src/Unison/Server/Local/Definitions.hs b/unison-share-api/src/Unison/Server/Local/Definitions.hs index 7f7f72c5f..b1f5b03d5 100644 --- a/unison-share-api/src/Unison/Server/Local/Definitions.hs +++ b/unison-share-api/src/Unison/Server/Local/Definitions.hs @@ -154,7 +154,7 @@ typeDisplayObjectByName :: Codebase m Symbol Ann -> NameSearch Sqlite.Transactio typeDisplayObjectByName codebase nameSearch name = runMaybeT do refs <- lift $ NameSearch.lookupRelativeHQRefs' (NS.typeSearch nameSearch) NS.ExactName (HQ'.NameOnly name) ref <- fmap NESet.findMin . hoistMaybe $ NESet.nonEmptySet refs - fmap (ref,) . lift $ Backend.displayType ref + fmap (ref,) . lift $ Backend.displayType codebase ref typeDefinitionByName :: Codebase IO Symbol Ann -> From 240cddcc3f567469076fe19df6601e1315e59203 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 17 May 2024 09:43:19 -0700 Subject: [PATCH 29/82] Add definition diff apis and tests --- .../src/Unison/Server/CodebaseServer.hs | 13 +- unison-src/transcripts/definition-diff-api.md | 41 + .../transcripts/definition-diff-api.output.md | 819 ++++++++++++++++++ 3 files changed, 868 insertions(+), 5 deletions(-) create mode 100644 unison-src/transcripts/definition-diff-api.md create mode 100644 unison-src/transcripts/definition-diff-api.output.md diff --git a/unison-share-api/src/Unison/Server/CodebaseServer.hs b/unison-share-api/src/Unison/Server/CodebaseServer.hs index e63266d7e..eb2332dc7 100644 --- a/unison-share-api/src/Unison/Server/CodebaseServer.hs +++ b/unison-share-api/src/Unison/Server/CodebaseServer.hs @@ -161,9 +161,11 @@ type CodebaseServerAPI = type ProjectsAPI = ListProjectsEndpoint :<|> ( Capture "project-name" ProjectName - :> "branches" - :> ( ListProjectBranchesEndpoint - :<|> (Capture "branch-name" ProjectBranchName :> CodebaseServerAPI) + :> ( ( "branches" + :> ( ListProjectBranchesEndpoint + :<|> (Capture "branch-name" ProjectBranchName :> CodebaseServerAPI) + ) + ) :<|> ( "diff" :> ( "terms" :> ProjectDiffTermsEndpoint :<|> "types" :> ProjectDiffTypesEndpoint @@ -668,8 +670,9 @@ serveProjectsAPI :: Codebase IO Symbol Ann -> Rt.Runtime Symbol -> ServerT Proje serveProjectsAPI codebase rt = projectListingEndpoint codebase :<|> ( \projectName -> - projectBranchListingEndpoint codebase projectName - :<|> serveProjectsCodebaseServerAPI codebase rt projectName + ( projectBranchListingEndpoint codebase projectName + :<|> serveProjectsCodebaseServerAPI codebase rt projectName + ) :<|> ( serveProjectDiffTermsEndpoint codebase rt projectName :<|> serveProjectDiffTypesEndpoint codebase rt projectName ) diff --git a/unison-src/transcripts/definition-diff-api.md b/unison-src/transcripts/definition-diff-api.md new file mode 100644 index 000000000..922a3c277 --- /dev/null +++ b/unison-src/transcripts/definition-diff-api.md @@ -0,0 +1,41 @@ +```ucm +.> project.create-empty diffs +diffs/main> builtins.merge +``` + +```unison +term = + _ = "Here's some text" + 1 + 1 + +type Type = Type Nat +``` + +```ucm +diffs/main> add +diffs/main> branch.create new +``` + +```unison +term = + _ = "Here's some different text" + 1 + 2 + +type Type a = Type a Text +``` + +```ucm +diffs/new> update +``` + +Diff terms + +```api +GET /api/projects/diffs/diff/terms?oldBranchRef=main&newBranchRef=new&oldTerm=term&newTerm=term +``` + +Diff types + +```api +GET /api/projects/diffs/diff/types?oldBranchRef=main&newBranchRef=new&oldType=Type&newType=Type +``` diff --git a/unison-src/transcripts/definition-diff-api.output.md b/unison-src/transcripts/definition-diff-api.output.md new file mode 100644 index 000000000..3fbf1c748 --- /dev/null +++ b/unison-src/transcripts/definition-diff-api.output.md @@ -0,0 +1,819 @@ +```ucm +.> project.create-empty diffs + + 🎉 I've created the project diffs. + + 🎨 Type `ui` to explore this project's code in your browser. + 🔭 Discover libraries at https://share.unison-lang.org + 📖 Use `help-topic projects` to learn more about projects. + + Write your first Unison code with UCM: + + 1. Open scratch.u. + 2. Write some Unison code and save the file. + 3. In UCM, type `add` to save it to your new project. + + 🎉 🥳 Happy coding! + +diffs/main> builtins.merge + + Done. + +``` +```unison +term = + _ = "Here's some text" + 1 + 1 + +type Type = Type Nat +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + type Type + term : Nat + +``` +```ucm +diffs/main> add + + ⍟ I've added these definitions: + + type Type + term : Nat + +diffs/main> branch.create new + + Done. I've created the new branch based off of main. + + Tip: Use `merge /new /main` to merge your work back into the + main branch. + +``` +```unison +term = + _ = "Here's some different text" + 1 + 2 + +type Type a = Type a Text +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + type Type a + term : Nat + +``` +```ucm +diffs/new> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +``` +```api +GET /api/projects/diffs/diff/terms?oldBranchRef=main&newBranchRef=new&oldTerm=term&newTerm=term +{ + "diff": { + "contents": [ + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseKeyword" + }, + "segment": "use " + }, + { + "annotation": { + "tag": "UsePrefix" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "_", + "tag": "HashQualifier" + }, + "segment": "_" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "annotation": { + "tag": "TextLiteral" + }, + "diffTag": "segmentChange", + "fromSegment": "\"Here's some text\"", + "toSegment": "\"Here's some different text\"" + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.+", + "tag": "TermReference" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": " " + } + ] + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "diffTag": "segmentChange", + "fromSegment": "1", + "toSegment": "2" + } + ], + "tag": "UserObject" + }, + "diffKind": "diff", + "newBranchRef": "new", + "newTerm": { + "bestTermName": "term", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseKeyword" + }, + "segment": "use " + }, + { + "annotation": { + "tag": "UsePrefix" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "_", + "tag": "HashQualifier" + }, + "segment": "_" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TextLiteral" + }, + "segment": "\"Here's some different text\"" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.+", + "tag": "TermReference" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "2" + } + ], + "tag": "UserObject" + }, + "termDocs": [], + "termNames": [ + "term" + ] + }, + "oldBranchRef": "main", + "oldTerm": { + "bestTermName": "term", + "defnTermTag": "Plain", + "signature": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "termDefinition": { + "contents": [ + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "TypeAscriptionColon" + }, + "segment": " :" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": { + "contents": "term", + "tag": "HashQualifier" + }, + "segment": "term" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseKeyword" + }, + "segment": "use " + }, + { + "annotation": { + "tag": "UsePrefix" + }, + "segment": "Nat" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "UseSuffix" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "_", + "tag": "HashQualifier" + }, + "segment": "_" + }, + { + "annotation": { + "tag": "BindingEquals" + }, + "segment": " =" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "TextLiteral" + }, + "segment": "\"Here's some text\"" + }, + { + "annotation": null, + "segment": "\n" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat.+", + "tag": "TermReference" + }, + "segment": "+" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "NumericLiteral" + }, + "segment": "1" + } + ], + "tag": "UserObject" + }, + "termDocs": [], + "termNames": [ + "term" + ] + }, + "project": "diffs" +} +``````api +GET /api/projects/diffs/diff/types?oldBranchRef=main&newBranchRef=new&oldType=Type&newType=Type +{ + "diff": { + "contents": [ + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "tag": "DataTypeKeyword" + }, + "segment": "type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "Type", + "tag": "HashQualifier" + }, + "segment": "Type" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DataTypeParams" + }, + "segment": "a" + } + ] + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": " = " + } + ] + }, + { + "diffTag": "annotationChange", + "fromAnnotation": { + "contents": "#0tc9e438eurvtevfa6k9pg04qvv66is75hs8iqejkuoaef140g8vvu92hc1ks4gamgc3i1ukgdn0blchp3038l43vffijpsbjh14igo#d0", + "tag": "TermReference" + }, + "segment": "Type", + "toAnnotation": { + "contents": "#mft8mne9i92b6k4m512rn2608rsp6ilq4ejufeof6mbh5aintes4tih1fo93fospmu2t3f0h67uu0mrk2qj75o7k0lj1juefhaidt4g#d0", + "tag": "TermReference" + } + }, + { + "diffTag": "both", + "elements": [ + { + "annotation": null, + "segment": " " + } + ] + }, + { + "diffTag": "old", + "elements": [ + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ] + }, + { + "diffTag": "new", + "elements": [ + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + } + ] + } + ], + "tag": "UserObject" + }, + "diffKind": "diff", + "newBranchRef": "new", + "newType": { + "bestTypeName": "Type", + "defnTypeTag": "Data", + "typeDefinition": { + "contents": [ + { + "annotation": { + "tag": "DataTypeKeyword" + }, + "segment": "type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "Type", + "tag": "HashQualifier" + }, + "segment": "Type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "DataTypeParams" + }, + "segment": "a" + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": " = " + }, + { + "annotation": { + "contents": "#mft8mne9i92b6k4m512rn2608rsp6ilq4ejufeof6mbh5aintes4tih1fo93fospmu2t3f0h67uu0mrk2qj75o7k0lj1juefhaidt4g#d0", + "tag": "TermReference" + }, + "segment": "Type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "tag": "Var" + }, + "segment": "a" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Text", + "tag": "TypeReference" + }, + "segment": "Text" + } + ], + "tag": "UserObject" + }, + "typeDocs": [], + "typeNames": [ + "Type" + ] + }, + "oldBranchRef": "main", + "oldType": { + "bestTypeName": "Type", + "defnTypeTag": "Data", + "typeDefinition": { + "contents": [ + { + "annotation": { + "tag": "DataTypeKeyword" + }, + "segment": "type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "Type", + "tag": "HashQualifier" + }, + "segment": "Type" + }, + { + "annotation": { + "tag": "DelimiterChar" + }, + "segment": " = " + }, + { + "annotation": { + "contents": "#0tc9e438eurvtevfa6k9pg04qvv66is75hs8iqejkuoaef140g8vvu92hc1ks4gamgc3i1ukgdn0blchp3038l43vffijpsbjh14igo#d0", + "tag": "TermReference" + }, + "segment": "Type" + }, + { + "annotation": null, + "segment": " " + }, + { + "annotation": { + "contents": "##Nat", + "tag": "TypeReference" + }, + "segment": "Nat" + } + ], + "tag": "UserObject" + }, + "typeDocs": [], + "typeNames": [ + "Type" + ] + }, + "project": "diffs" +} +``` \ No newline at end of file From bc54e4d0b480179accc048efaef556966f1933f0 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 17 May 2024 13:49:13 -0400 Subject: [PATCH 30/82] make `pull` call new `merge` instead of old `merge` --- unison-cli/src/Unison/Cli/MergeTypes.hs | 32 +++++ unison-cli/src/Unison/Cli/Pretty.hs | 17 ++- .../Codebase/Editor/HandleInput/Merge2.hs | 121 ++++++++++-------- .../Codebase/Editor/HandleInput/Pull.hs | 15 +-- .../src/Unison/Codebase/Editor/Output.hs | 22 ++-- .../src/Unison/Codebase/Editor/UriParser.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 57 +++++---- unison-cli/unison-cli.cabal | 1 + unison-src/transcripts/merge.output.md | 102 +++++++-------- 9 files changed, 225 insertions(+), 144 deletions(-) create mode 100644 unison-cli/src/Unison/Cli/MergeTypes.hs diff --git a/unison-cli/src/Unison/Cli/MergeTypes.hs b/unison-cli/src/Unison/Cli/MergeTypes.hs new file mode 100644 index 000000000..42524056d --- /dev/null +++ b/unison-cli/src/Unison/Cli/MergeTypes.hs @@ -0,0 +1,32 @@ +-- | Common types related to merge, pulled down far enough to be imported by all interested parties. +module Unison.Cli.MergeTypes + ( MergeSource (..), + MergeTarget, + MergeSourceAndTarget (..), + MergeSourceOrTarget (..), + ) +where + +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadShareLooseCode) +import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) + +-- | What are we merging in? +data MergeSource + = MergeSource'LocalProjectBranch !(ProjectAndBranch ProjectName ProjectBranchName) + | MergeSource'RemoteProjectBranch !(ProjectAndBranch ProjectName ProjectBranchName) + | MergeSource'RemoteLooseCode !ReadShareLooseCode + | MergeSource'RemoteGitRepo !ReadGitRemoteNamespace + +type MergeTarget = + ProjectAndBranch ProjectName ProjectBranchName + +-- | "Alice and Bob" +data MergeSourceAndTarget = MergeSourceAndTarget + { alice :: !MergeTarget, + bob :: !MergeSource + } + +-- | "Either Alice Bob" +data MergeSourceOrTarget + = MergeSourceOrTarget'Source !MergeSource + | MergeSourceOrTarget'Target !MergeTarget diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index 0bd17235b..8f82d3d44 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -19,6 +19,8 @@ module Unison.Cli.Pretty prettyLabeledDependencies, prettyPath, prettyPath', + prettyMergeSource, + prettyMergeSourceOrTarget, prettyProjectAndBranchName, prettyBranchName, prettyProjectBranchName, @@ -69,6 +71,7 @@ import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Util.Base32Hex (Base32Hex) import U.Util.Base32Hex qualified as Base32Hex +import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..)) import Unison.Cli.ProjectUtils (projectBranchPathPrism) import Unison.Cli.Share.Projects.Types qualified as Share import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, MissingObject, UserObject)) @@ -76,7 +79,7 @@ import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.RemoteRepo ( ReadGitRepo, - ReadRemoteNamespace, + ReadRemoteNamespace (..), ShareUserHandle (..), WriteGitRepo, WriteRemoteNamespace (..), @@ -225,6 +228,18 @@ prettyHash = prettyBase32Hex# . Hash.toBase32Hex prettyHash32 :: (IsString s) => Hash32 -> P.Pretty s prettyHash32 = prettyBase32Hex# . Hash32.toBase32Hex +prettyMergeSource :: MergeSource -> Pretty +prettyMergeSource = \case + MergeSource'LocalProjectBranch branch -> prettyProjectAndBranchName branch + MergeSource'RemoteProjectBranch branch -> "remote " <> prettyProjectAndBranchName branch + MergeSource'RemoteLooseCode info -> prettyReadRemoteNamespace (ReadShare'LooseCode info) + MergeSource'RemoteGitRepo info -> prettyReadRemoteNamespace (ReadRemoteNamespaceGit info) + +prettyMergeSourceOrTarget :: MergeSourceOrTarget -> Pretty +prettyMergeSourceOrTarget = \case + MergeSourceOrTarget'Target alice -> prettyProjectAndBranchName alice + MergeSourceOrTarget'Source bob -> prettyMergeSource bob + prettyProjectName :: ProjectName -> Pretty prettyProjectName = P.green . P.text . into @Text diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 7cf2da00e..d6685f105 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -43,6 +43,7 @@ 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 (..), MergeSourceOrTarget (..), MergeSourceAndTarget (..)) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli @@ -60,6 +61,8 @@ import Unison.Codebase.Editor.HandleInput.Update2 typecheckedUnisonFileToBranchAdds, ) import Unison.Codebase.Editor.Output qualified as Output +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadShareLooseCode (..)) +import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache) import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions @@ -121,6 +124,7 @@ import Unison.Typechecker qualified as Typechecker 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.Pretty (ColorText, Pretty) import Unison.Util.Pretty qualified as Pretty @@ -167,8 +171,7 @@ handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do bob = BobMergeInfo { causalHash = bobCausalHash, - projectName = bobProject.name, - projectBranchName = bobBranchName + source = MergeSource'LocalProjectBranch (ProjectAndBranch bobProject.name bobBranchName) }, lca = LcaMergeInfo @@ -185,7 +188,7 @@ handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do data MergeInfo = MergeInfo { alice :: !AliceMergeInfo, - bob :: !BobMergeInfo, + bob :: BobMergeInfo, lca :: !LcaMergeInfo, -- | How should we describe this merge in the reflog? description :: !Text @@ -199,12 +202,7 @@ data AliceMergeInfo = AliceMergeInfo data BobMergeInfo = BobMergeInfo { causalHash :: !CausalHash, - -- | Bob's project and branch names are just for display purposes; they don't necessarily correspond to a real local - -- project. For example, if we `pull @unison/base/bugfix`, then we'll use project name `@unison/base` and branch - -- name `bugfix`, even though we're just pulling the branch into the current one, with no relationship to any local - -- project/branch named `@unison/base/bugfix`. - projectName :: !ProjectName, - projectBranchName :: !ProjectBranchName + source :: !MergeSource } newtype LcaMergeInfo = LcaMergeInfo @@ -218,26 +216,23 @@ doMerge info = do then realDebugFunctions else fakeDebugFunctions - let alicePath = - Cli.projectBranchPath (ProjectAndBranch info.alice.project.projectId info.alice.projectBranch.branchId) - - let branchNames = - TwoWay - { alice = ProjectAndBranch info.alice.project.name info.alice.projectBranch.name, - bob = ProjectAndBranch info.bob.projectName info.bob.projectBranchName - } + let alicePath = Cli.projectBranchPath (ProjectAndBranch info.alice.project.projectId info.alice.projectBranch.branchId) + let aliceBranchNames = ProjectAndBranch info.alice.project.name info.alice.projectBranch.name + let mergeSource = MergeSourceOrTarget'Source info.bob.source + let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames + let mergeSourceAndTarget = MergeSourceAndTarget { alice = aliceBranchNames, bob = info.bob.source } Cli.Env {codebase} <- ask -- If alice == bob, or LCA == bob (so alice is ahead of bob), then we are done. when (info.alice.causalHash == info.bob.causalHash || info.lca.causalHash == Just info.bob.causalHash) do - Cli.returnEarly (Output.MergeAlreadyUpToDate (Right branchNames.bob) (Right branchNames.alice)) + Cli.returnEarly (Output.MergeAlreadyUpToDate2 mergeSourceAndTarget) -- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done. when (info.lca.causalHash == Just info.alice.causalHash) do bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash) _ <- Cli.updateAt info.description alicePath (\_aliceBranch -> bobBranch) - Cli.returnEarly (Output.MergeSuccessFastForward branchNames.alice branchNames.bob) + Cli.returnEarly (Output.MergeSuccessFastForward mergeSourceAndTarget) -- Create a bunch of cached database lookup functions db <- makeMergeDatabase codebase @@ -263,7 +258,7 @@ doMerge info = do pure TwoOrThreeWay {lca, alice, bob} -- Assert that neither Alice nor Bob have defns in lib - for_ [(branchNames.alice.branch, branches.alice), (branchNames.bob.branch, branches.bob)] \(who, branch) -> do + for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do libdeps <- case Map.lookup NameSegment.libSegment branch.children of Nothing -> pure V2.Branch.empty @@ -279,7 +274,7 @@ doMerge info = do ( Nametree {value = Defns Map.empty Map.empty, children = Map.empty}, DeclNameLookup Map.empty Map.empty ) - Just (maybeBranchName, branch) -> do + Just (who, branch) -> do defns <- Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName -> Cli.returnEarly case conflictedName of @@ -289,15 +284,15 @@ doMerge info = do Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err -> Cli.returnEarly case err of IncoherentDeclReason'ConstructorAlias name1 name2 -> - Output.MergeConstructorAlias maybeBranchName name1 name2 - IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName maybeBranchName name + Output.MergeConstructorAlias who name1 name2 + IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName who name IncoherentDeclReason'NestedDeclAlias shorterName longerName -> - Output.MergeNestedDeclAlias maybeBranchName shorterName longerName - IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor maybeBranchName name + Output.MergeNestedDeclAlias who shorterName longerName + IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor who name pure (defns, declNameLookup) - (aliceDefns0, aliceDeclNameLookup) <- load (Just (Just branchNames.alice.branch, branches.alice)) - (bobDefns0, bobDeclNameLookup) <- load (Just (Just branchNames.bob.branch, branches.bob)) + (aliceDefns0, aliceDeclNameLookup) <- load (Just (Just mergeTarget, branches.alice)) + (bobDefns0, bobDeclNameLookup) <- load (Just (Just mergeSource, branches.bob)) (lcaDefns0, lcaDeclNameLookup) <- load ((Nothing,) <$> branches.lca) let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns) @@ -317,9 +312,9 @@ doMerge info = do liftIO (debugFunctions.debugDiffs diffs) -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias - for_ ((,) <$> branchNames <*> diffs) \(names, diff) -> + for_ ((,) <$> TwoWay mergeTarget mergeSource <*> diffs) \(who, diff) -> whenJust (findConflictedAlias defns3.lca diff) \(name1, name2) -> - Cli.returnEarly (Output.MergeConflictedAliases names.branch name1 name2) + Cli.returnEarly (Output.MergeConflictedAliases who name1 name2) -- Combine the LCA->Alice and LCA->Bob diffs together let diff = combineDiffs diffs @@ -398,7 +393,27 @@ doMerge info = do <*> hydratedThings <*> ppes - let prettyUnisonFile = makePrettyUnisonFile (into @Text <$> branchNames) renderedConflicts renderedDependents + let prettyUnisonFile = + makePrettyUnisonFile + TwoWay + { alice = into @Text aliceBranchNames, + bob = + case info.bob.source of + MergeSource'LocalProjectBranch bobBranchNames -> into @Text bobBranchNames + MergeSource'RemoteProjectBranch bobBranchNames + | aliceBranchNames == bobBranchNames -> "remote " <> into @Text bobBranchNames + | otherwise -> into @Text bobBranchNames + MergeSource'RemoteLooseCode info -> + case Path.toName info.path of + Nothing -> "" + Just name -> Name.toText name + MergeSource'RemoteGitRepo info -> + case Path.toName info.path of + Nothing -> "" + Just name -> Name.toText name + } + renderedConflicts + renderedDependents let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps @@ -424,18 +439,14 @@ doMerge info = do (Branch.mergeNode stageOneBranch parents.alice parents.bob) Nothing info.alice.project - (findTemporaryBranchName info.alice.project.projectId (view #branch <$> branchNames)) + (findTemporaryBranchName info.alice.project.projectId mergeSourceAndTarget) info.description scratchFilePath <- Cli.getLatestFile <&> \case Nothing -> "scratch.u" Just (file, _) -> file liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) - Cli.respond $ - Output.MergeFailure - scratchFilePath - branchNames.alice - branchNames.bob + Cli.respond (Output.MergeFailure scratchFilePath mergeSourceAndTarget) Just tuf -> do Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch @@ -444,7 +455,7 @@ doMerge info = do info.description alicePath (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) - Cli.respond (Output.MergeSuccess branchNames.alice branchNames.bob) + Cli.respond (Output.MergeSuccess mergeSourceAndTarget) ------------------------------------------------------------------------------------------------------------------------ -- Loading basic info out of the database @@ -825,30 +836,40 @@ defnsToNames defns = types = Relation.fromMap (BiMultimap.range defns.types) } -findTemporaryBranchName :: ProjectId -> TwoWay ProjectBranchName -> Transaction ProjectBranchName -findTemporaryBranchName projectId branchNames = do +findTemporaryBranchName :: ProjectId -> MergeSourceAndTarget -> Transaction ProjectBranchName +findTemporaryBranchName projectId mergeSourceAndTarget = do Cli.findTemporaryBranchName projectId preferred where preferred :: ProjectBranchName preferred = unsafeFrom @Text $ - "merge-" - <> mangle branchNames.bob - <> "-into-" - <> mangle branchNames.alice + Text.Builder.run $ + "merge-" + <> mangleMergeSource mergeSourceAndTarget.bob + <> "-into-" + <> mangleBranchName mergeSourceAndTarget.alice.branch - mangle :: ProjectBranchName -> Text - mangle = - Text.Builder.run . mangleB - - mangleB :: ProjectBranchName -> Text.Builder - mangleB name = + mangleMergeSource :: MergeSource -> Text.Builder + mangleMergeSource = \case + MergeSource'LocalProjectBranch (ProjectAndBranch _project branch) -> mangleBranchName branch + MergeSource'RemoteProjectBranch (ProjectAndBranch _project branch) -> "remote-" <> mangleBranchName branch + MergeSource'RemoteLooseCode info -> manglePath info.path + MergeSource'RemoteGitRepo info -> manglePath info.path + mangleBranchName :: ProjectBranchName -> Text.Builder + mangleBranchName name = case classifyProjectBranchName name of - ProjectBranchNameKind'Contributor user name1 -> Text.Builder.text user <> Text.Builder.char '-' <> mangleB name1 + ProjectBranchNameKind'Contributor user name1 -> + Text.Builder.text user + <> Text.Builder.char '-' + <> mangleBranchName name1 ProjectBranchNameKind'DraftRelease semver -> "releases-drafts-" <> mangleSemver semver ProjectBranchNameKind'Release semver -> "releases-" <> mangleSemver semver ProjectBranchNameKind'NothingSpecial -> Text.Builder.text (into @Text name) + manglePath :: Path -> Text.Builder + manglePath = + Monoid.intercalateMap "-" (Text.Builder.text . NameSegment.toUnescapedText) . Path.toList + mangleSemver :: Semver -> Text.Builder mangleSemver (Semver x y z) = Text.Builder.decimal x diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index dc9a9b5e5..3bf286d99 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -17,6 +17,7 @@ import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..)) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch (..)) import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.DownloadUtils +import Unison.Cli.MergeTypes (MergeSource (..)) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli @@ -110,12 +111,6 @@ handlePull unresolvedSourceAndTarget pullMode = do void $ Cli.updateAtM description targetAbsolutePath (const $ pure remoteBranchObject) Cli.respond $ MergeOverEmpty target else do - ProjectAndBranch bobProjectName bobProjectBranchName <- - case source of - ReadRemoteNamespaceGit _ -> wundefined "can't pull from git" - ReadShare'LooseCode _ -> wundefined "can't pull from loose code" - ReadShare'ProjectBranch remoteBranch -> pure (ProjectAndBranch remoteBranch.projectName remoteBranch.branchName) - Cli.respond AboutToMerge aliceCausalHash <- @@ -136,8 +131,12 @@ handlePull unresolvedSourceAndTarget pullMode = do bob = BobMergeInfo { causalHash = remoteCausalHash, - projectName = bobProjectName, - projectBranchName = bobProjectBranchName + source = + case source of + ReadShare'ProjectBranch remoteBranch -> + MergeSource'RemoteProjectBranch (ProjectAndBranch remoteBranch.projectName remoteBranch.branchName) + ReadShare'LooseCode info -> MergeSource'RemoteLooseCode info + ReadRemoteNamespaceGit info -> MergeSource'RemoteGitRepo info }, lca = LcaMergeInfo diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index a45e7ef4a..95923f5cc 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -28,6 +28,7 @@ import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import Unison.Auth.Types (CredentialFailure) +import Unison.Cli.MergeTypes (MergeSourceOrTarget, MergeSourceAndTarget) import Unison.Cli.Share.Projects.Types qualified as Share import Unison.Codebase.Editor.Input import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) @@ -293,6 +294,8 @@ data Output | MergeAlreadyUpToDate (Either Path' (ProjectAndBranch ProjectName ProjectBranchName)) (Either Path' (ProjectAndBranch ProjectName ProjectBranchName)) + | -- This will replace the above once `merge.old` is deleted + MergeAlreadyUpToDate2 !MergeSourceAndTarget | PreviewMergeAlreadyUpToDate (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) (Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)) @@ -395,18 +398,18 @@ data Output | UpgradeFailure !FilePath !NameSegment !NameSegment | UpgradeSuccess !NameSegment !NameSegment | LooseCodePushDeprecated - | MergeFailure !FilePath !(ProjectAndBranch ProjectName ProjectBranchName) !(ProjectAndBranch ProjectName ProjectBranchName) - | MergeSuccess !(ProjectAndBranch ProjectName ProjectBranchName) !(ProjectAndBranch ProjectName ProjectBranchName) - | MergeSuccessFastForward !(ProjectAndBranch ProjectName ProjectBranchName) !(ProjectAndBranch ProjectName ProjectBranchName) - | MergeConflictedAliases !ProjectBranchName !Name !Name + | MergeFailure !FilePath !MergeSourceAndTarget + | MergeSuccess !MergeSourceAndTarget + | MergeSuccessFastForward !MergeSourceAndTarget + | MergeConflictedAliases !MergeSourceOrTarget !Name !Name | MergeConflictedTermName !Name !(NESet Referent) | MergeConflictedTypeName !Name !(NESet TypeReference) | MergeConflictInvolvingBuiltin !Name - | MergeConstructorAlias !(Maybe ProjectBranchName) !Name !Name - | MergeDefnsInLib !ProjectBranchName - | MergeMissingConstructorName !(Maybe ProjectBranchName) !Name - | MergeNestedDeclAlias !(Maybe ProjectBranchName) !Name !Name - | MergeStrayConstructor !(Maybe ProjectBranchName) !Name + | MergeConstructorAlias !(Maybe MergeSourceOrTarget) !Name !Name + | MergeDefnsInLib !MergeSourceOrTarget + | MergeMissingConstructorName !(Maybe MergeSourceOrTarget) !Name + | MergeNestedDeclAlias !(Maybe MergeSourceOrTarget) !Name !Name + | MergeStrayConstructor !(Maybe MergeSourceOrTarget) !Name | InstalledLibdep !(ProjectAndBranch ProjectName ProjectBranchName) !NameSegment data UpdateOrUpgrade = UOUUpdate | UOUUpgrade @@ -559,6 +562,7 @@ isFailure o = case o of AboutToMerge {} -> False MergeOverEmpty {} -> False MergeAlreadyUpToDate {} -> False + MergeAlreadyUpToDate2 {} -> False PreviewMergeAlreadyUpToDate {} -> False NoConflictsOrEdits {} -> False ListShallow _ es -> null es diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 03c5745df..d062952c2 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -109,7 +109,7 @@ writeShareRemoteNamespace = -- >>> P.parseMaybe readShareLooseCode ".unisonweb.base._releases.M4" -- >>> P.parseMaybe readShareLooseCode "unisonweb.base._releases.M4" -- Nothing --- Just (ReadShareLooseCode {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}) +-- Just (ReadShareLooseCode {server = DefaultCodeserver, repo = ShareUserHandle {shareUserHandleToText = "unisonweb"}, path = base._releases.M4}) readShareLooseCode :: P ReadShareLooseCode readShareLooseCode = do P.label "read share loose code" $ diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 4764bcd39..fc9b57023 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -43,6 +43,7 @@ import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import Unison.ABT qualified as ABT import Unison.Auth.Types qualified as Auth import Unison.Builtin.Decls qualified as DD +import Unison.Cli.MergeTypes (MergeSourceAndTarget (..)) import Unison.Cli.Pretty import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.ServantClientUtils qualified as ServantClientUtils @@ -1630,10 +1631,16 @@ notifyUser dir = \case either prettyPath' prettyProjectAndBranchName dest <> "was already up-to-date with" <> P.group (either prettyPath' prettyProjectAndBranchName src <> ".") - MergeConflictedAliases branch name1 name2 -> + MergeAlreadyUpToDate2 aliceAndBob -> + pure . P.callout "😶" $ + P.wrap $ + prettyProjectAndBranchName aliceAndBob.alice + <> "was already up-to-date with" + <> P.group (prettyMergeSource aliceAndBob.bob <> ".") + MergeConflictedAliases aliceOrBob name1 name2 -> pure . P.wrap $ "On" - <> P.group (prettyProjectBranchName branch <> ",") + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") <> prettyName name1 <> "and" <> prettyName name2 @@ -1649,48 +1656,48 @@ notifyUser dir = \case "There's a merge conflict on" <> P.group (prettyName name <> ",") <> "but it's a builtin on one or both branches. We can't yet handle merge conflicts on builtins." - MergeConstructorAlias maybeBranch name1 name2 -> + MergeConstructorAlias maybeAliceOrBob name1 name2 -> pure . P.wrap $ "On" - <> case maybeBranch of + <> case maybeAliceOrBob of Nothing -> "the LCA," - Just branch -> P.group (prettyProjectBranchName branch <> ",") + Just aliceOrBob -> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") <> prettyName name1 <> "and" <> prettyName name2 <> "are aliases. Every type declaration must have exactly one name for each constructor." - MergeDefnsInLib branch -> + MergeDefnsInLib aliceOrBob -> pure . P.wrap $ "On" - <> P.group (prettyProjectBranchName branch <> ",") + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") <> "there's a type or term directly in the `lib` namespace, but I expected only library dependencies to be in there." <> "Please remove it before merging." - MergeMissingConstructorName maybeBranch name -> + MergeMissingConstructorName maybeAliceOrBob name -> pure . P.wrap $ "On" - <> case maybeBranch of + <> case maybeAliceOrBob of Nothing -> "the LCA," - Just branch -> P.group (prettyProjectBranchName branch <> ",") + Just aliceOrBob -> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") <> "the type" <> prettyName name <> "is missing a name for one of its constructors. Please add one before merging." - MergeNestedDeclAlias maybeBranch shorterName longerName -> + MergeNestedDeclAlias maybeAliceOrBob shorterName longerName -> pure . P.wrap $ "On" - <> case maybeBranch of + <> case maybeAliceOrBob of Nothing -> "the LCA," - Just branch -> P.group (prettyProjectBranchName branch <> ",") + Just aliceOrBob -> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") <> "the type" <> prettyName longerName <> "is an alias of" <> P.group (prettyName shorterName <> ".") <> "Type aliases cannot be nested. Please make them disjoint before merging." - MergeStrayConstructor maybeBranch name -> + MergeStrayConstructor maybeAliceOrBob name -> pure . P.wrap $ "On" - <> case maybeBranch of + <> case maybeAliceOrBob of Nothing -> "the LCA," - Just branch -> P.group (prettyProjectBranchName branch <> ",") + Just aliceOrBob -> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") <> "the constructor" <> prettyName name <> "is not in a subnamespace of a name of its type." @@ -2278,26 +2285,26 @@ notifyUser dir = \case "", "Your non-project code is still available to pull from Share, and you can pull it into a local namespace using `pull myhandle.public`" ] - MergeFailure path base target -> + MergeFailure path aliceAndBob -> pure . P.wrap $ "I couldn't automatically merge" - <> prettyProjectBranchName (view #branch target) + <> prettyMergeSource aliceAndBob.bob <> "into" - <> P.group (prettyProjectBranchName (view #branch base) <> ".") + <> P.group (prettyProjectAndBranchName aliceAndBob.alice <> ".") <> "However, I've added the definitions that need attention to the top of" <> P.group (prettyFilePath path <> ".") - MergeSuccess base target -> + MergeSuccess aliceAndBob -> pure . P.wrap $ "I merged" - <> prettyProjectBranchName (view #branch target) + <> prettyMergeSource aliceAndBob.bob <> "into" - <> P.group (prettyProjectBranchName (view #branch base) <> ".") - MergeSuccessFastForward base target -> + <> P.group (prettyProjectAndBranchName aliceAndBob.alice <> ".") + MergeSuccessFastForward aliceAndBob -> pure . P.wrap $ "I fast-forward merged" - <> prettyProjectBranchName (view #branch target) + <> prettyMergeSource aliceAndBob.bob <> "into" - <> P.group (prettyProjectBranchName (view #branch base) <> ".") + <> P.group (prettyProjectAndBranchName aliceAndBob.alice <> ".") InstalledLibdep libdep segment -> pure . P.wrap $ "I installed" diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 6923ab417..b70ec4680 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -35,6 +35,7 @@ library Unison.Auth.Types Unison.Auth.UserInfo Unison.Cli.DownloadUtils + Unison.Cli.MergeTypes Unison.Cli.Monad Unison.Cli.MonadUtils Unison.Cli.NamesUtils diff --git a/unison-src/transcripts/merge.output.md b/unison-src/transcripts/merge.output.md index 3aa43eee1..6b50339ee 100644 --- a/unison-src/transcripts/merge.output.md +++ b/unison-src/transcripts/merge.output.md @@ -24,7 +24,7 @@ Merge result: ```ucm project/alice> merge /bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo bar @@ -58,7 +58,7 @@ Merge result: ```ucm project/alice> merge /bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo bar @@ -101,7 +101,7 @@ Merge result: ```ucm project/alice> merge /bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo bar @@ -164,7 +164,7 @@ Merge result: ```ucm project/alice> merge /bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo bar baz @@ -234,7 +234,7 @@ Merge result: ```ucm project/alice> merge /bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo bar baz @@ -283,7 +283,7 @@ Merge result: ```ucm project/alice> merge /bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo @@ -325,7 +325,7 @@ Merge result: ```ucm project/alice> merge bob - I merged bob into alice. + I merged project/bob into project/alice. project/alice> view foo bar baz @@ -446,7 +446,7 @@ project/bob> add project/alice> merge /bob - I fast-forward merged bob into alice. + I fast-forward merged project/bob into project/alice. ``` ## Merge failure: someone deleted something @@ -485,9 +485,9 @@ project/bob> add project/alice> merge /bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -526,9 +526,9 @@ bar = foo ++ " - " ++ foo ```ucm project/alice> merge /bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -579,9 +579,9 @@ baz = "bobs baz" ```ucm project/alice> merge /bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -636,9 +636,9 @@ unique type Foo = MkFoo Nat Text ```ucm project/alice> merge /bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -673,9 +673,9 @@ unique type Foo = Baz Nat | BobQux Text ```ucm project/alice> merge /bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -714,9 +714,9 @@ project/bob> move.term Foo.Qux Foo.Bob ```ucm project/alice> merge bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -748,9 +748,9 @@ unique ability my.cool where ```ucm project/alice> merge bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -794,9 +794,9 @@ These won't cleanly merge. ```ucm project/alice> merge bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -856,9 +856,9 @@ Notably, Alice's "unconflicted" update on the name "Foo.Bar.Baz" (because she ch ```ucm project/alice> merge bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -903,9 +903,9 @@ bob _ = 19 ```ucm project/alice> merge bob - I couldn't automatically merge bob into alice. However, I've - added the definitions that need attention to the top of - scratch.u. + I couldn't automatically merge project/bob into project/alice. + However, I've added the definitions that need attention to the + top of scratch.u. ``` ```unison:added-by-ucm scratch.u @@ -964,7 +964,8 @@ baz = "baz" ```ucm project/alice> merge /bob - On alice, bar and foo are not aliases, but they used to be. + On project/alice, bar and foo are not aliases, but they used + to be. ``` ### Conflict involving builtin @@ -1018,9 +1019,9 @@ bob = 100 ```ucm project/alice> merge /bob - On alice, Foo.Bar and Foo.some.other.Alias are aliases. Every - type declaration must have exactly one name for each - constructor. + On project/alice, Foo.Bar and Foo.some.other.Alias are + aliases. Every type declaration must have exactly one name for + each constructor. ``` ### Missing constructor name @@ -1047,8 +1048,8 @@ bob = 100 ```ucm project/alice> merge /bob - On alice, the type Foo is missing a name for one of its - constructors. Please add one before merging. + On project/alice, the type Foo is missing a name for one of + its constructors. Please add one before merging. ``` ### Nested decl alias @@ -1080,8 +1081,9 @@ bob = 100 ```ucm project/alice> merge /bob - On alice, the type A.inner.X is an alias of A. Type aliases - cannot be nested. Please make them disjoint before merging. + On project/alice, the type A.inner.X is an alias of A. Type + aliases cannot be nested. Please make them disjoint before + merging. ``` ### Stray constructor alias @@ -1113,9 +1115,9 @@ project/bob> add ```ucm project/alice> merge bob - On alice, the constructor AliasOutsideFooNamespace is not in a - subnamespace of a name of its type. Please either delete it or - rename it before merging. + On project/alice, the constructor AliasOutsideFooNamespace is + not in a subnamespace of a name of its type. Please either + delete it or rename it before merging. ``` ### Term or type in `lib` @@ -1137,7 +1139,7 @@ bob = 100 ```ucm project/alice> merge /bob - On alice, there's a type or term directly in the `lib` + On project/alice, there's a type or term directly in the `lib` namespace, but I expected only library dependencies to be in there. Please remove it before merging. From 3b8bdf58a3c2c7cd01a57e72eb50921e0c682fe3 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 17 May 2024 17:52:07 -0400 Subject: [PATCH 31/82] fix warning error and remove unused PinBoard code --- .../src/Unison/Util/PinBoard.hs | 143 ------------------ parser-typechecker/tests/Suite.hs | 2 - parser-typechecker/tests/Unison/Test/MCode.hs | 2 +- .../tests/Unison/Test/Util/PinBoard.hs | 52 ------- .../unison-parser-typechecker.cabal | 2 - 5 files changed, 1 insertion(+), 200 deletions(-) delete mode 100644 parser-typechecker/src/Unison/Util/PinBoard.hs delete mode 100644 parser-typechecker/tests/Unison/Test/Util/PinBoard.hs diff --git a/parser-typechecker/src/Unison/Util/PinBoard.hs b/parser-typechecker/src/Unison/Util/PinBoard.hs deleted file mode 100644 index 79c10589b..000000000 --- a/parser-typechecker/src/Unison/Util/PinBoard.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | A utility type for saving memory in the presence of many duplicate ByteStrings, etc. If you have data that may be --- a redundant duplicate, try pinning it to a pin board, and use the result of that operation instead. --- --- Without a pin board: --- --- x ───── "38dce848c8c829c62" --- y ───── "38dce848c8c829c62" --- z ───── "d2518f260535b927b" --- --- With a pin board: --- --- x ───── "38dce848c8c829c62" ┄┄┄┄┄┐ --- y ────────┘ board --- z ───── "d2518f260535b927b" ┄┄┄┄┄┘ --- --- ... and after x is garbage collected: --- --- "38dce848c8c829c62" ┄┄┄┄┄┐ --- y ────────┘ board --- z ───── "d2518f260535b927b" ┄┄┄┄┄┘ --- --- ... and after y is garbage collected: --- --- board --- z ───── "d2518f260535b927b" ┄┄┄┄┄┘ -module Unison.Util.PinBoard - ( PinBoard, - new, - pin, - - -- * For debugging - debugDump, - debugSize, - ) -where - -import Control.Concurrent.MVar -import Data.Foldable (find, foldlM) -import Data.Functor.Compose -import Data.Hashable (Hashable, hash) -import Data.IntMap qualified as IntMap -import Data.IntMap.Strict (IntMap) -import Data.Text qualified as Text -import Data.Text.IO qualified as Text -import Data.Tuple (swap) -import System.Mem.Weak (Weak, deRefWeak, mkWeakPtr) -import Unison.Prelude - --- | A "pin board" is a place to pin values; semantically, it's a set, but differs in a few ways: --- --- * Pinned values aren't kept alive by the pin board, they might be garbage collected at any time. --- * If you try to pin a value that's already pinned (per its Eq instance), the pinned one will be returned --- instead. --- * It has a small API: just 'new' and 'pin'. -newtype PinBoard a - = PinBoard (MVar (IntMap (Bucket a))) - -new :: (MonadIO m) => m (PinBoard a) -new = - liftIO (PinBoard <$> newMVar IntMap.empty) - -pin :: forall a m. (Eq a, Hashable a, MonadIO m) => PinBoard a -> a -> m a -pin (PinBoard boardVar) x = liftIO do - modifyMVar boardVar \board -> - swap <$> getCompose (IntMap.alterF alter n board) - where - -- Pin to pin board at a hash key: either there's nothing there (ifMiss), or there's a nonempty bucket (ifHit). - alter :: Maybe (Bucket a) -> Compose IO ((,) a) (Maybe (Bucket a)) - alter = - Compose . maybe ifMiss ifHit - -- Pin a new value: create a new singleton bucket. - ifMiss :: IO (a, Maybe (Bucket a)) - ifMiss = - (x,) . Just <$> newBucket x finalizer - -- Possibly pin a new value: if it already exists in the bucket, return that one instead. Otherwise, insert it. - ifHit :: Bucket a -> IO (a, Maybe (Bucket a)) - ifHit bucket = - bucketFind bucket x >>= \case - -- Hash collision: the bucket has things in it, but none are the given value. Insert. - Nothing -> (x,) . Just <$> bucketAdd bucket x finalizer - -- The thing being inserted already exists; return it. - Just y -> pure (y, Just bucket) - -- When each thing pinned here is garbage collected, compact its bucket. - finalizer :: IO () - finalizer = - modifyMVar_ boardVar (IntMap.alterF (maybe (pure Nothing) bucketCompact) n) - n :: Int - n = - hash x - -debugDump :: (MonadIO m) => (a -> Text) -> PinBoard a -> m () -debugDump f (PinBoard boardVar) = liftIO do - board <- readMVar boardVar - contents <- (traverse . traverse) bucketToList (IntMap.toList board) - Text.putStrLn (Text.unlines ("PinBoard" : map row contents)) - where - row (n, xs) = - Text.pack (show n) <> " => " <> Text.pack (show (map f xs)) - -debugSize :: PinBoard a -> IO Int -debugSize (PinBoard boardVar) = do - board <- readMVar boardVar - foldlM step 0 board - where - step :: Int -> Bucket a -> IO Int - step acc = - bucketToList >=> \xs -> pure (acc + length xs) - --- | A bucket of weak pointers to different values that all share a hash. -newtype Bucket a - = Bucket [Weak a] -- Invariant: non-empty list - --- | A singleton bucket. -newBucket :: a -> IO () -> IO (Bucket a) -newBucket = - bucketAdd (Bucket []) - --- | Add a value to a bucket. -bucketAdd :: Bucket a -> a -> IO () -> IO (Bucket a) -bucketAdd (Bucket weaks) x finalizer = do - weak <- mkWeakPtr x (Just finalizer) - pure (Bucket (weak : weaks)) - --- | Drop all garbage-collected values from a bucket. If none remain, returns Nothing. -bucketCompact :: Bucket a -> IO (Maybe (Bucket a)) -bucketCompact (Bucket weaks) = - bucketFromList <$> mapMaybeM (\w -> (w <$) <$> deRefWeak w) weaks - --- | Look up a value in a bucket per its Eq instance. -bucketFind :: (Eq a) => Bucket a -> a -> IO (Maybe a) -bucketFind bucket x = - find (== x) <$> bucketToList bucket - -bucketFromList :: [Weak a] -> Maybe (Bucket a) -bucketFromList = \case - [] -> Nothing - weaks -> Just (Bucket weaks) - -bucketToList :: Bucket a -> IO [a] -bucketToList (Bucket weaks) = - mapMaybeM deRefWeak weaks diff --git a/parser-typechecker/tests/Suite.hs b/parser-typechecker/tests/Suite.hs index be845c166..a3f0d89d6 100644 --- a/parser-typechecker/tests/Suite.hs +++ b/parser-typechecker/tests/Suite.hs @@ -26,7 +26,6 @@ import Unison.Test.Typechecker qualified as Typechecker import Unison.Test.Typechecker.Context qualified as Context import Unison.Test.Typechecker.TypeError qualified as TypeError import Unison.Test.UnisonSources qualified as UnisonSources -import Unison.Test.Util.PinBoard qualified as PinBoard import Unison.Test.Util.Relation qualified as Relation import Unison.Test.Util.Text qualified as Text import Unison.Test.Var qualified as Var @@ -54,7 +53,6 @@ test = Typechecker.test, Context.test, Name.test, - PinBoard.test, CodebaseInit.test, Branch.test ] diff --git a/parser-typechecker/tests/Unison/Test/MCode.hs b/parser-typechecker/tests/Unison/Test/MCode.hs index 8d28b0765..8224914d6 100644 --- a/parser-typechecker/tests/Unison/Test/MCode.hs +++ b/parser-typechecker/tests/Unison/Test/MCode.hs @@ -44,7 +44,7 @@ testEval0 :: [(Reference, SuperGroup Symbol)] -> SuperGroup Symbol -> Test () testEval0 env main = ok << io do cc <- baseCCache False - cacheAdd ((mainRef, main) : env) cc + _ <- cacheAdd ((mainRef, main) : env) cc rtm <- readTVarIO (refTm cc) apply0 Nothing cc Nothing (rtm Map.! mainRef) where diff --git a/parser-typechecker/tests/Unison/Test/Util/PinBoard.hs b/parser-typechecker/tests/Unison/Test/Util/PinBoard.hs deleted file mode 100644 index fe114c039..000000000 --- a/parser-typechecker/tests/Unison/Test/Util/PinBoard.hs +++ /dev/null @@ -1,52 +0,0 @@ -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE UnboxedTuples #-} - -module Unison.Test.Util.PinBoard - ( test, - ) -where - -import Data.ByteString qualified as ByteString -import EasyTest -import GHC.Exts (isTrue#, reallyUnsafePtrEquality#, touch#) -import GHC.IO (IO (IO)) -import System.Mem (performGC) -import Unison.Util.PinBoard qualified as PinBoard - -test :: Test () -test = - scope "util.pinboard" . tests $ - [ scope "pinning equal values stores only one" $ do - let b0 = ByteString.singleton 0 - let b1 = ByteString.copy b0 - - board <- PinBoard.new - - -- pinning a thing for the first time returns it - b0' <- PinBoard.pin board b0 - expectSamePointer b0 b0' - - -- pinning an equal thing returns the first - b1' <- PinBoard.pin board b1 - expectSamePointer b0 b1' - - -- the board should only have one value in it - expect' . (== 1) <$> io (PinBoard.debugSize board) - - -- keep b0 alive until here - touch b0 - - -- observe that the board doesn't keep its value alive - io performGC - expect' . (== 0) <$> io (PinBoard.debugSize board) - - ok - ] - -expectSamePointer :: a -> a -> Test () -expectSamePointer x y = - expect' (isTrue# (reallyUnsafePtrEquality# x y)) - -touch :: a -> Test () -touch x = - io (IO \s -> (# touch# x s, () #)) diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index b237cee44..53cdf698b 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -185,7 +185,6 @@ library Unison.Util.EnumContainers Unison.Util.Exception Unison.Util.Logger - Unison.Util.PinBoard Unison.Util.Pretty.MegaParsec Unison.Util.RefPromise Unison.Util.Star2 @@ -384,7 +383,6 @@ test-suite parser-typechecker-tests Unison.Test.Typechecker.Context Unison.Test.Typechecker.TypeError Unison.Test.UnisonSources - Unison.Test.Util.PinBoard Unison.Test.Util.Pretty Unison.Test.Util.Relation Unison.Test.Util.Text From 9d7fe1fbeff38f8cb10eea882838258d51a70166 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 17 May 2024 18:35:16 -0400 Subject: [PATCH 32/82] revert removing ApplicativeDo from default extensions because apparently we spookily rely on it! fragile! wow! --- parser-typechecker/package.yaml | 1 + parser-typechecker/unison-parser-typechecker.cabal | 2 ++ 2 files changed, 3 insertions(+) diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index d77457862..8bb50c518 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -169,6 +169,7 @@ tests: other-modules: Paths_unison_parser_typechecker default-extensions: + - ApplicativeDo - BangPatterns - BlockArguments - DeriveAnyClass diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 53cdf698b..512a0093a 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -195,6 +195,7 @@ library hs-source-dirs: src default-extensions: + ApplicativeDo BangPatterns BlockArguments DeriveAnyClass @@ -390,6 +391,7 @@ test-suite parser-typechecker-tests hs-source-dirs: tests default-extensions: + ApplicativeDo BangPatterns BlockArguments DeriveAnyClass From 4000a892e24c10ba218ae156d1e8254b63455e59 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Fri, 17 May 2024 19:08:11 -0700 Subject: [PATCH 33/82] Transcripts --- unison-src/transcripts/definition-diff-api.output.md | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/unison-src/transcripts/definition-diff-api.output.md b/unison-src/transcripts/definition-diff-api.output.md index 3fbf1c748..3712dd827 100644 --- a/unison-src/transcripts/definition-diff-api.output.md +++ b/unison-src/transcripts/definition-diff-api.output.md @@ -90,6 +90,8 @@ diffs/new> update Done. ``` +Diff terms + ```api GET /api/projects/diffs/diff/terms?oldBranchRef=main&newBranchRef=new&oldTerm=term&newTerm=term { @@ -572,7 +574,9 @@ GET /api/projects/diffs/diff/terms?oldBranchRef=main&newBranchRef=new&oldTerm=te }, "project": "diffs" } -``````api +```Diff types + +```api GET /api/projects/diffs/diff/types?oldBranchRef=main&newBranchRef=new&oldType=Type&newType=Type { "diff": { From 1be90b1414f53bf729331c286c428924d410db73 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sat, 18 May 2024 23:42:51 -0400 Subject: [PATCH 34/82] transcript output merge conflict --- unison-src/transcripts/definition-diff-api.output.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/unison-src/transcripts/definition-diff-api.output.md b/unison-src/transcripts/definition-diff-api.output.md index 3712dd827..d0c73dc48 100644 --- a/unison-src/transcripts/definition-diff-api.output.md +++ b/unison-src/transcripts/definition-diff-api.output.md @@ -54,8 +54,8 @@ diffs/main> branch.create new Done. I've created the new branch based off of main. - Tip: Use `merge /new /main` to merge your work back into the - main branch. + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /new`. ``` ```unison From 0c622f8a94e3a9127d840218e09d4bffd2aebf60 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sun, 19 May 2024 10:32:08 -0400 Subject: [PATCH 35/82] improve `pull` error messages --- .../src/Unison/Codebase/Editor/HandleInput.hs | 2 - .../src/Unison/Codebase/Editor/Input.hs | 1 - .../src/Unison/Codebase/Editor/UriParser.hs | 7 +- .../src/Unison/CommandLine/InputPatterns.hs | 306 ++++++++++++------ unison-core/src/Unison/Project.hs | 2 + 5 files changed, 212 insertions(+), 106 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index e784f8024..923439cf2 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1171,7 +1171,6 @@ loop e = do DeprecateTypeI {} -> Cli.respond NotImplemented RemoveTermReplacementI from patchPath -> doRemoveReplacement from patchPath True RemoveTypeReplacementI from patchPath -> doRemoveReplacement from patchPath False - ShowDefinitionByPrefixI {} -> Cli.respond NotImplemented UpdateBuiltinsI -> Cli.respond NotImplemented QuitI -> Cli.haltRepl GistI input -> handleGist input @@ -1397,7 +1396,6 @@ inputDescription input = PushRemoteBranchI {} -> wat QuitI {} -> wat ReleaseDraftI {} -> wat - ShowDefinitionByPrefixI {} -> wat ShowDefinitionI {} -> wat EditNamespaceI paths -> pure $ Text.unwords ("edit.namespace" : (Path.toText <$> paths)) diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 17008b8e0..47d1c75cd 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -197,7 +197,6 @@ data Input | StructuredFindReplaceI (HQ.HashQualified Name) -- sfind.replace rewriteQuery | -- Show provided definitions. ShowDefinitionI OutputLocation ShowDefinitionScope (NonEmpty (HQ.HashQualified Name)) - | ShowDefinitionByPrefixI OutputLocation [HQ.HashQualified Name] | ShowReflogI | UpdateBuiltinsI | MergeBuiltinsI (Maybe Path) diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index d062952c2..5ae4bf1ca 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -61,10 +61,9 @@ type P = P.Parsec Void Text.Text readRemoteNamespaceParser :: ProjectBranchSpecifier branch -> P (ReadRemoteNamespace (These ProjectName branch)) readRemoteNamespaceParser specifier = - P.label "generic repo" $ - ReadRemoteNamespaceGit <$> readGitRemoteNamespace - <|> ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier - <|> ReadShare'LooseCode <$> readShareLooseCode + ReadRemoteNamespaceGit <$> readGitRemoteNamespace + <|> ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier + <|> ReadShare'LooseCode <$> readShareLooseCode projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths :: ProjectBranchSpecifier branch -> diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index d6bbac933..b5b69727c 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -2,7 +2,150 @@ This module defines 'InputPattern' values for every supported input command. -} -module Unison.CommandLine.InputPatterns where +module Unison.CommandLine.InputPatterns + ( -- * Input commands + add, + aliasMany, + aliasTerm, + aliasType, + api, + authLogin, + back, + branchEmptyInputPattern, + branchInputPattern, + branchRenameInputPattern, + branchesInputPattern, + cd, + clear, + clone, + compileScheme, + copyPatch, + createAuthor, + debugClearWatchCache, + debugDoctor, + debugDumpNamespace, + debugDumpNamespaceSimple, + debugFileHashes, + debugFormat, + debugFuzzyOptions, + debugLSPFoldRanges, + debugNameDiff, + debugNumberedArgs, + debugTabCompletion, + debugTerm, + debugTermVerbose, + debugType, + delete, + deleteBranch, + deleteNamespace, + deleteNamespaceForce, + deletePatch, + deleteProject, + deleteTerm, + deleteTermReplacement, + deleteTermVerbose, + deleteType, + deleteTypeReplacement, + deleteTypeVerbose, + deleteVerbose, + dependencies, + dependents, + diffNamespace, + diffNamespaceToPatch, + display, + displayTo, + docToMarkdown, + docs, + docsToHtml, + edit, + editNamespace, + execute, + find, + findAll, + findGlobal, + findIn, + findInAll, + findPatch, + findShallow, + findVerbose, + findVerboseAll, + forkLocal, + gist, + help, + helpTopics, + history, + ioTest, + ioTestAll, + libInstallInputPattern, + load, + makeStandalone, + mergeBuiltins, + mergeIOBuiltins, + mergeInputPattern, + mergeOldInputPattern, + mergeOldPreviewInputPattern, + mergeOldSquashInputPattern, + moveAll, + names, + namespaceDependencies, + patch, + previewAdd, + previewUpdate, + printVersion, + projectCreate, + projectCreateEmptyInputPattern, + projectRenameInputPattern, + projectSwitch, + projectsInputPattern, + pull, + pullWithoutHistory, + push, + pushCreate, + pushExhaustive, + pushForce, + quit, + releaseDraft, + renameBranch, + renamePatch, + renameTerm, + renameType, + replace, + reset, + resetRoot, + runScheme, + saveExecuteResult, + sfind, + sfindReplace, + test, + testAll, + todo, + ui, + undo, + up, + update, + updateBuiltins, + updateOld, + updateOldNoPatch, + upgrade, + view, + viewGlobal, + viewPatch, + viewReflog, + + -- * Misc + deleteTermReplacementCommand, + deleteTypeReplacementCommand, + helpFor, + makeExample', + makeExample, + makeExampleEOS, + makeExampleNoBackticks, + patternMap, + patternName, + showPatternHelp, + validInputs, + ) +where import Control.Lens (preview, review, (^.)) import Control.Lens.Cons qualified as Cons @@ -11,7 +154,6 @@ import Data.List.Extra qualified as List import Data.List.NonEmpty qualified as NE import Data.Map qualified as Map import Data.Maybe (fromJust) -import Data.Proxy (Proxy (..)) import Data.Set qualified as Set import Data.Text qualified as Text import Data.These (These (..)) @@ -21,7 +163,7 @@ import System.Console.Haskeline.Completion qualified as Haskeline import System.Console.Haskeline.Completion qualified as Line import Text.Megaparsec qualified as Megaparsec import Text.Megaparsec.Internal qualified as Megaparsec (withParsecT) -import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) +import U.Codebase.Sqlite.DbId (ProjectBranchId) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Auth.HTTPClient (AuthenticatedHttpClient) @@ -34,7 +176,7 @@ import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push)) import Unison.Codebase.Editor.Output.PushPull qualified as PushPull -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (WriteGitRepo, WriteRemoteNamespace) import Unison.Codebase.Editor.SlurpResult qualified as SR import Unison.Codebase.Editor.UriParser (readRemoteNamespaceParser) import Unison.Codebase.Editor.UriParser qualified as UriParser @@ -62,6 +204,7 @@ import Unison.Project ProjectBranchSpecifier (..), ProjectName, Semver, + branchWithOptionalProjectParser, ) import Unison.Project.Util (ProjectContext (..), projectContextFromPath) import Unison.Syntax.HashQualified qualified as HQ (parseText) @@ -70,6 +213,7 @@ import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr, segme import Unison.Util.ColorText qualified as CT import Unison.Util.Monoid (intercalateMap) import Unison.Util.Pretty qualified as P +import Unison.Util.Pretty.MegaParsec (prettyPrintParseError) showPatternHelp :: InputPattern -> P.Pretty CT.ColorText showPatternHelp i = @@ -95,8 +239,7 @@ makeExampleNoBackticks p args = makeExample' :: InputPattern -> P.Pretty CT.ColorText makeExample' p = makeExample p [] -makeExampleEOS :: - InputPattern -> [P.Pretty CT.ColorText] -> P.Pretty CT.ColorText +makeExampleEOS :: InputPattern -> [P.Pretty CT.ColorText] -> P.Pretty CT.ColorText makeExampleEOS p args = P.group $ backtick (intercalateMap " " id (P.nonEmpty $ fromString (I.patternName p) : args)) <> "." @@ -530,18 +673,6 @@ undo = "`undo` reverts the most recent change to the codebase." (const $ pure Input.UndoI) -viewByPrefix :: InputPattern -viewByPrefix = - InputPattern - "view.recursive" - [] - I.Visible - [("definition to view", OnePlus, definitionQueryArg)] - "`view.recursive Foo` prints the definitions of `Foo` and `Foo.blah`." - ( fmap (Input.ShowDefinitionByPrefixI Input.ConsoleLocation) - . traverse parseHashQualifiedName - ) - sfind :: InputPattern sfind = InputPattern "rewrite.find" ["sfind"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse @@ -1353,9 +1484,9 @@ pullImpl name aliases pullMode addendum = do Optional, projectBranchNameArg ProjectBranchSuggestionsConfig - { showProjectCompletions = True, + { showProjectCompletions = False, projectInclusion = AllProjects, - branchInclusion = ExcludeCurrentBranch + branchInclusion = AllBranches } ) ], @@ -1382,21 +1513,57 @@ pullImpl name aliases pullMode addendum = do "", explainRemote Pull ], - parse = - maybeToEither (I.help self) . \case - [] -> Just $ Input.PullI Input.PullSourceTarget0 pullMode - [sourceString] -> do - source <- parsePullSource (Text.pack sourceString) - Just $ Input.PullI (Input.PullSourceTarget1 source) pullMode - [sourceString, targetString] -> do - source <- parsePullSource (Text.pack sourceString) - target <- - eitherToMaybe $ - tryInto - @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - (Text.pack targetString) - Just $ Input.PullI (Input.PullSourceTarget2 source target) pullMode - _ -> Nothing + parse = \case + -- maybeToEither (I.help self) . \case + [] -> Right $ Input.PullI Input.PullSourceTarget0 pullMode + [sourceString] -> do + source <- + sourceString + & Text.pack + & megaparse (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease) + & mapLeft (\err -> I.help self <> P.newline <> err) + Right $ Input.PullI (Input.PullSourceTarget1 source) pullMode + [sourceString, targetString] -> do + source <- + sourceString + & Text.pack + & megaparse (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease) + & mapLeft (\err -> I.help self <> P.newline <> err) + target <- + targetString + & Text.pack + & megaparse branchWithOptionalProjectParser + & mapLeft + ( \err -> + -- You used to be able to pull into a path. So if target parsing fails, but path parsing succeeds, + -- explain that the command has changed. Furthermore, in the special case that the user is trying to + -- pull into the `lib` namespace, suggest using `lib.install`. + case Path.parsePath' targetString of + Left _ -> I.help self <> P.newline <> err + Right path -> + I.help self + <> P.newline + <> P.newline + <> P.newline + <> let pullingIntoLib = + case path of + Path.RelativePath' + ( Path.Relative + (Path.toList -> lib : _) + ) -> lib == NameSegment.libSegment + _ -> False + in P.wrap $ + "You may only" + <> makeExample' pull + <> "into a branch." + <> if pullingIntoLib + then + "Did you mean to run" + <> P.group (makeExample libInstallInputPattern [P.string sourceString] <> "?") + else mempty + ) + Right $ Input.PullI (Input.PullSourceTarget2 source target) pullMode + _ -> Left (I.help self) } debugTabCompletion :: InputPattern @@ -1932,14 +2099,6 @@ topicNameArg = fzfResolver = Just $ Resolvers.fuzzySelectFromList (Text.pack <$> topics) } -codebaseServerNameArg :: ArgumentType -codebaseServerNameArg = - ArgumentType - { typeName = "codebase-server", - suggestions = \_ _ _ _ -> pure [], - fzfResolver = Nothing - } - helpTopics :: InputPattern helpTopics = InputPattern @@ -3147,14 +3306,6 @@ exactDefinitionArg = fzfResolver = Just Resolvers.definitionResolver } -fuzzyDefinitionQueryArg :: ArgumentType -fuzzyDefinitionQueryArg = - ArgumentType - { typeName = "fuzzy definition query", - suggestions = \q cb _http p -> Codebase.runTransaction cb (prefixCompleteTermOrType q p), - fzfResolver = Just Resolvers.definitionResolver - } - definitionQueryArg :: ArgumentType definitionQueryArg = exactDefinitionArg {typeName = "definition query"} @@ -3301,18 +3452,6 @@ data ProjectInclusion = OnlyWithinCurrentProject | OnlyOutsideCurrentProject | A data BranchInclusion = ExcludeCurrentBranch | AllBranches deriving stock (Eq, Ord, Show) -projectsByPrefix :: MonadIO m => ProjectInclusion -> Codebase m v a -> Path.Absolute -> Text -> m [(ProjectId, ProjectName)] -projectsByPrefix projectInclusion codebase path query = do - allProjectMatches <- Codebase.runTransaction codebase do - Queries.loadAllProjectsBeginningWith (Just query) - <&> map (\(Sqlite.Project projId projName) -> (projId, projName)) - let projectCtx = projectContextFromPath path - pure $ case (projectCtx, projectInclusion) of - (_, AllProjects) -> allProjectMatches - (LooseCodePath {}, _) -> allProjectMatches - (ProjectBranchPath currentProjectId _branchId _path, OnlyWithinCurrentProject) -> allProjectMatches & filter \(projId, _) -> projId == currentProjectId - (ProjectBranchPath currentProjectId _branchId _path, OnlyOutsideCurrentProject) -> allProjectMatches & filter \(projId, _) -> projId /= currentProjectId - data ProjectBranchSuggestionsConfig = ProjectBranchSuggestionsConfig { -- Whether projects (without branches) should be considered possible completions. showProjectCompletions :: Bool, @@ -3674,15 +3813,6 @@ projectBranchNameArg config = fzfResolver = Just Resolvers.projectBranchResolver } --- [project/]branch -projectBranchNameWithOptionalProjectNameArg :: ArgumentType -projectBranchNameWithOptionalProjectNameArg = - ArgumentType - { typeName = "project-branch-name-with-optional-project-name", - suggestions = \_ _ _ _ -> pure [], - fzfResolver = Just Resolvers.projectBranchResolver - } - branchRelativePathArg :: ArgumentType branchRelativePathArg = ArgumentType @@ -3738,10 +3868,6 @@ projectNameSuggestions slash (Text.strip . Text.pack -> input) codebase = do isFinished = False } -parsePullSource :: Text -> Maybe (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) -parsePullSource = - Megaparsec.parseMaybe (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease) - -- | Parse a 'Input.PushSource'. parsePushSource :: String -> Either (P.Pretty CT.ColorText) Input.PushSource parsePushSource sourceStr = @@ -3779,9 +3905,6 @@ parseWriteGitRepo label input = do (fromString . show) -- turn any parsing errors into a Pretty. (Megaparsec.parse (UriParser.writeGitRepo <* Megaparsec.eof) label (Text.pack input)) -collectNothings :: (a -> Maybe b) -> [a] -> [a] -collectNothings f as = [a | (Nothing, a) <- map f as `zip` as] - explainRemote :: PushPull -> P.Pretty CT.ColorText explainRemote pushPull = P.group $ @@ -3798,23 +3921,8 @@ explainRemote pushPull = where gitRepo = PushPull.fold @(P.Pretty P.ColorText) "git@github.com:" "https://github.com/" pushPull -showErrorFancy :: (Megaparsec.ShowErrorComponent e) => Megaparsec.ErrorFancy e -> String -showErrorFancy (Megaparsec.ErrorFail msg) = msg -showErrorFancy (Megaparsec.ErrorIndentation ord ref actual) = - "incorrect indentation (got " - <> show (Megaparsec.unPos actual) - <> ", should be " - <> p - <> show (Megaparsec.unPos ref) - <> ")" - where - p = case ord of - LT -> "less than " - EQ -> "equal to " - GT -> "greater than " -showErrorFancy (Megaparsec.ErrorCustom a) = Megaparsec.showErrorComponent a - -showErrorItem :: Megaparsec.ErrorItem (Megaparsec.Token Text) -> String -showErrorItem (Megaparsec.Tokens ts) = Megaparsec.showTokens (Proxy @Text) ts -showErrorItem (Megaparsec.Label label) = NE.toList label -showErrorItem Megaparsec.EndOfInput = "end of input" +megaparse :: Megaparsec.Parsec Void Text a -> Text -> Either (P.Pretty P.ColorText) a +megaparse parser input = + input + & Megaparsec.parse (parser <* Megaparsec.eof) "" + & mapLeft (prettyPrintParseError (Text.unpack input)) diff --git a/unison-core/src/Unison/Project.hs b/unison-core/src/Unison/Project.hs index 56eb6c55d..77a96a448 100644 --- a/unison-core/src/Unison/Project.hs +++ b/unison-core/src/Unison/Project.hs @@ -17,6 +17,8 @@ module Unison.Project ProjectBranchSpecifier (..), ProjectAndBranch (..), projectAndBranchNamesParser, + projectAndOptionalBranchParser, + branchWithOptionalProjectParser, ProjectAndBranchNames (..), projectAndBranchNamesParser2, projectNameParser, From cbed387dabf9498f83e10b067137e9415e4befc9 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 20 May 2024 08:51:55 -0400 Subject: [PATCH 36/82] slightly improve `help lib.install` --- .../src/Unison/CommandLine/InputPatterns.hs | 21 +++++++++++++++---- 1 file changed, 17 insertions(+), 4 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 05eb24753..ab97d5c3e 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1238,10 +1238,23 @@ libInstallInputPattern = visibility = I.Visible, args = [], help = - P.wrapColumn2 - [ ( makeExample libInstallInputPattern ["@unison/base/releases/latest"], - "installs `@unison/base/releases/latest` as a dependency of the current project" - ) + P.lines + [ P.wrap $ + "The" + <> makeExample' libInstallInputPattern + <> "command installs a dependency into the `lib` namespace.", + "", + P.wrapColumn2 + [ ( makeExample libInstallInputPattern ["@unison/base/releases/latest"], + "installs the latest release of `@unison/base`" + ), + ( makeExample libInstallInputPattern ["@unison/base/releases/3.0.0"], + "installs version 3.0.0 `@unison/base`" + ), + ( makeExample libInstallInputPattern ["@unison/base/topic"], + "installs the `topic` branch of `@unison/base`" + ) + ] ], parse = \args -> maybe (Left (I.help libInstallInputPattern)) Right do From b15e041e46f44b42d3510617544298d69560e17f Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 20 May 2024 09:31:35 -0400 Subject: [PATCH 37/82] make `prependUtf8` create file if it doesn't exist --- lib/unison-prelude/package.yaml | 1 + lib/unison-prelude/src/Unison/Prelude.hs | 36 ++++++++++++++---------- lib/unison-prelude/unison-prelude.cabal | 1 + 3 files changed, 23 insertions(+), 15 deletions(-) diff --git a/lib/unison-prelude/package.yaml b/lib/unison-prelude/package.yaml index c8d002857..2f2ee7d2e 100644 --- a/lib/unison-prelude/package.yaml +++ b/lib/unison-prelude/package.yaml @@ -12,6 +12,7 @@ dependencies: - base - bytestring - containers + - directory - generic-lens - either - extra diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index dfc75d7cd..998df0dd4 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -82,6 +82,7 @@ import GHC.Generics as X (Generic, Generic1) import GHC.IO.Handle qualified as Handle import GHC.Stack as X (HasCallStack) import Safe as X (atMay, headMay, lastMay, readMay) +import System.Directory qualified as Directory import System.FilePath qualified as FilePath import System.IO qualified as IO import Text.Read as X (readMaybe) @@ -236,23 +237,28 @@ writeUtf8 fileName txt = do Handle.hSetEncoding handle IO.utf8 Text.hPutStr handle txt --- | Atomically prepend some text to a file +-- | Atomically prepend some text to a file, creating the file if it doesn't already exist prependUtf8 :: FilePath -> Text -> IO () prependUtf8 path txt = do - let withTempFile tmpFilePath tmpHandle = do - Text.hPutStrLn tmpHandle txt - IO.withFile path IO.ReadMode \currentScratchFile -> do - let copyLoop = do - chunk <- Text.hGetChunk currentScratchFile - case Text.length chunk == 0 of - True -> pure () - False -> do - Text.hPutStr tmpHandle chunk - copyLoop - copyLoop - IO.hClose tmpHandle - UnliftIO.renameFile tmpFilePath path - UnliftIO.withTempFile (FilePath.takeDirectory path) ".unison-scratch" withTempFile + Directory.doesFileExist path >>= \case + False -> writeUtf8 path txt + True -> do + let withTempFile tmpFilePath tmpHandle = do + Handle.hSetEncoding tmpHandle IO.utf8 + Text.hPutStrLn tmpHandle txt + IO.withFile path IO.ReadMode \currentScratchFile -> do + Handle.hSetEncoding currentScratchFile IO.utf8 + let copyLoop = do + chunk <- Text.hGetChunk currentScratchFile + case Text.length chunk == 0 of + True -> pure () + False -> do + Text.hPutStr tmpHandle chunk + copyLoop + copyLoop + IO.hClose tmpHandle + UnliftIO.renameFile tmpFilePath path + UnliftIO.withTempFile (FilePath.takeDirectory path) ".unison-scratch" withTempFile reportBug :: String -> String -> String reportBug bugId msg = diff --git a/lib/unison-prelude/unison-prelude.cabal b/lib/unison-prelude/unison-prelude.cabal index 80768fa63..3fdff06ae 100644 --- a/lib/unison-prelude/unison-prelude.cabal +++ b/lib/unison-prelude/unison-prelude.cabal @@ -65,6 +65,7 @@ library base , bytestring , containers + , directory , either , extra , filepath From 0f2c64bb404ddd8f2aefbc9a1a76a8c9f7f3a075 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 20 May 2024 09:36:51 -0400 Subject: [PATCH 38/82] make upgrade-failed branch name more informative --- .../Codebase/Editor/HandleInput/Upgrade.hs | 33 +++++++++++++------ 1 file changed, 23 insertions(+), 10 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs index 4ea023456..aab5144e1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Upgrade.hs @@ -10,6 +10,7 @@ import Data.List.NonEmpty (pattern (:|)) import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text qualified as Text +import Text.Builder qualified import U.Codebase.Sqlite.DbId (ProjectId) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -169,8 +170,7 @@ handleUpgrade oldName newName = do Nothing -> "scratch.u" Just (file, _) -> file liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) - Cli.respond (Output.UpgradeFailure scratchFilePath oldName newName) - Cli.returnEarlyWithoutOutput + Cli.returnEarly (Output.UpgradeFailure scratchFilePath oldName newName) branchUpdates <- Cli.runTransactionWithRollback \abort -> do @@ -267,12 +267,25 @@ makeOldDepPPE oldName newName currentDeepNamesSansOld oldDeepNames oldLocalNames -- like "upgrade--to-". findTemporaryBranchName :: ProjectId -> NameSegment -> NameSegment -> Transaction ProjectBranchName findTemporaryBranchName projectId oldDepName newDepName = do - Cli.findTemporaryBranchName projectId preferred + Cli.findTemporaryBranchName projectId $ + -- First try something like + -- + -- upgrade-unison_base_3_0_0-to-unison_base_4_0_0 + -- + -- and if that fails (which it shouldn't, but may because of symbols or something), back off to some + -- more-guaranteed-to-work mangled name like + -- + -- upgrade-unisonbase300-to-unisonbase400 + tryFrom @Text (mk oldDepText newDepText) + & fromRight (unsafeFrom @Text (mk (scrub oldDepText) (scrub newDepText))) where - preferred :: ProjectBranchName - preferred = - unsafeFrom @Text $ - "upgrade-" - <> Text.filter Char.isAlpha (NameSegment.toEscapedText oldDepName) - <> "-to-" - <> Text.filter Char.isAlpha (NameSegment.toEscapedText newDepName) + mk :: Text -> Text -> Text + mk old new = + Text.Builder.run ("upgrade-" <> Text.Builder.text old <> "-to-" <> Text.Builder.text new) + + scrub :: Text -> Text + scrub = + Text.filter Char.isAlphaNum + + oldDepText = NameSegment.toEscapedText oldDepName + newDepText = NameSegment.toEscapedText newDepName From d9bc18f8048e333d0040be52f88a86f54716226c Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 20 May 2024 10:12:45 -0400 Subject: [PATCH 39/82] fix typo --- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index ab97d5c3e..ee4293a8d 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1249,7 +1249,7 @@ libInstallInputPattern = "installs the latest release of `@unison/base`" ), ( makeExample libInstallInputPattern ["@unison/base/releases/3.0.0"], - "installs version 3.0.0 `@unison/base`" + "installs version 3.0.0 of `@unison/base`" ), ( makeExample libInstallInputPattern ["@unison/base/topic"], "installs the `topic` branch of `@unison/base`" From 49ee64ef37fb3846d8aee8858435dc054d9992e3 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 20 May 2024 10:45:27 -0400 Subject: [PATCH 40/82] sketch out basic `upgrade.commit` command --- unison-cli/src/Unison/Cli/ProjectUtils.hs | 15 +++++ .../Codebase/Editor/HandleInput/Branch.hs | 3 +- .../Editor/HandleInput/CommitUpgrade.hs | 28 +++++++++ .../Editor/HandleInput/ProjectSwitch.hs | 62 +++++++++---------- unison-cli/unison-cli.cabal | 1 + 5 files changed, 75 insertions(+), 34 deletions(-) create mode 100644 unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index 9010be1c7..b74c5dbd8 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -39,6 +39,9 @@ module Unison.Cli.ProjectUtils -- * Other helpers findTemporaryBranchName, expectLatestReleaseBranchName, + + -- * Upgrade branch utils + getUpgradeBranchParent, ) where @@ -70,6 +73,7 @@ import Unison.Project.Util import Unison.Sqlite (Transaction) import Unison.Sqlite qualified as Sqlite import Witch (unsafeFrom) +import qualified Data.Text as Text branchRelativePathToAbsolute :: BranchRelativePath -> Cli Path.Absolute branchRelativePathToAbsolute brp = @@ -374,3 +378,14 @@ expectLatestReleaseBranchName remoteProject = case remoteProject.latestRelease of Nothing -> Cli.returnEarly (Output.ProjectHasNoReleases remoteProject.projectName) Just semver -> pure (UnsafeProjectBranchName ("releases/" <> into @Text semver)) + +-- | @getUpgradeBranchParent branch@ returns the parent branch of an "upgrade" branch. +-- +-- When an upgrade fails, we put you on a branch called `upgrade--to-`. That's an "upgrade" branch. It's not +-- currently distinguished in the database, so we first just switch on whether its name begins with "upgrade-". If it +-- does, then we get the branch's parent, which should exist, but perhaps wouldn't if the user had manually made a +-- parentless branch called "upgrade-whatever" for whatever reason. +getUpgradeBranchParent :: Sqlite.ProjectBranch -> Maybe ProjectBranchId +getUpgradeBranchParent branch = do + guard ("upgrade-" `Text.isPrefixOf` into @Text branch.name) + branch.parentBranchId diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs index 4e740830c..3ce5d167b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Branch.hs @@ -120,11 +120,10 @@ doCreateBranch createFrom project newBranchName description = do Cli.getBranchAt (ProjectUtils.projectBranchPath (ProjectAndBranch sourceProjectId sourceBranchId)) CreateFrom'LooseCode sourcePath -> Cli.getBranchAt sourcePath CreateFrom'Nothingness -> pure Branch.empty - let projectId = project ^. #projectId let parentBranchId = case createFrom of CreateFrom'Branch (ProjectAndBranch _ sourceBranch) - | (sourceBranch ^. #projectId) == projectId -> Just (sourceBranch ^. #branchId) + | sourceBranch.projectId == project.projectId -> Just sourceBranch.branchId _ -> Nothing doCreateBranch' sourceNamespaceObject parentBranchId project (pure newBranchName) description diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs new file mode 100644 index 000000000..f00526a96 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs @@ -0,0 +1,28 @@ +-- | @upgrade.commit@ handler. +module Unison.Codebase.Editor.HandleInput.CommitUpgrade + ( handleCommitUpgrade, + ) +where + +import U.Codebase.Sqlite.Project qualified +import Unison.Cli.Monad (Cli) +import Unison.Cli.ProjectUtils qualified as ProjectUtils +import Unison.Codebase.Editor.HandleInput.ProjectSwitch qualified as ProjectSwitch +import Unison.NameSegment (NameSegment) +import Unison.Prelude +import Unison.Project (ProjectAndBranch (..)) + +handleCommitUpgrade :: Cli () +handleCommitUpgrade = do + (projectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch + + -- Assert that this is an "upgrade" branch and get its parent, which is the branch we were on when we ran `upgrade`. + parentBranchId <- + ProjectUtils.getUpgradeBranchParent projectAndBranch.branch + & onNothing wundefined + + -- Switch to the parent + ProjectSwitch.switchToProjectBranch projectAndBranch.project.projectId parentBranchId + + -- Merge in the upgrade branch + wundefined diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs index 87329e00d..676a28244 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs @@ -1,11 +1,14 @@ -- | @switch@ input handler module Unison.Codebase.Editor.HandleInput.ProjectSwitch ( projectSwitch, + switchToProjectBranch, ) where -import Control.Lens ((^.)) import Data.These (These (..)) +import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) +import U.Codebase.Sqlite.Project qualified +import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -31,52 +34,47 @@ projectSwitch projectNames = do ProjectUtils.getCurrentProjectBranch >>= \case Nothing -> switchToProjectAndBranchByTheseNames (This projectName) Just (ProjectAndBranch currentProject _currentBranch, _restPath) -> do - let currentProjectName = currentProject ^. #name (projectExists, branchExists) <- Cli.runTransaction do (,) <$> Queries.projectExistsByName projectName - <*> Queries.projectBranchExistsByName (currentProject ^. #projectId) branchName + <*> Queries.projectBranchExistsByName currentProject.projectId branchName case (projectExists, branchExists) of (False, False) -> Cli.respond (Output.LocalProjectNorProjectBranchExist projectName branchName) - (False, True) -> switchToProjectAndBranchByTheseNames (These currentProjectName branchName) + (False, True) -> switchToProjectAndBranchByTheseNames (These currentProject.name branchName) (True, False) -> switchToProjectAndBranchByTheseNames (This projectName) (True, True) -> Cli.respondNumbered $ Output.AmbiguousSwitch projectName - (ProjectAndBranch currentProjectName branchName) + (ProjectAndBranch currentProject.name branchName) ProjectAndBranchNames'Unambiguous projectAndBranchNames0 -> switchToProjectAndBranchByTheseNames projectAndBranchNames0 switchToProjectAndBranchByTheseNames :: These ProjectName ProjectBranchName -> Cli () switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do - branch <- case projectAndBranchNames0 of - This projectName -> - Cli.runTransactionWithRollback \rollback -> do - project <- - Queries.loadProjectByName projectName & onNothingM do - rollback (Output.LocalProjectDoesntExist projectName) - Queries.loadMostRecentBranch (project ^. #projectId) >>= \case - Nothing -> do - let branchName = unsafeFrom @Text "main" - branch <- - Queries.loadProjectBranchByName (project ^. #projectId) branchName & onNothingM do - rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) - setMostRecentBranch branch - Just branchId -> - Queries.loadProjectBranch (project ^. #projectId) branchId >>= \case - Nothing -> error "impossible" - Just branch -> pure branch - _ -> do - projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0 - Cli.runTransactionWithRollback \rollback -> do - branch <- + branch <- + case projectAndBranchNames0 of + This projectName -> + Cli.runTransactionWithRollback \rollback -> do + project <- + Queries.loadProjectByName projectName & onNothingM do + rollback (Output.LocalProjectDoesntExist projectName) + let branchName = unsafeFrom @Text "main" + Queries.loadProjectBranchByName project.projectId branchName & onNothingM do + rollback (Output.LocalProjectBranchDoesntExist (ProjectAndBranch projectName branchName)) + _ -> do + projectAndBranchNames@(ProjectAndBranch projectName branchName) <- ProjectUtils.hydrateNames projectAndBranchNames0 + Cli.runTransactionWithRollback \rollback -> do Queries.loadProjectBranchByNames projectName branchName & onNothingM do rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) - setMostRecentBranch branch - Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch (branch ^. #projectId) (branch ^. #branchId))) - where - setMostRecentBranch branch = do - Queries.setMostRecentBranch (branch ^. #projectId) (branch ^. #branchId) - pure branch + switchToProjectBranch branch.projectId branch.branchId + +-- | Switch to a branch: +-- +-- * Record it as the most-recent branch (so it's restored when ucm starts). +-- * Change the current path in the in-memory loop state. +switchToProjectBranch :: ProjectId -> ProjectBranchId -> Cli () +switchToProjectBranch projectId branchId = do + Cli.runTransaction (Queries.setMostRecentBranch projectId branchId) + Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch projectId branchId)) diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 6923ab417..34b0da280 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -54,6 +54,7 @@ library Unison.Codebase.Editor.HandleInput.Branch Unison.Codebase.Editor.HandleInput.Branches Unison.Codebase.Editor.HandleInput.BranchRename + Unison.Codebase.Editor.HandleInput.CommitUpgrade Unison.Codebase.Editor.HandleInput.DebugDefinition Unison.Codebase.Editor.HandleInput.DebugFoldRanges Unison.Codebase.Editor.HandleInput.DeleteBranch From 75795e61e4c0eeeba327e3ed33215ce34d252765 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 20 May 2024 12:09:00 -0400 Subject: [PATCH 41/82] implement `upgrade.commit` command --- unison-cli/src/Unison/Cli/ProjectUtils.hs | 30 +++++++++- .../src/Unison/Codebase/Editor/HandleInput.hs | 3 + .../Editor/HandleInput/CommitUpgrade.hs | 55 ++++++++++++++++--- .../Codebase/Editor/HandleInput/Merge2.hs | 54 +++++++++--------- .../Editor/HandleInput/ProjectSwitch.hs | 11 ++-- .../Codebase/Editor/HandleInput/Pull.hs | 13 ++--- .../src/Unison/Codebase/Editor/Input.hs | 1 + .../src/Unison/Codebase/Editor/Output.hs | 2 + .../src/Unison/CommandLine/InputPatterns.hs | 15 +++++ .../src/Unison/CommandLine/OutputMessages.hs | 2 + unison-src/transcripts/upgrade-happy-path.md | 1 + .../transcripts/upgrade-happy-path.output.md | 1 + unison-src/transcripts/upgrade-sad-path.md | 13 +++++ .../transcripts/upgrade-sad-path.output.md | 45 +++++++++++++++ 14 files changed, 195 insertions(+), 51 deletions(-) diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index b74c5dbd8..66eb87414 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/unison-cli/src/Unison/Cli/ProjectUtils.hs @@ -25,6 +25,7 @@ module Unison.Cli.ProjectUtils getProjectAndBranchByTheseNames, expectProjectAndBranchByTheseNames, expectLooseCodeOrProjectBranch, + getProjectBranchCausalHash, -- * Loading remote project info expectRemoteProjectById, @@ -36,6 +37,11 @@ module Unison.Cli.ProjectUtils expectRemoteProjectBranchByNames, expectRemoteProjectBranchByTheseNames, + -- * Projecting out common things + justTheIds, + justTheIds', + justTheNames, + -- * Other helpers findTemporaryBranchName, expectLatestReleaseBranchName, @@ -49,7 +55,10 @@ import Control.Lens import Data.List qualified as List import Data.Maybe (fromJust) import Data.Set qualified as Set +import Data.Text qualified as Text import Data.These (These (..)) +import U.Codebase.Causal qualified +import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.DbId import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite @@ -59,6 +68,7 @@ import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.Share.Projects (IncludeSquashedHead) import Unison.Cli.Share.Projects qualified as Share +import Unison.Codebase qualified as Codebase import Unison.Codebase.Editor.Input (LooseCodeOrProject) import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist)) import Unison.Codebase.Editor.Output qualified as Output @@ -73,7 +83,6 @@ import Unison.Project.Util import Unison.Sqlite (Transaction) import Unison.Sqlite qualified as Sqlite import Witch (unsafeFrom) -import qualified Data.Text as Text branchRelativePathToAbsolute :: BranchRelativePath -> Cli Path.Absolute branchRelativePathToAbsolute brp = @@ -108,6 +117,18 @@ resolveBranchRelativePath = \case Left branchName -> That branchName Right (projectName, branchName) -> These projectName branchName +justTheIds :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId +justTheIds x = + ProjectAndBranch x.project.projectId x.branch.branchId + +justTheIds' :: Sqlite.ProjectBranch -> ProjectAndBranch ProjectId ProjectBranchId +justTheIds' x = + ProjectAndBranch x.projectId x.branchId + +justTheNames :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> ProjectAndBranch ProjectName ProjectBranchName +justTheNames x = + ProjectAndBranch x.project.name x.branch.name + -- @findTemporaryBranchName projectId preferred@ finds some unused branch name in @projectId@ with a name -- like @preferred@. findTemporaryBranchName :: ProjectId -> ProjectBranchName -> Transaction ProjectBranchName @@ -268,6 +289,13 @@ expectLooseCodeOrProjectBranch = That (ProjectAndBranch (Just project) branch) -> Right (These project branch) These path _ -> Left path -- (3) above +-- | Get the causal hash of a project branch. +getProjectBranchCausalHash :: ProjectAndBranch ProjectId ProjectBranchId -> Transaction CausalHash +getProjectBranchCausalHash branch = do + let path = projectBranchPath branch + causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path) + pure causal.causalHash + ------------------------------------------------------------------------------------------------------------------------ -- Remote project utils diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index ece99ab85..376f521a8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -57,6 +57,7 @@ import Unison.Codebase.Editor.HandleInput.AuthLogin (authLogin) import Unison.Codebase.Editor.HandleInput.Branch (handleBranch) import Unison.Codebase.Editor.HandleInput.BranchRename (handleBranchRename) import Unison.Codebase.Editor.HandleInput.Branches (handleBranches) +import Unison.Codebase.Editor.HandleInput.CommitUpgrade (handleCommitUpgrade) import Unison.Codebase.Editor.HandleInput.DebugDefinition qualified as DebugDefinition import Unison.Codebase.Editor.HandleInput.DebugFoldRanges qualified as DebugFoldRanges import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch) @@ -1192,6 +1193,7 @@ loop e = do CloneI remoteNames localNames -> handleClone remoteNames localNames ReleaseDraftI semver -> handleReleaseDraft semver UpgradeI old new -> handleUpgrade old new + UpgradeCommitI -> handleCommitUpgrade LibInstallI libdep -> handleInstallLib libdep inputDescription :: Input -> Cli Text @@ -1407,6 +1409,7 @@ inputDescription input = UiI {} -> wat UpI {} -> wat UpgradeI {} -> wat + UpgradeCommitI {} -> wat VersionI -> wat where hp' :: Either SCH.ShortCausalHash Path' -> Cli Text diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs index f00526a96..a02acd5bc 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs @@ -4,25 +4,66 @@ module Unison.Codebase.Editor.HandleInput.CommitUpgrade ) where +import Data.Text qualified as Text +import U.Codebase.Sqlite.Operations qualified as Operations import U.Codebase.Sqlite.Project qualified +import U.Codebase.Sqlite.Queries qualified as Queries +import Unison.Cli.MergeTypes (MergeSource (..)) import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils +import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge import Unison.Codebase.Editor.HandleInput.ProjectSwitch qualified as ProjectSwitch -import Unison.NameSegment (NameSegment) +import Unison.Codebase.Editor.Output qualified as Output +import Unison.CommandLine.InputPattern qualified as InputPattern +import Unison.CommandLine.InputPatterns qualified as InputPatterns import Unison.Prelude import Unison.Project (ProjectAndBranch (..)) handleCommitUpgrade :: Cli () handleCommitUpgrade = do - (projectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch + (upgradeProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch -- Assert that this is an "upgrade" branch and get its parent, which is the branch we were on when we ran `upgrade`. + parentBranchId <- - ProjectUtils.getUpgradeBranchParent projectAndBranch.branch - & onNothing wundefined + ProjectUtils.getUpgradeBranchParent upgradeProjectAndBranch.branch + & onNothing (Cli.returnEarly Output.NoUpgradeInProgress) + parentBranch <- + Cli.runTransaction do + Queries.expectProjectBranch upgradeProjectAndBranch.project.projectId parentBranchId + + let parentProjectAndBranch = + ProjectAndBranch upgradeProjectAndBranch.project parentBranch -- Switch to the parent - ProjectSwitch.switchToProjectBranch projectAndBranch.project.projectId parentBranchId - -- Merge in the upgrade branch - wundefined + ProjectSwitch.switchToProjectBranch (ProjectUtils.justTheIds parentProjectAndBranch) + + -- Merge the upgrade branch into the parent + + (parentCausalHash, upgradeCausalHash, lcaCausalHash) <- + Cli.runTransaction do + parentCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds parentProjectAndBranch) + upgradeCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds upgradeProjectAndBranch) + lcaCausalHash <- Operations.lca parentCausalHash upgradeCausalHash + pure (parentCausalHash, upgradeCausalHash, lcaCausalHash) + + Merge.doMerge + Merge.MergeInfo + { alice = + Merge.AliceMergeInfo + { causalHash = parentCausalHash, + projectAndBranch = parentProjectAndBranch + }, + bob = + Merge.BobMergeInfo + { causalHash = upgradeCausalHash, + source = MergeSource'LocalProjectBranch (ProjectUtils.justTheNames upgradeProjectAndBranch) + }, + lca = + Merge.LcaMergeInfo + { causalHash = lcaCausalHash + }, + description = Text.pack (InputPattern.patternName InputPatterns.upgradeCommitInputPattern) + } diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index d6685f105..4c566351b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -43,11 +43,11 @@ 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 (..), MergeSourceOrTarget (..), MergeSourceAndTarget (..)) +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 Cli +import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase (Codebase) import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch (Branch0) @@ -140,24 +140,28 @@ import Prelude hiding (unzip, zip, zipWith) handleMerge :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do -- Assert that Alice (us) is on a project branch, and grab the causal hash. - (ProjectAndBranch aliceProject aliceProjectBranch, _path) <- Cli.expectCurrentProjectBranch - aliceCausalHash <- Cli.runTransaction (projectBranchToCausalHash aliceProjectBranch) + (aliceProjectAndBranch, _path) <- ProjectUtils.expectCurrentProjectBranch -- Resolve Bob's maybe-project-name + branch-name to the info the merge algorithm needs: the project name, branch -- name, and causal hash. bobProject <- case maybeBobProjectName of - Nothing -> pure aliceProject + Nothing -> pure aliceProjectAndBranch.project Just bobProjectName - | bobProjectName == aliceProject.name -> pure aliceProject + | bobProjectName == aliceProjectAndBranch.project.name -> pure aliceProjectAndBranch.project | otherwise -> do Cli.runTransaction (Queries.loadProjectByName bobProjectName) & onNothingM (Cli.returnEarly (Output.LocalProjectDoesntExist bobProjectName)) - bobProjectBranch <- Cli.expectProjectBranchByName bobProject bobBranchName - bobCausalHash <- Cli.runTransaction (projectBranchToCausalHash bobProjectBranch) + bobProjectBranch <- ProjectUtils.expectProjectBranchByName bobProject bobBranchName + let bobProjectAndBranch = ProjectAndBranch bobProject bobProjectBranch - -- Using Alice and Bob's causal hashes, find the LCA (if it exists) - lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash bobCausalHash) + (aliceCausalHash, bobCausalHash, lcaCausalHash) <- + Cli.runTransaction do + aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds aliceProjectAndBranch) + bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds bobProjectAndBranch) + -- Using Alice and Bob's causal hashes, find the LCA (if it exists) + lcaCausalHash <- Operations.lca aliceCausalHash bobCausalHash + pure (aliceCausalHash, bobCausalHash, lcaCausalHash) -- Do the merge! doMerge @@ -165,30 +169,23 @@ handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do { alice = AliceMergeInfo { causalHash = aliceCausalHash, - project = aliceProject, - projectBranch = aliceProjectBranch + projectAndBranch = aliceProjectAndBranch }, bob = BobMergeInfo { causalHash = bobCausalHash, - source = MergeSource'LocalProjectBranch (ProjectAndBranch bobProject.name bobBranchName) + source = MergeSource'LocalProjectBranch (ProjectUtils.justTheNames bobProjectAndBranch) }, lca = LcaMergeInfo { causalHash = lcaCausalHash }, - description = "merge " <> into @Text (ProjectAndBranch bobProject.name bobBranchName) + description = "merge " <> into @Text (ProjectUtils.justTheNames bobProjectAndBranch) } - where - projectBranchToCausalHash :: ProjectBranch -> Transaction CausalHash - projectBranchToCausalHash branch = do - let path = Cli.projectBranchPath (ProjectAndBranch branch.projectId branch.branchId) - causal <- Codebase.getShallowCausalFromRoot Nothing (Path.unabsolute path) - pure causal.causalHash data MergeInfo = MergeInfo { alice :: !AliceMergeInfo, - bob :: BobMergeInfo, + bob :: !BobMergeInfo, lca :: !LcaMergeInfo, -- | How should we describe this merge in the reflog? description :: !Text @@ -196,8 +193,7 @@ data MergeInfo = MergeInfo data AliceMergeInfo = AliceMergeInfo { causalHash :: !CausalHash, - project :: !Project, - projectBranch :: !ProjectBranch + projectAndBranch :: !(ProjectAndBranch Project ProjectBranch) } data BobMergeInfo = BobMergeInfo @@ -216,11 +212,11 @@ doMerge info = do then realDebugFunctions else fakeDebugFunctions - let alicePath = Cli.projectBranchPath (ProjectAndBranch info.alice.project.projectId info.alice.projectBranch.branchId) - let aliceBranchNames = ProjectAndBranch info.alice.project.name info.alice.projectBranch.name + let alicePath = ProjectUtils.projectBranchPath (ProjectUtils.justTheIds info.alice.projectAndBranch) + let aliceBranchNames = ProjectUtils.justTheNames info.alice.projectAndBranch let mergeSource = MergeSourceOrTarget'Source info.bob.source let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames - let mergeSourceAndTarget = MergeSourceAndTarget { alice = aliceBranchNames, bob = info.bob.source } + let mergeSourceAndTarget = MergeSourceAndTarget {alice = aliceBranchNames, bob = info.bob.source} Cli.Env {codebase} <- ask @@ -438,8 +434,8 @@ doMerge info = do HandleInput.Branch.doCreateBranch' (Branch.mergeNode stageOneBranch parents.alice parents.bob) Nothing - info.alice.project - (findTemporaryBranchName info.alice.project.projectId mergeSourceAndTarget) + info.alice.projectAndBranch.project + (findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget) info.description scratchFilePath <- Cli.getLatestFile <&> \case @@ -838,7 +834,7 @@ defnsToNames defns = findTemporaryBranchName :: ProjectId -> MergeSourceAndTarget -> Transaction ProjectBranchName findTemporaryBranchName projectId mergeSourceAndTarget = do - Cli.findTemporaryBranchName projectId preferred + ProjectUtils.findTemporaryBranchName projectId preferred where preferred :: ProjectBranchName preferred = diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs index 676a28244..688ba5836 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectSwitch.hs @@ -8,7 +8,6 @@ where import Data.These (These (..)) import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) import U.Codebase.Sqlite.Project qualified -import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli @@ -68,13 +67,13 @@ switchToProjectAndBranchByTheseNames projectAndBranchNames0 = do Cli.runTransactionWithRollback \rollback -> do Queries.loadProjectBranchByNames projectName branchName & onNothingM do rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames) - switchToProjectBranch branch.projectId branch.branchId + switchToProjectBranch (ProjectUtils.justTheIds' branch) -- | Switch to a branch: -- -- * Record it as the most-recent branch (so it's restored when ucm starts). -- * Change the current path in the in-memory loop state. -switchToProjectBranch :: ProjectId -> ProjectBranchId -> Cli () -switchToProjectBranch projectId branchId = do - Cli.runTransaction (Queries.setMostRecentBranch projectId branchId) - Cli.cd (ProjectUtils.projectBranchPath (ProjectAndBranch projectId branchId)) +switchToProjectBranch :: ProjectAndBranch ProjectId ProjectBranchId -> Cli () +switchToProjectBranch x = do + Cli.runTransaction (Queries.setMostRecentBranch x.project x.branch) + Cli.cd (ProjectUtils.projectBranchPath x) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 3bf286d99..1d2cff148 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -125,8 +125,7 @@ handlePull unresolvedSourceAndTarget pullMode = do { alice = AliceMergeInfo { causalHash = aliceCausalHash, - project = target.project, - projectBranch = target.branch + projectAndBranch = target }, bob = BobMergeInfo @@ -221,9 +220,9 @@ resolveExplicitSource includeSquashed = \case (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) pure (ReadShare'ProjectBranch remoteProjectBranch) ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do - (ProjectAndBranch localProject localBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch - let localProjectId = localProject.projectId - let localBranchId = localBranch.branchId + (localProjectAndBranch, _restPath) <- ProjectUtils.expectCurrentProjectBranch + let localProjectId = localProjectAndBranch.project.projectId + let localBranchId = localProjectAndBranch.branch.branchId Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case Just (remoteProjectId, _maybeProjectBranchId) -> do remoteProjectName <- Cli.runTransaction (Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri) @@ -240,9 +239,7 @@ resolveExplicitSource includeSquashed = \case pure (ReadShare'ProjectBranch remoteProjectBranch) Nothing -> do Cli.returnEarly $ - Output.NoAssociatedRemoteProject - Share.hardCodedUri - (ProjectAndBranch localProject.name localBranch.name) + Output.NoAssociatedRemoteProject Share.hardCodedUri (ProjectUtils.justTheNames localProjectAndBranch) ReadShare'ProjectBranch (These projectName branchNameOrLatestRelease) -> do remoteProject <- ProjectUtils.expectRemoteProjectByName projectName let remoteProjectId = remoteProject.projectId diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 47d1c75cd..e1ee2c73e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -242,6 +242,7 @@ data Input | -- New merge algorithm: merge the given project branch into the current one. MergeI (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) | LibInstallI !(ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) + | UpgradeCommitI deriving (Eq, Show) -- | The source of a `branch` command: what to make the new branch from. diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 95923f5cc..d30c8ef94 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -411,6 +411,7 @@ data Output | MergeNestedDeclAlias !(Maybe MergeSourceOrTarget) !Name !Name | MergeStrayConstructor !(Maybe MergeSourceOrTarget) !Name | InstalledLibdep !(ProjectAndBranch ProjectName ProjectBranchName) !NameSegment + | NoUpgradeInProgress data UpdateOrUpgrade = UOUUpdate | UOUUpgrade @@ -654,6 +655,7 @@ isFailure o = case o of MergeNestedDeclAlias {} -> True MergeStrayConstructor {} -> True InstalledLibdep {} -> False + NoUpgradeInProgress {} -> True isNumberedFailure :: NumberedOutput -> Bool isNumberedFailure = \case diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index b5b69727c..11e4c8b98 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -127,6 +127,7 @@ module Unison.CommandLine.InputPatterns updateOld, updateOldNoPatch, upgrade, + upgradeCommitInputPattern, view, viewGlobal, viewPatch, @@ -3142,6 +3143,19 @@ upgrade = segment NE.:| [] <- Just (Name.reverseSegments name) Just segment +upgradeCommitInputPattern :: InputPattern +upgradeCommitInputPattern = + InputPattern + { patternName = "upgrade.commit", + aliases = ["commit.upgrade"], + visibility = I.Visible, + args = [], + help = P.wrap $ makeExample' upgradeCommitInputPattern <> "commits the current upgrade.", + parse = \case + [] -> Right Input.UpgradeCommitI + _ -> Left (I.help upgradeCommitInputPattern) + } + validInputs :: [InputPattern] validInputs = sortOn @@ -3270,6 +3284,7 @@ validInputs = updateOld, updateOldNoPatch, upgrade, + upgradeCommitInputPattern, view, viewGlobal, viewPatch, diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index fc9b57023..18e6e8768 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2311,6 +2311,8 @@ notifyUser dir = \case <> prettyProjectAndBranchName libdep <> "as" <> P.group (P.text (NameSegment.toEscapedText segment) <> ".") + NoUpgradeInProgress -> + pure . P.wrap $ "It doesn't look like there's an upgrade in progress." expectedEmptyPushDest :: WriteRemoteNamespace Void -> Pretty expectedEmptyPushDest namespace = diff --git a/unison-src/transcripts/upgrade-happy-path.md b/unison-src/transcripts/upgrade-happy-path.md index 3daf5f78e..c234e9ac7 100644 --- a/unison-src/transcripts/upgrade-happy-path.md +++ b/unison-src/transcripts/upgrade-happy-path.md @@ -15,6 +15,7 @@ proj/main> add ``` Test tab completion and fzf options of upgrade command. + ```ucm proj/main> debug.tab-complete upgrade ol proj/main> debug.fuzzy-options upgrade _ diff --git a/unison-src/transcripts/upgrade-happy-path.output.md b/unison-src/transcripts/upgrade-happy-path.output.md index 5e487a572..b2d8bb80a 100644 --- a/unison-src/transcripts/upgrade-happy-path.output.md +++ b/unison-src/transcripts/upgrade-happy-path.output.md @@ -30,6 +30,7 @@ proj/main> add ``` Test tab completion and fzf options of upgrade command. + ```ucm proj/main> debug.tab-complete upgrade ol diff --git a/unison-src/transcripts/upgrade-sad-path.md b/unison-src/transcripts/upgrade-sad-path.md index 4557c1cad..1aed98723 100644 --- a/unison-src/transcripts/upgrade-sad-path.md +++ b/unison-src/transcripts/upgrade-sad-path.md @@ -16,3 +16,16 @@ proj/main> add ```ucm:error proj/main> upgrade old new ``` + +Resolve the error and commit the upgrade. + +```unison +thingy = foo + +10 +``` + +```ucm +proj/upgrade-old-to-new> update +proj/upgrade-old-to-new> upgrade.commit +proj/main> view thingy +proj/main> ls lib +``` diff --git a/unison-src/transcripts/upgrade-sad-path.output.md b/unison-src/transcripts/upgrade-sad-path.output.md index 37f96f94e..7df2c6127 100644 --- a/unison-src/transcripts/upgrade-sad-path.output.md +++ b/unison-src/transcripts/upgrade-sad-path.output.md @@ -44,3 +44,48 @@ thingy = foo + 10 ``` +Resolve the error and commit the upgrade. + +```unison +thingy = foo + +10 +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These names already exist. You can `update` them to your + new definition: + + thingy : Int + +``` +```ucm +proj/upgrade-old-to-new> update + + Okay, I'm searching the branch for code that needs to be + updated... + + Done. + +proj/upgrade-old-to-new> upgrade.commit + + I fast-forward merged proj/upgrade-old-to-new into proj/main. + +proj/main> view thingy + + thingy : Int + thingy = + use Int + + foo + +10 + +proj/main> ls lib + + 1. builtin/ (469 terms, 74 types) + 2. new/ (1 term) + +``` From 4479966f8d04fb1510f51dcf2e5a287d23d2893b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 20 May 2024 13:04:31 -0400 Subject: [PATCH 42/82] make `upgrade.commit` perform the initial `update` --- .../Editor/HandleInput/CommitUpgrade.hs | 44 +++++-------- .../Editor/HandleInput/DeleteBranch.hs | 64 +++++++++---------- .../Codebase/Editor/HandleInput/Merge2.hs | 61 ++++++++++-------- unison-src/transcripts/upgrade-sad-path.md | 1 - .../transcripts/upgrade-sad-path.output.md | 4 +- 5 files changed, 83 insertions(+), 91 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs index a02acd5bc..901dada1e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs @@ -4,19 +4,17 @@ module Unison.Codebase.Editor.HandleInput.CommitUpgrade ) where -import Data.Text qualified as Text -import U.Codebase.Sqlite.Operations qualified as Operations import U.Codebase.Sqlite.Project qualified import U.Codebase.Sqlite.Queries qualified as Queries -import Unison.Cli.MergeTypes (MergeSource (..)) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils +import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge import Unison.Codebase.Editor.HandleInput.ProjectSwitch qualified as ProjectSwitch +import Unison.Codebase.Editor.HandleInput.Update2 qualified as Update import Unison.Codebase.Editor.Output qualified as Output -import Unison.CommandLine.InputPattern qualified as InputPattern -import Unison.CommandLine.InputPatterns qualified as InputPatterns +import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Prelude import Unison.Project (ProjectAndBranch (..)) @@ -36,34 +34,22 @@ handleCommitUpgrade = do let parentProjectAndBranch = ProjectAndBranch upgradeProjectAndBranch.project parentBranch + -- Run `update` + + Update.handleUpdate2 + -- Switch to the parent ProjectSwitch.switchToProjectBranch (ProjectUtils.justTheIds parentProjectAndBranch) -- Merge the upgrade branch into the parent - (parentCausalHash, upgradeCausalHash, lcaCausalHash) <- - Cli.runTransaction do - parentCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds parentProjectAndBranch) - upgradeCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds upgradeProjectAndBranch) - lcaCausalHash <- Operations.lca parentCausalHash upgradeCausalHash - pure (parentCausalHash, upgradeCausalHash, lcaCausalHash) - - Merge.doMerge - Merge.MergeInfo - { alice = - Merge.AliceMergeInfo - { causalHash = parentCausalHash, - projectAndBranch = parentProjectAndBranch - }, - bob = - Merge.BobMergeInfo - { causalHash = upgradeCausalHash, - source = MergeSource'LocalProjectBranch (ProjectUtils.justTheNames upgradeProjectAndBranch) - }, - lca = - Merge.LcaMergeInfo - { causalHash = lcaCausalHash - }, - description = Text.pack (InputPattern.patternName InputPatterns.upgradeCommitInputPattern) + Merge.doMergeLocalBranch + TwoWay + { alice = parentProjectAndBranch, + bob = upgradeProjectAndBranch } + + -- Delete the upgrade branch + + DeleteBranch.doDeleteProjectBranch upgradeProjectAndBranch diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs index b6865748f..0fa4291c6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/DeleteBranch.hs @@ -1,19 +1,21 @@ -- | @delete.branch@ input handler module Unison.Codebase.Editor.HandleInput.DeleteBranch ( handleDeleteBranch, + doDeleteProjectBranch, ) where -import Control.Lens (over, (^.)) +import Control.Lens (over) import Data.Map.Strict qualified as Map import Data.These (These (..)) +import U.Codebase.Sqlite.Project qualified as Sqlite +import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries 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.Codebase.Branch qualified as Branch -import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Path qualified as Path import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) @@ -25,47 +27,45 @@ import Witch (unsafeFrom) -- Its children branches, if any, are reparented to their grandparent, if any. You may delete the only branch in a -- project. handleDeleteBranch :: ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () -handleDeleteBranch projectAndBranchNames0 = do - projectAndBranchNames <- - ProjectUtils.hydrateNames - case projectAndBranchNames0 of +handleDeleteBranch projectAndBranchNamesToDelete = do + projectAndBranchToDelete <- + ProjectUtils.expectProjectAndBranchByTheseNames + case projectAndBranchNamesToDelete of ProjectAndBranch Nothing branch -> That branch ProjectAndBranch (Just project) branch -> These project branch maybeCurrentBranch <- ProjectUtils.getCurrentProjectBranch - deletedBranch <- - Cli.runTransactionWithRollback \rollback -> do - branch <- - Queries.loadProjectBranchByNames (projectAndBranchNames ^. #project) (projectAndBranchNames ^. #branch) - & onNothingM (rollback (Output.LocalProjectBranchDoesntExist projectAndBranchNames)) - Queries.deleteProjectBranch (branch ^. #projectId) (branch ^. #branchId) - pure branch - - let projectId = deletedBranch ^. #projectId - - Cli.stepAt - ("delete.branch " <> into @Text projectAndBranchNames) - ( Path.unabsolute (ProjectUtils.projectBranchesPath projectId), - \branchObject -> - branchObject - & over - Branch.children - (Map.delete (ProjectUtils.projectBranchSegment (deletedBranch ^. #branchId))) - ) + doDeleteProjectBranch projectAndBranchToDelete -- If the user is on the branch that they're deleting, we have to cd somewhere; try these in order: -- -- 1. cd to parent branch, if it exists -- 2. cd to "main", if it exists -- 3. cd to loose code path `.` - whenJust maybeCurrentBranch \(ProjectAndBranch _currentProject currentBranch, _restPath) -> - when (deletedBranch == currentBranch) do + whenJust maybeCurrentBranch \(currentProjectAndBranch, _restPath) -> + when (ProjectUtils.justTheIds currentProjectAndBranch == ProjectUtils.justTheIds projectAndBranchToDelete) do newPath <- - case deletedBranch ^. #parentBranchId of + case projectAndBranchToDelete.branch.parentBranchId of Nothing -> - Cli.runTransaction (Queries.loadProjectBranchByName projectId (unsafeFrom @Text "main")) <&> \case - Nothing -> Path.Absolute Path.empty - Just mainBranch -> ProjectUtils.projectBranchPath (ProjectAndBranch projectId (mainBranch ^. #branchId)) - Just parentBranchId -> pure (ProjectUtils.projectBranchPath (ProjectAndBranch projectId parentBranchId)) + let loadMain = + Queries.loadProjectBranchByName projectAndBranchToDelete.project.projectId (unsafeFrom @Text "main") + in Cli.runTransaction loadMain <&> \case + Nothing -> Path.Absolute Path.empty + Just mainBranch -> ProjectUtils.projectBranchPath (ProjectUtils.justTheIds' mainBranch) + Just parentBranchId -> + pure $ + ProjectUtils.projectBranchPath + (ProjectAndBranch projectAndBranchToDelete.project.projectId parentBranchId) Cli.cd newPath + +-- | Delete a project branch and record an entry in the reflog. +doDeleteProjectBranch :: ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch -> Cli () +doDeleteProjectBranch projectAndBranch = do + Cli.runTransaction do + Queries.deleteProjectBranch projectAndBranch.project.projectId projectAndBranch.branch.branchId + Cli.stepAt + ("delete.branch " <> into @Text (ProjectUtils.justTheNames projectAndBranch)) + ( Path.unabsolute (ProjectUtils.projectBranchesPath projectAndBranch.project.projectId), + over Branch.children (Map.delete (ProjectUtils.projectBranchSegment projectAndBranch.branch.branchId)) + ) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 4c566351b..3e1907e1b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -7,6 +7,7 @@ module Unison.Codebase.Editor.HandleInput.Merge2 BobMergeInfo (..), LcaMergeInfo (..), doMerge, + doMergeLocalBranch, ) where @@ -155,32 +156,10 @@ handleMerge (ProjectAndBranch maybeBobProjectName bobBranchName) = do bobProjectBranch <- ProjectUtils.expectProjectBranchByName bobProject bobBranchName let bobProjectAndBranch = ProjectAndBranch bobProject bobProjectBranch - (aliceCausalHash, bobCausalHash, lcaCausalHash) <- - Cli.runTransaction do - aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds aliceProjectAndBranch) - bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds bobProjectAndBranch) - -- Using Alice and Bob's causal hashes, find the LCA (if it exists) - lcaCausalHash <- Operations.lca aliceCausalHash bobCausalHash - pure (aliceCausalHash, bobCausalHash, lcaCausalHash) - - -- Do the merge! - doMerge - MergeInfo - { alice = - AliceMergeInfo - { causalHash = aliceCausalHash, - projectAndBranch = aliceProjectAndBranch - }, - bob = - BobMergeInfo - { causalHash = bobCausalHash, - source = MergeSource'LocalProjectBranch (ProjectUtils.justTheNames bobProjectAndBranch) - }, - lca = - LcaMergeInfo - { causalHash = lcaCausalHash - }, - description = "merge " <> into @Text (ProjectUtils.justTheNames bobProjectAndBranch) + doMergeLocalBranch + TwoWay + { alice = aliceProjectAndBranch, + bob = bobProjectAndBranch } data MergeInfo = MergeInfo @@ -453,6 +432,36 @@ doMerge info = do (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) Cli.respond (Output.MergeSuccess mergeSourceAndTarget) +doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli () +doMergeLocalBranch branches = do + (aliceCausalHash, bobCausalHash, lcaCausalHash) <- + Cli.runTransaction do + aliceCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.alice) + bobCausalHash <- ProjectUtils.getProjectBranchCausalHash (ProjectUtils.justTheIds branches.bob) + -- Using Alice and Bob's causal hashes, find the LCA (if it exists) + lcaCausalHash <- Operations.lca aliceCausalHash bobCausalHash + pure (aliceCausalHash, bobCausalHash, lcaCausalHash) + + -- Do the merge! + doMerge + MergeInfo + { alice = + AliceMergeInfo + { causalHash = aliceCausalHash, + projectAndBranch = branches.alice + }, + bob = + BobMergeInfo + { causalHash = bobCausalHash, + source = MergeSource'LocalProjectBranch (ProjectUtils.justTheNames branches.bob) + }, + lca = + LcaMergeInfo + { causalHash = lcaCausalHash + }, + description = "merge " <> into @Text (ProjectUtils.justTheNames branches.bob) + } + ------------------------------------------------------------------------------------------------------------------------ -- Loading basic info out of the database diff --git a/unison-src/transcripts/upgrade-sad-path.md b/unison-src/transcripts/upgrade-sad-path.md index 1aed98723..a27b75f0c 100644 --- a/unison-src/transcripts/upgrade-sad-path.md +++ b/unison-src/transcripts/upgrade-sad-path.md @@ -24,7 +24,6 @@ thingy = foo + +10 ``` ```ucm -proj/upgrade-old-to-new> update proj/upgrade-old-to-new> upgrade.commit proj/main> view thingy proj/main> ls lib diff --git a/unison-src/transcripts/upgrade-sad-path.output.md b/unison-src/transcripts/upgrade-sad-path.output.md index 7df2c6127..718a4c500 100644 --- a/unison-src/transcripts/upgrade-sad-path.output.md +++ b/unison-src/transcripts/upgrade-sad-path.output.md @@ -65,15 +65,13 @@ thingy = foo + +10 ``` ```ucm -proj/upgrade-old-to-new> update +proj/upgrade-old-to-new> upgrade.commit Okay, I'm searching the branch for code that needs to be updated... Done. -proj/upgrade-old-to-new> upgrade.commit - I fast-forward merged proj/upgrade-old-to-new into proj/main. proj/main> view thingy From 7273bd9a3af39dd9d3bd8b06479eb10bb16b22ac Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 20 May 2024 14:13:04 -0400 Subject: [PATCH 43/82] in `merge`, don't `returnEarly` on success --- .../Codebase/Editor/HandleInput/Merge2.hs | 403 +++++++++--------- unison-src/transcripts/upgrade-sad-path.md | 1 + .../transcripts/upgrade-sad-path.output.md | 5 + 3 files changed, 209 insertions(+), 200 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 3e1907e1b..265cd9d06 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -199,238 +199,241 @@ doMerge info = do Cli.Env {codebase} <- ask - -- If alice == bob, or LCA == bob (so alice is ahead of bob), then we are done. - when (info.alice.causalHash == info.bob.causalHash || info.lca.causalHash == Just info.bob.causalHash) do - Cli.returnEarly (Output.MergeAlreadyUpToDate2 mergeSourceAndTarget) + Cli.label \done -> do + -- If alice == bob, or LCA == bob (so alice is ahead of bob), then we are done. + when (info.alice.causalHash == info.bob.causalHash || info.lca.causalHash == Just info.bob.causalHash) do + Cli.respond (Output.MergeAlreadyUpToDate2 mergeSourceAndTarget) + done () - -- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done. - when (info.lca.causalHash == Just info.alice.causalHash) do - bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash) - _ <- Cli.updateAt info.description alicePath (\_aliceBranch -> bobBranch) - Cli.returnEarly (Output.MergeSuccessFastForward mergeSourceAndTarget) + -- Otherwise, if LCA == alice (so alice is behind bob), then we could fast forward to bob, so we're done. + when (info.lca.causalHash == Just info.alice.causalHash) do + bobBranch <- liftIO (Codebase.expectBranchForHash codebase info.bob.causalHash) + _ <- Cli.updateAt info.description alicePath (\_aliceBranch -> bobBranch) + Cli.respond (Output.MergeSuccessFastForward mergeSourceAndTarget) + done () - -- Create a bunch of cached database lookup functions - db <- makeMergeDatabase codebase + -- Create a bunch of cached database lookup functions + db <- makeMergeDatabase codebase - -- Load Alice/Bob/LCA causals - causals <- Cli.runTransaction do - traverse - Operations.expectCausalBranchByCausalHash - TwoOrThreeWay - { alice = info.alice.causalHash, - bob = info.bob.causalHash, - lca = info.lca.causalHash - } + -- Load Alice/Bob/LCA causals + causals <- Cli.runTransaction do + traverse + Operations.expectCausalBranchByCausalHash + TwoOrThreeWay + { alice = info.alice.causalHash, + bob = info.bob.causalHash, + lca = info.lca.causalHash + } - liftIO (debugFunctions.debugCausals causals) + liftIO (debugFunctions.debugCausals causals) - -- Load Alice/Bob/LCA branches - branches <- - Cli.runTransaction do - alice <- causals.alice.value - bob <- causals.bob.value - lca <- for causals.lca \causal -> causal.value - pure TwoOrThreeWay {lca, alice, bob} + -- Load Alice/Bob/LCA branches + branches <- + Cli.runTransaction do + alice <- causals.alice.value + bob <- causals.bob.value + lca <- for causals.lca \causal -> causal.value + pure TwoOrThreeWay {lca, alice, bob} - -- Assert that neither Alice nor Bob have defns in lib - for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do - libdeps <- - case Map.lookup NameSegment.libSegment branch.children of - Nothing -> pure V2.Branch.empty - Just libdeps -> Cli.runTransaction libdeps.value - when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do - Cli.returnEarly (Output.MergeDefnsInLib who) + -- Assert that neither Alice nor Bob have defns in lib + for_ [(mergeTarget, branches.alice), (mergeSource, branches.bob)] \(who, branch) -> do + libdeps <- + case Map.lookup NameSegment.libSegment branch.children of + Nothing -> pure V2.Branch.empty + Just libdeps -> Cli.runTransaction libdeps.value + when (not (Map.null libdeps.terms) || not (Map.null libdeps.types)) do + Cli.returnEarly (Output.MergeDefnsInLib who) - -- Load Alice/Bob/LCA definitions and decl name lookups - (defns3, declNameLookups3) <- do - let load = \case - Nothing -> - pure - ( Nametree {value = Defns Map.empty Map.empty, children = Map.empty}, - DeclNameLookup Map.empty Map.empty - ) - Just (who, branch) -> do - defns <- - Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName -> - Cli.returnEarly case conflictedName of - ConflictedName'Term name refs -> Output.MergeConflictedTermName name refs - ConflictedName'Type name refs -> Output.MergeConflictedTypeName name refs - declNameLookup <- - Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err -> - Cli.returnEarly case err of - IncoherentDeclReason'ConstructorAlias name1 name2 -> - Output.MergeConstructorAlias who name1 name2 - IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName who name - IncoherentDeclReason'NestedDeclAlias shorterName longerName -> - Output.MergeNestedDeclAlias who shorterName longerName - IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor who name - pure (defns, declNameLookup) + -- Load Alice/Bob/LCA definitions and decl name lookups + (defns3, declNameLookups3) <- do + let load = \case + Nothing -> + pure + ( Nametree {value = Defns Map.empty Map.empty, children = Map.empty}, + DeclNameLookup Map.empty Map.empty + ) + Just (who, branch) -> do + defns <- + Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName -> + Cli.returnEarly case conflictedName of + ConflictedName'Term name refs -> Output.MergeConflictedTermName name refs + ConflictedName'Type name refs -> Output.MergeConflictedTypeName name refs + declNameLookup <- + Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err -> + Cli.returnEarly case err of + IncoherentDeclReason'ConstructorAlias name1 name2 -> + Output.MergeConstructorAlias who name1 name2 + IncoherentDeclReason'MissingConstructorName name -> Output.MergeMissingConstructorName who name + IncoherentDeclReason'NestedDeclAlias shorterName longerName -> + Output.MergeNestedDeclAlias who shorterName longerName + IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor who name + pure (defns, declNameLookup) - (aliceDefns0, aliceDeclNameLookup) <- load (Just (Just mergeTarget, branches.alice)) - (bobDefns0, bobDeclNameLookup) <- load (Just (Just mergeSource, branches.bob)) - (lcaDefns0, lcaDeclNameLookup) <- load ((Nothing,) <$> branches.lca) + (aliceDefns0, aliceDeclNameLookup) <- load (Just (Just mergeTarget, branches.alice)) + (bobDefns0, bobDeclNameLookup) <- load (Just (Just mergeSource, branches.bob)) + (lcaDefns0, lcaDeclNameLookup) <- load ((Nothing,) <$> branches.lca) - let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns) - let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0} - let declNameLookups3 = ThreeWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup, lca = lcaDeclNameLookup} + let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns) + let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0} + let declNameLookups3 = ThreeWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup, lca = lcaDeclNameLookup} - pure (defns3, declNameLookups3) + pure (defns3, declNameLookups3) - let defns = ThreeWay.forgetLca defns3 - let declNameLookups = ThreeWay.forgetLca declNameLookups3 + let defns = ThreeWay.forgetLca defns3 + let declNameLookups = ThreeWay.forgetLca declNameLookups3 - liftIO (debugFunctions.debugDefns defns3 declNameLookups3) + liftIO (debugFunctions.debugDefns defns3 declNameLookups3) - -- Diff LCA->Alice and LCA->Bob - diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups3 defns3) + -- Diff LCA->Alice and LCA->Bob + diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups3 defns3) - liftIO (debugFunctions.debugDiffs diffs) + liftIO (debugFunctions.debugDiffs diffs) - -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias - for_ ((,) <$> TwoWay mergeTarget mergeSource <*> diffs) \(who, diff) -> - whenJust (findConflictedAlias defns3.lca diff) \(name1, name2) -> - Cli.returnEarly (Output.MergeConflictedAliases who name1 name2) + -- Bail early if it looks like we can't proceed with the merge, because Alice or Bob has one or more conflicted alias + for_ ((,) <$> TwoWay mergeTarget mergeSource <*> diffs) \(who, diff) -> + whenJust (findConflictedAlias defns3.lca diff) \(name1, name2) -> + Cli.returnEarly (Output.MergeConflictedAliases who name1 name2) - -- Combine the LCA->Alice and LCA->Bob diffs together - let diff = combineDiffs diffs + -- Combine the LCA->Alice and LCA->Bob diffs together + let diff = combineDiffs diffs - liftIO (debugFunctions.debugCombinedDiff diff) + liftIO (debugFunctions.debugCombinedDiff diff) - -- Partition the combined diff into the conflicted things and the unconflicted things - (conflicts, unconflicts) <- - partitionCombinedDiffs defns declNameLookups diff & onLeft \name -> - Cli.returnEarly (Output.MergeConflictInvolvingBuiltin name) + -- Partition the combined diff into the conflicted things and the unconflicted things + (conflicts, unconflicts) <- + partitionCombinedDiffs defns declNameLookups diff & onLeft \name -> + Cli.returnEarly (Output.MergeConflictInvolvingBuiltin name) - liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts) + liftIO (debugFunctions.debugPartitionedDiff conflicts unconflicts) - -- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there - -- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are) - dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts) + -- Identify the unconflicted dependents we need to pull into the Unison file (either first for typechecking, if there + -- aren't conflicts, or else for manual conflict resolution without a typechecking step, if there are) + dependents <- Cli.runTransaction (identifyDependents defns conflicts unconflicts) - liftIO (debugFunctions.debugDependents dependents) + liftIO (debugFunctions.debugDependents dependents) - let stageOne :: DefnsF (Map Name) Referent TypeReference - stageOne = - makeStageOne - declNameLookups - conflicts - unconflicts - dependents - (bimap BiMultimap.range BiMultimap.range defns3.lca) + let stageOne :: DefnsF (Map Name) Referent TypeReference + stageOne = + makeStageOne + declNameLookups + conflicts + unconflicts + dependents + (bimap BiMultimap.range BiMultimap.range defns3.lca) - liftIO (debugFunctions.debugStageOne stageOne) + liftIO (debugFunctions.debugStageOne stageOne) - -- Load and merge Alice's and Bob's libdeps - mergedLibdeps <- - Cli.runTransaction do - libdeps <- loadLibdeps branches - libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps) + -- Load and merge Alice's and Bob's libdeps + mergedLibdeps <- + Cli.runTransaction do + libdeps <- loadLibdeps branches + libdepsToBranch0 db (Merge.mergeLibdeps getTwoFreshNames libdeps) - -- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names - let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl - mkPpes defnsNames libdepsNames = - defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier - where - suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames) - let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps) + -- Make PPE for Alice that contains all of Alice's names, but suffixified against her names + Bob's names + let mkPpes :: TwoWay Names -> Names -> TwoWay PrettyPrintEnvDecl + mkPpes defnsNames libdepsNames = + defnsNames <&> \names -> PPED.makePPED (PPE.namer (names <> libdepsNames)) suffixifier + where + suffixifier = PPE.suffixifyByName (fold defnsNames <> libdepsNames) + let ppes = mkPpes (defnsToNames <$> defns) (Branch.toNames mergedLibdeps) - hydratedThings <- do - Cli.runTransaction do - for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) -> - let hydrate = hydrateDefns (Codebase.unsafeGetTermComponent codebase) Operations.expectDeclComponent - in (,) <$> hydrate conflicts1 <*> hydrate dependents1 + hydratedThings <- do + Cli.runTransaction do + for ((,) <$> conflicts <*> dependents) \(conflicts1, dependents1) -> + let hydrate = hydrateDefns (Codebase.unsafeGetTermComponent codebase) Operations.expectDeclComponent + in (,) <$> hydrate conflicts1 <*> hydrate dependents1 - let (renderedConflicts, renderedDependents) = - let honk declNameLookup ppe defns = - let (types, accessorNames) = - Writer.runWriter $ - defns.types & Map.traverseWithKey \name (ref, typ) -> - renderTypeBinding - -- Sort of a hack; since the decl printer looks in the PPE for names of constructors, - -- we just delete all term names out and add back the constructors... - -- probably no need to wipe out the suffixified side but we do it anyway - (setPpedToConstructorNames declNameLookup name ref ppe) - name - ref - typ - terms = - defns.terms & Map.mapMaybeWithKey \name (term, typ) -> - if Set.member name accessorNames - then Nothing - else Just (renderTermBinding ppe.suffixifiedPPE name term typ) - in Defns {terms, types} - in unzip $ - ( \declNameLookup (conflicts, dependents) ppe -> - let honk1 = honk declNameLookup ppe - in (honk1 conflicts, honk1 dependents) - ) - <$> declNameLookups - <*> hydratedThings - <*> ppes + let (renderedConflicts, renderedDependents) = + let honk declNameLookup ppe defns = + let (types, accessorNames) = + Writer.runWriter $ + defns.types & Map.traverseWithKey \name (ref, typ) -> + renderTypeBinding + -- Sort of a hack; since the decl printer looks in the PPE for names of constructors, + -- we just delete all term names out and add back the constructors... + -- probably no need to wipe out the suffixified side but we do it anyway + (setPpedToConstructorNames declNameLookup name ref ppe) + name + ref + typ + terms = + defns.terms & Map.mapMaybeWithKey \name (term, typ) -> + if Set.member name accessorNames + then Nothing + else Just (renderTermBinding ppe.suffixifiedPPE name term typ) + in Defns {terms, types} + in unzip $ + ( \declNameLookup (conflicts, dependents) ppe -> + let honk1 = honk declNameLookup ppe + in (honk1 conflicts, honk1 dependents) + ) + <$> declNameLookups + <*> hydratedThings + <*> ppes - let prettyUnisonFile = - makePrettyUnisonFile - TwoWay - { alice = into @Text aliceBranchNames, - bob = - case info.bob.source of - MergeSource'LocalProjectBranch bobBranchNames -> into @Text bobBranchNames - MergeSource'RemoteProjectBranch bobBranchNames - | aliceBranchNames == bobBranchNames -> "remote " <> into @Text bobBranchNames - | otherwise -> into @Text bobBranchNames - MergeSource'RemoteLooseCode info -> - case Path.toName info.path of - Nothing -> "" - Just name -> Name.toText name - MergeSource'RemoteGitRepo info -> - case Path.toName info.path of - Nothing -> "" - Just name -> Name.toText name - } - renderedConflicts - renderedDependents + let prettyUnisonFile = + makePrettyUnisonFile + TwoWay + { alice = into @Text aliceBranchNames, + bob = + case info.bob.source of + MergeSource'LocalProjectBranch bobBranchNames -> into @Text bobBranchNames + MergeSource'RemoteProjectBranch bobBranchNames + | aliceBranchNames == bobBranchNames -> "remote " <> into @Text bobBranchNames + | otherwise -> into @Text bobBranchNames + MergeSource'RemoteLooseCode info -> + case Path.toName info.path of + Nothing -> "" + Just name -> Name.toText name + MergeSource'RemoteGitRepo info -> + case Path.toName info.path of + Nothing -> "" + Just name -> Name.toText name + } + renderedConflicts + renderedDependents - let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps + let stageOneBranch = defnsAndLibdepsToBranch0 codebase stageOne mergedLibdeps - maybeTypecheckedUnisonFile <- - let thisMergeHasConflicts = - -- Eh, they'd either both be null, or neither, but just check both maps anyway - not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob) - in if thisMergeHasConflicts - then pure Nothing - else do - currentPath <- Cli.getCurrentPath - parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch) - prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe + maybeTypecheckedUnisonFile <- + let thisMergeHasConflicts = + -- Eh, they'd either both be null, or neither, but just check both maps anyway + not (defnsAreEmpty conflicts.alice) || not (defnsAreEmpty conflicts.bob) + in if thisMergeHasConflicts + then pure Nothing + else do + currentPath <- Cli.getCurrentPath + parsingEnv <- makeParsingEnv currentPath (Branch.toNames stageOneBranch) + prettyParseTypecheck2 prettyUnisonFile parsingEnv <&> eitherToMaybe - let parents = - (\causal -> (causal.causalHash, Codebase.expectBranchForHash codebase causal.causalHash)) <$> causals + let parents = + (\causal -> (causal.causalHash, Codebase.expectBranchForHash codebase causal.causalHash)) <$> causals - case maybeTypecheckedUnisonFile of - Nothing -> do - Cli.Env {writeSource} <- ask - _temporaryBranchId <- - HandleInput.Branch.doCreateBranch' - (Branch.mergeNode stageOneBranch parents.alice parents.bob) - Nothing - info.alice.projectAndBranch.project - (findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget) - info.description - scratchFilePath <- - Cli.getLatestFile <&> \case - Nothing -> "scratch.u" - Just (file, _) -> file - liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) - Cli.respond (Output.MergeFailure scratchFilePath mergeSourceAndTarget) - Just tuf -> do - Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) - let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch - _ <- - Cli.updateAt - info.description - alicePath - (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) - Cli.respond (Output.MergeSuccess mergeSourceAndTarget) + case maybeTypecheckedUnisonFile of + Nothing -> do + Cli.Env {writeSource} <- ask + _temporaryBranchId <- + HandleInput.Branch.doCreateBranch' + (Branch.mergeNode stageOneBranch parents.alice parents.bob) + Nothing + info.alice.projectAndBranch.project + (findTemporaryBranchName info.alice.projectAndBranch.project.projectId mergeSourceAndTarget) + info.description + scratchFilePath <- + Cli.getLatestFile <&> \case + Nothing -> "scratch.u" + Just (file, _) -> file + liftIO $ writeSource (Text.pack scratchFilePath) (Text.pack $ Pretty.toPlain 80 prettyUnisonFile) + Cli.respond (Output.MergeFailure scratchFilePath mergeSourceAndTarget) + Just tuf -> do + Cli.runTransaction (Codebase.addDefsToCodebase codebase tuf) + let stageTwoBranch = Branch.batchUpdates (typecheckedUnisonFileToBranchAdds tuf) stageOneBranch + _ <- + Cli.updateAt + info.description + alicePath + (\_aliceBranch -> Branch.mergeNode stageTwoBranch parents.alice parents.bob) + Cli.respond (Output.MergeSuccess mergeSourceAndTarget) doMergeLocalBranch :: TwoWay (ProjectAndBranch Project ProjectBranch) -> Cli () doMergeLocalBranch branches = do diff --git a/unison-src/transcripts/upgrade-sad-path.md b/unison-src/transcripts/upgrade-sad-path.md index a27b75f0c..e0e87f218 100644 --- a/unison-src/transcripts/upgrade-sad-path.md +++ b/unison-src/transcripts/upgrade-sad-path.md @@ -27,4 +27,5 @@ thingy = foo + +10 proj/upgrade-old-to-new> upgrade.commit proj/main> view thingy proj/main> ls lib +proj/main> branches ``` diff --git a/unison-src/transcripts/upgrade-sad-path.output.md b/unison-src/transcripts/upgrade-sad-path.output.md index 718a4c500..627a24596 100644 --- a/unison-src/transcripts/upgrade-sad-path.output.md +++ b/unison-src/transcripts/upgrade-sad-path.output.md @@ -86,4 +86,9 @@ proj/main> ls lib 1. builtin/ (469 terms, 74 types) 2. new/ (1 term) +proj/main> branches + + Branch Remote branch + 1. main + ``` From 2a21ed52556068f6fdfb915ac73bb97d5a5aee33 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 20 May 2024 18:55:58 -0400 Subject: [PATCH 44/82] improve `push` output --- unison-cli/src/Unison/Cli/Pretty.hs | 14 ++++++--- .../Codebase/Editor/HandleInput/Push.hs | 8 +++-- .../src/Unison/CommandLine/OutputMessages.hs | 29 +++++++++++-------- 3 files changed, 32 insertions(+), 19 deletions(-) diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index 8f82d3d44..a14937554 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -37,6 +37,7 @@ module Unison.Cli.Pretty prettySemver, prettyShareLink, prettySharePath, + prettyShareURI, prettySlashProjectBranchName, prettyTermName, prettyTypeName, @@ -140,6 +141,11 @@ type Pretty = P.Pretty P.ColorText prettyURI :: URI -> Pretty prettyURI = P.bold . P.blue . P.shown +prettyShareURI :: URI -> Pretty +prettyShareURI host + | URI.uriToString id host "" == "https://api.unison-lang.org" = P.bold (P.blue "Unison Share") + | otherwise = P.bold (P.blue (P.shown host)) + prettyReadRemoteNamespace :: ReadRemoteNamespace Share.RemoteProjectBranch -> Pretty prettyReadRemoteNamespace = prettyReadRemoteNamespaceWith \remoteProjectBranch -> @@ -394,15 +400,15 @@ prettyRemoteBranchInfo (host, remoteProject, remoteBranch) = -- Special-case Unison Share since we know its project branch URLs if URI.uriToString id host "" == "https://api.unison-lang.org" then - P.hiBlack . P.text $ + P.group $ "https://share.unison-lang.org/" - <> into @Text remoteProject + <> prettyProjectName remoteProject <> "/code/" - <> into @Text remoteBranch + <> prettyProjectBranchName remoteBranch else prettyProjectAndBranchName (ProjectAndBranch remoteProject remoteBranch) <> " on " - <> P.hiBlack (P.shown host) + <> P.shown host stripProjectBranchInfo :: Path.Absolute -> Maybe Path.Path stripProjectBranchInfo = fmap snd . preview projectBranchPathPrism diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs index 455f558b7..3c68d0ebf 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs @@ -650,10 +650,12 @@ makeSetHeadAfterUploadAction :: Share.RemoteProjectBranch -> Cli AfterUploadAction makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do - let remoteProjectAndBranchNames = ProjectAndBranch (remoteBranch ^. #projectName) (remoteBranch ^. #branchName) + let remoteProjectAndBranchNames = ProjectAndBranch remoteBranch.projectName remoteBranch.branchName + + when (localBranchHead == Share.API.hashJWTHash remoteBranch.branchHead) do + Cli.respond (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames) + Cli.returnEarly (ViewOnShare (Right (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName))) - when (localBranchHead == Share.API.hashJWTHash (remoteBranch ^. #branchHead)) do - Cli.returnEarly (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames) when (not force) do whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index fc9b57023..daa55b87f 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1830,7 +1830,7 @@ notifyUser dir = \case ShareError shareError -> pure (prettyShareError shareError) ViewOnShare shareRef -> pure $ - "View it on Unison Share: " <> case shareRef of + "View it here: " <> case shareRef of Left repoPath -> prettyShareLink repoPath Right branchInfo -> prettyRemoteBranchInfo branchInfo IntegrityCheck result -> pure $ case result of @@ -1956,12 +1956,17 @@ notifyUser dir = \case "I just created" <> prettyProjectName projectName <> "on" - <> prettyURI host + <> prettyShareURI host CreatedRemoteProjectBranch host projectAndBranch -> pure . P.wrap $ - "I just created" <> prettyProjectAndBranchName projectAndBranch <> "on" <> prettyURI host + "I just created" <> prettyProjectAndBranchName projectAndBranch <> "on" <> prettyShareURI host RemoteProjectBranchIsUpToDate host projectAndBranch -> - pure (P.wrap (prettyProjectAndBranchName projectAndBranch <> "on" <> prettyURI host <> "is already up-to-date.")) + pure $ + P.wrap $ + prettyProjectAndBranchName projectAndBranch + <> "on" + <> prettyShareURI host + <> "is already up-to-date." InvalidProjectName name -> pure (P.wrap (P.text name <> "is not a valid project name.")) InvalidProjectBranchName name -> pure (P.wrap (P.text name <> "is not a valid branch name.")) ProjectNameAlreadyExists name -> @@ -1981,12 +1986,12 @@ notifyUser dir = \case NotOnProjectBranch -> pure (P.wrap "You are not currently on a branch.") NoAssociatedRemoteProject host projectAndBranch -> pure . P.wrap $ - prettyProjectAndBranchName projectAndBranch <> "isn't associated with any project on" <> prettyURI host + prettyProjectAndBranchName projectAndBranch <> "isn't associated with any project on" <> prettyShareURI host NoAssociatedRemoteProjectBranch host (ProjectAndBranch project branch) -> pure . P.wrap $ prettyProjectAndBranchName (ProjectAndBranch (project ^. #name) (branch ^. #name)) <> "isn't associated with any branch on" - <> prettyURI host + <> prettyShareURI host LocalProjectDoesntExist project -> pure . P.wrap $ prettyProjectName project <> "does not exist." @@ -2002,17 +2007,17 @@ notifyUser dir = \case <> "exists." RemoteProjectDoesntExist host project -> pure . P.wrap $ - prettyProjectName project <> "does not exist on" <> prettyURI host + prettyProjectName project <> "does not exist on" <> prettyShareURI host RemoteProjectBranchDoesntExist host projectAndBranch -> pure . P.wrap $ - prettyProjectAndBranchName projectAndBranch <> "does not exist on" <> prettyURI host + prettyProjectAndBranchName projectAndBranch <> "does not exist on" <> prettyShareURI host RemoteProjectBranchDoesntExist'Push host projectAndBranch -> let push = P.group . P.backticked . IP.patternName $ IP.push in pure . P.wrap $ "The previous push target named" <> prettyProjectAndBranchName projectAndBranch <> "has been deleted from" - <> P.group (prettyURI host <> ".") + <> P.group (prettyShareURI host <> ".") <> "I've deleted the invalid push target." <> "Run the" <> push @@ -2021,14 +2026,14 @@ notifyUser dir = \case pure . P.wrap $ prettyProjectAndBranchName projectAndBranch <> "on" - <> prettyURI host + <> prettyShareURI host <> "has some history that I don't know about." RemoteProjectPublishedReleaseCannotBeChanged host projectAndBranch -> pure . P.wrap $ "The release" <> prettyProjectAndBranchName projectAndBranch <> "on" - <> prettyURI host + <> prettyShareURI host <> "has already been published and cannot be changed." <> "Consider making a new release instead." RemoteProjectReleaseIsDeprecated host projectAndBranch -> @@ -2036,7 +2041,7 @@ notifyUser dir = \case "The release" <> prettyProjectAndBranchName projectAndBranch <> "on" - <> prettyURI host + <> prettyShareURI host <> "has been deprecated." Unauthorized message -> pure . P.wrap $ From d7077c994bb7ea222b2acba2e5148d261da668e4 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Mon, 20 May 2024 16:58:59 -0700 Subject: [PATCH 45/82] remove unused incoming hashes event --- .../src/Unison/Codebase/Editor/HandleInput.hs | 7 --- .../src/Unison/Codebase/Editor/Input.hs | 2 - .../src/Unison/Codebase/Editor/Output.hs | 2 - .../src/Unison/CommandLine/OutputMessages.hs | 43 ------------------- 4 files changed, 54 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index ece99ab85..7e5352675 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -201,13 +201,6 @@ import UnliftIO.Directory qualified as Directory loop :: Either Event Input -> Cli () loop e = do case e of - Left (IncomingRootBranch hashes) -> Cli.time "IncomingRootBranch" do - schLength <- Cli.runTransaction Codebase.branchHashLength - rootBranch <- Cli.getRootBranch - Cli.respond $ - WarnIncomingRootBranch - (SCH.fromHash schLength $ Branch.headHash rootBranch) - (Set.map (SCH.fromHash schLength) hashes) Left (UnisonFileChanged sourceName text) -> Cli.time "UnisonFileChanged" do -- We skip this update if it was programmatically generated Cli.getLatestFile >>= \case diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 47d1c75cd..2cdfb96c1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -32,7 +32,6 @@ where import Data.List.NonEmpty (NonEmpty) import Data.Text qualified as Text import Data.These (These) -import U.Codebase.HashTags (CausalHash) import Unison.Codebase.Branch.Merge qualified as Branch import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace) import Unison.Codebase.Path (Path, Path') @@ -52,7 +51,6 @@ import Unison.Util.Pretty qualified as P data Event = UnisonFileChanged SourceName Source - | IncomingRootBranch (Set CausalHash) deriving stock (Show) type Source = Text -- "id x = x\nconst a b = a" diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 95923f5cc..da1a1349a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -279,7 +279,6 @@ data Output NothingToPatch PatchPath Path' | PatchNeedsToBeConflictFree | PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference) - | WarnIncomingRootBranch ShortCausalHash (Set ShortCausalHash) | StartOfCurrentPathHistory | ShowReflog [(Maybe UTCTime, SCH.ShortCausalHash, Text)] | PullAlreadyUpToDate @@ -551,7 +550,6 @@ isFailure o = case o of PatchInvolvesExternalDependents {} -> True AboutToPropagatePatch {} -> False NothingToPatch {} -> False - WarnIncomingRootBranch {} -> False StartOfCurrentPathHistory -> True NotImplemented -> True DumpNumberedArgs {} -> False diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index fc9b57023..625dae438 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -685,49 +685,6 @@ notifyUser dir = \case $ "The namespaces " <> P.commas (prettyBranchId <$> ps) <> " are empty. Was there a typo?" - WarnIncomingRootBranch current hashes -> - pure $ - if null hashes - then - P.wrap $ - "Please let someone know I generated an empty IncomingRootBranch" - <> " event, which shouldn't be possible!" - else - P.lines - [ P.wrap $ - (if length hashes == 1 then "A" else "Some") - <> "codebase" - <> P.plural hashes "root" - <> "appeared unexpectedly" - <> "with" - <> P.group (P.plural hashes "hash" <> ":"), - "", - (P.indentN 2 . P.oxfordCommas) - (map prettySCH $ toList hashes), - "", - P.wrap $ - "and I'm not sure what to do about it." - <> "The last root namespace hash that I knew about was:", - "", - P.indentN 2 $ prettySCH current, - "", - P.wrap $ "Now might be a good time to make a backup of your codebase. 😬", - "", - P.wrap $ - "After that, you might try using the" - <> makeExample' IP.forkLocal - <> "command to inspect the namespaces listed above, and decide which" - <> "one you want as your root." - <> "You can also use" - <> makeExample' IP.viewReflog - <> "to see the" - <> "last few root namespace hashes on record.", - "", - P.wrap $ - "Once you find one you like, you can use the" - <> makeExample' IP.resetRoot - <> "command to set it." - ] LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath -> pure $ P.lines From b210679917a8265bedcea22ddef1293bd13d0ac4 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 22 May 2024 11:35:51 -0700 Subject: [PATCH 46/82] Add failing transcript --- .../delete-namespace-dependents-check.md | 23 ++++++++ ...elete-namespace-dependents-check.output.md | 53 +++++++++++++++++++ 2 files changed, 76 insertions(+) create mode 100644 unison-src/transcripts/delete-namespace-dependents-check.md create mode 100644 unison-src/transcripts/delete-namespace-dependents-check.output.md diff --git a/unison-src/transcripts/delete-namespace-dependents-check.md b/unison-src/transcripts/delete-namespace-dependents-check.md new file mode 100644 index 000000000..088769cdd --- /dev/null +++ b/unison-src/transcripts/delete-namespace-dependents-check.md @@ -0,0 +1,23 @@ + + +# Delete namespace dependents check + +This is a regression test, previously `delete.namespace` allowed a delete as long as the deletions had a name _anywhere_ in your codebase, it should only check the current project branch. + +```ucm:hide +.> project.create-empty myproject +myproject/main> builtins.merge +``` + +```unison +sub.dependency = 123 + +dependent = dependency + 99 +``` + +```ucm +myproject/main> add +myproject/main> branch /new +myproject/new> delete.namespace sub +myproject/new> view dependent +``` diff --git a/unison-src/transcripts/delete-namespace-dependents-check.output.md b/unison-src/transcripts/delete-namespace-dependents-check.output.md new file mode 100644 index 000000000..eda162337 --- /dev/null +++ b/unison-src/transcripts/delete-namespace-dependents-check.output.md @@ -0,0 +1,53 @@ + + +# Delete namespace dependents check + +This is a regression test, previously `delete.namespace` allowed a delete as long as the deletions had a name _anywhere_ in your codebase, it should only check the current project branch. + +```unison +sub.dependency = 123 + +dependent = dependency + 99 +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + dependent : Nat + sub.dependency : Nat + +``` +```ucm +myproject/main> add + + ⍟ I've added these definitions: + + dependent : Nat + sub.dependency : Nat + +myproject/main> branch /new + + Done. I've created the new branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /new`. + +myproject/new> delete.namespace sub + + Done. + +myproject/new> view dependent + + dependent : Nat + dependent = + use Nat + + #mllb0u5378 + 99 + +``` From f25a221c25c5b77b61b29b5de403630e3f797d1f Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 22 May 2024 11:51:10 -0700 Subject: [PATCH 47/82] Don't allow absolute paths in delete.namespace --- .../src/Unison/Codebase/Editor/HandleInput.hs | 20 +++++++++---------- .../src/Unison/Codebase/Editor/Input.hs | 2 +- .../src/Unison/CommandLine/InputPatterns.hs | 2 +- .../delete-namespace-dependents-check.md | 2 +- ...elete-namespace-dependents-check.output.md | 13 ++++++++++-- 5 files changed, 24 insertions(+), 15 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 7e5352675..98085b2b2 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -744,16 +744,15 @@ loop e = do Cli.respond DeletedEverything else Cli.respond DeleteEverythingConfirmation DeleteTarget'Namespace insistence (Just p@(parentPath, childName)) -> do - branch <- Cli.expectBranchAtPath' (Path.unsplit' p) + branch <- Cli.expectBranchAtPath (Path.unsplit p) description <- inputDescription input - absPath <- Cli.resolveSplit' p let toDelete = Names.prefix0 - (Path.unsafeToName (Path.unsplit (Path.convert absPath))) + (Path.unsafeToName (Path.unsplit (p))) (Branch.toNames (Branch.head branch)) afterDelete <- do - rootNames <- Branch.toNames <$> Cli.getRootBranch0 - endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty rootNames) + names <- Cli.currentNames + endangerments <- Cli.runTransaction (getEndangeredDependents toDelete Set.empty names) case (null endangerments, insistence) of (True, _) -> pure (Cli.respond Success) (False, Force) -> do @@ -765,7 +764,7 @@ loop e = do ppeDecl <- Cli.currentPrettyPrintEnvDecl Cli.respondNumbered $ CantDeleteNamespace ppeDecl endangerments Cli.returnEarlyWithoutOutput - parentPathAbs <- Cli.resolvePath' parentPath + parentPathAbs <- Cli.resolvePath parentPath -- We have to modify the parent in order to also wipe out the history at the -- child. Cli.updateAt description parentPathAbs \parentBranch -> @@ -1274,10 +1273,10 @@ inputDescription input = thing <- traverse hqs' thing0 pure ("delete.type.verbose " <> Text.intercalate " " thing) DeleteTarget'Namespace Try opath0 -> do - opath <- ops' opath0 + opath <- ops opath0 pure ("delete.namespace " <> opath) DeleteTarget'Namespace Force opath0 -> do - opath <- ops' opath0 + opath <- ops opath0 pure ("delete.namespace.force " <> opath) DeleteTarget'Patch path0 -> do path <- ps' path0 @@ -1410,8 +1409,8 @@ inputDescription input = p' = fmap tShow . Cli.resolvePath' brp :: BranchRelativePath -> Cli Text brp = fmap from . ProjectUtils.resolveBranchRelativePath - ops' :: Maybe Path.Split' -> Cli Text - ops' = maybe (pure ".") ps' + ops :: Maybe Path.Split -> Cli Text + ops = maybe (pure ".") ps opatch :: Maybe Path.Split' -> Cli Text opatch = ps' . fromMaybe Cli.defaultPatchPath wat = error $ show input ++ " is not expected to alter the branch" @@ -1425,6 +1424,7 @@ inputDescription input = pure (p <> "." <> HQ'.toTextWith NameSegment.toEscapedText hq) hqs (p, hq) = hqs' (Path' . Right . Path.Relative $ p, hq) ps' = p' . Path.unsplit' + ps = p . Path.unsplit looseCodeOrProjectToText :: Input.LooseCodeOrProject -> Cli Text looseCodeOrProjectToText = \case This path -> p' path diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 2cdfb96c1..c82ef2866 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -331,7 +331,7 @@ data DeleteTarget = DeleteTarget'TermOrType DeleteOutput [Path.HQSplit'] | DeleteTarget'Term DeleteOutput [Path.HQSplit'] | DeleteTarget'Type DeleteOutput [Path.HQSplit'] - | DeleteTarget'Namespace Insistence (Maybe Path.Split') + | DeleteTarget'Namespace Insistence (Maybe Path.Split) | DeleteTarget'Patch Path.Split' | DeleteTarget'ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) | DeleteTarget'Project ProjectName diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 490d29b6c..b29df8783 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1239,7 +1239,7 @@ deleteNamespaceParser helpText insistence = \case . pure $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) [p] -> first P.text do - p <- Path.parseSplit' p + p <- Path.parseSplit p pure $ Input.DeleteI (DeleteTarget'Namespace insistence (Just p)) _ -> Left helpText diff --git a/unison-src/transcripts/delete-namespace-dependents-check.md b/unison-src/transcripts/delete-namespace-dependents-check.md index 088769cdd..9bbf7b94d 100644 --- a/unison-src/transcripts/delete-namespace-dependents-check.md +++ b/unison-src/transcripts/delete-namespace-dependents-check.md @@ -15,7 +15,7 @@ sub.dependency = 123 dependent = dependency + 99 ``` -```ucm +```ucm:error myproject/main> add myproject/main> branch /new myproject/new> delete.namespace sub diff --git a/unison-src/transcripts/delete-namespace-dependents-check.output.md b/unison-src/transcripts/delete-namespace-dependents-check.output.md index eda162337..4ab652409 100644 --- a/unison-src/transcripts/delete-namespace-dependents-check.output.md +++ b/unison-src/transcripts/delete-namespace-dependents-check.output.md @@ -41,13 +41,22 @@ myproject/main> branch /new myproject/new> delete.namespace sub - Done. + ⚠️ + + I didn't delete the namespace because the following + definitions are still in use. + + Dependency Referenced In + dependency 1. dependent + + If you want to proceed anyways and leave those definitions + without names, use delete.namespace.force myproject/new> view dependent dependent : Nat dependent = use Nat + - #mllb0u5378 + 99 + dependency + 99 ``` From c9e6702c8ecf4a78f1ae6dd4cc67229d2f21c1cc Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Wed, 22 May 2024 11:56:50 -0700 Subject: [PATCH 48/82] Fix transcripts which use absolute paths with delete.namespace --- unison-src/transcripts/empty-namespaces.md | 2 +- unison-src/transcripts/merges.md | 2 +- unison-src/transcripts/merges.output.md | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/unison-src/transcripts/empty-namespaces.md b/unison-src/transcripts/empty-namespaces.md index 32dd9942a..223ab34ba 100644 --- a/unison-src/transcripts/empty-namespaces.md +++ b/unison-src/transcripts/empty-namespaces.md @@ -45,7 +45,7 @@ stuff.thing = 2 ```ucm:hide .> add -.> delete.namespace .deleted +.> delete.namespace deleted ``` ## fork diff --git a/unison-src/transcripts/merges.md b/unison-src/transcripts/merges.md index ee2251e30..330e46857 100644 --- a/unison-src/transcripts/merges.md +++ b/unison-src/transcripts/merges.md @@ -52,7 +52,7 @@ We can also delete the fork if we're done with it. (Don't worry, even though the it's still in the `history` of the parent namespace and can be resurrected at any time.) ```ucm -.> delete.namespace .feature1 +.> delete.namespace feature1 .> history .feature1 .> history ``` diff --git a/unison-src/transcripts/merges.output.md b/unison-src/transcripts/merges.output.md index 73c8a3931..8bfbb170f 100644 --- a/unison-src/transcripts/merges.output.md +++ b/unison-src/transcripts/merges.output.md @@ -106,7 +106,7 @@ We can also delete the fork if we're done with it. (Don't worry, even though the it's still in the `history` of the parent namespace and can be resurrected at any time.) ```ucm -.> delete.namespace .feature1 +.> delete.namespace feature1 Done. From c430f4c2112cc8bceeab9cd64defce98c85b8bae Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 22 May 2024 15:47:13 -0400 Subject: [PATCH 49/82] fix bug in `lib.install` that prevented you from installing from a project with a '-' character in its name --- .../Codebase/Editor/HandleInput/InstallLib.hs | 33 +++++++++---------- 1 file changed, 15 insertions(+), 18 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs index 31ddeb5c1..11d51197c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs @@ -117,25 +117,22 @@ fresh bump taken x = makeDependencyName :: ProjectName -> ProjectBranchName -> NameSegment makeDependencyName projectName branchName = NameSegment.unsafeParseText $ - Text.intercalate "_" $ - fold - [ case projectNameToUserProjectSlugs projectName of - (user, project) -> - fold - [ if Text.null user then [] else [user], - [project] - ], - case classifyProjectBranchName branchName of - ProjectBranchNameKind'Contributor user branch -> [user, underscorify branch] - ProjectBranchNameKind'DraftRelease ver -> semverSegments ver ++ ["draft"] - ProjectBranchNameKind'Release ver -> semverSegments ver - ProjectBranchNameKind'NothingSpecial -> [underscorify branchName] - ] + Text.replace "-" "_" $ + Text.intercalate "_" $ + fold + [ case projectNameToUserProjectSlugs projectName of + (user, project) -> + fold + [ if Text.null user then [] else [user], + [project] + ], + case classifyProjectBranchName branchName of + ProjectBranchNameKind'Contributor user branch -> [user, into @Text branch] + ProjectBranchNameKind'DraftRelease ver -> semverSegments ver ++ ["draft"] + ProjectBranchNameKind'Release ver -> semverSegments ver + ProjectBranchNameKind'NothingSpecial -> [into @Text branchName] + ] where semverSegments :: Semver -> [Text] semverSegments (Semver x y z) = [tShow x, tShow y, tShow z] - - underscorify :: ProjectBranchName -> Text - underscorify = - Text.replace "-" "_" . into @Text From 6168e4a245808e0486923c48691f70be54799309 Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Wed, 22 May 2024 18:31:01 -0400 Subject: [PATCH 50/82] Update README.md --- README.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/README.md b/README.md index db40dc20a..3a857d380 100644 --- a/README.md +++ b/README.md @@ -1,7 +1,8 @@ The Unison language =================== -[![Build Status](https://github.com/unisonweb/unison/actions/workflows/ci.yaml/badge.svg)](https://github.com/unisonweb/unison/actions/workflows/ci.yaml?query=branch%3Atrunk) +[![CI Status](https://github.com/unisonweb/unison/actions/workflows/ci.yaml/badge.svg)](https://github.com/unisonweb/unison/actions/workflows/ci.yaml?query=branch%3Atrunk) +[![Pre-Release Status](https://github.com/unisonweb/unison/actions/workflows/pre-release.yaml/badge.svg)](https://github.com/unisonweb/unison/actions/workflows/pre-release.yaml) * [Overview](#overview) * [Building using Stack](#building-using-stack) From d20d30d47589a7b7deee4641031cde45d106f2b5 Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Wed, 22 May 2024 18:34:08 -0400 Subject: [PATCH 51/82] update workflows for lib.install --- .github/workflows/ci.yaml | 2 +- unison-src/transcripts-manual/gen-racket-libs.md | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/ci.yaml b/.github/workflows/ci.yaml index bee857575..4ee48187b 100644 --- a/.github/workflows/ci.yaml +++ b/.github/workflows/ci.yaml @@ -378,7 +378,7 @@ jobs: contents: | ```ucm .> project.create-empty jit-setup - jit-setup/main> pull ${{ env.jit_version }} lib.jit + jit-setup/main> lib.install ${{ env.jit_version }} ``` ```unison go = generateSchemeBoot "${{ env.jit_generated_src_scheme }}" diff --git a/unison-src/transcripts-manual/gen-racket-libs.md b/unison-src/transcripts-manual/gen-racket-libs.md index 3967df5ce..44c078db5 100644 --- a/unison-src/transcripts-manual/gen-racket-libs.md +++ b/unison-src/transcripts-manual/gen-racket-libs.md @@ -5,7 +5,7 @@ Next, we'll download the jit project and generate a few Racket files from it. ```ucm .> project.create-empty jit-setup -jit-setup/main> pull @unison/internal/releases/0.0.17 lib.jit +jit-setup/main> lib.install @unison/internal/releases/0.0.17 ``` ```unison From 24b8c2d9289c7cb33e23793db99223b629297a6b Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Wed, 22 May 2024 18:42:49 -0400 Subject: [PATCH 52/82] update cachix actions to latest --- .github/workflows/nix-dev-cache.yaml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.github/workflows/nix-dev-cache.yaml b/.github/workflows/nix-dev-cache.yaml index aacb38342..915b42090 100644 --- a/.github/workflows/nix-dev-cache.yaml +++ b/.github/workflows/nix-dev-cache.yaml @@ -23,12 +23,12 @@ jobs: - macOS-12 steps: - uses: actions/checkout@v4 - - uses: cachix/install-nix-action@v22 + - uses: cachix/install-nix-action@v27 with: extra_nix_config: | extra-trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= extra-substituters = https://cache.iog.io - - uses: cachix/cachix-action@v12 + - uses: cachix/cachix-action@v15 with: name: unison authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' From e250d0598054f6744f48ea66c90c8ab397330a20 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Tue, 14 May 2024 00:27:26 -0600 Subject: [PATCH 53/82] Maintain `NumberedArgs` as structured data This is the first step toward avoiding printing/parsing the values provided via `NumberedArgs`. It simply adds a new sum type to hold all of the types that can be in numbered args and stores it alongside the `Text` representation. It currently gets discarded when we actually expand the arguments. --- unison-cli/src/Unison/Cli/Pretty.hs | 4 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 64 +++++++++-------- .../Editor/HandleInput/FindAndReplace.hs | 4 +- .../src/Unison/Codebase/Editor/Output.hs | 8 ++- .../Codebase/Editor/StructuredArgument.hs | 31 ++++++++ unison-cli/src/Unison/CommandLine.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 70 +++++++++++-------- unison-cli/tests/Unison/Test/Cli/Monad.hs | 6 +- unison-cli/unison-cli.cabal | 1 + 9 files changed, 124 insertions(+), 66 deletions(-) create mode 100644 unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index 4ec00b02f..d3e1f2bff 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -345,8 +345,8 @@ prettyWhichBranchEmpty = \case WhichBranchEmptyPath path -> prettyPath' path -- | Displays a full, non-truncated Branch.CausalHash to a string, e.g. #abcdef -displayBranchHash :: CausalHash -> String -displayBranchHash = ("#" <>) . Text.unpack . Hash.toBase32HexText . unCausalHash +displayBranchHash :: CausalHash -> Text +displayBranchHash = ("#" <>) . Hash.toBase32HexText . unCausalHash prettyHumanReadableTime :: UTCTime -> UTCTime -> Pretty prettyHumanReadableTime now time = diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index b9e06cd69..bfc6f72f6 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -5,6 +5,7 @@ module Unison.Codebase.Editor.HandleInput (loop) where -- TODO: Don't import backend +import Control.Arrow ((&&&)) import Control.Error.Util qualified as ErrorUtil import Control.Lens hiding (from) import Control.Monad.Reader (ask) @@ -96,6 +97,7 @@ import Unison.Codebase.Editor.Output.DumpNamespace qualified as Output.DN import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.Slurp qualified as Slurp import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult +import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.Codebase.Editor.TodoOutput qualified as TO import Unison.Codebase.IntegrityCheck qualified as IntegrityCheck (integrityCheckFullCodebase) import Unison.Codebase.Metadata qualified as Metadata @@ -288,19 +290,22 @@ loop e = do Cli.respond $ PrintMessage pretty ShowReflogI -> do let numEntriesToShow = 500 - entries <- - Cli.runTransaction do - schLength <- Codebase.branchHashLength - Codebase.getReflog numEntriesToShow <&> fmap (first $ SCH.fromHash schLength) + (schLength, entries) <- + Cli.runTransaction $ + (,) <$> Codebase.branchHashLength <*> Codebase.getReflog numEntriesToShow let moreEntriesToLoad = length entries == numEntriesToShow let expandedEntries = List.unfoldr expandEntries (entries, Nothing, moreEntriesToLoad) - let numberedEntries = expandedEntries <&> \(_time, hash, _reason) -> "#" <> SCH.toString hash + let (shortEntries, numberedEntries) = + unzip $ + expandedEntries <&> \(time, hash, reason) -> + let ((exp, txt), sa) = ((id &&& ("#" <>) . SCH.toText) . SCH.fromHash schLength &&& SA.Namespace) hash + in ((time, exp, reason), (txt, sa)) Cli.setNumberedArgs numberedEntries - Cli.respond $ ShowReflog expandedEntries + Cli.respond $ ShowReflog shortEntries where expandEntries :: - ([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool) -> - Maybe ((Maybe UTCTime, SCH.ShortCausalHash, Text), ([Reflog.Entry SCH.ShortCausalHash Text], Maybe SCH.ShortCausalHash, Bool)) + ([Reflog.Entry CausalHash Text], Maybe CausalHash, Bool) -> + Maybe ((Maybe UTCTime, CausalHash, Text), ([Reflog.Entry CausalHash Text], Maybe CausalHash, Bool)) expandEntries ([], Just expectedHash, moreEntriesToLoad) = if moreEntriesToLoad then Nothing @@ -786,13 +791,13 @@ loop e = do (seg, _) <- Map.toList (Branch._edits b) ] Cli.respond $ ListOfPatches $ Set.fromList patches - Cli.setNumberedArgs $ fmap (Text.unpack . Name.toText) patches + Cli.setNumberedArgs $ fmap (Name.toText &&& SA.Name) patches FindShallowI pathArg -> do Cli.Env {codebase} <- ask pathArgAbs <- Cli.resolvePath' pathArg entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs) - Cli.setNumberedArgs $ fmap entryToHQString entries + Cli.setNumberedArgs $ fmap (entryToHQText &&& SA.ShallowListEntry pathArg) entries pped <- Cli.currentPrettyPrintEnvDecl let suffixifiedPPE = PPED.suffixifiedPPE pped -- This used to be a delayed action which only forced the loading of the root @@ -803,19 +808,20 @@ loop e = do let buildPPE = pure suffixifiedPPE Cli.respond $ ListShallow buildPPE entries where - entryToHQString :: ShallowListEntry v Ann -> String - entryToHQString e = - fixup $ Text.unpack case e of + entryToHQText :: ShallowListEntry v Ann -> Text + entryToHQText e = + fixup $ case e of ShallowTypeEntry te -> Backend.typeEntryDisplayName te ShallowTermEntry te -> Backend.termEntryDisplayName te ShallowBranchEntry ns _ _ -> NameSegment.toEscapedText ns ShallowPatchEntry ns -> NameSegment.toEscapedText ns where - fixup s = case pathArgStr of - "" -> s - p | last p == '.' -> p ++ s - p -> p ++ "." ++ s - pathArgStr = show pathArg + fixup s = + pathArgStr + <> if Text.null pathArgStr || Text.isSuffixOf "." pathArgStr + then s + else "." <> s + pathArgStr = Text.pack $ show pathArg FindI isVerbose fscope ws -> handleFindI isVerbose fscope ws input StructuredFindI _fscope ws -> handleStructuredFindI ws StructuredFindReplaceI ws -> handleStructuredFindReplaceI ws @@ -1495,7 +1501,7 @@ handleFindI isVerbose fscope ws input = do (mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs) pure $ uniqueBy SR.toReferent srs let respondResults results = do - Cli.setNumberedArgs $ fmap (searchResultToHQString searchRoot) results + Cli.setNumberedArgs $ fmap (searchResultToHQText searchRoot &&& SA.SearchResult searchRoot) results results' <- Cli.runTransaction (Backend.loadSearchResults codebase results) Cli.respond $ ListOfDefinitions fscope suffixifiedPPE isVerbose results' results <- getResults names @@ -1550,8 +1556,8 @@ handleDependencies hq = do let types = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ fst <$> results) let terms = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ snd <$> results) Cli.setNumberedArgs $ - map (Text.unpack . Reference.toText . snd) types - <> map (Text.unpack . Reference.toText . Referent.toReference . snd) terms + map ((Reference.toText &&& SA.Ref) . snd) types + <> map ((Reference.toText &&& SA.Ref) . Referent.toReference . snd) terms Cli.respond $ ListDependencies suffixifiedPPE lds (fst <$> types) (fst <$> terms) handleDependents :: HQ.HashQualified Name -> Cli () @@ -1588,7 +1594,7 @@ handleDependents hq = do let sort = nubOrdOn snd . Name.sortByText (HQ.toText . fst) let types = sort [(n, r) | (False, n, r) <- join results] let terms = sort [(n, r) | (True, n, r) <- join results] - Cli.setNumberedArgs $ map (Text.unpack . Reference.toText . view _2) (types <> terms) + Cli.setNumberedArgs . map ((Reference.toText &&& SA.Ref) . view _2) $ types <> terms Cli.respond (ListDependents ppe lds (fst <$> types) (fst <$> terms)) handleDiffNamespaceToPatch :: Text -> DiffNamespaceToPatchInput -> Cli () @@ -1769,9 +1775,7 @@ doShowTodoOutput patch scopePath = do then Cli.respond NoConflictsOrEdits else do Cli.setNumberedArgs - ( Text.unpack . Reference.toText . view _2 - <$> fst (TO.todoFrontierDependents todo) - ) + ((Reference.toText &&& SA.Ref) . view _2 <$> fst (TO.todoFrontierDependents todo)) pped <- Cli.currentPrettyPrintEnvDecl Cli.respondNumbered $ TodoOutput pped todo @@ -1817,11 +1821,11 @@ confirmedCommand i = do loopState <- State.get pure $ Just i == (loopState ^. #lastInput) --- | restores the full hash to these search results, for _numberedArgs purposes -searchResultToHQString :: Maybe Path -> SearchResult -> String -searchResultToHQString oprefix = \case - SR.Tm' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify (addPrefix <$> n) r - SR.Tp' n r _ -> Text.unpack $ HQ.toText $ HQ.requalify (addPrefix <$> n) (Referent.Ref r) +--- | restores the full hash to these search results, for _numberedArgs purposes +searchResultToHQText :: Maybe Path -> SearchResult -> Text +searchResultToHQText oprefix = \case + SR.Tm' n r _ -> HQ.toText $ HQ.requalify (addPrefix <$> n) r + SR.Tp' n r _ -> HQ.toText $ HQ.requalify (addPrefix <$> n) (Referent.Ref r) _ -> error "impossible match failure" where addPrefix :: Name -> Name diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs index 83cc5486e..9ad17bbcc 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs @@ -4,6 +4,7 @@ module Unison.Codebase.Editor.HandleInput.FindAndReplace ) where +import Control.Arrow ((&&&)) import Control.Lens hiding (at) import Control.Monad.Reader (ask) import Control.Monad.State @@ -18,6 +19,7 @@ import Unison.Cli.Pretty qualified as P import Unison.Codebase qualified as Codebase import Unison.Codebase.Branch.Names qualified as Branch import Unison.Codebase.Editor.Output +import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) @@ -87,7 +89,7 @@ handleStructuredFindI rule = do ok t = pure (t, False) results0 <- traverse ok results let results = Alphabetical.sortAlphabeticallyOn fst [(hq, r) | ((hq, r), True) <- results0] - let toNumArgs = Text.unpack . Reference.toText . Referent.toReference . view _2 + let toNumArgs = (Reference.toText &&& SA.Ref) . Referent.toReference . view _2 Cli.setNumberedArgs $ map toNumArgs results Cli.respond (ListStructuredFind (fst <$> results)) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 28ec687de..751292ba9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -36,6 +36,7 @@ import Unison.Codebase.Editor.Output.PushPull (PushPull) import Unison.Codebase.Editor.RemoteRepo import Unison.Codebase.Editor.SlurpResult (SlurpResult (..)) import Unison.Codebase.Editor.SlurpResult qualified as SR +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) import Unison.Codebase.Editor.TodoOutput qualified as TO import Unison.Codebase.IntegrityCheck (IntegrityResult (..)) import Unison.Codebase.Patch (Patch) @@ -84,7 +85,12 @@ type ListDetailed = Bool type SourceName = Text -type NumberedArgs = [String] +-- | +-- +-- __NB__: This only temporarily holds `Text`. Until all of the inputs are +-- updated to handle `StructuredArgument`s, we need to ensure that the +-- serialization remains unchanged. +type NumberedArgs = [(Text, StructuredArgument)] type HashLength = Int diff --git a/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs b/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs new file mode 100644 index 000000000..935d6ccd2 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs @@ -0,0 +1,31 @@ +module Unison.Codebase.Editor.StructuredArgument where + +import GHC.Generics (Generic) +import U.Codebase.HashTags (CausalHash) +import Unison.Codebase.Editor.Input +import Unison.Codebase.Path (Path, Path') +import Unison.Codebase.Path qualified as Path +import Unison.HashQualified qualified as HQ +import Unison.HashQualified' qualified as HQ' +import Unison.Name (Name) +import Unison.Parser.Ann (Ann) +import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) +import Unison.Reference (Reference) +import Unison.Server.Backend (ShallowListEntry) +import Unison.Server.SearchResult (SearchResult) +import Unison.Symbol (Symbol) + +-- | The types that can be referenced by a numeric command argument. +data StructuredArgument + = AbsolutePath Path.Absolute + | Name Name + | HashQualified (HQ.HashQualified Name) + | Project ProjectName + | ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + | Ref Reference + | Namespace CausalHash + | NameWithBranchPrefix AbsBranchId Name + | HashQualifiedWithBranchPrefix AbsBranchId (HQ'.HashQualified Name) + | ShallowListEntry Path' (ShallowListEntry Symbol Ann) + | SearchResult (Maybe Path) SearchResult + deriving (Eq, Generic, Show) diff --git a/unison-cli/src/Unison/CommandLine.hs b/unison-cli/src/Unison/CommandLine.hs index 38d53a4a8..41cf3ae96 100644 --- a/unison-cli/src/Unison/CommandLine.hs +++ b/unison-cli/src/Unison/CommandLine.hs @@ -173,7 +173,7 @@ expandNumber :: NumberedArgs -> String -> [String] expandNumber numberedArgs s = case expandedNumber of Nothing -> [s] Just nums -> - [s | i <- nums, Just s <- [vargs Vector.!? (i - 1)]] + [Text.unpack (fst s) | i <- nums, Just s <- [vargs Vector.!? (i - 1)]] where vargs = Vector.fromList numberedArgs rangeRegex = "([0-9]+)-([0-9]+)" :: String diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 3464235f1..af5b1fa1c 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -5,6 +5,7 @@ module Unison.CommandLine.OutputMessages where +import Control.Arrow ((&&&)) import Control.Lens hiding (at) import Control.Monad.State import Control.Monad.State.Strict qualified as State @@ -61,6 +62,8 @@ import Unison.Codebase.Editor.Output.PushPull qualified as PushPull import Unison.Codebase.Editor.RemoteRepo (ShareUserHandle (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..)) import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) +import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.Codebase.Editor.TodoOutput qualified as TO import Unison.Codebase.GitError import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors) @@ -348,7 +351,7 @@ notifyNumbered = \case ] branchHashes :: [CausalHash] branchHashes = (fst <$> reversedHistory) <> tailHashes - in (msg, displayBranchHash <$> branchHashes) + in (msg, (displayBranchHash &&& SA.Namespace) <$> branchHashes) where toSCH :: CausalHash -> ShortCausalHash toSCH h = SCH.fromHash schLength h @@ -407,7 +410,7 @@ notifyNumbered = \case ListEdits patch ppe -> showListEdits patch ppe ListProjects projects -> ( P.numberedList (map (prettyProjectName . view #name) projects), - map (Text.unpack . into @Text . view #name) projects + map ((into @Text &&& SA.Project) . view #name) projects ) ListBranches projectName branches -> ( P.columnNHeader @@ -423,7 +426,13 @@ notifyNumbered = \case ] : map (\branch -> ["", "", prettyRemoteBranchInfo branch]) remoteBranches ), - map (\(branchName, _) -> Text.unpack (into @Text (ProjectAndBranch projectName branchName))) branches + map + ( ( (into @Text . ProjectAndBranch projectName) + &&& (SA.ProjectBranch . ProjectAndBranch (pure projectName)) + ) + . fst + ) + branches ) AmbiguousSwitch project (ProjectAndBranch currentProject branch) -> ( P.wrap @@ -448,8 +457,11 @@ notifyNumbered = \case <> switch ["2"] <> " to pick one of these." ), - [ Text.unpack (Text.cons '/' (into @Text branch)), - Text.unpack (into @Text (ProjectAndBranch project (UnsafeProjectBranchName "main"))) + [ (Text.cons '/' . into @Text &&& SA.ProjectBranch . ProjectAndBranch Nothing) branch, + ( (into @Text . ProjectAndBranch project) + &&& (SA.ProjectBranch . ProjectAndBranch (pure project)) + ) + $ UnsafeProjectBranchName "main" ] ) where @@ -478,8 +490,8 @@ notifyNumbered = \case <> reset (resetArgs ["2"]) <> " to pick one of these." ), - [ Text.unpack (Text.cons '/' (into @Text branch)), - Text.unpack (into @Text (show absPath0)) + [ (Text.cons '/' . into @Text &&& SA.ProjectBranch . ProjectAndBranch Nothing) branch, + (into @Text . show &&& SA.AbsolutePath) absPath0 ] ) where @@ -515,13 +527,13 @@ notifyNumbered = \case newNextNum = nextNum + length unnumberedNames in ( newNextNum, ( nameToNum <> (Map.fromList (zip unnumberedNames [nextNum ..])), - args <> fmap Name.toText unnumberedNames + args <> unnumberedNames ) ) ) (1, (mempty, mempty)) & snd - & over (_2 . mapped) Text.unpack + & over (_2 . mapped) (Name.toText &&& SA.Name) externalDepsTable :: Map LabeledDependency (Set Name) -> [(P.Pretty P.ColorText, P.Pretty P.ColorText)] externalDepsTable = ifoldMap $ \ld dependents -> [(prettyLD ld, prettyDependents dependents)] @@ -601,7 +613,7 @@ showListEdits patch ppe = let lhsTermName = PPE.termName ppe (Referent.Ref lhsRef) -- We use the shortHash of the lhs rather than its name for numbered args, -- since its name is likely to be "historical", and won't work if passed to a ucm command. - let lhsHash = Text.unpack . ShortHash.toText . Reference.toShortHash $ lhsRef + let lhsHash = (ShortHash.toText . Reference.toShortHash &&& SA.Ref) $ lhsRef case termEdit of TermEdit.Deprecate -> do lift $ tell ([lhsHash], []) @@ -612,7 +624,7 @@ showListEdits patch ppe = TermEdit.Replace rhsRef _typing -> do n2 <- gets snd <* modify (second succ) let rhsTermName = PPE.termName ppe (Referent.Ref rhsRef) - lift $ tell ([lhsHash], [Text.unpack (HQ.toText rhsTermName)]) + lift $ tell ([lhsHash], [(HQ.toText &&& SA.HashQualified) rhsTermName]) pure ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTermName), "-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTermName) @@ -626,7 +638,7 @@ showListEdits patch ppe = let lhsTypeName = PPE.typeName ppe lhsRef -- We use the shortHash of the lhs rather than its name for numbered args, -- since its name is likely to be "historical", and won't work if passed to a ucm command. - let lhsHash = Text.unpack . ShortHash.toText . Reference.toShortHash $ lhsRef + let lhsHash = (ShortHash.toText . Reference.toShortHash &&& SA.Ref) $ lhsRef case typeEdit of TypeEdit.Deprecate -> do lift $ tell ([lhsHash], []) @@ -637,7 +649,7 @@ showListEdits patch ppe = TypeEdit.Replace rhsRef -> do n2 <- gets snd <* modify (second succ) let rhsTypeName = PPE.typeName ppe rhsRef - lift $ tell ([lhsHash], [Text.unpack (HQ.toText rhsTypeName)]) + lift $ tell ([lhsHash], [(HQ.toText &&& SA.HashQualified) rhsTypeName]) pure ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTypeName), "-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTypeName) @@ -1651,7 +1663,7 @@ notifyUser dir = \case prettyNamespaceKey dest <> "is already up-to-date with" <> P.group (prettyNamespaceKey src <> ".") - DumpNumberedArgs args -> pure . P.numberedList $ fmap P.string args + DumpNumberedArgs args -> pure . P.numberedList $ fmap (P.text . fst) args NoConflictsOrEdits -> pure (P.okCallout "No conflicts or edits in progress.") HelpMessage pat -> pure $ IP.showPatternHelp pat @@ -2717,7 +2729,7 @@ renderNameConflicts ppe conflictedNames = do P.lines <$> do for (Map.toList conflictedNames) $ \(name, hashes) -> do prettyConflicts <- for hashes \hash -> do - n <- addNumberedArg (Text.unpack (HQ.toText hash)) + n <- addNumberedArg $ (HQ.toText &&& SA.HashQualified) hash pure $ formatNum n <> (P.blue . P.syntaxToColor . prettyHashQualified $ hash) pure . P.wrap $ ( "The " @@ -2749,7 +2761,7 @@ renderEditConflicts ppe Patch {..} = do <> (fmap Right . Map.toList . R.toMultimap . R.filterManyDom $ _termEdits) numberedHQName :: HQ.HashQualified Name -> Numbered Pretty numberedHQName hqName = do - n <- addNumberedArg (Text.unpack (HQ.toText hqName)) + n <- addNumberedArg $ (HQ.toText &&& SA.HashQualified) hqName pure $ formatNum n <> styleHashQualified P.bold hqName formatTypeEdits :: (Reference, Set TypeEdit.TypeEdit) -> @@ -2788,9 +2800,9 @@ renderEditConflicts ppe Patch {..} = do Numbered Pretty formatConflict = either formatTypeEdits formatTermEdits -type Numbered = State.State (Int, Seq.Seq String) +type Numbered = State.State (Int, Seq.Seq (Text, StructuredArgument)) -addNumberedArg :: String -> Numbered Int +addNumberedArg :: (Text, StructuredArgument) -> Numbered Int addNumberedArg s = do (n, args) <- State.get State.put (n + 1, args Seq.|> s) @@ -2862,11 +2874,11 @@ todoOutput ppe todo = runNumbered do todoEdits :: Numbered Pretty todoEdits = do numberedTypes <- for (unscore <$> dirtyTypes) \(ref, displayObj) -> do - n <- addNumberedArg (Text.unpack (HQ.toText $ PPE.typeName ppeu ref)) + n <- addNumberedArg . (HQ.toText &&& SA.HashQualified) $ PPE.typeName ppeu ref pure $ formatNum n <> prettyDeclPair ppeu (ref, displayObj) let filteredTerms = goodTerms (unscore <$> dirtyTerms) termNumbers <- for filteredTerms \(ref, _, _) -> do - n <- addNumberedArg (Text.unpack (HQ.toText $ PPE.termName ppeu ref)) + n <- addNumberedArg . (HQ.toText &&& SA.HashQualified) $ PPE.termName ppeu ref pure $ formatNum n let formattedTerms = TypePrinter.prettySignaturesCT ppes filteredTerms numberedTerms = zipWith (<>) termNumbers formattedTerms @@ -3166,7 +3178,7 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = [] -> mempty x : ys -> " (" <> P.commas (x <> " updates" : ys) <> ")" pure $ n <> P.bold " patch " <> prettyName name <> message - -- 18. patch q + -- 18. patch q prettyNamePatch prefix (name, _patchDiff) = do n <- numPatch prefix name pure $ n <> P.bold " patch " <> prettyName name @@ -3271,21 +3283,21 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = -- DeclPrinter.prettyDeclHeader : HQ -> Either numPatch :: Input.AbsBranchId -> Name -> Numbered Pretty numPatch prefix name = - addNumberedArg' $ prefixBranchId prefix name + addNumberedArg' $ (prefixBranchId prefix &&& SA.NameWithBranchPrefix prefix) name numHQ' :: Input.AbsBranchId -> HQ'.HashQualified Name -> Referent -> Numbered Pretty numHQ' prefix hq r = - addNumberedArg' . HQ'.toStringWith (prefixBranchId prefix) . HQ'.requalify hq $ r + addNumberedArg' . (HQ'.toTextWith (prefixBranchId prefix) &&& SA.HashQualifiedWithBranchPrefix prefix) $ HQ'.requalify hq r -- E.g. - -- prefixBranchId "#abcdef" "base.List.map" -> "#abcdef.base.List.map" + -- prefixBranchId "#abcdef" "base.List.map" -> "#abcdef:.base.List.map" -- prefixBranchId ".base" "List.map" -> ".base.List.map" - prefixBranchId :: Input.AbsBranchId -> Name -> String + prefixBranchId :: Input.AbsBranchId -> Name -> Text prefixBranchId branchId name = case branchId of - Left sch -> "#" <> SCH.toString sch <> ":" <> Text.unpack (Name.toText (Name.makeAbsolute name)) - Right pathPrefix -> Text.unpack (Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name)) + Left sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name) + Right pathPrefix -> Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name) - addNumberedArg' :: String -> Numbered Pretty + addNumberedArg' :: (Text, StructuredArgument) -> Numbered Pretty addNumberedArg' s = case sn of ShowNumbers -> do n <- addNumberedArg s @@ -3540,7 +3552,7 @@ numberedArgsForEndangerments (PPED.unsuffixifiedPPE -> ppe) m = m & Map.elems & concatMap toList - & fmap (Text.unpack . HQ.toText . PPE.labeledRefName ppe) + & fmap ((HQ.toText &&& SA.HashQualified) . PPE.labeledRefName ppe) -- | Format and render all dependents which are endangered by references going extinct. endangeredDependentsTable :: diff --git a/unison-cli/tests/Unison/Test/Cli/Monad.hs b/unison-cli/tests/Unison/Test/Cli/Monad.hs index 3b9407da1..0edb1dc3d 100644 --- a/unison-cli/tests/Unison/Test/Cli/Monad.hs +++ b/unison-cli/tests/Unison/Test/Cli/Monad.hs @@ -6,6 +6,8 @@ where import Control.Lens import EasyTest import Unison.Cli.Monad qualified as Cli +import Unison.Codebase.Editor.StructuredArgument qualified as SA +import Unison.Reference qualified as Reference test :: Test () test = @@ -16,13 +18,13 @@ test = Cli.runCli dummyEnv dummyLoopState do Cli.label \goto -> do Cli.label \_ -> do - Cli.setNumberedArgs ["foo"] + Cli.setNumberedArgs [SA.Ref $ Reference.ReferenceBuiltin "foo"] goto (1 :: Int) pure 2 -- test that 'goto' short-circuits, as expected expectEqual' (Cli.Success 1) r -- test that calling 'goto' doesn't lose state changes made along the way - expectEqual' ["foo"] (state ^. #numberedArgs) + expectEqual' [SA.Ref $ Reference.ReferenceBuiltin "foo"] (state ^. #numberedArgs) ok ] diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index 804f0f4ef..43b6756ff 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -93,6 +93,7 @@ library Unison.Codebase.Editor.Slurp Unison.Codebase.Editor.SlurpComponent Unison.Codebase.Editor.SlurpResult + Unison.Codebase.Editor.StructuredArgument Unison.Codebase.Editor.TodoOutput Unison.Codebase.Editor.UCMVersion Unison.Codebase.Editor.UriParser From 8a95c5fe52f5f4395b21bacd542080ab5ff15616 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Tue, 14 May 2024 21:18:08 -0600 Subject: [PATCH 54/82] Push `StructuredArgument`s into `InputPattern`s MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This forces each `InputPattern.parse` function to serialize any `StructuredArgument` in its arguments. It’s a stop-gap that allows us to incrementally handle the structured arguments command-by-command. --- unison-cli/src/Unison/CommandLine.hs | 27 +- .../src/Unison/CommandLine/InputPattern.hs | 13 +- .../src/Unison/CommandLine/InputPatterns.hs | 548 ++++++++++-------- unison-cli/src/Unison/CommandLine/Main.hs | 7 +- 4 files changed, 332 insertions(+), 263 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine.hs b/unison-cli/src/Unison/CommandLine.hs index 41cf3ae96..2c8be9bf4 100644 --- a/unison-cli/src/Unison/CommandLine.hs +++ b/unison-cli/src/Unison/CommandLine.hs @@ -131,7 +131,7 @@ parseInput :: [String] -> -- Returns either an error message or the fully expanded arguments list and parsed input. -- If the output is `Nothing`, the user cancelled the input (e.g. ctrl-c) - IO (Either (P.Pretty CT.ColorText) (Maybe ([String], Input))) + IO (Either (P.Pretty CT.ColorText) (Maybe (InputPattern.Arguments, Input))) parseInput codebase currentPath numberedArgs patterns segments = runExceptT do let getCurrentBranch0 :: IO (Branch0 IO) getCurrentBranch0 = Branch.head <$> Codebase.getBranchAtPath codebase currentPath @@ -141,16 +141,16 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do [] -> throwE "" command : args -> case Map.lookup command patterns of Just pat@(InputPattern {parse, help}) -> do - let expandedNumbers :: [String] + let expandedNumbers :: InputPattern.Arguments expandedNumbers = - foldMap (expandNumber numberedArgs) args + foldMap (\arg -> maybe [Left arg] (fmap pure) $ expandNumber numberedArgs arg) args lift (fzfResolve codebase projCtx getCurrentBranch0 pat expandedNumbers) >>= \case Left (NoFZFResolverForArgumentType _argDesc) -> throwError help Left (NoFZFOptions argDesc) -> throwError (noCompletionsMessage argDesc) Left FZFCancelled -> pure Nothing Right resolvedArgs -> do parsedInput <- except . parse $ resolvedArgs - pure $ Just (command : resolvedArgs, parsedInput) + pure $ Just (Left command : resolvedArgs, parsedInput) Nothing -> throwE . warn @@ -169,11 +169,9 @@ parseInput codebase currentPath numberedArgs patterns segments = runExceptT do ] -- Expand a numeric argument like `1` or a range like `3-9` -expandNumber :: NumberedArgs -> String -> [String] -expandNumber numberedArgs s = case expandedNumber of - Nothing -> [s] - Just nums -> - [Text.unpack (fst s) | i <- nums, Just s <- [vargs Vector.!? (i - 1)]] +expandNumber :: NumberedArgs -> String -> Maybe NumberedArgs +expandNumber numberedArgs s = + (\nums -> [arg | i <- nums, Just arg <- [vargs Vector.!? (i - 1)]]) <$> expandedNumber where vargs = Vector.fromList numberedArgs rangeRegex = "([0-9]+)-([0-9]+)" :: String @@ -194,13 +192,13 @@ data FZFResolveFailure | NoFZFOptions Text {- argument description -} | FZFCancelled -fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> [String] -> IO (Either FZFResolveFailure [String]) +fzfResolve :: Codebase IO Symbol Ann -> ProjectContext -> (IO (Branch0 IO)) -> InputPattern -> InputPattern.Arguments -> IO (Either FZFResolveFailure InputPattern.Arguments) fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do -- We resolve args in two steps, first we check that all arguments that will require a fzf -- resolver have one, and only if so do we prompt the user to actually do a fuzzy search. -- Otherwise, we might ask the user to perform a search only to realize we don't have a resolver -- for a later arg. - argumentResolvers :: [ExceptT FZFResolveFailure IO [String]] <- + argumentResolvers :: [ExceptT FZFResolveFailure IO InputPattern.Arguments] <- (Align.align (InputPattern.args pat) args) & traverse \case This (argName, opt, InputPattern.ArgumentType {fzfResolver}) @@ -213,7 +211,7 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do These _ arg -> pure $ pure [arg] argumentResolvers & foldMapM id where - fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO [String] + fuzzyFillArg :: InputPattern.IsOptional -> Text -> InputPattern.FZFResolver -> ExceptT FZFResolveFailure IO InputPattern.Arguments fuzzyFillArg opt argDesc InputPattern.FZFResolver {getOptions} = do currentBranch <- Branch.withoutTransitiveLibs <$> liftIO getCurrentBranch options <- liftIO $ getOptions codebase projCtx currentBranch @@ -224,8 +222,9 @@ fzfResolve codebase projCtx getCurrentBranch pat args = runExceptT do `whenNothingM` throwError FZFCancelled -- If the user triggered the fuzzy finder, but selected nothing, abort the command rather than continuing execution -- with no arguments. - when (null results) $ throwError FZFCancelled - pure (Text.unpack <$> results) + if null results + then throwError FZFCancelled + else pure (Left . Text.unpack <$> results) multiSelectForOptional :: InputPattern.IsOptional -> Bool multiSelectForOptional = \case diff --git a/unison-cli/src/Unison/CommandLine/InputPattern.hs b/unison-cli/src/Unison/CommandLine/InputPattern.hs index f72506bab..15f58eb73 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -4,8 +4,10 @@ module Unison.CommandLine.InputPattern ( InputPattern (..), + Argument, ArgumentType (..), ArgumentDescription, + Arguments, argType, FZFResolver (..), IsOptional (..), @@ -25,6 +27,7 @@ import System.Console.Haskeline qualified as Line import Unison.Auth.HTTPClient (AuthenticatedHttpClient) import Unison.Codebase (Codebase) import Unison.Codebase.Editor.Input (Input (..)) +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) import Unison.Codebase.Path as Path import Unison.CommandLine.FZFResolvers (FZFResolver (..)) import Unison.Prelude @@ -44,6 +47,14 @@ data IsOptional data Visibility = Hidden | Visible deriving (Show, Eq, Ord) +-- | An argument to a command is either a string provided by the user which +-- needs to be parsed or a numbered argument that doesn’t need to be parsed, as +-- we’ve preserved its representation (although the numbered argument could +-- still be of the wrong type, which should result in an error). +type Argument = Either String (Text, StructuredArgument) + +type Arguments = [Argument] + -- | Argument description -- It should fit grammatically into sentences like "I was expecting an argument for the " -- e.g. "namespace to merge", "definition to delete", "remote target to push to" etc. @@ -55,7 +66,7 @@ data InputPattern = InputPattern visibility :: Visibility, -- Allow hiding certain commands when debugging or work-in-progress args :: [(ArgumentDescription, IsOptional, ArgumentType)], help :: P.Pretty CT.ColorText, - parse :: [String] -> Either (P.Pretty CT.ColorText) Input + parse :: Arguments -> Either (P.Pretty CT.ColorText) Input } data ArgumentType = ArgumentType diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 906804251..f82e3c8dc 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -66,6 +66,26 @@ import Unison.Util.ColorText qualified as CT import Unison.Util.Monoid (intercalateMap) import Unison.Util.Pretty qualified as P +-- | +-- +-- __TODO__: Temporary. This may stick around in a handful of cases, but it’ll +-- have to actually serialize the `StructuredArgument` rather than +-- relying on the parallel `Text`. +unifyArgument :: I.Argument -> String +unifyArgument = either id (Text.unpack . fst) + +-- | Reversed composition, here temporarily to support the deferred parsing. +-- +-- __TODO__: Temporary. +andThen :: (a -> b) -> (b -> c) -> a -> c +andThen = flip (.) + +-- | +-- +-- __TODO__: Temporary. +unifyArguments :: [I.Argument] -> [String] +unifyArguments = fmap unifyArgument + showPatternHelp :: InputPattern -> P.Pretty CT.ColorText showPatternHelp i = P.lines @@ -107,7 +127,7 @@ mergeBuiltins = I.Hidden [("namespace", Optional, namespaceArg)] "Adds the builtins (excluding `io` and misc) to the specified namespace. Defaults to `builtin.`" - \case + $ unifyArguments `andThen` \case [] -> pure . Input.MergeBuiltinsI $ Nothing [p] -> first P.text do p <- Path.parsePath p @@ -122,7 +142,7 @@ mergeIOBuiltins = I.Hidden [("namespace", Optional, namespaceArg)] "Adds all the builtins, including `io` and misc., to the specified namespace. Defaults to `builtin.`" - \case + $ unifyArguments `andThen` \case [] -> pure . Input.MergeIOBuiltinsI $ Nothing [p] -> first P.text do p <- Path.parsePath p @@ -162,7 +182,7 @@ todo = ) ] ) - ( \case + ( unifyArguments `andThen` \case patchStr : ws -> mapLeft (warn . P.text) $ do patch <- Path.parseSplit' patchStr branch <- case ws of @@ -189,7 +209,7 @@ load = ) ] ) - ( \case + ( unifyArguments `andThen` \case [] -> pure $ Input.LoadI Nothing [file] -> pure $ Input.LoadI . Just $ file _ -> Left (I.help load) @@ -223,7 +243,7 @@ add = ( "`add` adds to the codebase all the definitions from the most recently " <> "typechecked file." ) - \ws -> pure $ Input.AddI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) + $ pure . Input.AddI . Set.fromList . map (Name.unsafeParseText . Text.pack) . unifyArguments previewAdd :: InputPattern previewAdd = @@ -237,7 +257,7 @@ previewAdd = <> "results. Use `load` to reparse & typecheck the file if the context " <> "has changed." ) - \ws -> pure $ Input.PreviewAddI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) + $ pure . Input.PreviewAddI . Set.fromList . map (Name.unsafeParseText . Text.pack) . unifyArguments update :: InputPattern update = @@ -284,12 +304,11 @@ updateOldNoPatch = ) ] ) - ( \case - ws -> do - pure $ - Input.UpdateI - Input.NoPatch - (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) + ( pure + . Input.UpdateI Input.NoPatch + . Set.fromList + . map (Name.unsafeParseText . Text.pack) + . unifyArguments ) updateOld :: InputPattern @@ -324,7 +343,7 @@ updateOld = ) ] ) - \case + $ unifyArguments `andThen` \case patchStr : ws -> do patch <- first P.text $ Path.parseSplit' patchStr pure $ @@ -345,7 +364,7 @@ previewUpdate = <> "typechecking results. Use `load` to reparse & typecheck the file if " <> "the context has changed." ) - \ws -> pure $ Input.PreviewUpdateI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) + $ pure . Input.PreviewUpdateI . Set.fromList . map (Name.unsafeParseText . Text.pack) . unifyArguments patch :: InputPattern patch = @@ -373,7 +392,7 @@ patch = ] ] ) - \case + $ unifyArguments `andThen` \case patchStr : ws -> first P.text do patch <- Path.parseSplit' patchStr branch <- case ws of @@ -404,7 +423,7 @@ view = <> "not `List.map.doc` (since ? only matches 1 name segment)." ] ) - ( \case + ( unifyArguments `andThen` \case (x : xs) -> (x NE.:| xs) & traverse parseHashQualifiedName @@ -424,7 +443,7 @@ viewGlobal = "`view.global` without arguments invokes a search to select definitions to view, which requires that `fzf` can be found within your PATH." ] ) - ( \case + ( unifyArguments `andThen` \case (x : xs) -> (x NE.:| xs) & traverse parseHashQualifiedName @@ -444,7 +463,7 @@ display = "`display` without arguments invokes a search to select a definition to display, which requires that `fzf` can be found within your PATH." ] ) - \case + $ unifyArguments `andThen` \case (x : xs) -> (x NE.:| xs) & traverse parseHashQualifiedName @@ -462,7 +481,7 @@ displayTo = makeExample displayTo ["", "foo"] <> "prints a rendered version of the term `foo` to the given file." ) - \case + $ unifyArguments `andThen` \case file : (x : xs) -> (x NE.:| xs) & traverse parseHashQualifiedName @@ -481,7 +500,7 @@ docs = "`docs` without arguments invokes a search to select which definition to view documentation for, which requires that `fzf` can be found within your PATH." ] ) - ( \case + ( unifyArguments `andThen` \case x : xs -> (x NE.:| xs) & traverse Path.parseHQSplit' @@ -507,12 +526,13 @@ ui = visibility = I.Visible, args = [("definition to load", Optional, namespaceOrDefinitionArg)], help = P.wrap "`ui` opens the Local UI in the default browser.", - parse = \case - [] -> pure $ Input.UiI Path.relativeEmpty' - [path] -> first P.text $ do - p <- Path.parsePath' path - pure $ Input.UiI p - _ -> Left (I.help ui) + parse = + unifyArguments `andThen` \case + [] -> pure $ Input.UiI Path.relativeEmpty' + [path] -> first P.text $ do + p <- Path.parsePath' path + pure $ Input.UiI p + _ -> Left (I.help ui) } undo :: InputPattern @@ -535,11 +555,12 @@ viewByPrefix = "`view.recursive Foo` prints the definitions of `Foo` and `Foo.blah`." ( fmap (Input.ShowDefinitionByPrefixI Input.ConsoleLocation) . traverse parseHashQualifiedName + . unifyArguments ) sfind :: InputPattern sfind = - InputPattern "rewrite.find" ["sfind"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse + InputPattern "rewrite.find" ["sfind"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg $ parse . unifyArguments where parse [q] = Input.StructuredFindI (Input.FindLocal Path.empty) <$> parseHashQualifiedName q parse _ = Left "expected exactly one argument" @@ -570,7 +591,7 @@ sfind = sfindReplace :: InputPattern sfindReplace = - InputPattern "rewrite" ["sfind.replace"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse + InputPattern "rewrite" ["sfind.replace"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg $ parse . unifyArguments where parse [q] = Input.StructuredFindReplaceI <$> parseHashQualifiedName q parse _ = Left "expected exactly one argument" @@ -619,7 +640,7 @@ findIn' cmd mkfscope = I.Visible [("namespace", Required, namespaceArg), ("query", ZeroPlus, exactDefinitionArg)] findHelp - \case + $ unifyArguments `andThen` \case p : args -> first P.text do p <- Path.parsePath p pure (Input.FindI False (mkfscope p) args) @@ -669,7 +690,7 @@ find' cmd fscope = I.Visible [("query", ZeroPlus, exactDefinitionArg)] findHelp - (pure . Input.FindI False fscope) + (pure . Input.FindI False fscope . unifyArguments) findShallow :: InputPattern findShallow = @@ -684,7 +705,7 @@ findShallow = ("`list .foo`", "lists the '.foo' namespace.") ] ) - ( \case + ( unifyArguments `andThen` \case [] -> pure $ Input.FindShallowI Path.relativeEmpty' [path] -> first P.text $ do p <- Path.parsePath' path @@ -702,7 +723,7 @@ findVerbose = ( "`find.verbose` searches for definitions like `find`, but includes hashes " <> "and aliases in the results." ) - (pure . Input.FindI True (Input.FindLocal Path.empty)) + (pure . Input.FindI True (Input.FindLocal Path.empty) . unifyArguments) findVerboseAll :: InputPattern findVerboseAll = @@ -714,7 +735,7 @@ findVerboseAll = ( "`find.all.verbose` searches for definitions like `find.all`, but includes hashes " <> "and aliases in the results." ) - (pure . Input.FindI True (Input.FindLocalAndDeps Path.empty)) + (pure . Input.FindI True (Input.FindLocalAndDeps Path.empty) . unifyArguments) findPatch :: InputPattern findPatch = @@ -738,7 +759,7 @@ renameTerm = ("new location", Required, newNameArg) ] "`move.term foo bar` renames `foo` to `bar`." - ( \case + ( unifyArguments `andThen` \case [oldName, newName] -> first P.text do src <- Path.parseHQSplit' oldName target <- Path.parseSplit' newName @@ -759,7 +780,7 @@ moveAll = ("new location", Required, newNameArg) ] "`move foo bar` renames the term, type, and namespace foo to bar." - ( \case + ( unifyArguments `andThen` \case [oldName, newName] -> first P.text $ do src <- Path.parsePath' oldName target <- Path.parsePath' newName @@ -780,7 +801,7 @@ renameType = ("new location", Required, newNameArg) ] "`move.type foo bar` renames `foo` to `bar`." - ( \case + ( unifyArguments `andThen` \case [oldName, newName] -> first P.text do src <- Path.parseHQSplit' oldName target <- Path.parseSplit' newName @@ -828,7 +849,7 @@ deleteGen suffix queryCompletionArg target mkTarget = I.Visible [("definition to delete", OnePlus, queryCompletionArg)] info - ( \case + ( unifyArguments `andThen` \case [] -> Left . P.warnCallout $ P.wrap warn queries -> first P.text do paths <- traverse Path.parseHQSplit' queries @@ -876,7 +897,7 @@ deleteReplacement isTerm = <> str <> " - not the one in place after the edit." ) - ( \case + ( unifyArguments `andThen` \case query : patch -> do patch <- first P.text . traverse Path.parseSplit' $ listToMaybe patch q <- parseHashQualifiedName query @@ -912,11 +933,12 @@ deleteProject = P.wrapColumn2 [ ("`delete.project foo`", "deletes the local project `foo`") ], - parse = \case - [name] - | Right project <- tryInto @ProjectName (Text.pack name) -> - Right (Input.DeleteI (DeleteTarget'Project project)) - _ -> Left (showPatternHelp deleteProject) + parse = + unifyArguments `andThen` \case + [name] + | Right project <- tryInto @ProjectName (Text.pack name) -> + Right (Input.DeleteI (DeleteTarget'Project project)) + _ -> Left (showPatternHelp deleteProject) } deleteBranch :: InputPattern @@ -931,12 +953,13 @@ deleteBranch = [ ("`delete.branch foo/bar`", "deletes the branch `bar` in the project `foo`"), ("`delete.branch /bar`", "deletes the branch `bar` in the current project") ], - parse = \case - [name] -> - case tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack name) of - Left _ -> Left (showPatternHelp deleteBranch) - Right projectAndBranch -> Right (Input.DeleteI (DeleteTarget'ProjectBranch projectAndBranch)) - _ -> Left (showPatternHelp deleteBranch) + parse = + unifyArguments `andThen` \case + [name] -> + case tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack name) of + Left _ -> Left (showPatternHelp deleteBranch) + Right projectAndBranch -> Right (Input.DeleteI (DeleteTarget'ProjectBranch projectAndBranch)) + _ -> Left (showPatternHelp deleteBranch) } where suggestionsConfig = @@ -960,7 +983,7 @@ aliasTerm = I.Visible [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)] "`alias.term foo bar` introduces `bar` with the same definition as `foo`." - \case + $ unifyArguments `andThen` \case [oldName, newName] -> first P.text do source <- Path.parseShortHashOrHQSplit' oldName target <- Path.parseSplit' newName @@ -978,7 +1001,7 @@ aliasType = I.Visible [("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)] "`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`." - \case + $ unifyArguments `andThen` \case [oldName, newName] -> first P.text do source <- Path.parseShortHashOrHQSplit' oldName target <- Path.parseSplit' newName @@ -1004,7 +1027,7 @@ aliasMany = <> "creates aliases `.quux.foo.foo` and `.quux.bar.bar`." ] ) - \case + $ unifyArguments `andThen` \case srcs@(_ : _) Cons.:> dest -> first P.text do sourceDefinitions <- traverse Path.parseHQSplit srcs destNamespace <- Path.parsePath' dest @@ -1050,7 +1073,7 @@ cd = ] ] ) - \case + $ unifyArguments `andThen` \case [".."] -> Right Input.UpI [p] -> first P.text do p <- Path.parsePath' p @@ -1082,7 +1105,7 @@ deleteNamespace = I.Visible [("namespace to delete", Required, namespaceArg)] "`delete.namespace ` deletes the namespace `foo`" - (deleteNamespaceParser (I.help deleteNamespace) Input.Try) + (deleteNamespaceParser (I.help deleteNamespace) Input.Try . unifyArguments) deleteNamespaceForce :: InputPattern deleteNamespaceForce = @@ -1094,7 +1117,7 @@ deleteNamespaceForce = ( "`delete.namespace.force ` deletes the namespace `foo`," <> "deletion will proceed even if other code depends on definitions in foo." ) - (deleteNamespaceParser (I.help deleteNamespaceForce) Input.Force) + (deleteNamespaceParser (I.help deleteNamespaceForce) Input.Force . unifyArguments) deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> [String] -> Either (P.Pretty CT.ColorText) Input deleteNamespaceParser helpText insistence = \case @@ -1115,7 +1138,7 @@ deletePatch = I.Visible [("patch to delete", Required, patchArg)] "`delete.patch ` deletes the patch `foo`" - \case + $ unifyArguments `andThen` \case [p] -> first P.text do p <- Path.parseSplit' p pure . Input.DeleteI $ DeleteTarget'Patch p @@ -1141,7 +1164,7 @@ copyPatch = I.Visible [("patch to copy", Required, patchArg), ("copy destination", Required, newNameArg)] "`copy.patch foo bar` copies the patch `foo` to `bar`." - \case + $ unifyArguments `andThen` \case [src, dest] -> copyPatch' src dest _ -> Left (I.help copyPatch) @@ -1153,7 +1176,7 @@ renamePatch = I.Visible [("patch", Required, patchArg), ("new location", Required, newNameArg)] "`move.patch foo bar` renames the patch `foo` to `bar`." - \case + $ unifyArguments `andThen` \case [src, dest] -> movePatch src dest _ -> Left (I.help renamePatch) @@ -1165,7 +1188,7 @@ renameBranch = I.Visible [("namespace to move", Required, namespaceArg), ("new location", Required, newNameArg)] "`move.namespace foo bar` renames the path `foo` to `bar`." - \case + $ unifyArguments `andThen` \case [src, dest] -> first P.text do src <- Path.parsePath' src dest <- Path.parsePath' dest @@ -1188,7 +1211,7 @@ history = ) ] ) - \case + $ unifyArguments `andThen` \case [src] -> first P.text do p <- Input.parseBranchId src pure $ Input.HistoryI (Just 10) (Just 10) p @@ -1216,7 +1239,7 @@ forkLocal = ) ] ) - \case + $ unifyArguments `andThen` \case [src, dest] -> do src <- Input.parseBranchId2 src dest <- parseBranchRelativePath dest @@ -1239,15 +1262,18 @@ reset = ("`reset #pvfd222s8n /topic`", "reset the branch `topic` of the current project to the causal `#pvfd222s8n`.") ] ) - ( maybeToEither (I.help reset) . \case - arg0 : restArgs -> do - arg0 <- branchIdOrProject arg0 - arg1 <- case restArgs of - [] -> pure Nothing - arg1 : [] -> Just <$> parseLooseCodeOrProject arg1 - _ -> Nothing - Just (Input.ResetI arg0 arg1) - _ -> Nothing + ( maybeToEither (I.help reset) + . ( \case + arg0 : restArgs -> do + arg0 <- branchIdOrProject arg0 + arg1 <- case restArgs of + [] -> pure Nothing + arg1 : [] -> Just <$> parseLooseCodeOrProject arg1 + _ -> Nothing + Just (Input.ResetI arg0 arg1) + _ -> Nothing + ) + . unifyArguments ) where branchIdOrProject :: @@ -1293,7 +1319,7 @@ resetRoot = ] ] ) - \case + $ unifyArguments `andThen` \case [src] -> first P.text $ do src <- Input.parseBranchId src pure $ Input.ResetRootI src @@ -1361,21 +1387,24 @@ pullImpl name aliases verbosity pullMode addendum = do explainRemote Pull ], parse = - maybeToEither (I.help self) . \case - [] -> Just $ Input.PullRemoteBranchI Input.PullSourceTarget0 SyncMode.ShortCircuit pullMode verbosity - [sourceString] -> do - source <- parsePullSource (Text.pack sourceString) - Just $ Input.PullRemoteBranchI (Input.PullSourceTarget1 source) SyncMode.ShortCircuit pullMode verbosity - [sourceString, targetString] -> do - source <- parsePullSource (Text.pack sourceString) - target <- parseLooseCodeOrProject targetString - Just $ - Input.PullRemoteBranchI - (Input.PullSourceTarget2 source target) - SyncMode.ShortCircuit - pullMode - verbosity - _ -> Nothing + maybeToEither (I.help self) + . ( \case + [] -> Just $ Input.PullRemoteBranchI Input.PullSourceTarget0 SyncMode.ShortCircuit pullMode verbosity + [sourceString] -> do + source <- parsePullSource (Text.pack sourceString) + Just $ Input.PullRemoteBranchI (Input.PullSourceTarget1 source) SyncMode.ShortCircuit pullMode verbosity + [sourceString, targetString] -> do + source <- parsePullSource (Text.pack sourceString) + target <- parseLooseCodeOrProject targetString + Just $ + Input.PullRemoteBranchI + (Input.PullSourceTarget2 source target) + SyncMode.ShortCircuit + pullMode + verbosity + _ -> Nothing + ) + . unifyArguments } pullExhaustive :: InputPattern @@ -1396,32 +1425,35 @@ pullExhaustive = <> "versions M1l and earlier. It may be extra slow!" ] ) - ( maybeToEither (I.help pullExhaustive) . \case - [] -> - Just $ - Input.PullRemoteBranchI - Input.PullSourceTarget0 - SyncMode.Complete - Input.PullWithHistory - Verbosity.Verbose - [sourceString] -> do - source <- parsePullSource (Text.pack sourceString) - Just $ - Input.PullRemoteBranchI - (Input.PullSourceTarget1 source) - SyncMode.Complete - Input.PullWithHistory - Verbosity.Verbose - [sourceString, targetString] -> do - source <- parsePullSource (Text.pack sourceString) - target <- parseLooseCodeOrProject targetString - Just $ - Input.PullRemoteBranchI - (Input.PullSourceTarget2 source target) - SyncMode.Complete - Input.PullWithHistory - Verbosity.Verbose - _ -> Nothing + ( maybeToEither (I.help pullExhaustive) + . ( \case + [] -> + Just $ + Input.PullRemoteBranchI + Input.PullSourceTarget0 + SyncMode.Complete + Input.PullWithHistory + Verbosity.Verbose + [sourceString] -> do + source <- parsePullSource (Text.pack sourceString) + Just $ + Input.PullRemoteBranchI + (Input.PullSourceTarget1 source) + SyncMode.Complete + Input.PullWithHistory + Verbosity.Verbose + [sourceString, targetString] -> do + source <- parsePullSource (Text.pack sourceString) + target <- parseLooseCodeOrProject targetString + Just $ + Input.PullRemoteBranchI + (Input.PullSourceTarget2 source target) + SyncMode.Complete + Input.PullWithHistory + Verbosity.Verbose + _ -> Nothing + ) + . unifyArguments ) debugTabCompletion :: InputPattern @@ -1436,9 +1468,7 @@ debugTabCompletion = P.wrap $ "Completions which are finished are prefixed with a * represent finished completions." ] ) - ( \inputs -> - Right $ Input.DebugTabCompletionI inputs - ) + (Right . Input.DebugTabCompletionI . unifyArguments) debugFuzzyOptions :: InputPattern debugFuzzyOptions = @@ -1455,7 +1485,7 @@ debugFuzzyOptions = P.wrap $ "or `debug.fuzzy-options merge - _`" ] ) - \case + $ unifyArguments `andThen` \case (cmd : args) -> Right $ Input.DebugFuzzyOptionsI cmd args _ -> Left (I.help debugFuzzyOptions) @@ -1508,7 +1538,7 @@ push = explainRemote Push ] ) - \args -> do + $ unifyArguments `andThen` \args -> do sourceTarget <- case args of [] -> Right Input.PushSourceTarget0 @@ -1564,7 +1594,7 @@ pushCreate = explainRemote Push ] ) - \args -> do + $ unifyArguments `andThen` \args -> do sourceTarget <- case args of [] -> Right Input.PushSourceTarget0 @@ -1599,7 +1629,7 @@ pushForce = I.Hidden [("remote destination", Optional, remoteNamespaceArg), ("local source", Optional, namespaceOrProjectBranchArg suggestionsConfig)] (P.wrap "Like `push`, but overwrites any remote namespace.") - \args -> do + $ unifyArguments `andThen` \args -> do sourceTarget <- case args of [] -> Right Input.PushSourceTarget0 @@ -1644,7 +1674,7 @@ pushExhaustive = <> "versions M1l and earlier. It may be extra slow!" ] ) - \args -> do + $ unifyArguments `andThen` \args -> do sourceTarget <- case args of [] -> Right Input.PushSourceTarget0 @@ -1686,12 +1716,15 @@ squashMerge = <> "The resulting `dest` will have (at most) 1" <> "additional history entry.", parse = - maybeToEither (I.help squashMerge) . \case - [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - Just $ Input.MergeLocalBranchI src dest Branch.SquashMerge - _ -> Nothing + maybeToEither (I.help squashMerge) + . ( \case + [src, dest] -> do + src <- parseLooseCodeOrProject src + dest <- parseLooseCodeOrProject dest + Just $ Input.MergeLocalBranchI src dest Branch.SquashMerge + _ -> Nothing + ) + . unifyArguments } where suggestionsConfig = @@ -1731,15 +1764,18 @@ mergeLocal = ) ] ) - ( maybeToEither (I.help mergeLocal) . \case - [src] -> do - src <- parseLooseCodeOrProject src - Just $ Input.MergeLocalBranchI src (This Path.relativeEmpty') Branch.RegularMerge - [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - Just $ Input.MergeLocalBranchI src dest Branch.RegularMerge - _ -> Nothing + ( maybeToEither (I.help mergeLocal) + . ( \case + [src] -> do + src <- parseLooseCodeOrProject src + Just $ Input.MergeLocalBranchI src (This Path.relativeEmpty') Branch.RegularMerge + [src, dest] -> do + src <- parseLooseCodeOrProject src + dest <- parseLooseCodeOrProject dest + Just $ Input.MergeLocalBranchI src dest Branch.RegularMerge + _ -> Nothing + ) + . unifyArguments ) where config = @@ -1778,7 +1814,7 @@ diffNamespace = ) ] ) - ( \case + ( unifyArguments `andThen` \case [before, after] -> first P.text do before <- Input.parseBranchId before after <- Input.parseBranchId after @@ -1812,15 +1848,18 @@ previewMergeLocal = ) ] ) - ( maybeToEither (I.help previewMergeLocal) . \case - [src] -> do - src <- parseLooseCodeOrProject src - pure $ Input.PreviewMergeLocalBranchI src (This Path.relativeEmpty') - [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - pure $ Input.PreviewMergeLocalBranchI src dest - _ -> Nothing + ( maybeToEither (I.help previewMergeLocal) + . ( \case + [src] -> do + src <- parseLooseCodeOrProject src + pure $ Input.PreviewMergeLocalBranchI src (This Path.relativeEmpty') + [src, dest] -> do + src <- parseLooseCodeOrProject src + dest <- parseLooseCodeOrProject dest + pure $ Input.PreviewMergeLocalBranchI src dest + _ -> Nothing + ) + . unifyArguments ) where suggestionsConfig = @@ -1857,7 +1896,7 @@ replaceEdit f = self ) ] ) - ( \case + ( unifyArguments `andThen` \case source : target : patch -> do patch <- first P.text <$> traverse Path.parseSplit' $ listToMaybe patch sourcehq <- parseHashQualifiedName source @@ -1898,7 +1937,7 @@ edit = "`edit` without arguments invokes a search to select a definition for editing, which requires that `fzf` can be found within your PATH." ], parse = - \case + unifyArguments `andThen` \case (x : xs) -> (x NE.:| xs) & traverse parseHashQualifiedName @@ -1918,7 +1957,7 @@ editNamespace = [ "`edit.namespace` will load all terms and types contained within the current namespace into your scratch file. This includes definitions in namespaces, but excludes libraries.", "`edit.namespace ns1 ns2 ...` loads the terms and types contained within the provided namespaces." ], - parse = Right . Input.EditNamespaceI . fmap (Path.unsafeParseText . Text.pack) + parse = Right . Input.EditNamespaceI . fmap (Path.unsafeParseText . Text.pack) . unifyArguments } topicNameArg :: ArgumentType @@ -1946,7 +1985,7 @@ helpTopics = I.Visible [("topic", Optional, topicNameArg)] ("`help-topics` lists all topics and `help-topics ` shows an explanation of that topic.") - ( \case + ( unifyArguments `andThen` \case [] -> Left topics [topic] -> case Map.lookup topic helpTopicsMap of Nothing -> Left . warn $ "I don't know of that topic. Try `help-topics`." @@ -2129,7 +2168,7 @@ help = I.Visible [("command", Optional, commandNameArg)] "`help` shows general help and `help ` shows help for one command." - \case + $ unifyArguments `andThen` \case [] -> Left $ intercalateMap @@ -2191,7 +2230,7 @@ viewPatch = ) ] ) - \case + $ unifyArguments `andThen` \case [] -> Right $ Input.ListEditsI Nothing [patchStr] -> mapLeft P.text do patch <- Path.parseSplit' patchStr @@ -2206,7 +2245,7 @@ names isGlobal = I.Visible [("name or hash", Required, definitionQueryArg)] (P.wrap $ makeExample (names isGlobal) ["foo"] <> " shows the hash and all known names for `foo`.") - \case + $ unifyArguments `andThen` \case [thing] -> case HQ.parseText (Text.pack thing) of Just hq -> Right $ Input.NamesI isGlobal hq Nothing -> @@ -2225,7 +2264,7 @@ dependents = I.Visible [("definition", Required, definitionQueryArg)] "List the named dependents of the specified definition." - \case + $ unifyArguments `andThen` \case [thing] -> fmap Input.ListDependentsI $ parseHashQualifiedName thing _ -> Left (I.help dependents) dependencies = @@ -2235,7 +2274,7 @@ dependencies = I.Visible [("definition", Required, definitionQueryArg)] "List the dependencies of the specified definition." - \case + $ unifyArguments `andThen` \case [thing] -> fmap Input.ListDependenciesI $ parseHashQualifiedName thing _ -> Left (I.help dependencies) @@ -2247,7 +2286,7 @@ namespaceDependencies = I.Visible [("namespace", Optional, namespaceArg)] "List the external dependencies of the specified namespace." - \case + $ unifyArguments `andThen` \case [p] -> first P.text do p <- Path.parsePath' p pure $ Input.NamespaceDependenciesI (Just p) @@ -2302,7 +2341,7 @@ debugTerm = I.Hidden [("term", Required, exactDefinitionTermQueryArg)] "View debugging information for a given term." - ( \case + ( unifyArguments `andThen` \case [thing] -> fmap (Input.DebugTermI False) $ parseHashQualifiedName thing _ -> Left (I.help debugTerm) ) @@ -2315,7 +2354,7 @@ debugTermVerbose = I.Hidden [("term", Required, exactDefinitionTermQueryArg)] "View verbose debugging information for a given term." - ( \case + ( unifyArguments `andThen` \case [thing] -> fmap (Input.DebugTermI True) $ parseHashQualifiedName thing _ -> Left (I.help debugTermVerbose) ) @@ -2328,7 +2367,7 @@ debugType = I.Hidden [("type", Required, exactDefinitionTypeQueryArg)] "View debugging information for a given type." - ( \case + ( unifyArguments `andThen` \case [thing] -> fmap (Input.DebugTypeI) $ parseHashQualifiedName thing _ -> Left (I.help debugType) ) @@ -2376,7 +2415,7 @@ debugNameDiff = args = [("before namespace", Required, namespaceArg), ("after namespace", Required, namespaceArg)], help = P.wrap "List all name changes between two causal hashes. Does not detect patch changes.", parse = - ( \case + ( unifyArguments `andThen` \case [from, to] -> first fromString $ do fromSCH <- Input.parseShortCausalHash from toSCH <- Input.parseShortCausalHash to @@ -2435,7 +2474,7 @@ docsToHtml = ) ] ) - \case + $ unifyArguments `andThen` \case [namespacePath, destinationFilePath] -> first P.text do np <- Path.parsePath' namespacePath pure $ Input.DocsToHtmlI np destinationFilePath @@ -2454,7 +2493,7 @@ docToMarkdown = ) ] ) - \case + $ unifyArguments `andThen` \case [docNameText] -> first fromString $ do docName <- maybeToEither "Invalid name" . Name.parseText . Text.pack $ docNameText pure $ Input.DocToMarkdownI docName @@ -2476,7 +2515,7 @@ execute = ) ] ) - \case + $ unifyArguments `andThen` \case [w] -> pure $ Input.ExecuteI (Text.pack w) [] w : ws -> pure $ Input.ExecuteI (Text.pack w) ws _ -> Left $ showPatternHelp execute @@ -2491,7 +2530,7 @@ saveExecuteResult = ( "`add.run name` adds to the codebase the result of the most recent `run` command" <> "as `name`." ) - \case + $ unifyArguments `andThen` \case [w] -> pure $ Input.SaveExecuteResultI (Name.unsafeParseText (Text.pack w)) _ -> Left $ showPatternHelp saveExecuteResult @@ -2508,9 +2547,10 @@ ioTest = "Runs `!mytest`, where `mytest` is a delayed test that can use the `IO` and `Exception` abilities." ) ], - parse = \case - [thing] -> fmap Input.IOTestI $ parseHashQualifiedName thing - _ -> Left $ showPatternHelp ioTest + parse = + unifyArguments `andThen` \case + [thing] -> fmap Input.IOTestI $ parseHashQualifiedName thing + _ -> Left $ showPatternHelp ioTest } ioTestAll :: InputPattern @@ -2546,7 +2586,7 @@ makeStandalone = ) ] ) - \case + $ unifyArguments `andThen` \case [main, file] -> Input.MakeStandaloneI file <$> parseHashQualifiedName main _ -> Left $ showPatternHelp makeStandalone @@ -2564,7 +2604,7 @@ runScheme = ) ] ) - \case + $ unifyArguments `andThen` \case main : args -> Right $ Input.ExecuteSchemeI (Text.pack main) args _ -> Left $ showPatternHelp runScheme @@ -2583,7 +2623,7 @@ compileScheme = ) ] ) - \case + $ unifyArguments `andThen` \case [main, file] -> Input.CompileSchemeI (Text.pack file) <$> parseHashQualifiedName main _ -> Left $ showPatternHelp compileScheme @@ -2606,7 +2646,7 @@ createAuthor = <> backtick (P.group ("metadata.copyrightHolders" <> ".")) ) ) - ( \case + ( unifyArguments `andThen` \case symbolStr : authorStr@(_ : _) -> first P.text do symbol <- Megaparsec.runParser (Megaparsec.withParsecT (fmap NameSegment.renderParseErr) NameSegment.segmentP <* Megaparsec.eof) "" symbolStr @@ -2641,7 +2681,7 @@ gist = <> "`push.create` of the current namespace to your Unison Share codebase wherever you like!" ] ) - ( \case + ( unifyArguments `andThen` \case [repoString] -> do repo <- parseWriteGitRepo "gist git repo" repoString pure (Input.GistI (Input.GistInput repo)) @@ -2688,14 +2728,15 @@ diffNamespaceToPatch = visibility = I.Visible, args = [], help = P.wrap "Create a patch from a namespace diff.", - parse = \case - [branchId1, branchId2, patch] -> - mapLeft P.text do - branchId1 <- Input.parseBranchId branchId1 - branchId2 <- Input.parseBranchId branchId2 - patch <- Path.parseSplit' patch - pure (Input.DiffNamespaceToPatchI Input.DiffNamespaceToPatchInput {branchId1, branchId2, patch}) - _ -> Left (showPatternHelp diffNamespaceToPatch) + parse = + unifyArguments `andThen` \case + [branchId1, branchId2, patch] -> + mapLeft P.text do + branchId1 <- Input.parseBranchId branchId1 + branchId2 <- Input.parseBranchId branchId2 + patch <- Path.parseSplit' patch + pure (Input.DiffNamespaceToPatchI Input.DiffNamespaceToPatchInput {branchId1, branchId2, patch}) + _ -> Left (showPatternHelp diffNamespaceToPatch) } projectCreate :: InputPattern @@ -2710,12 +2751,13 @@ projectCreate = [ ("`project.create`", "creates a project with a random name"), ("`project.create foo`", "creates a project named `foo`") ], - parse = \case - [name] -> - case tryInto @ProjectName (Text.pack name) of - Left _ -> Left "Invalid project name." - Right name1 -> Right (Input.ProjectCreateI True (Just name1)) - _ -> Right (Input.ProjectCreateI True Nothing) + parse = + unifyArguments `andThen` \case + [name] -> + case tryInto @ProjectName (Text.pack name) of + Left _ -> Left "Invalid project name." + Right name1 -> Right (Input.ProjectCreateI True (Just name1)) + _ -> Right (Input.ProjectCreateI True Nothing) } projectCreateEmptyInputPattern :: InputPattern @@ -2730,12 +2772,13 @@ projectCreateEmptyInputPattern = [ ("`project.create-empty`", "creates an empty project with a random name"), ("`project.create-empty foo`", "creates an empty project named `foo`") ], - parse = \case - [name] -> - case tryInto @ProjectName (Text.pack name) of - Left _ -> Left "Invalid project name." - Right name1 -> Right (Input.ProjectCreateI False (Just name1)) - _ -> Right (Input.ProjectCreateI False Nothing) + parse = + unifyArguments `andThen` \case + [name] -> + case tryInto @ProjectName (Text.pack name) of + Left _ -> Left "Invalid project name." + Right name1 -> Right (Input.ProjectCreateI False (Just name1)) + _ -> Right (Input.ProjectCreateI False Nothing) } projectRenameInputPattern :: InputPattern @@ -2749,9 +2792,10 @@ projectRenameInputPattern = P.wrapColumn2 [ ("`project.rename foo`", "renames the current project to `foo`") ], - parse = \case - [nameString] | Right name <- tryInto (Text.pack nameString) -> Right (Input.ProjectRenameI name) - _ -> Left (showPatternHelp projectRenameInputPattern) + parse = + unifyArguments `andThen` \case + [nameString] | Right name <- tryInto (Text.pack nameString) -> Right (Input.ProjectRenameI name) + _ -> Left (showPatternHelp projectRenameInputPattern) } projectSwitch :: InputPattern @@ -2768,12 +2812,13 @@ projectSwitch = ("`switch foo/`", "switches to the last branch you visited in the project `foo`"), ("`switch /bar`", "switches to the branch `bar` in the current project") ], - parse = \case - [name] -> - case tryInto @ProjectAndBranchNames (Text.pack name) of - Left _ -> Left (showPatternHelp projectSwitch) - Right projectAndBranch -> Right (Input.ProjectSwitchI projectAndBranch) - _ -> Left (showPatternHelp projectSwitch) + parse = + unifyArguments `andThen` \case + [name] -> + case tryInto @ProjectAndBranchNames (Text.pack name) of + Left _ -> Left (showPatternHelp projectSwitch) + Right projectAndBranch -> Right (Input.ProjectSwitchI projectAndBranch) + _ -> Left (showPatternHelp projectSwitch) } where suggestionsConfig = @@ -2806,10 +2851,11 @@ branchesInputPattern = [ ("`branches`", "lists all branches in the current project"), ("`branches foo", "lists all branches in the project `foo`") ], - parse = \case - [] -> Right (Input.BranchesI Nothing) - [nameString] | Right name <- tryFrom (Text.pack nameString) -> Right (Input.BranchesI (Just name)) - _ -> Left (showPatternHelp branchesInputPattern) + parse = + unifyArguments `andThen` \case + [] -> Right (Input.BranchesI Nothing) + [nameString] | Right name <- tryFrom (Text.pack nameString) -> Right (Input.BranchesI (Just name)) + _ -> Left (showPatternHelp branchesInputPattern) } branchInputPattern :: InputPattern @@ -2829,21 +2875,24 @@ branchInputPattern = ("`branch .bar foo`", "forks the path `.bar` of the current project to a new branch `foo`") ], parse = - maybeToEither (showPatternHelp branchInputPattern) . \case - [source0, name] -> do - source <- parseLooseCodeOrProject source0 - projectAndBranch <- - Text.pack name - & tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - & eitherToMaybe - Just (Input.BranchI (Input.BranchSourceI'LooseCodeOrProject source) projectAndBranch) - [name] -> do - projectAndBranch <- - Text.pack name - & tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - & eitherToMaybe - Just (Input.BranchI Input.BranchSourceI'CurrentContext projectAndBranch) - _ -> Nothing + maybeToEither (showPatternHelp branchInputPattern) + . ( \case + [source0, name] -> do + source <- parseLooseCodeOrProject source0 + projectAndBranch <- + Text.pack name + & tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + & eitherToMaybe + Just (Input.BranchI (Input.BranchSourceI'LooseCodeOrProject source) projectAndBranch) + [name] -> do + projectAndBranch <- + Text.pack name + & tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + & eitherToMaybe + Just (Input.BranchI Input.BranchSourceI'CurrentContext projectAndBranch) + _ -> Nothing + ) + . unifyArguments } where newBranchNameArg = @@ -2867,12 +2916,13 @@ branchEmptyInputPattern = visibility = I.Visible, args = [], help = P.wrap "Create a new empty branch.", - parse = \case - [name] -> - first (\_ -> showPatternHelp branchEmptyInputPattern) do - projectAndBranch <- tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack name) - Right (Input.BranchI Input.BranchSourceI'Empty projectAndBranch) - _ -> Left (showPatternHelp branchEmptyInputPattern) + parse = + unifyArguments `andThen` \case + [name] -> + first (\_ -> showPatternHelp branchEmptyInputPattern) do + projectAndBranch <- tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack name) + Right (Input.BranchI Input.BranchSourceI'Empty projectAndBranch) + _ -> Left (showPatternHelp branchEmptyInputPattern) } branchRenameInputPattern :: InputPattern @@ -2886,9 +2936,10 @@ branchRenameInputPattern = P.wrapColumn2 [ ("`branch.rename foo`", "renames the current branch to `foo`") ], - parse = \case - [nameString] | Right name <- tryInto (Text.pack nameString) -> Right (Input.BranchRenameI name) - _ -> Left (showPatternHelp branchRenameInputPattern) + parse = + unifyArguments `andThen` \case + [nameString] | Right name <- tryInto (Text.pack nameString) -> Right (Input.BranchRenameI name) + _ -> Left (showPatternHelp branchRenameInputPattern) } clone :: InputPattern @@ -2921,15 +2972,18 @@ clone = ) ], parse = - maybe (Left (showPatternHelp clone)) Right . \case - [remoteNamesString] -> do - remoteNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack remoteNamesString)) - Just (Input.CloneI remoteNames Nothing) - [remoteNamesString, localNamesString] -> do - remoteNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack remoteNamesString)) - localNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack localNamesString)) - Just (Input.CloneI remoteNames (Just localNames)) - _ -> Nothing + maybe (Left (showPatternHelp clone)) Right + . ( \case + [remoteNamesString] -> do + remoteNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack remoteNamesString)) + Just (Input.CloneI remoteNames Nothing) + [remoteNamesString, localNamesString] -> do + remoteNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack remoteNamesString)) + localNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack localNamesString)) + Just (Input.CloneI remoteNames (Just localNames)) + _ -> Nothing + ) + . unifyArguments } releaseDraft :: InputPattern @@ -2940,9 +2994,10 @@ releaseDraft = visibility = I.Visible, args = [], help = P.wrap "Draft a release.", - parse = \case - [tryInto @Semver . Text.pack -> Right semver] -> Right (Input.ReleaseDraftI semver) - _ -> Left (showPatternHelp releaseDraft) + parse = + unifyArguments `andThen` \case + [tryInto @Semver . Text.pack -> Right semver] -> Right (Input.ReleaseDraftI semver) + _ -> Left (showPatternHelp releaseDraft) } upgrade :: InputPattern @@ -2956,11 +3011,14 @@ upgrade = P.wrap $ "`upgrade old new` upgrades library dependency `lib.old` to `lib.new`, and, if successful, deletes `lib.old`.", parse = - maybeToEither (I.help upgrade) . \args -> do - [oldString, newString] <- Just args - old <- parseRelativeNameSegment oldString - new <- parseRelativeNameSegment newString - Just (Input.UpgradeI old new) + maybeToEither (I.help upgrade) + . ( \args -> do + [oldString, newString] <- Just args + old <- parseRelativeNameSegment oldString + new <- parseRelativeNameSegment newString + Just (Input.UpgradeI old new) + ) + . unifyArguments } where parseRelativeNameSegment :: String -> Maybe NameSegment diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 0e948b5da..18a0c8f9c 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -113,10 +113,11 @@ getUserInput codebase authHTTPClient currentPath numberedArgs = -- Ctrl-c or some input cancel, re-run the prompt go Right (Just (expandedArgs, i)) -> do - let expandedArgsStr = unwords expandedArgs - when (expandedArgs /= ws) $ do + let expandedArgs' = IP.unifyArguments expandedArgs + expandedArgsStr = unwords expandedArgs' + when (expandedArgs' /= ws) $ do liftIO . putStrLn $ fullPrompt <> expandedArgsStr - Line.modifyHistory $ Line.addHistoryUnlessConsecutiveDupe $ unwords expandedArgs + Line.modifyHistory $ Line.addHistoryUnlessConsecutiveDupe $ expandedArgsStr pure i settings :: Line.Settings IO settings = From 0a94308d625a413e61ee190258ecf188479fe057 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Wed, 15 May 2024 23:21:24 -0600 Subject: [PATCH 55/82] Have `InputPattern`s handle `NumberedRef` This converts the commands to accept structured numbered arguments, rather than turning them all into strings. --- .../src/Unison/Codebase/Editor/HandleInput.hs | 12 +- .../src/Unison/CommandLine/InputPatterns.hs | 1646 +++++++++++------ unison-cli/src/Unison/CommandLine/Main.hs | 2 +- 3 files changed, 1032 insertions(+), 628 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index bfc6f72f6..4886caeb4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1501,7 +1501,7 @@ handleFindI isVerbose fscope ws input = do (mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs) pure $ uniqueBy SR.toReferent srs let respondResults results = do - Cli.setNumberedArgs $ fmap (searchResultToHQText searchRoot &&& SA.SearchResult searchRoot) results + Cli.setNumberedArgs $ fmap (HQ.toText . IP.searchResultToHQ searchRoot &&& SA.SearchResult searchRoot) results results' <- Cli.runTransaction (Backend.loadSearchResults codebase results) Cli.respond $ ListOfDefinitions fscope suffixifiedPPE isVerbose results' results <- getResults names @@ -1821,16 +1821,6 @@ confirmedCommand i = do loopState <- State.get pure $ Just i == (loopState ^. #lastInput) ---- | restores the full hash to these search results, for _numberedArgs purposes -searchResultToHQText :: Maybe Path -> SearchResult -> Text -searchResultToHQText oprefix = \case - SR.Tm' n r _ -> HQ.toText $ HQ.requalify (addPrefix <$> n) r - SR.Tp' n r _ -> HQ.toText $ HQ.requalify (addPrefix <$> n) (Referent.Ref r) - _ -> error "impossible match failure" - where - addPrefix :: Name -> Name - addPrefix = maybe id Path.prefixName2 oprefix - -- return `name` and `name....` _searchBranchPrefix :: Branch m -> Name -> [SearchResult] _searchBranchPrefix b n = case Path.unsnoc (Path.fromName n) of diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index f82e3c8dc..ebae14662 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -20,7 +20,7 @@ import System.Console.Haskeline.Completion (Completion (Completion)) import System.Console.Haskeline.Completion qualified as Haskeline import System.Console.Haskeline.Completion qualified as Line import Text.Megaparsec qualified as Megaparsec -import Text.Megaparsec.Internal qualified as Megaparsec (withParsecT) +import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Sqlite.DbId (ProjectBranchId, ProjectId) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Queries @@ -35,23 +35,30 @@ import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push)) import Unison.Codebase.Editor.Output.PushPull qualified as PushPull import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.SlurpResult qualified as SR +import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) +import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.Codebase.Editor.UriParser (readRemoteNamespaceParser) import Unison.Codebase.Editor.UriParser qualified as UriParser +import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.PushBehavior qualified as PushBehavior +import Unison.Codebase.ShortCausalHash (ShortCausalHash) +import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.SyncMode qualified as SyncMode import Unison.Codebase.Verbosity (Verbosity) import Unison.Codebase.Verbosity qualified as Verbosity import Unison.CommandLine -import Unison.CommandLine.BranchRelativePath (parseBranchRelativePath, parseIncrementalBranchRelativePath) +import Unison.CommandLine.BranchRelativePath (BranchRelativePath (..), parseBranchRelativePath, parseIncrementalBranchRelativePath) import Unison.CommandLine.BranchRelativePath qualified as BranchRelativePath import Unison.CommandLine.Completion import Unison.CommandLine.FZFResolvers qualified as Resolvers import Unison.CommandLine.InputPattern (ArgumentType (..), InputPattern (InputPattern), IsOptional (..), unionSuggestions) import Unison.CommandLine.InputPattern qualified as I import Unison.HashQualified qualified as HQ +import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Name qualified as Name import Unison.NameSegment (NameSegment) @@ -59,13 +66,23 @@ import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectBranchNameOrLatestRelease (..), ProjectBranchSpecifier (..), ProjectName, Semver) import Unison.Project.Util (ProjectContext (..), projectContextFromPath) +import Unison.Reference qualified as Reference +import Unison.Referent qualified as Referent +import Unison.Server.SearchResult (SearchResult) +import Unison.Server.SearchResult qualified as SR +import Unison.ShortHash (ShortHash) import Unison.Syntax.HashQualified qualified as HQ (parseText) -import Unison.Syntax.Name qualified as Name (parseText, unsafeParseText) -import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr, segmentP) +import Unison.Syntax.Name qualified as Name (parseTextEither) import Unison.Util.ColorText qualified as CT import Unison.Util.Monoid (intercalateMap) import Unison.Util.Pretty qualified as P +-- | +-- +-- __FIXME__: Don’t hardcode this +schLength :: Int +schLength = 10 + -- | -- -- __TODO__: Temporary. This may stick around in a handful of cases, but it’ll @@ -74,18 +91,6 @@ import Unison.Util.Pretty qualified as P unifyArgument :: I.Argument -> String unifyArgument = either id (Text.unpack . fst) --- | Reversed composition, here temporarily to support the deferred parsing. --- --- __TODO__: Temporary. -andThen :: (a -> b) -> (b -> c) -> a -> c -andThen = flip (.) - --- | --- --- __TODO__: Temporary. -unifyArguments :: [I.Argument] -> [String] -unifyArguments = fmap unifyArgument - showPatternHelp :: InputPattern -> P.Pretty CT.ColorText showPatternHelp i = P.lines @@ -98,6 +103,51 @@ showPatternHelp i = I.help i ] +-- | restores the full hash to these search results, for _numberedArgs purposes +searchResultToHQ :: Maybe Path -> SearchResult -> HQ.HashQualified Name +searchResultToHQ oprefix = \case + SR.Tm' n r _ -> HQ.requalify (addPrefix <$> n) r + SR.Tp' n r _ -> HQ.requalify (addPrefix <$> n) (Referent.Ref r) + _ -> error "impossible match failure" + where + addPrefix :: Name -> Name + addPrefix = maybe id Path.prefixName2 oprefix + +unsupportedStructuredArgument :: + Text -> I.Argument -> Either (P.Pretty CT.ColorText) String +unsupportedStructuredArgument expected = + either + pure + (const . Left . P.text $ "can’t use a numbered argument for " <> expected) + +expectedButActually :: Text -> Text -> Text -> Text +expectedButActually expected actualValue actualType = + "Expected " + <> expected + <> ", but the numbered arg resulted in " + <> actualValue + <> ", which is " + <> actualType + <> "." + +wrongStructuredArgument :: Text -> (Text, StructuredArgument) -> Text +wrongStructuredArgument expected (actualStr, actual) = + expectedButActually + expected + actualStr + case actual of + SA.Ref _ -> "a reference" + SA.Name _ -> "a name" + SA.AbsolutePath _ -> "an absolute path" + SA.Namespace _ -> "a namespace" + SA.Project _ -> "a project" + SA.ProjectBranch _ -> "a branch" + SA.HashQualified _ -> "a hash-qualified name" + SA.NameWithBranchPrefix _ _ -> "a name" + SA.HashQualifiedWithBranchPrefix _ _ -> "a hash-qualified name" + SA.ShallowListEntry _ _ -> "an annotated symbol" + SA.SearchResult _ _ -> "a search result" + patternName :: InputPattern -> P.Pretty P.ColorText patternName = fromString . I.patternName @@ -117,7 +167,411 @@ makeExampleEOS p args = backtick (intercalateMap " " id (P.nonEmpty $ fromString (I.patternName p) : args)) <> "." helpFor :: InputPattern -> P.Pretty CT.ColorText -helpFor p = I.help p +helpFor = I.help + +handleProjectArg :: I.Argument -> Either Text ProjectName +handleProjectArg = + either + ( \name -> + first + (const $ "“" <> Text.pack name <> "” is an invalid project name") + . tryInto @ProjectName + $ Text.pack name + ) + ( \case + (_, SA.Project project) -> pure project + -- __FIXME__: Do we want to treat a project branch as a project? + (_, SA.ProjectBranch (ProjectAndBranch (Just project) _)) -> pure project + otherArgType -> Left $ wrongStructuredArgument "a path" otherArgType + ) + +handleLooseCodeOrProjectArg :: + I.Argument -> Either Text Input.LooseCodeOrProject +handleLooseCodeOrProjectArg = + either + ( maybe (Left "invalid path or project branch") pure + . parseLooseCodeOrProject + ) + ( \case + (_, SA.AbsolutePath path) -> pure . This $ Path.absoluteToPath' path + (_, SA.ProjectBranch pb) -> pure $ That pb + otherArgType -> + Left $ wrongStructuredArgument "a path or project branch" otherArgType + ) + +handleProjectAndBranchArg :: + I.Argument -> + Either Text (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) +handleProjectAndBranchArg = + either + ( \name -> + first + (const $ "couldn’t find a branch named “" <> Text.pack name <> "”") + . tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + $ Text.pack name + ) + ( \case + (_, SA.ProjectBranch pb) -> pure pb + otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType + ) + +handleHashQualifiedNameArg :: + I.Argument -> Either (P.Pretty CT.ColorText) (HQ.HashQualified Name) +handleHashQualifiedNameArg = + either + parseHashQualifiedName + ( \case + (_, SA.Name name) -> pure $ HQ.NameOnly name + (_, SA.NameWithBranchPrefix (Left _) name) -> pure $ HQ.NameOnly name + (_, SA.NameWithBranchPrefix (Right prefix) name) -> + pure . HQ.NameOnly . Name.makeAbsolute $ Path.prefixName prefix name + (_, SA.Ref ref) -> pure . HQ.HashOnly $ Reference.toShortHash ref + (_, SA.HashQualified hqname) -> pure hqname + (_, SA.HashQualifiedWithBranchPrefix (Left _) hqname) -> pure $ HQ'.toHQ hqname + (_, SA.HashQualifiedWithBranchPrefix (Right prefix) hqname) -> + pure . HQ'.toHQ $ Name.makeAbsolute . Path.prefixName prefix <$> hqname + (_, SA.SearchResult mpath result) -> pure $ searchResultToHQ mpath result + otherArgType -> + Left . P.text $ wrongStructuredArgument "a hash-qualified name" otherArgType + ) + +handlePathArg :: I.Argument -> Either Text Path.Path +handlePathArg = + either + Path.parsePath + \case + (_, SA.Name name) -> pure $ Path.fromName name + (_, SA.NameWithBranchPrefix (Left _) name) -> pure $ Path.fromName name + (_, SA.NameWithBranchPrefix (Right prefix) name) -> + pure . Path.fromName $ Path.prefixName prefix name + otherArgType -> + Left $ wrongStructuredArgument "a relative path" otherArgType + +handlePath'Arg :: I.Argument -> Either Text Path.Path' +handlePath'Arg = + either + Path.parsePath' + ( \case + (_, SA.AbsolutePath path) -> pure $ Path.absoluteToPath' path + (_, SA.Name name) -> pure $ Path.fromName' name + (_, SA.NameWithBranchPrefix (Left _) name) -> pure $ Path.fromName' name + (_, SA.NameWithBranchPrefix (Right prefix) name) -> + pure . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + otherArgType -> Left $ wrongStructuredArgument "a namespace" otherArgType + ) + +handleNewName :: I.Argument -> Either Text Path.Split' +handleNewName = + either + Path.parseSplit' + (const . Left $ "can’t use a numbered argument for a new name") + +handleNewPath :: I.Argument -> Either Text Path.Path' +handleNewPath = + either + Path.parsePath' + (const . Left $ "can’t use a numbered argument for a new namespace") + +handleSplit'Arg :: I.Argument -> Either Text Path.Split' +handleSplit'Arg = + either + Path.parseSplit' + ( \case + (_, SA.Name name) -> pure $ Path.splitFromName' name + (_, SA.NameWithBranchPrefix (Left _) name) -> pure $ Path.splitFromName' name + (_, SA.NameWithBranchPrefix (Right prefix) name) -> + pure . Path.splitFromName' . Name.makeAbsolute $ Path.prefixName prefix name + otherNumArg -> Left $ wrongStructuredArgument "a split name" otherNumArg + ) + +neSnoc :: [a] -> a -> NE.NonEmpty a +neSnoc xs x = foldr NE.cons (pure x) xs + +handleProjectBranchNameArg :: I.Argument -> Either Text ProjectBranchName +handleProjectBranchNameArg = + either + (first (const "Wanted a branch name, but it wasn’t") . tryInto . Text.pack) + ( \case + (_, SA.ProjectBranch (ProjectAndBranch _ branch)) -> pure branch + otherNumArg -> Left $ wrongStructuredArgument "a branch name" otherNumArg + ) + +handleBranchIdArg :: I.Argument -> Either Text Input.BranchId +handleBranchIdArg = + either + Input.parseBranchId + ( \case + (_, SA.AbsolutePath path) -> pure . pure $ Path.absoluteToPath' path + (_, SA.Name name) -> pure . pure $ Path.fromName' name + (_, SA.NameWithBranchPrefix (Left _) name) -> + pure . pure $ Path.fromName' name + (_, SA.NameWithBranchPrefix (Right prefix) name) -> + pure . pure . Path.fromName' . Name.makeAbsolute $ + Path.prefixName prefix name + (_, SA.Namespace hash) -> pure . Left $ SCH.fromHash schLength hash + otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg + ) + +handleBranchIdOrProjectArg :: + I.Argument -> + Either + Text + ( These + Input.BranchId + (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + ) +handleBranchIdOrProjectArg = + either + ( maybe (Left "Expected a branch or project, but it’s not") pure + . branchIdOrProject + ) + ( \case + (_, SA.Namespace hash) -> + pure . This . Left $ SCH.fromHash schLength hash + (_, SA.AbsolutePath path) -> + pure . This . pure $ Path.absoluteToPath' path + (_, SA.Name name) -> pure . This . pure $ Path.fromName' name + (_, SA.NameWithBranchPrefix (Left _) name) -> + pure . This . pure $ Path.fromName' name + (_, SA.NameWithBranchPrefix (Right prefix) name) -> + pure . This . pure . Path.fromName' . Name.makeAbsolute $ + Path.prefixName prefix name + (_, SA.ProjectBranch pb) -> pure $ pure pb + otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType + ) + where + branchIdOrProject :: + String -> + Maybe + ( These + Input.BranchId + (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + ) + branchIdOrProject str = + let branchIdRes = Input.parseBranchId str + projectRes = + tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + (Text.pack str) + in case (branchIdRes, projectRes) of + (Left _, Left _) -> Nothing + (Left _, Right pr) -> Just (That pr) + (Right bid, Left _) -> Just (This bid) + (Right bid, Right pr) -> Just (These bid pr) + +handleBranchId2Arg :: + I.Argument -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath) +handleBranchId2Arg = + either + Input.parseBranchId2 + ( \case + (_, SA.Namespace hash) -> pure . Left $ SCH.fromHash schLength hash + (_, SA.AbsolutePath path) -> + pure . pure . LoosePath $ Path.absoluteToPath' path + (_, SA.Name name) -> pure . pure . LoosePath $ Path.fromName' name + (_, SA.NameWithBranchPrefix (Left _) name) -> + pure . pure . LoosePath $ Path.fromName' name + (_, SA.NameWithBranchPrefix (Right prefix) name) -> + pure . pure . LoosePath . Path.fromName' . Name.makeAbsolute $ + Path.prefixName prefix name + (_, SA.ProjectBranch (ProjectAndBranch mproject branch)) -> + pure . pure . BranchRelative . This $ + maybe (Left branch) (pure . (,branch)) mproject + otherNumArg -> + Left . P.text $ wrongStructuredArgument "a branch id" otherNumArg + ) + +handleBranchRelativePathArg :: + I.Argument -> Either (P.Pretty P.ColorText) BranchRelativePath +handleBranchRelativePathArg = + either + parseBranchRelativePath + ( \case + (_, SA.AbsolutePath path) -> pure . LoosePath $ Path.absoluteToPath' path + (_, SA.Name name) -> pure . LoosePath $ Path.fromName' name + (_, SA.NameWithBranchPrefix (Left _) name) -> + pure . LoosePath $ Path.fromName' name + (_, SA.NameWithBranchPrefix (Right prefix) name) -> + pure . LoosePath . Path.fromName' . Name.makeAbsolute $ + Path.prefixName prefix name + (_, SA.ProjectBranch (ProjectAndBranch mproject branch)) -> + pure . BranchRelative . This $ + maybe (Left branch) (pure . (,branch)) mproject + otherNumArg -> + Left . P.text $ wrongStructuredArgument "a branch id" otherNumArg + ) + +hqNameToSplit' :: HQ.HashQualified Name -> Either Text Path.HQSplit' +hqNameToSplit' = \case + HQ.HashOnly _ -> Left "Only have a hash" + HQ.NameOnly name -> pure . fmap HQ'.NameOnly $ Path.splitFromName' name + HQ.HashQualified name hash -> pure . fmap (`HQ'.HashQualified` hash) $ Path.splitFromName' name + +hqNameToSplit :: HQ.HashQualified Name -> Either Text Path.HQSplit +hqNameToSplit = \case + HQ.HashOnly _ -> Left "Only have a hash" + HQ.NameOnly name -> pure . fmap HQ'.NameOnly $ Path.splitFromName name + HQ.HashQualified name hash -> pure . fmap (`HQ'.HashQualified` hash) $ Path.splitFromName name + +hq'NameToSplit' :: HQ'.HashQualified Name -> Path.HQSplit' +hq'NameToSplit' = \case + HQ'.NameOnly name -> HQ'.NameOnly <$> Path.splitFromName' name + HQ'.HashQualified name hash -> flip HQ'.HashQualified hash <$> Path.splitFromName' name + +hq'NameToSplit :: HQ'.HashQualified Name -> Path.HQSplit +hq'NameToSplit = \case + HQ'.NameOnly name -> HQ'.NameOnly <$> Path.splitFromName name + HQ'.HashQualified name hash -> flip HQ'.HashQualified hash <$> Path.splitFromName name + +handleHashQualifiedSplit'Arg :: I.Argument -> Either Text Path.HQSplit' +handleHashQualifiedSplit'Arg = + either + Path.parseHQSplit' + ( \case + (_, SA.HashQualified name) -> hqNameToSplit' name + (_, SA.HashQualifiedWithBranchPrefix (Left _) hqname) -> pure $ hq'NameToSplit' hqname + (_, SA.HashQualifiedWithBranchPrefix (Right prefix) hqname) -> + pure . hq'NameToSplit' $ Name.makeAbsolute . Path.prefixName prefix <$> hqname + (_, SA.SearchResult mpath result) -> hqNameToSplit' $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg + ) + +handleHashQualifiedSplitArg :: I.Argument -> Either Text Path.HQSplit +handleHashQualifiedSplitArg = + either + Path.parseHQSplit + ( \case + (_, SA.HashQualified name) -> hqNameToSplit name + (_, SA.HashQualifiedWithBranchPrefix (Left _) hqname) -> pure $ hq'NameToSplit hqname + (_, SA.HashQualifiedWithBranchPrefix (Right prefix) hqname) -> + pure . hq'NameToSplit $ Name.makeAbsolute . Path.prefixName prefix <$> hqname + (_, SA.SearchResult mpath result) -> hqNameToSplit $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a relative name" otherNumArg + ) + +handleShortCausalHashArg :: I.Argument -> Either Text ShortCausalHash +handleShortCausalHashArg = + either + (first Text.pack . Input.parseShortCausalHash) + ( \case + (_, SA.Namespace hash) -> pure $ SCH.fromHash schLength hash + otherNumArg -> Left $ wrongStructuredArgument "a causal hash" otherNumArg + ) + +handleShortHashOrHQSplit'Arg :: + I.Argument -> Either Text (Either ShortHash Path.HQSplit') +handleShortHashOrHQSplit'Arg = + either + Path.parseShortHashOrHQSplit' + ( \case + (_, SA.Ref ref) -> pure $ Left $ Reference.toShortHash ref + (_, SA.HashQualified name) -> pure <$> hqNameToSplit' name + (_, SA.HashQualifiedWithBranchPrefix (Left _) hqname) -> pure . pure $ hq'NameToSplit' hqname + (_, SA.HashQualifiedWithBranchPrefix (Right prefix) hqname) -> + pure . pure $ hq'NameToSplit' (Name.makeAbsolute . Path.prefixName prefix <$> hqname) + (_, SA.SearchResult mpath result) -> + fmap pure . hqNameToSplit' $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a hash or name" otherNumArg + ) + +handleRelativeNameSegmentArg :: I.Argument -> Either Text NameSegment +handleRelativeNameSegmentArg arg = do + name <- handleNameArg arg + let (segment NE.:| tail) = Name.reverseSegments name + if Name.isRelative name && null tail + then pure segment + else Left "Wanted a single relative name segment, but it wasn’t." + +handleNameArg :: I.Argument -> Either Text Name +handleNameArg = + either + (Name.parseTextEither . Text.pack) + ( \case + (_, SA.Name name) -> pure name + (_, SA.NameWithBranchPrefix (Left _) name) -> pure name + (_, SA.NameWithBranchPrefix (Right prefix) name) -> + pure . Name.makeAbsolute $ Path.prefixName prefix name + (_, SA.HashQualified hqname) -> + maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname + (_, SA.HashQualifiedWithBranchPrefix (Left _) hqname) -> pure $ HQ'.toName hqname + (_, SA.HashQualifiedWithBranchPrefix (Right prefix) hqname) -> + pure . Name.makeAbsolute . Path.prefixName prefix $ HQ'.toName hqname + (_, SA.SearchResult mpath result) -> + maybe (Left "can’t find a name from the numbered arg") pure + . HQ.toName + $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg + ) + +handlePullSourceArg :: + I.Argument -> + Either + Text + (ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease)) +handlePullSourceArg = + either + (maybe (Left "not a pull source") pure . parsePullSource . Text.pack) + ( \case + (_, SA.Project project) -> + pure . RemoteRepo.ReadShare'ProjectBranch $ This project + (_, SA.ProjectBranch (ProjectAndBranch project branch)) -> + pure . RemoteRepo.ReadShare'ProjectBranch . maybe That These project $ + ProjectBranchNameOrLatestRelease'Name branch + otherNumArg -> + Left $ wrongStructuredArgument "a source to pull from" otherNumArg + ) + +handlePushTargetArg :: + I.Argument -> + Either Text (WriteRemoteNamespace (These ProjectName ProjectBranchName)) +handlePushTargetArg = + either + ( maybe (Left "Wanted a source to push from, but this ain’t it.") pure + . parsePushTarget + ) + ( fmap RemoteRepo.WriteRemoteProjectBranch + . \case + (_, SA.Project project) -> pure $ This project + (_, SA.ProjectBranch (ProjectAndBranch project branch)) -> + pure $ maybe That These project branch + otherNumArg -> + Left $ wrongStructuredArgument "a source to push from" otherNumArg + ) + +handlePushSourceArg :: I.Argument -> Either Text Input.PushSource +handlePushSourceArg = + either + ( maybe (Left "Wanted a source to push from, but this ain’t it.") pure + . parsePushSource + ) + ( \case + (_, SA.AbsolutePath path) -> pure . Input.PathySource $ Path.absoluteToPath' path + (_, SA.Name name) -> pure . Input.PathySource $ Path.fromName' name + (_, SA.NameWithBranchPrefix (Left _) name) -> + pure . Input.PathySource $ Path.fromName' name + (_, SA.NameWithBranchPrefix (Right prefix) name) -> + pure . Input.PathySource . Path.fromName' . Name.makeAbsolute $ + Path.prefixName prefix name + (_, SA.Project project) -> pure . Input.ProjySource $ This project + (_, SA.ProjectBranch (ProjectAndBranch project branch)) -> + pure . Input.ProjySource . maybe That These project $ branch + otherNumArg -> + Left $ wrongStructuredArgument "a source to push from" otherNumArg + ) + +handleProjectAndBranchNamesArg :: I.Argument -> Either Text ProjectAndBranchNames +handleProjectAndBranchNamesArg = + either + ( first (const "The argument wasn’t a project or branch") + . tryInto @ProjectAndBranchNames + . Text.pack + ) + ( fmap ProjectAndBranchNames'Unambiguous . \case + (_, SA.Project project) -> pure $ This project + (_, SA.ProjectBranch (ProjectAndBranch mproj branch)) -> + pure $ maybe That These mproj branch + otherNumArg -> + Left $ wrongStructuredArgument "a project or branch" otherNumArg + ) mergeBuiltins :: InputPattern mergeBuiltins = @@ -127,11 +581,9 @@ mergeBuiltins = I.Hidden [("namespace", Optional, namespaceArg)] "Adds the builtins (excluding `io` and misc) to the specified namespace. Defaults to `builtin.`" - $ unifyArguments `andThen` \case + $ \case [] -> pure . Input.MergeBuiltinsI $ Nothing - [p] -> first P.text do - p <- Path.parsePath p - pure . Input.MergeBuiltinsI $ Just p + [p] -> bimap P.text (Input.MergeBuiltinsI . Just) $ handlePathArg p _ -> Left (I.help mergeBuiltins) mergeIOBuiltins :: InputPattern @@ -142,11 +594,9 @@ mergeIOBuiltins = I.Hidden [("namespace", Optional, namespaceArg)] "Adds all the builtins, including `io` and misc., to the specified namespace. Defaults to `builtin.`" - $ unifyArguments `andThen` \case + \case [] -> pure . Input.MergeIOBuiltinsI $ Nothing - [p] -> first P.text do - p <- Path.parsePath p - pure . Input.MergeIOBuiltinsI $ Just p + [p] -> bimap P.text (Input.MergeIOBuiltinsI . Just) $ handlePathArg p _ -> Left (I.help mergeBuiltins) updateBuiltins :: InputPattern @@ -182,12 +632,12 @@ todo = ) ] ) - ( unifyArguments `andThen` \case - patchStr : ws -> mapLeft (warn . P.text) $ do - patch <- Path.parseSplit' patchStr + ( \case + patchStr : ws -> first (warn . P.text) $ do + patch <- handleSplit'Arg patchStr branch <- case ws of [] -> pure Path.relativeEmpty' - [pathStr] -> Path.parsePath' pathStr + [pathStr] -> handlePath'Arg pathStr _ -> Left "`todo` just takes a patch and one optional namespace" Right $ Input.TodoI (Just patch) branch [] -> Right $ Input.TodoI Nothing Path.relativeEmpty' @@ -209,9 +659,11 @@ load = ) ] ) - ( unifyArguments `andThen` \case + ( \case [] -> pure $ Input.LoadI Nothing - [file] -> pure $ Input.LoadI . Just $ file + [file] -> + Input.LoadI . Just + <$> unsupportedStructuredArgument "a file name" file _ -> Left (I.help load) ) @@ -229,7 +681,7 @@ clear = ] ) ( \case - [] -> pure $ Input.ClearI + [] -> pure Input.ClearI _ -> Left (I.help clear) ) @@ -243,7 +695,7 @@ add = ( "`add` adds to the codebase all the definitions from the most recently " <> "typechecked file." ) - $ pure . Input.AddI . Set.fromList . map (Name.unsafeParseText . Text.pack) . unifyArguments + $ bimap P.text (Input.AddI . Set.fromList) . traverse handleNameArg previewAdd :: InputPattern previewAdd = @@ -257,7 +709,7 @@ previewAdd = <> "results. Use `load` to reparse & typecheck the file if the context " <> "has changed." ) - $ pure . Input.PreviewAddI . Set.fromList . map (Name.unsafeParseText . Text.pack) . unifyArguments + $ bimap P.text (Input.PreviewAddI . Set.fromList) . traverse handleNameArg update :: InputPattern update = @@ -272,10 +724,9 @@ update = <> "replacing existing definitions having the same name, and attempts to update all the existing dependents accordingly. If the process" <> "can't be completed automatically, the dependents will be added back to the scratch file" <> "for your review.", - parse = - maybeToEither (I.help update) . \case - [] -> Just Input.Update2I - _ -> Nothing + parse = \case + [] -> pure Input.Update2I + _ -> Left $ I.help update } updateOldNoPatch :: InputPattern @@ -304,12 +755,8 @@ updateOldNoPatch = ) ] ) - ( pure - . Input.UpdateI Input.NoPatch - . Set.fromList - . map (Name.unsafeParseText . Text.pack) - . unifyArguments - ) + $ bimap P.text (Input.UpdateI Input.NoPatch . Set.fromList) + . traverse handleNameArg updateOld :: InputPattern updateOld = @@ -343,13 +790,11 @@ updateOld = ) ] ) - $ unifyArguments `andThen` \case - patchStr : ws -> do - patch <- first P.text $ Path.parseSplit' patchStr - pure $ - Input.UpdateI - (Input.UsePatch patch) - (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) + \case + patchStr : ws -> first P.text do + patch <- handleSplit'Arg patchStr + Input.UpdateI (Input.UsePatch patch) . Set.fromList + <$> traverse handleNameArg ws [] -> Right $ Input.UpdateI Input.DefaultPatch mempty previewUpdate :: InputPattern @@ -364,7 +809,8 @@ previewUpdate = <> "typechecking results. Use `load` to reparse & typecheck the file if " <> "the context has changed." ) - $ pure . Input.PreviewUpdateI . Set.fromList . map (Name.unsafeParseText . Text.pack) . unifyArguments + $ bimap P.text (Input.PreviewUpdateI . Set.fromList) + . traverse handleNameArg patch :: InputPattern patch = @@ -392,13 +838,16 @@ patch = ] ] ) - $ unifyArguments `andThen` \case - patchStr : ws -> first P.text do - patch <- Path.parseSplit' patchStr - branch <- case ws of - [pathStr] -> Path.parsePath' pathStr - _ -> pure Path.relativeEmpty' - pure $ Input.PropagatePatchI patch branch + $ \case + patchStr : ws -> + Input.PropagatePatchI + <$> first P.text (handleSplit'Arg patchStr) + <*> case ws of + [] -> pure Path.relativeEmpty' + [pathStr] -> first P.text $ handlePath'Arg pathStr + -- __FIXME__: This is a breaking change (previously, too many 3+ would + -- work the same as only one arg) + _ -> Left $ I.help patch [] -> Left $ warn $ @@ -423,12 +872,12 @@ view = <> "not `List.map.doc` (since ? only matches 1 name segment)." ] ) - ( unifyArguments `andThen` \case - (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - & fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionLocal) - _ -> Left (I.help view) + ( maybe + (Left $ I.help view) + ( fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionLocal) + . traverse handleHashQualifiedNameArg + ) + . NE.nonEmpty ) viewGlobal :: InputPattern @@ -443,12 +892,12 @@ viewGlobal = "`view.global` without arguments invokes a search to select definitions to view, which requires that `fzf` can be found within your PATH." ] ) - ( unifyArguments `andThen` \case - (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - & fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionGlobal) - _ -> Left (I.help viewGlobal) + ( maybe + (Left $ I.help viewGlobal) + ( fmap (Input.ShowDefinitionI Input.ConsoleLocation Input.ShowDefinitionGlobal) + . traverse handleHashQualifiedNameArg + ) + . NE.nonEmpty ) display :: InputPattern @@ -463,12 +912,12 @@ display = "`display` without arguments invokes a search to select a definition to display, which requires that `fzf` can be found within your PATH." ] ) - $ unifyArguments `andThen` \case - (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - <&> Input.DisplayI Input.ConsoleLocation - _ -> Left (I.help display) + $ maybe + (Left $ I.help display) + ( fmap (Input.DisplayI Input.ConsoleLocation) + . traverse handleHashQualifiedNameArg + ) + . NE.nonEmpty displayTo :: InputPattern displayTo = @@ -481,11 +930,16 @@ displayTo = makeExample displayTo ["", "foo"] <> "prints a rendered version of the term `foo` to the given file." ) - $ unifyArguments `andThen` \case - file : (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - <&> Input.DisplayI (Input.FileLocation file) + $ \case + file : defs -> + maybe + (Left $ I.help displayTo) + ( \defs -> + Input.DisplayI . Input.FileLocation + <$> unsupportedStructuredArgument "a file name" file + <*> traverse handleHashQualifiedNameArg defs + ) + $ NE.nonEmpty defs _ -> Left (I.help displayTo) docs :: InputPattern @@ -500,13 +954,10 @@ docs = "`docs` without arguments invokes a search to select which definition to view documentation for, which requires that `fzf` can be found within your PATH." ] ) - ( unifyArguments `andThen` \case - x : xs -> - (x NE.:| xs) - & traverse Path.parseHQSplit' - & bimap P.text Input.DocsI - _ -> Left (I.help docs) - ) + $ maybe + (Left $ I.help docs) + (bimap P.text Input.DocsI . traverse handleHashQualifiedSplit'Arg) + . NE.nonEmpty api :: InputPattern api = @@ -526,13 +977,10 @@ ui = visibility = I.Visible, args = [("definition to load", Optional, namespaceOrDefinitionArg)], help = P.wrap "`ui` opens the Local UI in the default browser.", - parse = - unifyArguments `andThen` \case - [] -> pure $ Input.UiI Path.relativeEmpty' - [path] -> first P.text $ do - p <- Path.parsePath' path - pure $ Input.UiI p - _ -> Left (I.help ui) + parse = \case + [] -> pure $ Input.UiI Path.relativeEmpty' + [path] -> bimap P.text Input.UiI $ handlePath'Arg path + _ -> Left (I.help ui) } undo :: InputPattern @@ -554,15 +1002,16 @@ viewByPrefix = [("definition to view", OnePlus, definitionQueryArg)] "`view.recursive Foo` prints the definitions of `Foo` and `Foo.blah`." ( fmap (Input.ShowDefinitionByPrefixI Input.ConsoleLocation) - . traverse parseHashQualifiedName - . unifyArguments + . traverse handleHashQualifiedNameArg ) sfind :: InputPattern sfind = - InputPattern "rewrite.find" ["sfind"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg $ parse . unifyArguments + InputPattern "rewrite.find" ["sfind"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse where - parse [q] = Input.StructuredFindI (Input.FindLocal Path.empty) <$> parseHashQualifiedName q + parse [q] = + Input.StructuredFindI (Input.FindLocal Path.empty) + <$> handleHashQualifiedNameArg q parse _ = Left "expected exactly one argument" msg = P.lines @@ -591,9 +1040,9 @@ sfind = sfindReplace :: InputPattern sfindReplace = - InputPattern "rewrite" ["sfind.replace"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg $ parse . unifyArguments + InputPattern "rewrite" ["sfind.replace"] I.Visible [("rewrite-rule definition", Required, definitionQueryArg)] msg parse where - parse [q] = Input.StructuredFindReplaceI <$> parseHashQualifiedName q + parse [q] = Input.StructuredFindReplaceI <$> handleHashQualifiedNameArg q parse _ = Left "expected exactly one argument" msg :: P.Pretty CT.ColorText msg = @@ -640,10 +1089,17 @@ findIn' cmd mkfscope = I.Visible [("namespace", Required, namespaceArg), ("query", ZeroPlus, exactDefinitionArg)] findHelp - $ unifyArguments `andThen` \case - p : args -> first P.text do - p <- Path.parsePath p - pure (Input.FindI False (mkfscope p) args) + $ \case + p : args -> + Input.FindI False . mkfscope + <$> first P.text (handlePathArg p) + -- __FIXME__: This changes things a bit. Previously, `find` and + -- friends would just expand the numbered args and search + -- for them like any other string, but now it recognizes + -- that you’re trying to look up something you already + -- have, and refuses to. Is that the right thing to do? We + -- _could_ still serialize in this case. + <*> traverse (unsupportedStructuredArgument "text") args _ -> Left findHelp findHelp :: P.Pretty CT.ColorText @@ -690,7 +1146,7 @@ find' cmd fscope = I.Visible [("query", ZeroPlus, exactDefinitionArg)] findHelp - (pure . Input.FindI False fscope . unifyArguments) + (fmap (Input.FindI False fscope) . traverse (unsupportedStructuredArgument "text")) findShallow :: InputPattern findShallow = @@ -705,11 +1161,9 @@ findShallow = ("`list .foo`", "lists the '.foo' namespace.") ] ) - ( unifyArguments `andThen` \case - [] -> pure $ Input.FindShallowI Path.relativeEmpty' - [path] -> first P.text $ do - p <- Path.parsePath' path - pure $ Input.FindShallowI p + ( fmap Input.FindShallowI . \case + [] -> pure Path.relativeEmpty' + [path] -> first P.text $ handlePath'Arg path _ -> Left (I.help findShallow) ) @@ -723,7 +1177,9 @@ findVerbose = ( "`find.verbose` searches for definitions like `find`, but includes hashes " <> "and aliases in the results." ) - (pure . Input.FindI True (Input.FindLocal Path.empty) . unifyArguments) + ( fmap (Input.FindI True $ Input.FindLocal Path.empty) + . traverse (unsupportedStructuredArgument "text") + ) findVerboseAll :: InputPattern findVerboseAll = @@ -735,7 +1191,9 @@ findVerboseAll = ( "`find.all.verbose` searches for definitions like `find.all`, but includes hashes " <> "and aliases in the results." ) - (pure . Input.FindI True (Input.FindLocalAndDeps Path.empty) . unifyArguments) + ( fmap (Input.FindI True $ Input.FindLocalAndDeps Path.empty) + . traverse (unsupportedStructuredArgument "text") + ) findPatch :: InputPattern findPatch = @@ -759,11 +1217,12 @@ renameTerm = ("new location", Required, newNameArg) ] "`move.term foo bar` renames `foo` to `bar`." - ( unifyArguments `andThen` \case - [oldName, newName] -> first P.text do - src <- Path.parseHQSplit' oldName - target <- Path.parseSplit' newName - pure $ Input.MoveTermI src target + ( \case + [oldName, newName] -> + first P.text $ + Input.MoveTermI + <$> handleHashQualifiedSplit'Arg oldName + <*> handleNewName newName _ -> Left . P.warnCallout $ P.wrap @@ -780,11 +1239,12 @@ moveAll = ("new location", Required, newNameArg) ] "`move foo bar` renames the term, type, and namespace foo to bar." - ( unifyArguments `andThen` \case - [oldName, newName] -> first P.text $ do - src <- Path.parsePath' oldName - target <- Path.parsePath' newName - pure $ Input.MoveAllI src target + ( \case + [oldName, newName] -> + first P.text $ + Input.MoveAllI + <$> handlePath'Arg oldName + <*> handleNewPath newName _ -> Left . P.warnCallout $ P.wrap @@ -801,11 +1261,12 @@ renameType = ("new location", Required, newNameArg) ] "`move.type foo bar` renames `foo` to `bar`." - ( unifyArguments `andThen` \case - [oldName, newName] -> first P.text do - src <- Path.parseHQSplit' oldName - target <- Path.parseSplit' newName - pure $ Input.MoveTypeI src target + ( \case + [oldName, newName] -> + first P.text $ + Input.MoveTypeI + <$> handleHashQualifiedSplit'Arg oldName + <*> handleNewName newName _ -> Left . P.warnCallout $ P.wrap @@ -849,11 +1310,11 @@ deleteGen suffix queryCompletionArg target mkTarget = I.Visible [("definition to delete", OnePlus, queryCompletionArg)] info - ( unifyArguments `andThen` \case + ( \case [] -> Left . P.warnCallout $ P.wrap warn - queries -> first P.text do - paths <- traverse Path.parseHQSplit' queries - pure $ Input.DeleteI (mkTarget paths) + queries -> + bimap P.text (Input.DeleteI . mkTarget) $ + traverse handleHashQualifiedSplit'Arg queries ) delete :: InputPattern @@ -897,11 +1358,11 @@ deleteReplacement isTerm = <> str <> " - not the one in place after the edit." ) - ( unifyArguments `andThen` \case - query : patch -> do - patch <- first P.text . traverse Path.parseSplit' $ listToMaybe patch - q <- parseHashQualifiedName query - pure $ input q patch + ( \case + query : patch -> + input + <$> handleHashQualifiedNameArg query + <*> first P.text (traverse handleSplit'Arg $ listToMaybe patch) _ -> Left . P.warnCallout @@ -933,12 +1394,11 @@ deleteProject = P.wrapColumn2 [ ("`delete.project foo`", "deletes the local project `foo`") ], - parse = - unifyArguments `andThen` \case - [name] - | Right project <- tryInto @ProjectName (Text.pack name) -> - Right (Input.DeleteI (DeleteTarget'Project project)) - _ -> Left (showPatternHelp deleteProject) + parse = \case + [name] -> + bimap P.text (Input.DeleteI . DeleteTarget'Project) $ + handleProjectArg name + _ -> Left (showPatternHelp deleteProject) } deleteBranch :: InputPattern @@ -953,13 +1413,11 @@ deleteBranch = [ ("`delete.branch foo/bar`", "deletes the branch `bar` in the project `foo`"), ("`delete.branch /bar`", "deletes the branch `bar` in the current project") ], - parse = - unifyArguments `andThen` \case - [name] -> - case tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack name) of - Left _ -> Left (showPatternHelp deleteBranch) - Right projectAndBranch -> Right (Input.DeleteI (DeleteTarget'ProjectBranch projectAndBranch)) - _ -> Left (showPatternHelp deleteBranch) + parse = \case + [name] -> + bimap P.text (Input.DeleteI . DeleteTarget'ProjectBranch) $ + handleProjectAndBranchArg name + _ -> Left (showPatternHelp deleteBranch) } where suggestionsConfig = @@ -983,11 +1441,12 @@ aliasTerm = I.Visible [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)] "`alias.term foo bar` introduces `bar` with the same definition as `foo`." - $ unifyArguments `andThen` \case - [oldName, newName] -> first P.text do - source <- Path.parseShortHashOrHQSplit' oldName - target <- Path.parseSplit' newName - pure $ Input.AliasTermI source target + $ \case + [oldName, newName] -> + first P.text $ + Input.AliasTermI + <$> handleShortHashOrHQSplit'Arg oldName + <*> handleSplit'Arg newName _ -> Left . warn $ P.wrap @@ -1001,11 +1460,12 @@ aliasType = I.Visible [("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)] "`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`." - $ unifyArguments `andThen` \case - [oldName, newName] -> first P.text do - source <- Path.parseShortHashOrHQSplit' oldName - target <- Path.parseSplit' newName - pure $ Input.AliasTypeI source target + $ \case + [oldName, newName] -> + first P.text $ + Input.AliasTypeI + <$> handleShortHashOrHQSplit'Arg oldName + <*> handleSplit'Arg newName _ -> Left . warn $ P.wrap @@ -1027,11 +1487,12 @@ aliasMany = <> "creates aliases `.quux.foo.foo` and `.quux.bar.bar`." ] ) - $ unifyArguments `andThen` \case - srcs@(_ : _) Cons.:> dest -> first P.text do - sourceDefinitions <- traverse Path.parseHQSplit srcs - destNamespace <- Path.parsePath' dest - pure $ Input.AliasManyI sourceDefinitions destNamespace + $ \case + srcs@(_ : _) Cons.:> dest -> + first P.text $ + Input.AliasManyI + <$> traverse handleHashQualifiedSplitArg srcs + <*> handlePath'Arg dest _ -> Left (I.help aliasMany) up :: InputPattern @@ -1073,11 +1534,9 @@ cd = ] ] ) - $ unifyArguments `andThen` \case - [".."] -> Right Input.UpI - [p] -> first P.text do - p <- Path.parsePath' p - pure . Input.SwitchBranchI $ p + $ \case + [Left ".."] -> Right Input.UpI + [p] -> bimap P.text Input.SwitchBranchI $ handlePath'Arg p _ -> Left (I.help cd) back :: InputPattern @@ -1105,7 +1564,7 @@ deleteNamespace = I.Visible [("namespace to delete", Required, namespaceArg)] "`delete.namespace ` deletes the namespace `foo`" - (deleteNamespaceParser (I.help deleteNamespace) Input.Try . unifyArguments) + (deleteNamespaceParser (I.help deleteNamespace) Input.Try) deleteNamespaceForce :: InputPattern deleteNamespaceForce = @@ -1117,17 +1576,17 @@ deleteNamespaceForce = ( "`delete.namespace.force ` deletes the namespace `foo`," <> "deletion will proceed even if other code depends on definitions in foo." ) - (deleteNamespaceParser (I.help deleteNamespaceForce) Input.Force . unifyArguments) + (deleteNamespaceParser (I.help deleteNamespaceForce) Input.Force) -deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> [String] -> Either (P.Pretty CT.ColorText) Input +deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> I.Arguments -> Either (P.Pretty CT.ColorText) Input deleteNamespaceParser helpText insistence = \case - ["."] -> + [Left "."] -> first fromString . pure $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) - [p] -> first P.text do - p <- Path.parseSplit' p - pure $ Input.DeleteI (DeleteTarget'Namespace insistence (Just p)) + [p] -> + bimap P.text (Input.DeleteI . DeleteTarget'Namespace insistence . pure) $ + handleSplit'Arg p _ -> Left helpText deletePatch :: InputPattern @@ -1138,23 +1597,20 @@ deletePatch = I.Visible [("patch to delete", Required, patchArg)] "`delete.patch ` deletes the patch `foo`" - $ unifyArguments `andThen` \case - [p] -> first P.text do - p <- Path.parseSplit' p - pure . Input.DeleteI $ DeleteTarget'Patch p + $ \case + [p] -> + bimap P.text (Input.DeleteI . DeleteTarget'Patch) $ handleSplit'Arg p _ -> Left (I.help deletePatch) -movePatch :: String -> String -> Either (P.Pretty CT.ColorText) Input -movePatch src dest = first P.text do - src <- Path.parseSplit' src - dest <- Path.parseSplit' dest - pure $ Input.MovePatchI src dest +movePatch :: I.Argument -> I.Argument -> Either (P.Pretty CT.ColorText) Input +movePatch src dest = + first P.text $ + Input.MovePatchI <$> handleSplit'Arg src <*> handleSplit'Arg dest -copyPatch' :: String -> String -> Either (P.Pretty CT.ColorText) Input -copyPatch' src dest = first P.text do - src <- Path.parseSplit' src - dest <- Path.parseSplit' dest - pure $ Input.CopyPatchI src dest +copyPatch' :: I.Argument -> I.Argument -> Either (P.Pretty CT.ColorText) Input +copyPatch' src dest = + first P.text $ + Input.CopyPatchI <$> handleSplit'Arg src <*> handleSplit'Arg dest copyPatch :: InputPattern copyPatch = @@ -1164,7 +1620,7 @@ copyPatch = I.Visible [("patch to copy", Required, patchArg), ("copy destination", Required, newNameArg)] "`copy.patch foo bar` copies the patch `foo` to `bar`." - $ unifyArguments `andThen` \case + $ \case [src, dest] -> copyPatch' src dest _ -> Left (I.help copyPatch) @@ -1176,7 +1632,7 @@ renamePatch = I.Visible [("patch", Required, patchArg), ("new location", Required, newNameArg)] "`move.patch foo bar` renames the patch `foo` to `bar`." - $ unifyArguments `andThen` \case + $ \case [src, dest] -> movePatch src dest _ -> Left (I.help renamePatch) @@ -1188,11 +1644,10 @@ renameBranch = I.Visible [("namespace to move", Required, namespaceArg), ("new location", Required, newNameArg)] "`move.namespace foo bar` renames the path `foo` to `bar`." - $ unifyArguments `andThen` \case - [src, dest] -> first P.text do - src <- Path.parsePath' src - dest <- Path.parsePath' dest - pure $ Input.MoveBranchI src dest + $ \case + [src, dest] -> + first P.text $ + Input.MoveBranchI <$> handlePath'Arg src <*> handlePath'Arg dest _ -> Left (I.help renameBranch) history :: InputPattern @@ -1211,10 +1666,10 @@ history = ) ] ) - $ unifyArguments `andThen` \case - [src] -> first P.text do - p <- Input.parseBranchId src - pure $ Input.HistoryI (Just 10) (Just 10) p + $ \case + [src] -> + bimap P.text (Input.HistoryI (Just 10) (Just 10)) $ + handleBranchIdArg src [] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath) _ -> Left (I.help history) @@ -1239,11 +1694,11 @@ forkLocal = ) ] ) - $ unifyArguments `andThen` \case - [src, dest] -> do - src <- Input.parseBranchId2 src - dest <- parseBranchRelativePath dest - pure $ Input.ForkLocalBranchI src dest + $ \case + [src, dest] -> + Input.ForkLocalBranchI + <$> handleBranchId2Arg src + <*> handleBranchRelativePathArg dest _ -> Left (I.help forkLocal) reset :: InputPattern @@ -1262,35 +1717,18 @@ reset = ("`reset #pvfd222s8n /topic`", "reset the branch `topic` of the current project to the causal `#pvfd222s8n`.") ] ) - ( maybeToEither (I.help reset) - . ( \case - arg0 : restArgs -> do - arg0 <- branchIdOrProject arg0 - arg1 <- case restArgs of - [] -> pure Nothing - arg1 : [] -> Just <$> parseLooseCodeOrProject arg1 - _ -> Nothing - Just (Input.ResetI arg0 arg1) - _ -> Nothing - ) - . unifyArguments + ( \case + [arg0] -> + Input.ResetI + <$> first P.text (handleBranchIdOrProjectArg arg0) + <*> pure Nothing + [arg0, arg1] -> + Input.ResetI + <$> first P.text (handleBranchIdOrProjectArg arg0) + <*> bimap P.text pure (handleLooseCodeOrProjectArg arg1) + _ -> Left $ I.help reset ) where - branchIdOrProject :: - String -> - Maybe - ( These - Input.BranchId - (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - ) - branchIdOrProject str = - let branchIdRes = Input.parseBranchId str - projectRes = tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack str) - in case (branchIdRes, projectRes) of - (Left _, Left _) -> Nothing - (Left _, Right pr) -> Just (That pr) - (Right bid, Left _) -> Just (This bid) - (Right bid, Right pr) -> Just (These bid pr) config = ProjectBranchSuggestionsConfig { showProjectCompletions = False, @@ -1319,10 +1757,8 @@ resetRoot = ] ] ) - $ unifyArguments `andThen` \case - [src] -> first P.text $ do - src <- Input.parseBranchId src - pure $ Input.ResetRootI src + $ \case + [src] -> bimap P.text Input.ResetRootI $ handleBranchIdArg src _ -> Left (I.help resetRoot) pull :: InputPattern @@ -1387,24 +1823,27 @@ pullImpl name aliases verbosity pullMode addendum = do explainRemote Pull ], parse = - maybeToEither (I.help self) + fmap + ( \sourceTarget -> + Input.PullRemoteBranchI + sourceTarget + SyncMode.ShortCircuit + pullMode + verbosity + ) . ( \case - [] -> Just $ Input.PullRemoteBranchI Input.PullSourceTarget0 SyncMode.ShortCircuit pullMode verbosity - [sourceString] -> do - source <- parsePullSource (Text.pack sourceString) - Just $ Input.PullRemoteBranchI (Input.PullSourceTarget1 source) SyncMode.ShortCircuit pullMode verbosity - [sourceString, targetString] -> do - source <- parsePullSource (Text.pack sourceString) - target <- parseLooseCodeOrProject targetString - Just $ - Input.PullRemoteBranchI - (Input.PullSourceTarget2 source target) - SyncMode.ShortCircuit - pullMode - verbosity - _ -> Nothing + [] -> pure $ Input.PullSourceTarget0 + [sourceString] -> + first P.text $ + Input.PullSourceTarget1 + <$> handlePullSourceArg sourceString + [sourceString, targetString] -> + first P.text $ + Input.PullSourceTarget2 + <$> handlePullSourceArg sourceString + <*> handleLooseCodeOrProjectArg targetString + _ -> Left $ I.help self ) - . unifyArguments } pullExhaustive :: InputPattern @@ -1425,35 +1864,27 @@ pullExhaustive = <> "versions M1l and earlier. It may be extra slow!" ] ) - ( maybeToEither (I.help pullExhaustive) + ( fmap + ( \sourceTarget -> + Input.PullRemoteBranchI + sourceTarget + SyncMode.Complete + Input.PullWithHistory + Verbosity.Verbose + ) . ( \case - [] -> - Just $ - Input.PullRemoteBranchI - Input.PullSourceTarget0 - SyncMode.Complete - Input.PullWithHistory - Verbosity.Verbose - [sourceString] -> do - source <- parsePullSource (Text.pack sourceString) - Just $ - Input.PullRemoteBranchI - (Input.PullSourceTarget1 source) - SyncMode.Complete - Input.PullWithHistory - Verbosity.Verbose - [sourceString, targetString] -> do - source <- parsePullSource (Text.pack sourceString) - target <- parseLooseCodeOrProject targetString - Just $ - Input.PullRemoteBranchI - (Input.PullSourceTarget2 source target) - SyncMode.Complete - Input.PullWithHistory - Verbosity.Verbose - _ -> Nothing + [] -> pure $ Input.PullSourceTarget0 + [sourceString] -> + first P.text $ + Input.PullSourceTarget1 + <$> handlePullSourceArg sourceString + [sourceString, targetString] -> + first P.text $ + Input.PullSourceTarget2 + <$> handlePullSourceArg sourceString + <*> handleLooseCodeOrProjectArg targetString + _ -> Left $ I.help pullExhaustive ) - . unifyArguments ) debugTabCompletion :: InputPattern @@ -1468,7 +1899,7 @@ debugTabCompletion = P.wrap $ "Completions which are finished are prefixed with a * represent finished completions." ] ) - (Right . Input.DebugTabCompletionI . unifyArguments) + (fmap Input.DebugTabCompletionI . traverse (unsupportedStructuredArgument "text")) debugFuzzyOptions :: InputPattern debugFuzzyOptions = @@ -1485,9 +1916,11 @@ debugFuzzyOptions = P.wrap $ "or `debug.fuzzy-options merge - _`" ] ) - $ unifyArguments `andThen` \case + $ \case (cmd : args) -> - Right $ Input.DebugFuzzyOptionsI cmd args + Input.DebugFuzzyOptionsI + <$> unsupportedStructuredArgument "a command" cmd + <*> traverse (unsupportedStructuredArgument "text") args _ -> Left (I.help debugFuzzyOptions) debugFormat :: InputPattern @@ -1538,25 +1971,25 @@ push = explainRemote Push ] ) - $ unifyArguments `andThen` \args -> do - sourceTarget <- - case args of - [] -> Right Input.PushSourceTarget0 - [targetStr] -> do - target <- parsePushTarget targetStr - Right (Input.PushSourceTarget1 target) - [targetStr, sourceStr] -> do - target <- parsePushTarget targetStr - source <- parsePushSource sourceStr - Right (Input.PushSourceTarget2 source target) - _ -> Left (I.help push) - Right $ - Input.PushRemoteBranchI - Input.PushRemoteBranchInput - { sourceTarget, - pushBehavior = PushBehavior.RequireNonEmpty, - syncMode = SyncMode.ShortCircuit - } + $ fmap + ( \sourceTarget -> + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { sourceTarget, + pushBehavior = PushBehavior.RequireNonEmpty, + syncMode = SyncMode.ShortCircuit + } + ) + . \case + [] -> pure Input.PushSourceTarget0 + [targetStr] -> + bimap P.text Input.PushSourceTarget1 $ handlePushTargetArg targetStr + [targetStr, sourceStr] -> + first P.text $ + Input.PushSourceTarget2 + <$> handlePushSourceArg sourceStr + <*> handlePushTargetArg targetStr + _ -> Left (I.help push) where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1594,25 +2027,25 @@ pushCreate = explainRemote Push ] ) - $ unifyArguments `andThen` \args -> do - sourceTarget <- - case args of - [] -> Right Input.PushSourceTarget0 - [targetStr] -> do - target <- parsePushTarget targetStr - Right (Input.PushSourceTarget1 target) - [targetStr, sourceStr] -> do - target <- parsePushTarget targetStr - source <- parsePushSource sourceStr - Right (Input.PushSourceTarget2 source target) - _ -> Left (I.help pushForce) - Right $ - Input.PushRemoteBranchI - Input.PushRemoteBranchInput - { sourceTarget, - pushBehavior = PushBehavior.RequireEmpty, - syncMode = SyncMode.ShortCircuit - } + $ fmap + ( \sourceTarget -> + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { sourceTarget, + pushBehavior = PushBehavior.RequireEmpty, + syncMode = SyncMode.ShortCircuit + } + ) + . \case + [] -> pure Input.PushSourceTarget0 + [targetStr] -> + bimap P.text Input.PushSourceTarget1 $ handlePushTargetArg targetStr + [targetStr, sourceStr] -> + first P.text $ + Input.PushSourceTarget2 + <$> handlePushSourceArg sourceStr + <*> handlePushTargetArg targetStr + _ -> Left (I.help pushForce) where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1629,25 +2062,25 @@ pushForce = I.Hidden [("remote destination", Optional, remoteNamespaceArg), ("local source", Optional, namespaceOrProjectBranchArg suggestionsConfig)] (P.wrap "Like `push`, but overwrites any remote namespace.") - $ unifyArguments `andThen` \args -> do - sourceTarget <- - case args of - [] -> Right Input.PushSourceTarget0 - [targetStr] -> do - target <- parsePushTarget targetStr - Right (Input.PushSourceTarget1 target) - [targetStr, sourceStr] -> do - target <- parsePushTarget targetStr - source <- parsePushSource sourceStr - Right (Input.PushSourceTarget2 source target) - _ -> Left (I.help pushForce) - Right $ - Input.PushRemoteBranchI - Input.PushRemoteBranchInput - { sourceTarget, - pushBehavior = PushBehavior.ForcePush, - syncMode = SyncMode.ShortCircuit - } + $ fmap + ( \sourceTarget -> + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { sourceTarget, + pushBehavior = PushBehavior.ForcePush, + syncMode = SyncMode.ShortCircuit + } + ) + . \case + [] -> pure Input.PushSourceTarget0 + [targetStr] -> + bimap P.text Input.PushSourceTarget1 $ handlePushTargetArg targetStr + [targetStr, sourceStr] -> + first P.text $ + Input.PushSourceTarget2 + <$> handlePushSourceArg sourceStr + <*> handlePushTargetArg targetStr + _ -> Left (I.help pushForce) where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1674,25 +2107,25 @@ pushExhaustive = <> "versions M1l and earlier. It may be extra slow!" ] ) - $ unifyArguments `andThen` \args -> do - sourceTarget <- - case args of - [] -> Right Input.PushSourceTarget0 - [targetStr] -> do - target <- parsePushTarget targetStr - Right (Input.PushSourceTarget1 target) - [targetStr, sourceStr] -> do - target <- parsePushTarget targetStr - source <- parsePushSource sourceStr - Right (Input.PushSourceTarget2 source target) - _ -> Left (I.help pushExhaustive) - Right $ - Input.PushRemoteBranchI - Input.PushRemoteBranchInput - { sourceTarget, - pushBehavior = PushBehavior.RequireNonEmpty, - syncMode = SyncMode.Complete - } + $ fmap + ( \sourceTarget -> + Input.PushRemoteBranchI + Input.PushRemoteBranchInput + { sourceTarget, + pushBehavior = PushBehavior.RequireNonEmpty, + syncMode = SyncMode.Complete + } + ) + . \case + [] -> pure Input.PushSourceTarget0 + [targetStr] -> + bimap P.text Input.PushSourceTarget1 $ handlePushTargetArg targetStr + [targetStr, sourceStr] -> + first P.text $ + Input.PushSourceTarget2 + <$> handlePushSourceArg sourceStr + <*> handlePushTargetArg targetStr + _ -> Left (I.help pushExhaustive) where suggestionsConfig = ProjectBranchSuggestionsConfig @@ -1715,16 +2148,14 @@ squashMerge = <> "discarding the history of `src` in the process." <> "The resulting `dest` will have (at most) 1" <> "additional history entry.", - parse = - maybeToEither (I.help squashMerge) - . ( \case - [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - Just $ Input.MergeLocalBranchI src dest Branch.SquashMerge - _ -> Nothing - ) - . unifyArguments + parse = \case + [src, dest] -> + first P.text $ + Input.MergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> handleLooseCodeOrProjectArg dest + <*> pure Branch.SquashMerge + _ -> Left $ I.help squashMerge } where suggestionsConfig = @@ -1764,18 +2195,20 @@ mergeLocal = ) ] ) - ( maybeToEither (I.help mergeLocal) - . ( \case - [src] -> do - src <- parseLooseCodeOrProject src - Just $ Input.MergeLocalBranchI src (This Path.relativeEmpty') Branch.RegularMerge - [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - Just $ Input.MergeLocalBranchI src dest Branch.RegularMerge - _ -> Nothing - ) - . unifyArguments + ( \case + [src] -> + first P.text $ + Input.MergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> pure (This Path.relativeEmpty') + <*> pure Branch.RegularMerge + [src, dest] -> + first P.text $ + Input.MergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> handleLooseCodeOrProjectArg dest + <*> pure Branch.RegularMerge + _ -> Left $ I.help mergeLocal ) where config = @@ -1814,14 +2247,17 @@ diffNamespace = ) ] ) - ( unifyArguments `andThen` \case - [before, after] -> first P.text do - before <- Input.parseBranchId before - after <- Input.parseBranchId after - pure $ Input.DiffNamespaceI before after - [before] -> first P.text do - before <- Input.parseBranchId before - pure $ Input.DiffNamespaceI before (Right Path.currentPath) + ( \case + [before, after] -> + first P.text $ + Input.DiffNamespaceI + <$> handleBranchIdArg before + <*> handleBranchIdArg after + [before] -> + first P.text $ + Input.DiffNamespaceI + <$> handleBranchIdArg before + <*> pure (pure Path.currentPath) _ -> Left $ I.help diffNamespace ) where @@ -1848,18 +2284,18 @@ previewMergeLocal = ) ] ) - ( maybeToEither (I.help previewMergeLocal) - . ( \case - [src] -> do - src <- parseLooseCodeOrProject src - pure $ Input.PreviewMergeLocalBranchI src (This Path.relativeEmpty') - [src, dest] -> do - src <- parseLooseCodeOrProject src - dest <- parseLooseCodeOrProject dest - pure $ Input.PreviewMergeLocalBranchI src dest - _ -> Nothing - ) - . unifyArguments + ( \case + [src] -> + first P.text $ + Input.PreviewMergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> pure (This Path.relativeEmpty') + [src, dest] -> + first P.text $ + Input.PreviewMergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> handleLooseCodeOrProjectArg dest + _ -> Left $ I.help previewMergeLocal ) where suggestionsConfig = @@ -1896,12 +2332,12 @@ replaceEdit f = self ) ] ) - ( unifyArguments `andThen` \case - source : target : patch -> do - patch <- first P.text <$> traverse Path.parseSplit' $ listToMaybe patch - sourcehq <- parseHashQualifiedName source - targethq <- parseHashQualifiedName target - pure $ f sourcehq targethq patch + ( \case + source : target : patch -> + f + <$> handleHashQualifiedNameArg source + <*> handleHashQualifiedNameArg target + <*> first P.text (traverse handleSplit'Arg $ listToMaybe patch) _ -> Left $ I.help self ) @@ -1937,12 +2373,12 @@ edit = "`edit` without arguments invokes a search to select a definition for editing, which requires that `fzf` can be found within your PATH." ], parse = - unifyArguments `andThen` \case - (x : xs) -> - (x NE.:| xs) - & traverse parseHashQualifiedName - <&> (Input.ShowDefinitionI Input.LatestFileLocation Input.ShowDefinitionLocal) - [] -> Left (I.help edit) + maybe + (Left $ I.help edit) + ( fmap (Input.ShowDefinitionI Input.LatestFileLocation Input.ShowDefinitionLocal) + . traverse handleHashQualifiedNameArg + ) + . NE.nonEmpty } editNamespace :: InputPattern @@ -1957,7 +2393,7 @@ editNamespace = [ "`edit.namespace` will load all terms and types contained within the current namespace into your scratch file. This includes definitions in namespaces, but excludes libraries.", "`edit.namespace ns1 ns2 ...` loads the terms and types contained within the provided namespaces." ], - parse = Right . Input.EditNamespaceI . fmap (Path.unsafeParseText . Text.pack) . unifyArguments + parse = bimap P.text Input.EditNamespaceI . traverse handlePathArg } topicNameArg :: ArgumentType @@ -1965,7 +2401,7 @@ topicNameArg = let topics = Map.keys helpTopicsMap in ArgumentType { typeName = "topic", - suggestions = \q _ _ _ -> pure (exactComplete q $ topics), + suggestions = \q _ _ _ -> pure (exactComplete q topics), fzfResolver = Just $ Resolvers.fuzzySelectFromList (Text.pack <$> topics) } @@ -1985,11 +2421,13 @@ helpTopics = I.Visible [("topic", Optional, topicNameArg)] ("`help-topics` lists all topics and `help-topics ` shows an explanation of that topic.") - ( unifyArguments `andThen` \case + ( \case [] -> Left topics - [topic] -> case Map.lookup topic helpTopicsMap of - Nothing -> Left . warn $ "I don't know of that topic. Try `help-topics`." - Just t -> Left t + [topic] -> do + topic <- unsupportedStructuredArgument "a help topic" topic + case Map.lookup topic helpTopicsMap of + Nothing -> Left . warn $ "I don't know of that topic. Try `help-topics`." + Just t -> Left t _ -> Left $ warn "Use `help-topics ` or `help-topics`." ) where @@ -2168,14 +2606,15 @@ help = I.Visible [("command", Optional, commandNameArg)] "`help` shows general help and `help ` shows help for one command." - $ unifyArguments `andThen` \case + $ \case [] -> Left $ intercalateMap "\n\n" showPatternHelp visibleInputs - [cmd] -> + [cmd] -> do + cmd <- unsupportedStructuredArgument "a command" cmd case (Map.lookup cmd commandsByName, isHelp cmd) of (Nothing, Just msg) -> Left msg (Nothing, Nothing) -> Left . warn $ "I don't know of that command. Try `help`." @@ -2230,11 +2669,10 @@ viewPatch = ) ] ) - $ unifyArguments `andThen` \case + $ \case [] -> Right $ Input.ListEditsI Nothing - [patchStr] -> mapLeft P.text do - patch <- Path.parseSplit' patchStr - Right $ Input.ListEditsI (Just patch) + [patchStr] -> + bimap P.text (Input.ListEditsI . pure) $ handleSplit'Arg patchStr _ -> Left $ warn "`view.patch` takes a patch and that's it." names :: Input.IsGlobal -> InputPattern @@ -2245,13 +2683,8 @@ names isGlobal = I.Visible [("name or hash", Required, definitionQueryArg)] (P.wrap $ makeExample (names isGlobal) ["foo"] <> " shows the hash and all known names for `foo`.") - $ unifyArguments `andThen` \case - [thing] -> case HQ.parseText (Text.pack thing) of - Just hq -> Right $ Input.NamesI isGlobal hq - Nothing -> - Left $ - "I was looking for one of these forms: " - <> P.blue "foo .foo.bar foo#abc #abcde .foo.bar#asdf" + $ \case + [thing] -> Input.NamesI isGlobal <$> handleHashQualifiedNameArg thing _ -> Left (I.help (names isGlobal)) where cmdName = if isGlobal then "names.global" else "names" @@ -2264,8 +2697,8 @@ dependents = I.Visible [("definition", Required, definitionQueryArg)] "List the named dependents of the specified definition." - $ unifyArguments `andThen` \case - [thing] -> fmap Input.ListDependentsI $ parseHashQualifiedName thing + $ \case + [thing] -> Input.ListDependentsI <$> handleHashQualifiedNameArg thing _ -> Left (I.help dependents) dependencies = InputPattern @@ -2274,8 +2707,8 @@ dependencies = I.Visible [("definition", Required, definitionQueryArg)] "List the dependencies of the specified definition." - $ unifyArguments `andThen` \case - [thing] -> fmap Input.ListDependenciesI $ parseHashQualifiedName thing + $ \case + [thing] -> Input.ListDependenciesI <$> handleHashQualifiedNameArg thing _ -> Left (I.help dependencies) namespaceDependencies :: InputPattern @@ -2286,10 +2719,9 @@ namespaceDependencies = I.Visible [("namespace", Optional, namespaceArg)] "List the external dependencies of the specified namespace." - $ unifyArguments `andThen` \case - [p] -> first P.text do - p <- Path.parsePath' p - pure $ Input.NamespaceDependenciesI (Just p) + $ \case + [p] -> + bimap P.text (Input.NamespaceDependenciesI . pure) $ handlePath'Arg p [] -> pure (Input.NamespaceDependenciesI Nothing) _ -> Left (I.help namespaceDependencies) @@ -2341,8 +2773,8 @@ debugTerm = I.Hidden [("term", Required, exactDefinitionTermQueryArg)] "View debugging information for a given term." - ( unifyArguments `andThen` \case - [thing] -> fmap (Input.DebugTermI False) $ parseHashQualifiedName thing + ( \case + [thing] -> Input.DebugTermI False <$> handleHashQualifiedNameArg thing _ -> Left (I.help debugTerm) ) @@ -2354,8 +2786,8 @@ debugTermVerbose = I.Hidden [("term", Required, exactDefinitionTermQueryArg)] "View verbose debugging information for a given term." - ( unifyArguments `andThen` \case - [thing] -> fmap (Input.DebugTermI True) $ parseHashQualifiedName thing + ( \case + [thing] -> Input.DebugTermI True <$> handleHashQualifiedNameArg thing _ -> Left (I.help debugTermVerbose) ) @@ -2367,8 +2799,8 @@ debugType = I.Hidden [("type", Required, exactDefinitionTypeQueryArg)] "View debugging information for a given type." - ( unifyArguments `andThen` \case - [thing] -> fmap (Input.DebugTypeI) $ parseHashQualifiedName thing + ( \case + [thing] -> Input.DebugTypeI <$> handleHashQualifiedNameArg thing _ -> Left (I.help debugType) ) @@ -2415,11 +2847,12 @@ debugNameDiff = args = [("before namespace", Required, namespaceArg), ("after namespace", Required, namespaceArg)], help = P.wrap "List all name changes between two causal hashes. Does not detect patch changes.", parse = - ( unifyArguments `andThen` \case - [from, to] -> first fromString $ do - fromSCH <- Input.parseShortCausalHash from - toSCH <- Input.parseShortCausalHash to - pure $ Input.DebugNameDiffI fromSCH toSCH + ( \case + [from, to] -> + first P.text $ + Input.DebugNameDiffI + <$> handleShortCausalHashArg from + <*> handleShortCausalHashArg to _ -> Left (I.help debugNameDiff) ) } @@ -2474,10 +2907,11 @@ docsToHtml = ) ] ) - $ unifyArguments `andThen` \case - [namespacePath, destinationFilePath] -> first P.text do - np <- Path.parsePath' namespacePath - pure $ Input.DocsToHtmlI np destinationFilePath + $ \case + [namespacePath, destinationFilePath] -> + Input.DocsToHtmlI + <$> first P.text (handlePath'Arg namespacePath) + <*> unsupportedStructuredArgument "a file name" destinationFilePath _ -> Left $ showPatternHelp docsToHtml docToMarkdown :: InputPattern @@ -2493,10 +2927,9 @@ docToMarkdown = ) ] ) - $ unifyArguments `andThen` \case - [docNameText] -> first fromString $ do - docName <- maybeToEither "Invalid name" . Name.parseText . Text.pack $ docNameText - pure $ Input.DocToMarkdownI docName + $ \case + [docNameText] -> + bimap P.text Input.DocToMarkdownI $ handleNameArg docNameText _ -> Left $ showPatternHelp docToMarkdown execute :: InputPattern @@ -2515,9 +2948,10 @@ execute = ) ] ) - $ unifyArguments `andThen` \case - [w] -> pure $ Input.ExecuteI (Text.pack w) [] - w : ws -> pure $ Input.ExecuteI (Text.pack w) ws + $ \case + main : args -> + Input.ExecuteI (Text.pack $ unifyArgument main) + <$> traverse (unsupportedStructuredArgument "a command-line argument") args _ -> Left $ showPatternHelp execute saveExecuteResult :: InputPattern @@ -2530,8 +2964,8 @@ saveExecuteResult = ( "`add.run name` adds to the codebase the result of the most recent `run` command" <> "as `name`." ) - $ unifyArguments `andThen` \case - [w] -> pure $ Input.SaveExecuteResultI (Name.unsafeParseText (Text.pack w)) + $ \case + [w] -> first P.text $ Input.SaveExecuteResultI <$> handleNameArg w _ -> Left $ showPatternHelp saveExecuteResult ioTest :: InputPattern @@ -2547,10 +2981,9 @@ ioTest = "Runs `!mytest`, where `mytest` is a delayed test that can use the `IO` and `Exception` abilities." ) ], - parse = - unifyArguments `andThen` \case - [thing] -> fmap Input.IOTestI $ parseHashQualifiedName thing - _ -> Left $ showPatternHelp ioTest + parse = \case + [thing] -> Input.IOTestI <$> handleHashQualifiedNameArg thing + _ -> Left $ showPatternHelp ioTest } ioTestAll :: InputPattern @@ -2586,9 +3019,11 @@ makeStandalone = ) ] ) - $ unifyArguments `andThen` \case + $ \case [main, file] -> - Input.MakeStandaloneI file <$> parseHashQualifiedName main + Input.MakeStandaloneI + <$> unsupportedStructuredArgument "a file name" file + <*> handleHashQualifiedNameArg main _ -> Left $ showPatternHelp makeStandalone runScheme :: InputPattern @@ -2604,8 +3039,10 @@ runScheme = ) ] ) - $ unifyArguments `andThen` \case - main : args -> Right $ Input.ExecuteSchemeI (Text.pack main) args + $ \case + main : args -> + Input.ExecuteSchemeI (Text.pack $ unifyArgument main) + <$> traverse (unsupportedStructuredArgument "a command-line argument") args _ -> Left $ showPatternHelp runScheme compileScheme :: InputPattern @@ -2623,9 +3060,11 @@ compileScheme = ) ] ) - $ unifyArguments `andThen` \case + $ \case [main, file] -> - Input.CompileSchemeI (Text.pack file) <$> parseHashQualifiedName main + Input.CompileSchemeI . Text.pack + <$> unsupportedStructuredArgument "a file name" file + <*> handleHashQualifiedNameArg main _ -> Left $ showPatternHelp compileScheme createAuthor :: InputPattern @@ -2646,19 +3085,21 @@ createAuthor = <> backtick (P.group ("metadata.copyrightHolders" <> ".")) ) ) - ( unifyArguments `andThen` \case - symbolStr : authorStr@(_ : _) -> first P.text do - symbol <- - Megaparsec.runParser (Megaparsec.withParsecT (fmap NameSegment.renderParseErr) NameSegment.segmentP <* Megaparsec.eof) "" symbolStr - & mapLeft (Text.pack . Megaparsec.errorBundlePretty) - -- let's have a real parser in not too long - let author :: Text - author = Text.pack $ case (unwords authorStr) of - quoted@('"' : _) -> (init . tail) quoted - bare -> bare - pure $ Input.CreateAuthorI symbol author - _ -> Left $ showPatternHelp createAuthor - ) + \case + symbolStr : authorStr@(_ : _) -> + Input.CreateAuthorI + <$> first P.text (handleRelativeNameSegmentArg symbolStr) + <*> fmap + (parseAuthorName . unwords) + (traverse (unsupportedStructuredArgument "text") authorStr) + _ -> Left $ showPatternHelp createAuthor + where + -- let's have a real parser in not too long + parseAuthorName :: String -> Text + parseAuthorName = + Text.pack . \case + ('"' : quoted) -> init quoted + bare -> bare gist :: InputPattern gist = @@ -2681,10 +3122,11 @@ gist = <> "`push.create` of the current namespace to your Unison Share codebase wherever you like!" ] ) - ( unifyArguments `andThen` \case - [repoString] -> do - repo <- parseWriteGitRepo "gist git repo" repoString - pure (Input.GistI (Input.GistInput repo)) + ( \case + [repoString] -> + fmap (Input.GistI . Input.GistInput) + . parseWriteGitRepo "gist git repo" + =<< unsupportedStructuredArgument "a VCS repository" repoString _ -> Left (showPatternHelp gist) ) @@ -2728,15 +3170,14 @@ diffNamespaceToPatch = visibility = I.Visible, args = [], help = P.wrap "Create a patch from a namespace diff.", - parse = - unifyArguments `andThen` \case - [branchId1, branchId2, patch] -> - mapLeft P.text do - branchId1 <- Input.parseBranchId branchId1 - branchId2 <- Input.parseBranchId branchId2 - patch <- Path.parseSplit' patch - pure (Input.DiffNamespaceToPatchI Input.DiffNamespaceToPatchInput {branchId1, branchId2, patch}) - _ -> Left (showPatternHelp diffNamespaceToPatch) + parse = \case + [branchId1, branchId2, patch] -> + bimap P.text Input.DiffNamespaceToPatchI $ + Input.DiffNamespaceToPatchInput + <$> handleBranchIdArg branchId1 + <*> handleBranchIdArg branchId2 + <*> handleSplit'Arg patch + _ -> Left (showPatternHelp diffNamespaceToPatch) } projectCreate :: InputPattern @@ -2751,13 +3192,12 @@ projectCreate = [ ("`project.create`", "creates a project with a random name"), ("`project.create foo`", "creates a project named `foo`") ], - parse = - unifyArguments `andThen` \case - [name] -> - case tryInto @ProjectName (Text.pack name) of - Left _ -> Left "Invalid project name." - Right name1 -> Right (Input.ProjectCreateI True (Just name1)) - _ -> Right (Input.ProjectCreateI True Nothing) + parse = \case + [] -> Right (Input.ProjectCreateI True Nothing) + [name] -> + bimap P.text (Input.ProjectCreateI True . pure) $ + handleProjectArg name + _ -> Left $ showPatternHelp projectCreate } projectCreateEmptyInputPattern :: InputPattern @@ -2772,13 +3212,12 @@ projectCreateEmptyInputPattern = [ ("`project.create-empty`", "creates an empty project with a random name"), ("`project.create-empty foo`", "creates an empty project named `foo`") ], - parse = - unifyArguments `andThen` \case - [name] -> - case tryInto @ProjectName (Text.pack name) of - Left _ -> Left "Invalid project name." - Right name1 -> Right (Input.ProjectCreateI False (Just name1)) - _ -> Right (Input.ProjectCreateI False Nothing) + parse = \case + [] -> Right (Input.ProjectCreateI False Nothing) + [name] -> + bimap P.text (Input.ProjectCreateI False . pure) $ + handleProjectArg name + _ -> Left $ showPatternHelp projectCreateEmptyInputPattern } projectRenameInputPattern :: InputPattern @@ -2792,10 +3231,10 @@ projectRenameInputPattern = P.wrapColumn2 [ ("`project.rename foo`", "renames the current project to `foo`") ], - parse = - unifyArguments `andThen` \case - [nameString] | Right name <- tryInto (Text.pack nameString) -> Right (Input.ProjectRenameI name) - _ -> Left (showPatternHelp projectRenameInputPattern) + parse = \case + [nameString] -> + bimap P.text Input.ProjectRenameI $ handleProjectArg nameString + _ -> Left (showPatternHelp projectRenameInputPattern) } projectSwitch :: InputPattern @@ -2812,13 +3251,11 @@ projectSwitch = ("`switch foo/`", "switches to the last branch you visited in the project `foo`"), ("`switch /bar`", "switches to the branch `bar` in the current project") ], - parse = - unifyArguments `andThen` \case - [name] -> - case tryInto @ProjectAndBranchNames (Text.pack name) of - Left _ -> Left (showPatternHelp projectSwitch) - Right projectAndBranch -> Right (Input.ProjectSwitchI projectAndBranch) - _ -> Left (showPatternHelp projectSwitch) + parse = \case + [name] -> + bimap P.text Input.ProjectSwitchI $ + handleProjectAndBranchNamesArg name + _ -> Left (showPatternHelp projectSwitch) } where suggestionsConfig = @@ -2851,11 +3288,11 @@ branchesInputPattern = [ ("`branches`", "lists all branches in the current project"), ("`branches foo", "lists all branches in the project `foo`") ], - parse = - unifyArguments `andThen` \case - [] -> Right (Input.BranchesI Nothing) - [nameString] | Right name <- tryFrom (Text.pack nameString) -> Right (Input.BranchesI (Just name)) - _ -> Left (showPatternHelp branchesInputPattern) + parse = \case + [] -> Right (Input.BranchesI Nothing) + [nameString] -> + bimap P.text (Input.BranchesI . pure) $ handleProjectArg nameString + _ -> Left (showPatternHelp branchesInputPattern) } branchInputPattern :: InputPattern @@ -2874,25 +3311,17 @@ branchInputPattern = ("`branch /bar foo`", "forks the branch `bar` of the current project to a new branch `foo`"), ("`branch .bar foo`", "forks the path `.bar` of the current project to a new branch `foo`") ], - parse = - maybeToEither (showPatternHelp branchInputPattern) - . ( \case - [source0, name] -> do - source <- parseLooseCodeOrProject source0 - projectAndBranch <- - Text.pack name - & tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - & eitherToMaybe - Just (Input.BranchI (Input.BranchSourceI'LooseCodeOrProject source) projectAndBranch) - [name] -> do - projectAndBranch <- - Text.pack name - & tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - & eitherToMaybe - Just (Input.BranchI Input.BranchSourceI'CurrentContext projectAndBranch) - _ -> Nothing - ) - . unifyArguments + parse = \case + [source0, name] -> + first P.text $ + Input.BranchI . Input.BranchSourceI'LooseCodeOrProject + <$> handleLooseCodeOrProjectArg source0 + <*> handleProjectAndBranchArg name + [name] -> + first P.text $ + Input.BranchI Input.BranchSourceI'CurrentContext + <$> handleProjectAndBranchArg name + _ -> Left $ showPatternHelp branchInputPattern } where newBranchNameArg = @@ -2916,13 +3345,11 @@ branchEmptyInputPattern = visibility = I.Visible, args = [], help = P.wrap "Create a new empty branch.", - parse = - unifyArguments `andThen` \case - [name] -> - first (\_ -> showPatternHelp branchEmptyInputPattern) do - projectAndBranch <- tryInto @(ProjectAndBranch (Maybe ProjectName) ProjectBranchName) (Text.pack name) - Right (Input.BranchI Input.BranchSourceI'Empty projectAndBranch) - _ -> Left (showPatternHelp branchEmptyInputPattern) + parse = \case + [name] -> + bimap P.text (Input.BranchI Input.BranchSourceI'Empty) $ + handleProjectAndBranchArg name + _ -> Left (showPatternHelp branchEmptyInputPattern) } branchRenameInputPattern :: InputPattern @@ -2934,12 +3361,11 @@ branchRenameInputPattern = args = [], help = P.wrapColumn2 - [ ("`branch.rename foo`", "renames the current branch to `foo`") - ], - parse = - unifyArguments `andThen` \case - [nameString] | Right name <- tryInto (Text.pack nameString) -> Right (Input.BranchRenameI name) - _ -> Left (showPatternHelp branchRenameInputPattern) + [("`branch.rename foo`", "renames the current branch to `foo`")], + parse = \case + [name] -> + bimap P.text Input.BranchRenameI $ handleProjectBranchNameArg name + _ -> Left (showPatternHelp branchRenameInputPattern) } clone :: InputPattern @@ -2971,19 +3397,18 @@ clone = <> P.group (makeExample helpTopics ["remotes"] <> ")") ) ], - parse = - maybe (Left (showPatternHelp clone)) Right - . ( \case - [remoteNamesString] -> do - remoteNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack remoteNamesString)) - Just (Input.CloneI remoteNames Nothing) - [remoteNamesString, localNamesString] -> do - remoteNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack remoteNamesString)) - localNames <- eitherToMaybe (tryInto @ProjectAndBranchNames (Text.pack localNamesString)) - Just (Input.CloneI remoteNames (Just localNames)) - _ -> Nothing - ) - . unifyArguments + parse = \case + [remoteNames] -> do + first P.text $ + Input.CloneI + <$> handleProjectAndBranchNamesArg remoteNames + <*> pure Nothing + [remoteNames, localNames] -> + first P.text $ + Input.CloneI + <$> handleProjectAndBranchNamesArg remoteNames + <*> fmap pure (handleProjectAndBranchNamesArg localNames) + _ -> Left $ showPatternHelp clone } releaseDraft :: InputPattern @@ -2994,10 +3419,13 @@ releaseDraft = visibility = I.Visible, args = [], help = P.wrap "Draft a release.", - parse = - unifyArguments `andThen` \case - [tryInto @Semver . Text.pack -> Right semver] -> Right (Input.ReleaseDraftI semver) - _ -> Left (showPatternHelp releaseDraft) + parse = \case + [semverString] -> + bimap (const "Couldn’t parse version number") Input.ReleaseDraftI + . tryInto @Semver + . Text.pack + =<< unsupportedStructuredArgument "a version number" semverString + _ -> Left (showPatternHelp releaseDraft) } upgrade :: InputPattern @@ -3010,23 +3438,14 @@ upgrade = help = P.wrap $ "`upgrade old new` upgrades library dependency `lib.old` to `lib.new`, and, if successful, deletes `lib.old`.", - parse = - maybeToEither (I.help upgrade) - . ( \args -> do - [oldString, newString] <- Just args - old <- parseRelativeNameSegment oldString - new <- parseRelativeNameSegment newString - Just (Input.UpgradeI old new) - ) - . unifyArguments + parse = \case + [oldString, newString] -> + first P.text $ + Input.UpgradeI + <$> handleRelativeNameSegmentArg oldString + <*> handleRelativeNameSegmentArg newString + _ -> Left $ I.help upgrade } - where - parseRelativeNameSegment :: String -> Maybe NameSegment - parseRelativeNameSegment string = do - name <- Name.parseText (Text.pack string) - guard (Name.isRelative name) - segment NE.:| [] <- Just (Name.reverseSegments name) - Just segment validInputs :: [InputPattern] validInputs = @@ -3347,7 +3766,7 @@ data ProjectInclusion = OnlyWithinCurrentProject | OnlyOutsideCurrentProject | A data BranchInclusion = ExcludeCurrentBranch | AllBranches deriving stock (Eq, Ord, Show) -projectsByPrefix :: MonadIO m => ProjectInclusion -> Codebase m v a -> Path.Absolute -> Text -> m [(ProjectId, ProjectName)] +projectsByPrefix :: (MonadIO m) => ProjectInclusion -> Codebase m v a -> Path.Absolute -> Text -> m [(ProjectId, ProjectName)] projectsByPrefix projectInclusion codebase path query = do allProjectMatches <- Codebase.runTransaction codebase do Queries.loadAllProjectsBeginningWith (Just query) @@ -3427,7 +3846,7 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do ProjectBranchPath projectId branchId _ -> (Just projectId, Just branchId) handleAmbiguousComplete :: - MonadIO m => + (MonadIO m) => Text -> Codebase m v a -> m [Completion] @@ -3516,7 +3935,7 @@ projectAndOrBranchSuggestions config inputStr codebase _httpClient path = do then projectCompletions else branchCompletions ++ projectCompletions - handleBranchesComplete :: MonadIO m => Text -> Codebase m v a -> Path.Absolute -> m [Completion] + handleBranchesComplete :: (MonadIO m) => Text -> Codebase m v a -> Path.Absolute -> m [Completion] handleBranchesComplete branchName codebase path = do branches <- case preview ProjectUtils.projectBranchPathPrism path of @@ -3557,7 +3976,7 @@ projectBranchToCompletion projectName (_, branchName) = } handleBranchesComplete :: - MonadIO m => + (MonadIO m) => ProjectBranchSuggestionsConfig -> Text -> Codebase m v a -> @@ -3593,7 +4012,7 @@ currentProjectBranchToCompletion (_, branchName) = } branchRelativePathSuggestions :: - MonadIO m => + (MonadIO m) => ProjectBranchSuggestionsConfig -> String -> Codebase m v a -> @@ -3699,7 +4118,7 @@ branchRelativePathSuggestions config inputStr codebase _httpClient currentPath = branchPathSepPretty = P.hiBlack branchPathSep - branchPathSep :: IsString s => s + branchPathSep :: (IsString s) => s branchPathSep = ":" -- | A project name, branch name, or both. @@ -3758,7 +4177,7 @@ data OptionalSlash | NoSlash projectNameSuggestions :: - MonadIO m => + (MonadIO m) => OptionalSlash -> String -> Codebase m v a -> @@ -3789,21 +4208,16 @@ parsePullSource = Megaparsec.parseMaybe (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease) -- | Parse a 'Input.PushSource'. -parsePushSource :: String -> Either (P.Pretty CT.ColorText) Input.PushSource +parsePushSource :: String -> Maybe Input.PushSource parsePushSource sourceStr = - case tryFrom (Text.pack sourceStr) of - Left _ -> - case Path.parsePath' sourceStr of - Left _ -> Left (I.help push) - Right path -> Right (Input.PathySource path) - Right branch -> Right (Input.ProjySource branch) + fixup Input.ProjySource (tryFrom $ Text.pack sourceStr) + <|> fixup Input.PathySource (Path.parsePath' sourceStr) + where + fixup = either (const Nothing) . (pure .) -- | Parse a push target. -parsePushTarget :: String -> Either (P.Pretty CT.ColorText) (WriteRemoteNamespace (These ProjectName ProjectBranchName)) -parsePushTarget target = - case Megaparsec.parseMaybe UriParser.writeRemoteNamespace (Text.pack target) of - Nothing -> Left (I.help push) - Just path -> Right path +parsePushTarget :: String -> Maybe (WriteRemoteNamespace (These ProjectName ProjectBranchName)) +parsePushTarget = Megaparsec.parseMaybe UriParser.writeRemoteNamespace . Text.pack parseHashQualifiedName :: String -> Either (P.Pretty CT.ColorText) (HQ.HashQualified Name) diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 18a0c8f9c..f675f9189 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -113,7 +113,7 @@ getUserInput codebase authHTTPClient currentPath numberedArgs = -- Ctrl-c or some input cancel, re-run the prompt go Right (Just (expandedArgs, i)) -> do - let expandedArgs' = IP.unifyArguments expandedArgs + let expandedArgs' = IP.unifyArgument <$> expandedArgs expandedArgsStr = unwords expandedArgs' when (expandedArgs' /= ws) $ do liftIO . putStrLn $ fullPrompt <> expandedArgsStr From d6a394f3e0698d2fd711ec375fd0c1d3eb6141ba Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Tue, 21 May 2024 00:54:16 -0600 Subject: [PATCH 56/82] Serialize `StructuredArgument`s on demand Previously, the `Text` format had been preserved from the original code. This extracts all to a separate function that is called as needed. All transcripts still pass. --- .../src/Unison/Codebase/Editor/HandleInput.hs | 34 +-- .../Editor/HandleInput/FindAndReplace.hs | 3 +- .../src/Unison/Codebase/Editor/Output.hs | 2 +- .../src/Unison/CommandLine/InputPattern.hs | 2 +- .../src/Unison/CommandLine/InputPatterns.hs | 248 +++++++++++------- .../src/Unison/CommandLine/OutputMessages.hs | 64 ++--- 6 files changed, 185 insertions(+), 168 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 4886caeb4..312c8c343 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -153,7 +153,6 @@ import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent import Unison.Runtime.IOSource qualified as IOSource -import Unison.Server.Backend (ShallowListEntry (..)) import Unison.Server.Backend qualified as Backend import Unison.Server.CodebaseServer qualified as Server import Unison.Server.Doc.Markdown.Render qualified as Md @@ -298,8 +297,8 @@ loop e = do let (shortEntries, numberedEntries) = unzip $ expandedEntries <&> \(time, hash, reason) -> - let ((exp, txt), sa) = ((id &&& ("#" <>) . SCH.toText) . SCH.fromHash schLength &&& SA.Namespace) hash - in ((time, exp, reason), (txt, sa)) + let (exp, sa) = (SCH.fromHash schLength &&& SA.Namespace) hash + in ((time, exp, reason), sa) Cli.setNumberedArgs numberedEntries Cli.respond $ ShowReflog shortEntries where @@ -791,13 +790,13 @@ loop e = do (seg, _) <- Map.toList (Branch._edits b) ] Cli.respond $ ListOfPatches $ Set.fromList patches - Cli.setNumberedArgs $ fmap (Name.toText &&& SA.Name) patches + Cli.setNumberedArgs $ fmap SA.Name patches FindShallowI pathArg -> do Cli.Env {codebase} <- ask pathArgAbs <- Cli.resolvePath' pathArg entries <- liftIO (Backend.lsAtPath codebase Nothing pathArgAbs) - Cli.setNumberedArgs $ fmap (entryToHQText &&& SA.ShallowListEntry pathArg) entries + Cli.setNumberedArgs $ fmap (SA.ShallowListEntry pathArg) entries pped <- Cli.currentPrettyPrintEnvDecl let suffixifiedPPE = PPED.suffixifiedPPE pped -- This used to be a delayed action which only forced the loading of the root @@ -807,21 +806,6 @@ loop e = do -- in an improvement, so perhaps it's not worth the effort. let buildPPE = pure suffixifiedPPE Cli.respond $ ListShallow buildPPE entries - where - entryToHQText :: ShallowListEntry v Ann -> Text - entryToHQText e = - fixup $ case e of - ShallowTypeEntry te -> Backend.typeEntryDisplayName te - ShallowTermEntry te -> Backend.termEntryDisplayName te - ShallowBranchEntry ns _ _ -> NameSegment.toEscapedText ns - ShallowPatchEntry ns -> NameSegment.toEscapedText ns - where - fixup s = - pathArgStr - <> if Text.null pathArgStr || Text.isSuffixOf "." pathArgStr - then s - else "." <> s - pathArgStr = Text.pack $ show pathArg FindI isVerbose fscope ws -> handleFindI isVerbose fscope ws input StructuredFindI _fscope ws -> handleStructuredFindI ws StructuredFindReplaceI ws -> handleStructuredFindReplaceI ws @@ -1501,7 +1485,7 @@ handleFindI isVerbose fscope ws input = do (mapMaybe (HQ.parseTextWith anythingBeforeHash . Text.pack) qs) pure $ uniqueBy SR.toReferent srs let respondResults results = do - Cli.setNumberedArgs $ fmap (HQ.toText . IP.searchResultToHQ searchRoot &&& SA.SearchResult searchRoot) results + Cli.setNumberedArgs $ fmap (SA.SearchResult searchRoot) results results' <- Cli.runTransaction (Backend.loadSearchResults codebase results) Cli.respond $ ListOfDefinitions fscope suffixifiedPPE isVerbose results' results <- getResults names @@ -1556,8 +1540,8 @@ handleDependencies hq = do let types = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ fst <$> results) let terms = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ snd <$> results) Cli.setNumberedArgs $ - map ((Reference.toText &&& SA.Ref) . snd) types - <> map ((Reference.toText &&& SA.Ref) . Referent.toReference . snd) terms + map (SA.Ref . snd) types + <> map (SA.Ref . Referent.toReference . snd) terms Cli.respond $ ListDependencies suffixifiedPPE lds (fst <$> types) (fst <$> terms) handleDependents :: HQ.HashQualified Name -> Cli () @@ -1594,7 +1578,7 @@ handleDependents hq = do let sort = nubOrdOn snd . Name.sortByText (HQ.toText . fst) let types = sort [(n, r) | (False, n, r) <- join results] let terms = sort [(n, r) | (True, n, r) <- join results] - Cli.setNumberedArgs . map ((Reference.toText &&& SA.Ref) . view _2) $ types <> terms + Cli.setNumberedArgs . map (SA.Ref . view _2) $ types <> terms Cli.respond (ListDependents ppe lds (fst <$> types) (fst <$> terms)) handleDiffNamespaceToPatch :: Text -> DiffNamespaceToPatchInput -> Cli () @@ -1775,7 +1759,7 @@ doShowTodoOutput patch scopePath = do then Cli.respond NoConflictsOrEdits else do Cli.setNumberedArgs - ((Reference.toText &&& SA.Ref) . view _2 <$> fst (TO.todoFrontierDependents todo)) + (SA.Ref . view _2 <$> fst (TO.todoFrontierDependents todo)) pped <- Cli.currentPrettyPrintEnvDecl Cli.respondNumbered $ TodoOutput pped todo diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs index 9ad17bbcc..f96ae85b2 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs @@ -4,7 +4,6 @@ module Unison.Codebase.Editor.HandleInput.FindAndReplace ) where -import Control.Arrow ((&&&)) import Control.Lens hiding (at) import Control.Monad.Reader (ask) import Control.Monad.State @@ -89,7 +88,7 @@ handleStructuredFindI rule = do ok t = pure (t, False) results0 <- traverse ok results let results = Alphabetical.sortAlphabeticallyOn fst [(hq, r) | ((hq, r), True) <- results0] - let toNumArgs = (Reference.toText &&& SA.Ref) . Referent.toReference . view _2 + let toNumArgs = SA.Ref . Referent.toReference . view _2 Cli.setNumberedArgs $ map toNumArgs results Cli.respond (ListStructuredFind (fst <$> results)) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 751292ba9..88ad7f204 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -90,7 +90,7 @@ type SourceName = Text -- __NB__: This only temporarily holds `Text`. Until all of the inputs are -- updated to handle `StructuredArgument`s, we need to ensure that the -- serialization remains unchanged. -type NumberedArgs = [(Text, StructuredArgument)] +type NumberedArgs = [StructuredArgument] type HashLength = Int diff --git a/unison-cli/src/Unison/CommandLine/InputPattern.hs b/unison-cli/src/Unison/CommandLine/InputPattern.hs index 15f58eb73..4014bc1dc 100644 --- a/unison-cli/src/Unison/CommandLine/InputPattern.hs +++ b/unison-cli/src/Unison/CommandLine/InputPattern.hs @@ -51,7 +51,7 @@ data Visibility = Hidden | Visible -- needs to be parsed or a numbered argument that doesn’t need to be parsed, as -- we’ve preserved its representation (although the numbered argument could -- still be of the wrong type, which should result in an error). -type Argument = Either String (Text, StructuredArgument) +type Argument = Either String StructuredArgument type Arguments = [Argument] diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index ebae14662..247df1ce2 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -41,7 +41,7 @@ import Unison.Codebase.Editor.StructuredArgument (StructuredArgument) import Unison.Codebase.Editor.StructuredArgument qualified as SA import Unison.Codebase.Editor.UriParser (readRemoteNamespaceParser) import Unison.Codebase.Editor.UriParser qualified as UriParser -import Unison.Codebase.Path (Path) +import Unison.Codebase.Path (Path, Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.PushBehavior qualified as PushBehavior @@ -63,16 +63,20 @@ 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.Prelude import Unison.Project (ProjectAndBranch (..), ProjectAndBranchNames (..), ProjectBranchName, ProjectBranchNameOrLatestRelease (..), ProjectBranchSpecifier (..), ProjectName, Semver) import Unison.Project.Util (ProjectContext (..), projectContextFromPath) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent +import Unison.Server.Backend (ShallowListEntry (..)) +import Unison.Server.Backend qualified as Backend import Unison.Server.SearchResult (SearchResult) import Unison.Server.SearchResult qualified as SR import Unison.ShortHash (ShortHash) -import Unison.Syntax.HashQualified qualified as HQ (parseText) -import Unison.Syntax.Name qualified as Name (parseTextEither) +import Unison.Syntax.HashQualified qualified as HQ (parseText, toText) +import Unison.Syntax.Name qualified as Name (parseTextEither, toText) +import Unison.Syntax.NameSegment qualified as NameSegment import Unison.Util.ColorText qualified as CT import Unison.Util.Monoid (intercalateMap) import Unison.Util.Pretty qualified as P @@ -83,13 +87,60 @@ import Unison.Util.Pretty qualified as P schLength :: Int schLength = 10 --- | --- --- __TODO__: Temporary. This may stick around in a handful of cases, but it’ll --- have to actually serialize the `StructuredArgument` rather than --- relying on the parallel `Text`. +formatStructuredArgument :: StructuredArgument -> Text +formatStructuredArgument = \case + SA.AbsolutePath path -> into @Text $ show path + SA.Name name -> Name.toText name + SA.HashQualified hqName -> HQ.toText hqName + SA.Project projectName -> into @Text projectName + SA.ProjectBranch (ProjectAndBranch mproj branch) -> + maybe + (Text.cons '/' . into @Text) + (\project -> into @Text . ProjectAndBranch project) + mproj + branch + SA.Ref reference -> + -- also: ShortHash.toText . Reference.toShortHash + Reference.toText reference + SA.Namespace causalHash -> + -- also: ("#" <>) . Hash.toBase32HexText . unCausalHash + ("#" <>) . SCH.toText $ SCH.fromHash schLength causalHash + SA.NameWithBranchPrefix absBranchId name -> + prefixBranchId absBranchId name + SA.HashQualifiedWithBranchPrefix absBranchId hq'Name -> + HQ'.toTextWith (prefixBranchId absBranchId) hq'Name + SA.ShallowListEntry path entry -> entryToHQText path entry + SA.SearchResult searchRoot searchResult -> + HQ.toText $ searchResultToHQ searchRoot searchResult + where + -- E.g. + -- prefixBranchId "#abcdef" "base.List.map" -> "#abcdef:.base.List.map" + -- prefixBranchId ".base" "List.map" -> ".base.List.map" + prefixBranchId :: Input.AbsBranchId -> Name -> Text + prefixBranchId branchId name = case branchId of + Left sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name) + Right pathPrefix -> Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name) + + entryToHQText :: Path' -> ShallowListEntry v Ann -> Text + entryToHQText pathArg e = + fixup $ case e of + ShallowTypeEntry te -> Backend.typeEntryDisplayName te + ShallowTermEntry te -> Backend.termEntryDisplayName te + ShallowBranchEntry ns _ _ -> NameSegment.toEscapedText ns + ShallowPatchEntry ns -> NameSegment.toEscapedText ns + where + fixup s = + pathArgStr + <> if Text.null pathArgStr || Text.isSuffixOf "." pathArgStr + then s + else "." <> s + pathArgStr = Text.pack $ show pathArg + +-- | Converts an arbitrary argument to a `String`. This is for cases where the +-- command /should/ accept a structured argument of some type, but currently +-- wants a `String`. unifyArgument :: I.Argument -> String -unifyArgument = either id (Text.unpack . fst) +unifyArgument = either id (Text.unpack . formatStructuredArgument) showPatternHelp :: InputPattern -> P.Pretty CT.ColorText showPatternHelp i = @@ -130,11 +181,11 @@ expectedButActually expected actualValue actualType = <> actualType <> "." -wrongStructuredArgument :: Text -> (Text, StructuredArgument) -> Text -wrongStructuredArgument expected (actualStr, actual) = +wrongStructuredArgument :: Text -> StructuredArgument -> Text +wrongStructuredArgument expected actual = expectedButActually expected - actualStr + (formatStructuredArgument actual) case actual of SA.Ref _ -> "a reference" SA.Name _ -> "a name" @@ -179,9 +230,9 @@ handleProjectArg = $ Text.pack name ) ( \case - (_, SA.Project project) -> pure project + SA.Project project -> pure project -- __FIXME__: Do we want to treat a project branch as a project? - (_, SA.ProjectBranch (ProjectAndBranch (Just project) _)) -> pure project + SA.ProjectBranch (ProjectAndBranch (Just project) _) -> pure project otherArgType -> Left $ wrongStructuredArgument "a path" otherArgType ) @@ -193,8 +244,8 @@ handleLooseCodeOrProjectArg = . parseLooseCodeOrProject ) ( \case - (_, SA.AbsolutePath path) -> pure . This $ Path.absoluteToPath' path - (_, SA.ProjectBranch pb) -> pure $ That pb + SA.AbsolutePath path -> pure . This $ Path.absoluteToPath' path + SA.ProjectBranch pb -> pure $ That pb otherArgType -> Left $ wrongStructuredArgument "a path or project branch" otherArgType ) @@ -211,7 +262,7 @@ handleProjectAndBranchArg = $ Text.pack name ) ( \case - (_, SA.ProjectBranch pb) -> pure pb + SA.ProjectBranch pb -> pure pb otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType ) @@ -221,16 +272,16 @@ handleHashQualifiedNameArg = either parseHashQualifiedName ( \case - (_, SA.Name name) -> pure $ HQ.NameOnly name - (_, SA.NameWithBranchPrefix (Left _) name) -> pure $ HQ.NameOnly name - (_, SA.NameWithBranchPrefix (Right prefix) name) -> + SA.Name name -> pure $ HQ.NameOnly name + SA.NameWithBranchPrefix (Left _) name -> pure $ HQ.NameOnly name + SA.NameWithBranchPrefix (Right prefix) name -> pure . HQ.NameOnly . Name.makeAbsolute $ Path.prefixName prefix name - (_, SA.Ref ref) -> pure . HQ.HashOnly $ Reference.toShortHash ref - (_, SA.HashQualified hqname) -> pure hqname - (_, SA.HashQualifiedWithBranchPrefix (Left _) hqname) -> pure $ HQ'.toHQ hqname - (_, SA.HashQualifiedWithBranchPrefix (Right prefix) hqname) -> + SA.Ref ref -> pure . HQ.HashOnly $ Reference.toShortHash ref + SA.HashQualified hqname -> pure hqname + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toHQ hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> pure . HQ'.toHQ $ Name.makeAbsolute . Path.prefixName prefix <$> hqname - (_, SA.SearchResult mpath result) -> pure $ searchResultToHQ mpath result + SA.SearchResult mpath result -> pure $ searchResultToHQ mpath result otherArgType -> Left . P.text $ wrongStructuredArgument "a hash-qualified name" otherArgType ) @@ -240,9 +291,9 @@ handlePathArg = either Path.parsePath \case - (_, SA.Name name) -> pure $ Path.fromName name - (_, SA.NameWithBranchPrefix (Left _) name) -> pure $ Path.fromName name - (_, SA.NameWithBranchPrefix (Right prefix) name) -> + SA.Name name -> pure $ Path.fromName name + SA.NameWithBranchPrefix (Left _) name -> pure $ Path.fromName name + SA.NameWithBranchPrefix (Right prefix) name -> pure . Path.fromName $ Path.prefixName prefix name otherArgType -> Left $ wrongStructuredArgument "a relative path" otherArgType @@ -252,10 +303,10 @@ handlePath'Arg = either Path.parsePath' ( \case - (_, SA.AbsolutePath path) -> pure $ Path.absoluteToPath' path - (_, SA.Name name) -> pure $ Path.fromName' name - (_, SA.NameWithBranchPrefix (Left _) name) -> pure $ Path.fromName' name - (_, SA.NameWithBranchPrefix (Right prefix) name) -> + SA.AbsolutePath path -> pure $ Path.absoluteToPath' path + SA.Name name -> pure $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> pure . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name otherArgType -> Left $ wrongStructuredArgument "a namespace" otherArgType ) @@ -277,9 +328,9 @@ handleSplit'Arg = either Path.parseSplit' ( \case - (_, SA.Name name) -> pure $ Path.splitFromName' name - (_, SA.NameWithBranchPrefix (Left _) name) -> pure $ Path.splitFromName' name - (_, SA.NameWithBranchPrefix (Right prefix) name) -> + SA.Name name -> pure $ Path.splitFromName' name + SA.NameWithBranchPrefix (Left _) name -> pure $ Path.splitFromName' name + SA.NameWithBranchPrefix (Right prefix) name -> pure . Path.splitFromName' . Name.makeAbsolute $ Path.prefixName prefix name otherNumArg -> Left $ wrongStructuredArgument "a split name" otherNumArg ) @@ -292,7 +343,7 @@ handleProjectBranchNameArg = either (first (const "Wanted a branch name, but it wasn’t") . tryInto . Text.pack) ( \case - (_, SA.ProjectBranch (ProjectAndBranch _ branch)) -> pure branch + SA.ProjectBranch (ProjectAndBranch _ branch) -> pure branch otherNumArg -> Left $ wrongStructuredArgument "a branch name" otherNumArg ) @@ -301,14 +352,12 @@ handleBranchIdArg = either Input.parseBranchId ( \case - (_, SA.AbsolutePath path) -> pure . pure $ Path.absoluteToPath' path - (_, SA.Name name) -> pure . pure $ Path.fromName' name - (_, SA.NameWithBranchPrefix (Left _) name) -> - pure . pure $ Path.fromName' name - (_, SA.NameWithBranchPrefix (Right prefix) name) -> - pure . pure . Path.fromName' . Name.makeAbsolute $ - Path.prefixName prefix name - (_, SA.Namespace hash) -> pure . Left $ SCH.fromHash schLength hash + SA.AbsolutePath path -> pure . pure $ Path.absoluteToPath' path + SA.Name name -> pure . pure $ Path.fromName' name + SA.NameWithBranchPrefix mprefix name -> + pure . pure . Path.fromName' $ + either (const name) (Name.makeAbsolute . flip Path.prefixName name) mprefix + SA.Namespace hash -> pure . Left $ SCH.fromHash schLength hash otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg ) @@ -326,17 +375,16 @@ handleBranchIdOrProjectArg = . branchIdOrProject ) ( \case - (_, SA.Namespace hash) -> - pure . This . Left $ SCH.fromHash schLength hash - (_, SA.AbsolutePath path) -> + SA.Namespace hash -> pure . This . Left $ SCH.fromHash schLength hash + SA.AbsolutePath path -> pure . This . pure $ Path.absoluteToPath' path - (_, SA.Name name) -> pure . This . pure $ Path.fromName' name - (_, SA.NameWithBranchPrefix (Left _) name) -> + SA.Name name -> pure . This . pure $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . This . pure $ Path.fromName' name - (_, SA.NameWithBranchPrefix (Right prefix) name) -> + SA.NameWithBranchPrefix (Right prefix) name -> pure . This . pure . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name - (_, SA.ProjectBranch pb) -> pure $ pure pb + SA.ProjectBranch pb -> pure $ pure pb otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType ) where @@ -364,16 +412,16 @@ handleBranchId2Arg = either Input.parseBranchId2 ( \case - (_, SA.Namespace hash) -> pure . Left $ SCH.fromHash schLength hash - (_, SA.AbsolutePath path) -> + SA.Namespace hash -> pure . Left $ SCH.fromHash schLength hash + SA.AbsolutePath path -> pure . pure . LoosePath $ Path.absoluteToPath' path - (_, SA.Name name) -> pure . pure . LoosePath $ Path.fromName' name - (_, SA.NameWithBranchPrefix (Left _) name) -> + SA.Name name -> pure . pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . pure . LoosePath $ Path.fromName' name - (_, SA.NameWithBranchPrefix (Right prefix) name) -> + SA.NameWithBranchPrefix (Right prefix) name -> pure . pure . LoosePath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name - (_, SA.ProjectBranch (ProjectAndBranch mproject branch)) -> + SA.ProjectBranch (ProjectAndBranch mproject branch) -> pure . pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject otherNumArg -> @@ -386,14 +434,14 @@ handleBranchRelativePathArg = either parseBranchRelativePath ( \case - (_, SA.AbsolutePath path) -> pure . LoosePath $ Path.absoluteToPath' path - (_, SA.Name name) -> pure . LoosePath $ Path.fromName' name - (_, SA.NameWithBranchPrefix (Left _) name) -> + SA.AbsolutePath path -> pure . LoosePath $ Path.absoluteToPath' path + SA.Name name -> pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . LoosePath $ Path.fromName' name - (_, SA.NameWithBranchPrefix (Right prefix) name) -> + SA.NameWithBranchPrefix (Right prefix) name -> pure . LoosePath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name - (_, SA.ProjectBranch (ProjectAndBranch mproject branch)) -> + SA.ProjectBranch (ProjectAndBranch mproject branch) -> pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject otherNumArg -> @@ -427,11 +475,11 @@ handleHashQualifiedSplit'Arg = either Path.parseHQSplit' ( \case - (_, SA.HashQualified name) -> hqNameToSplit' name - (_, SA.HashQualifiedWithBranchPrefix (Left _) hqname) -> pure $ hq'NameToSplit' hqname - (_, SA.HashQualifiedWithBranchPrefix (Right prefix) hqname) -> + SA.HashQualified name -> hqNameToSplit' name + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit' hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> pure . hq'NameToSplit' $ Name.makeAbsolute . Path.prefixName prefix <$> hqname - (_, SA.SearchResult mpath result) -> hqNameToSplit' $ searchResultToHQ mpath result + SA.SearchResult mpath result -> hqNameToSplit' $ searchResultToHQ mpath result otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg ) @@ -440,11 +488,11 @@ handleHashQualifiedSplitArg = either Path.parseHQSplit ( \case - (_, SA.HashQualified name) -> hqNameToSplit name - (_, SA.HashQualifiedWithBranchPrefix (Left _) hqname) -> pure $ hq'NameToSplit hqname - (_, SA.HashQualifiedWithBranchPrefix (Right prefix) hqname) -> + SA.HashQualified name -> hqNameToSplit name + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> pure . hq'NameToSplit $ Name.makeAbsolute . Path.prefixName prefix <$> hqname - (_, SA.SearchResult mpath result) -> hqNameToSplit $ searchResultToHQ mpath result + SA.SearchResult mpath result -> hqNameToSplit $ searchResultToHQ mpath result otherNumArg -> Left $ wrongStructuredArgument "a relative name" otherNumArg ) @@ -453,7 +501,7 @@ handleShortCausalHashArg = either (first Text.pack . Input.parseShortCausalHash) ( \case - (_, SA.Namespace hash) -> pure $ SCH.fromHash schLength hash + SA.Namespace hash -> pure $ SCH.fromHash schLength hash otherNumArg -> Left $ wrongStructuredArgument "a causal hash" otherNumArg ) @@ -463,12 +511,12 @@ handleShortHashOrHQSplit'Arg = either Path.parseShortHashOrHQSplit' ( \case - (_, SA.Ref ref) -> pure $ Left $ Reference.toShortHash ref - (_, SA.HashQualified name) -> pure <$> hqNameToSplit' name - (_, SA.HashQualifiedWithBranchPrefix (Left _) hqname) -> pure . pure $ hq'NameToSplit' hqname - (_, SA.HashQualifiedWithBranchPrefix (Right prefix) hqname) -> + SA.Ref ref -> pure $ Left $ Reference.toShortHash ref + SA.HashQualified name -> pure <$> hqNameToSplit' name + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure . pure $ hq'NameToSplit' hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> pure . pure $ hq'NameToSplit' (Name.makeAbsolute . Path.prefixName prefix <$> hqname) - (_, SA.SearchResult mpath result) -> + SA.SearchResult mpath result -> fmap pure . hqNameToSplit' $ searchResultToHQ mpath result otherNumArg -> Left $ wrongStructuredArgument "a hash or name" otherNumArg ) @@ -486,16 +534,16 @@ handleNameArg = either (Name.parseTextEither . Text.pack) ( \case - (_, SA.Name name) -> pure name - (_, SA.NameWithBranchPrefix (Left _) name) -> pure name - (_, SA.NameWithBranchPrefix (Right prefix) name) -> + SA.Name name -> pure name + SA.NameWithBranchPrefix (Left _) name -> pure name + SA.NameWithBranchPrefix (Right prefix) name -> pure . Name.makeAbsolute $ Path.prefixName prefix name - (_, SA.HashQualified hqname) -> + SA.HashQualified hqname -> maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname - (_, SA.HashQualifiedWithBranchPrefix (Left _) hqname) -> pure $ HQ'.toName hqname - (_, SA.HashQualifiedWithBranchPrefix (Right prefix) hqname) -> + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toName hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> pure . Name.makeAbsolute . Path.prefixName prefix $ HQ'.toName hqname - (_, SA.SearchResult mpath result) -> + SA.SearchResult mpath result -> maybe (Left "can’t find a name from the numbered arg") pure . HQ.toName $ searchResultToHQ mpath result @@ -511,9 +559,9 @@ handlePullSourceArg = either (maybe (Left "not a pull source") pure . parsePullSource . Text.pack) ( \case - (_, SA.Project project) -> + SA.Project project -> pure . RemoteRepo.ReadShare'ProjectBranch $ This project - (_, SA.ProjectBranch (ProjectAndBranch project branch)) -> + SA.ProjectBranch (ProjectAndBranch project branch) -> pure . RemoteRepo.ReadShare'ProjectBranch . maybe That These project $ ProjectBranchNameOrLatestRelease'Name branch otherNumArg -> @@ -530,8 +578,8 @@ handlePushTargetArg = ) ( fmap RemoteRepo.WriteRemoteProjectBranch . \case - (_, SA.Project project) -> pure $ This project - (_, SA.ProjectBranch (ProjectAndBranch project branch)) -> + SA.Project project -> pure $ This project + SA.ProjectBranch (ProjectAndBranch project branch) -> pure $ maybe That These project branch otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg @@ -544,15 +592,15 @@ handlePushSourceArg = . parsePushSource ) ( \case - (_, SA.AbsolutePath path) -> pure . Input.PathySource $ Path.absoluteToPath' path - (_, SA.Name name) -> pure . Input.PathySource $ Path.fromName' name - (_, SA.NameWithBranchPrefix (Left _) name) -> + SA.AbsolutePath path -> pure . Input.PathySource $ Path.absoluteToPath' path + SA.Name name -> pure . Input.PathySource $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . Input.PathySource $ Path.fromName' name - (_, SA.NameWithBranchPrefix (Right prefix) name) -> + SA.NameWithBranchPrefix (Right prefix) name -> pure . Input.PathySource . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name - (_, SA.Project project) -> pure . Input.ProjySource $ This project - (_, SA.ProjectBranch (ProjectAndBranch project branch)) -> + SA.Project project -> pure . Input.ProjySource $ This project + SA.ProjectBranch (ProjectAndBranch project branch) -> pure . Input.ProjySource . maybe That These project $ branch otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg @@ -566,8 +614,8 @@ handleProjectAndBranchNamesArg = . Text.pack ) ( fmap ProjectAndBranchNames'Unambiguous . \case - (_, SA.Project project) -> pure $ This project - (_, SA.ProjectBranch (ProjectAndBranch mproj branch)) -> + SA.Project project -> pure $ This project + SA.ProjectBranch (ProjectAndBranch mproj branch) -> pure $ maybe That These mproj branch otherNumArg -> Left $ wrongStructuredArgument "a project or branch" otherNumArg @@ -2950,8 +2998,9 @@ execute = ) $ \case main : args -> - Input.ExecuteI (Text.pack $ unifyArgument main) - <$> traverse (unsupportedStructuredArgument "a command-line argument") args + Input.ExecuteI + <$> handleHashQualifiedNameArg main + <*> traverse (unsupportedStructuredArgument "a command-line argument") args _ -> Left $ showPatternHelp execute saveExecuteResult :: InputPattern @@ -3041,8 +3090,9 @@ runScheme = ) $ \case main : args -> - Input.ExecuteSchemeI (Text.pack $ unifyArgument main) - <$> traverse (unsupportedStructuredArgument "a command-line argument") args + Input.ExecuteSchemeI + <$> handleHashQualifiedNameArg main + <*> traverse (unsupportedStructuredArgument "a command-line argument") args _ -> Left $ showPatternHelp runScheme compileScheme :: InputPattern diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index af5b1fa1c..0d9fe8e7c 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -5,7 +5,6 @@ module Unison.CommandLine.OutputMessages where -import Control.Arrow ((&&&)) import Control.Lens hiding (at) import Control.Monad.State import Control.Monad.State.Strict qualified as State @@ -130,7 +129,6 @@ import Unison.Server.Backend qualified as Backend import Unison.Server.SearchResult' qualified as SR' import Unison.Share.Sync qualified as Share import Unison.Share.Sync.Types (CodeserverTransportError (..)) -import Unison.ShortHash qualified as ShortHash import Unison.Sync.Types qualified as Share import Unison.Syntax.DeclPrinter qualified as DeclPrinter import Unison.Syntax.HashQualified qualified as HQ (toText, unsafeFromVar) @@ -351,7 +349,7 @@ notifyNumbered = \case ] branchHashes :: [CausalHash] branchHashes = (fst <$> reversedHistory) <> tailHashes - in (msg, (displayBranchHash &&& SA.Namespace) <$> branchHashes) + in (msg, SA.Namespace <$> branchHashes) where toSCH :: CausalHash -> ShortCausalHash toSCH h = SCH.fromHash schLength h @@ -410,7 +408,7 @@ notifyNumbered = \case ListEdits patch ppe -> showListEdits patch ppe ListProjects projects -> ( P.numberedList (map (prettyProjectName . view #name) projects), - map ((into @Text &&& SA.Project) . view #name) projects + map (SA.Project . view #name) projects ) ListBranches projectName branches -> ( P.columnNHeader @@ -427,11 +425,7 @@ notifyNumbered = \case : map (\branch -> ["", "", prettyRemoteBranchInfo branch]) remoteBranches ), map - ( ( (into @Text . ProjectAndBranch projectName) - &&& (SA.ProjectBranch . ProjectAndBranch (pure projectName)) - ) - . fst - ) + (SA.ProjectBranch . ProjectAndBranch (pure projectName) . fst) branches ) AmbiguousSwitch project (ProjectAndBranch currentProject branch) -> @@ -457,11 +451,9 @@ notifyNumbered = \case <> switch ["2"] <> " to pick one of these." ), - [ (Text.cons '/' . into @Text &&& SA.ProjectBranch . ProjectAndBranch Nothing) branch, - ( (into @Text . ProjectAndBranch project) - &&& (SA.ProjectBranch . ProjectAndBranch (pure project)) - ) - $ UnsafeProjectBranchName "main" + [ SA.ProjectBranch $ ProjectAndBranch Nothing branch, + SA.ProjectBranch . ProjectAndBranch (pure project) $ + UnsafeProjectBranchName "main" ] ) where @@ -490,8 +482,8 @@ notifyNumbered = \case <> reset (resetArgs ["2"]) <> " to pick one of these." ), - [ (Text.cons '/' . into @Text &&& SA.ProjectBranch . ProjectAndBranch Nothing) branch, - (into @Text . show &&& SA.AbsolutePath) absPath0 + [ SA.ProjectBranch $ ProjectAndBranch Nothing branch, + SA.AbsolutePath absPath0 ] ) where @@ -533,7 +525,7 @@ notifyNumbered = \case ) (1, (mempty, mempty)) & snd - & over (_2 . mapped) (Name.toText &&& SA.Name) + & over (_2 . mapped) SA.Name externalDepsTable :: Map LabeledDependency (Set Name) -> [(P.Pretty P.ColorText, P.Pretty P.ColorText)] externalDepsTable = ifoldMap $ \ld dependents -> [(prettyLD ld, prettyDependents dependents)] @@ -613,7 +605,7 @@ showListEdits patch ppe = let lhsTermName = PPE.termName ppe (Referent.Ref lhsRef) -- We use the shortHash of the lhs rather than its name for numbered args, -- since its name is likely to be "historical", and won't work if passed to a ucm command. - let lhsHash = (ShortHash.toText . Reference.toShortHash &&& SA.Ref) $ lhsRef + let lhsHash = SA.Ref lhsRef case termEdit of TermEdit.Deprecate -> do lift $ tell ([lhsHash], []) @@ -624,7 +616,7 @@ showListEdits patch ppe = TermEdit.Replace rhsRef _typing -> do n2 <- gets snd <* modify (second succ) let rhsTermName = PPE.termName ppe (Referent.Ref rhsRef) - lift $ tell ([lhsHash], [(HQ.toText &&& SA.HashQualified) rhsTermName]) + lift $ tell ([lhsHash], [SA.HashQualified rhsTermName]) pure ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTermName), "-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTermName) @@ -638,7 +630,7 @@ showListEdits patch ppe = let lhsTypeName = PPE.typeName ppe lhsRef -- We use the shortHash of the lhs rather than its name for numbered args, -- since its name is likely to be "historical", and won't work if passed to a ucm command. - let lhsHash = (ShortHash.toText . Reference.toShortHash &&& SA.Ref) $ lhsRef + let lhsHash = SA.Ref lhsRef case typeEdit of TypeEdit.Deprecate -> do lift $ tell ([lhsHash], []) @@ -649,7 +641,7 @@ showListEdits patch ppe = TypeEdit.Replace rhsRef -> do n2 <- gets snd <* modify (second succ) let rhsTypeName = PPE.typeName ppe rhsRef - lift $ tell ([lhsHash], [(HQ.toText &&& SA.HashQualified) rhsTypeName]) + lift $ tell ([lhsHash], [SA.HashQualified rhsTypeName]) pure ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTypeName), "-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTypeName) @@ -1663,7 +1655,7 @@ notifyUser dir = \case prettyNamespaceKey dest <> "is already up-to-date with" <> P.group (prettyNamespaceKey src <> ".") - DumpNumberedArgs args -> pure . P.numberedList $ fmap (P.text . fst) args + DumpNumberedArgs args -> pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument) args NoConflictsOrEdits -> pure (P.okCallout "No conflicts or edits in progress.") HelpMessage pat -> pure $ IP.showPatternHelp pat @@ -2729,7 +2721,7 @@ renderNameConflicts ppe conflictedNames = do P.lines <$> do for (Map.toList conflictedNames) $ \(name, hashes) -> do prettyConflicts <- for hashes \hash -> do - n <- addNumberedArg $ (HQ.toText &&& SA.HashQualified) hash + n <- addNumberedArg $ SA.HashQualified hash pure $ formatNum n <> (P.blue . P.syntaxToColor . prettyHashQualified $ hash) pure . P.wrap $ ( "The " @@ -2761,7 +2753,7 @@ renderEditConflicts ppe Patch {..} = do <> (fmap Right . Map.toList . R.toMultimap . R.filterManyDom $ _termEdits) numberedHQName :: HQ.HashQualified Name -> Numbered Pretty numberedHQName hqName = do - n <- addNumberedArg $ (HQ.toText &&& SA.HashQualified) hqName + n <- addNumberedArg $ SA.HashQualified hqName pure $ formatNum n <> styleHashQualified P.bold hqName formatTypeEdits :: (Reference, Set TypeEdit.TypeEdit) -> @@ -2800,9 +2792,9 @@ renderEditConflicts ppe Patch {..} = do Numbered Pretty formatConflict = either formatTypeEdits formatTermEdits -type Numbered = State.State (Int, Seq.Seq (Text, StructuredArgument)) +type Numbered = State.State (Int, Seq.Seq StructuredArgument) -addNumberedArg :: (Text, StructuredArgument) -> Numbered Int +addNumberedArg :: StructuredArgument -> Numbered Int addNumberedArg s = do (n, args) <- State.get State.put (n + 1, args Seq.|> s) @@ -2874,11 +2866,11 @@ todoOutput ppe todo = runNumbered do todoEdits :: Numbered Pretty todoEdits = do numberedTypes <- for (unscore <$> dirtyTypes) \(ref, displayObj) -> do - n <- addNumberedArg . (HQ.toText &&& SA.HashQualified) $ PPE.typeName ppeu ref + n <- addNumberedArg . SA.HashQualified $ PPE.typeName ppeu ref pure $ formatNum n <> prettyDeclPair ppeu (ref, displayObj) let filteredTerms = goodTerms (unscore <$> dirtyTerms) termNumbers <- for filteredTerms \(ref, _, _) -> do - n <- addNumberedArg . (HQ.toText &&& SA.HashQualified) $ PPE.termName ppeu ref + n <- addNumberedArg . SA.HashQualified $ PPE.termName ppeu ref pure $ formatNum n let formattedTerms = TypePrinter.prettySignaturesCT ppes filteredTerms numberedTerms = zipWith (<>) termNumbers formattedTerms @@ -3283,21 +3275,13 @@ showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = -- DeclPrinter.prettyDeclHeader : HQ -> Either numPatch :: Input.AbsBranchId -> Name -> Numbered Pretty numPatch prefix name = - addNumberedArg' $ (prefixBranchId prefix &&& SA.NameWithBranchPrefix prefix) name + addNumberedArg' $ SA.NameWithBranchPrefix prefix name numHQ' :: Input.AbsBranchId -> HQ'.HashQualified Name -> Referent -> Numbered Pretty numHQ' prefix hq r = - addNumberedArg' . (HQ'.toTextWith (prefixBranchId prefix) &&& SA.HashQualifiedWithBranchPrefix prefix) $ HQ'.requalify hq r + addNumberedArg' . SA.HashQualifiedWithBranchPrefix prefix $ HQ'.requalify hq r - -- E.g. - -- prefixBranchId "#abcdef" "base.List.map" -> "#abcdef:.base.List.map" - -- prefixBranchId ".base" "List.map" -> ".base.List.map" - prefixBranchId :: Input.AbsBranchId -> Name -> Text - prefixBranchId branchId name = case branchId of - Left sch -> "#" <> SCH.toText sch <> ":" <> Name.toText (Name.makeAbsolute name) - Right pathPrefix -> Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name) - - addNumberedArg' :: (Text, StructuredArgument) -> Numbered Pretty + addNumberedArg' :: StructuredArgument -> Numbered Pretty addNumberedArg' s = case sn of ShowNumbers -> do n <- addNumberedArg s @@ -3552,7 +3536,7 @@ numberedArgsForEndangerments (PPED.unsuffixifiedPPE -> ppe) m = m & Map.elems & concatMap toList - & fmap ((HQ.toText &&& SA.HashQualified) . PPE.labeledRefName ppe) + & fmap (SA.HashQualified . PPE.labeledRefName ppe) -- | Format and render all dependents which are endangered by references going extinct. endangeredDependentsTable :: From ff785cb8a5e304fb6ce784ceb97ec886c96e0534 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Wed, 22 May 2024 23:46:31 -0600 Subject: [PATCH 57/82] Allow structured args in `find` commands --- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 91bf1960f..97c41767f 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1355,7 +1355,7 @@ find' cmd fscope = I.Visible [("query", ZeroPlus, exactDefinitionArg)] findHelp - (fmap (Input.FindI False fscope) . traverse (unsupportedStructuredArgument "text")) + (pure . Input.FindI False fscope . fmap unifyArgument) findShallow :: InputPattern findShallow = From 510e9dc6bb944105189ad70bcfadfa8a34b027fa Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 23 May 2024 08:26:52 -0400 Subject: [PATCH 58/82] don't update in upgrade --- .../src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs | 5 ----- unison-cli/src/Unison/CommandLine/OutputMessages.hs | 5 +---- unison-src/transcripts/upgrade-sad-path.md | 1 + unison-src/transcripts/upgrade-sad-path.output.md | 4 +++- 4 files changed, 5 insertions(+), 10 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs index 901dada1e..76229b8bf 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/CommitUpgrade.hs @@ -12,7 +12,6 @@ import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Codebase.Editor.HandleInput.DeleteBranch qualified as DeleteBranch import Unison.Codebase.Editor.HandleInput.Merge2 qualified as Merge import Unison.Codebase.Editor.HandleInput.ProjectSwitch qualified as ProjectSwitch -import Unison.Codebase.Editor.HandleInput.Update2 qualified as Update import Unison.Codebase.Editor.Output qualified as Output import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Prelude @@ -34,10 +33,6 @@ handleCommitUpgrade = do let parentProjectAndBranch = ProjectAndBranch upgradeProjectAndBranch.project parentBranch - -- Run `update` - - Update.handleUpdate2 - -- Switch to the parent ProjectSwitch.switchToProjectBranch (ProjectUtils.justTheIds parentProjectAndBranch) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 18e6e8768..d5e3918aa 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1188,8 +1188,6 @@ notifyUser dir = \case LoadingFile sourceName -> do fileName <- renderFileName $ Text.unpack sourceName pure $ P.wrap $ "Loading changes detected in " <> P.group (fileName <> ".") - -- TODO: Present conflicting TermEdits and TypeEdits - -- if we ever allow users to edit hashes directly. Typechecked sourceName ppe slurpResult uf -> do let fileStatusMsg = SlurpResult.pretty False ppe slurpResult let containsWatchExpressions = notNull $ UF.watchComponents uf @@ -1222,8 +1220,7 @@ notifyUser dir = \case <> IP.makeExample' IP.add <> " or " <> P.group (IP.makeExample' IP.update <> ",") - <> "here's how your codebase would" - <> "change:", + <> "here's how your codebase would change:", P.indentN 2 $ SlurpResult.pretty False ppe slurpResult ] ] diff --git a/unison-src/transcripts/upgrade-sad-path.md b/unison-src/transcripts/upgrade-sad-path.md index e0e87f218..ccf51fd60 100644 --- a/unison-src/transcripts/upgrade-sad-path.md +++ b/unison-src/transcripts/upgrade-sad-path.md @@ -24,6 +24,7 @@ thingy = foo + +10 ``` ```ucm +proj/upgrade-old-to-new> update proj/upgrade-old-to-new> upgrade.commit proj/main> view thingy proj/main> ls lib diff --git a/unison-src/transcripts/upgrade-sad-path.output.md b/unison-src/transcripts/upgrade-sad-path.output.md index 627a24596..e4ed5187b 100644 --- a/unison-src/transcripts/upgrade-sad-path.output.md +++ b/unison-src/transcripts/upgrade-sad-path.output.md @@ -65,13 +65,15 @@ thingy = foo + +10 ``` ```ucm -proj/upgrade-old-to-new> upgrade.commit +proj/upgrade-old-to-new> update Okay, I'm searching the branch for code that needs to be updated... Done. +proj/upgrade-old-to-new> upgrade.commit + I fast-forward merged proj/upgrade-old-to-new into proj/main. proj/main> view thingy From 9aa4bf51683160eb444e04b65c0a044f9ed29cc1 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Thu, 23 May 2024 23:19:33 -0600 Subject: [PATCH 59/82] Remove unused `Unison.Util.Convert` module --- parser-typechecker/src/Unison/Util/Convert.hs | 10 ---------- parser-typechecker/unison-parser-typechecker.cabal | 1 - 2 files changed, 11 deletions(-) delete mode 100644 parser-typechecker/src/Unison/Util/Convert.hs diff --git a/parser-typechecker/src/Unison/Util/Convert.hs b/parser-typechecker/src/Unison/Util/Convert.hs deleted file mode 100644 index 7962a9851..000000000 --- a/parser-typechecker/src/Unison/Util/Convert.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Unison.Util.Convert where - -class Convert a b where - convert :: a -> b - -class Parse a b where - parse :: a -> Maybe b - -instance (Parse a a2, Parse b b2) => Parse (a, b) (a2, b2) where - parse (a, b) = (,) <$> parse a <*> parse b diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index c952d6487..219f532ef 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -179,7 +179,6 @@ library Unison.UnisonFile.Names Unison.UnisonFile.Summary Unison.UnisonFile.Type - Unison.Util.Convert Unison.Util.CycleTable Unison.Util.CyclicEq Unison.Util.CyclicOrd From 6adb88f5b319c3574f1cd3b8c7e6d85e099f58d2 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 24 May 2024 11:01:45 -0400 Subject: [PATCH 60/82] delete a bunch of patch manipulation commands --- .../src/Unison/Codebase/BranchUtil.hs | 9 - unison-cli/src/Unison/Cli/MonadUtils.hs | 13 - .../src/Unison/Codebase/Editor/HandleInput.hs | 334 +----------------- .../src/Unison/Codebase/Editor/Input.hs | 24 -- .../src/Unison/Codebase/Editor/Output.hs | 15 - .../src/Unison/CommandLine/InputPatterns.hs | 257 -------------- .../src/Unison/CommandLine/OutputMessages.hs | 125 ------- unison-src/transcripts/command-replace.md | 58 --- .../transcripts/command-replace.output.md | 146 -------- unison-src/transcripts/copy-patch.md | 42 --- unison-src/transcripts/copy-patch.output.md | 80 ----- unison-src/transcripts/deleteReplacements.md | 94 ----- .../transcripts/deleteReplacements.output.md | 302 ---------------- .../transcripts/diff-namespace-to-patch.md | 43 --- .../diff-namespace-to-patch.output.md | 28 +- .../transcripts/diff-namespace.output.md | 317 +---------------- unison-src/transcripts/find-patch.md | 27 -- unison-src/transcripts/find-patch.output.md | 77 ---- unison-src/transcripts/fix1334.md | 30 +- unison-src/transcripts/fix1334.output.md | 97 +---- unison-src/transcripts/resolve.md | 116 ------ unison-src/transcripts/resolve.output.md | 265 -------------- .../transcripts/tab-completion.output.md | 4 - unison-src/transcripts/todo.md | 1 - unison-src/transcripts/todo.output.md | 8 - unison-src/transcripts/update-on-conflict.md | 3 +- .../transcripts/update-on-conflict.output.md | 6 +- 27 files changed, 23 insertions(+), 2498 deletions(-) delete mode 100644 unison-src/transcripts/command-replace.md delete mode 100644 unison-src/transcripts/command-replace.output.md delete mode 100644 unison-src/transcripts/copy-patch.md delete mode 100644 unison-src/transcripts/copy-patch.output.md delete mode 100644 unison-src/transcripts/deleteReplacements.md delete mode 100644 unison-src/transcripts/deleteReplacements.output.md delete mode 100644 unison-src/transcripts/diff-namespace-to-patch.md delete mode 100644 unison-src/transcripts/find-patch.md delete mode 100644 unison-src/transcripts/find-patch.output.md delete mode 100644 unison-src/transcripts/resolve.md delete mode 100644 unison-src/transcripts/resolve.output.md diff --git a/parser-typechecker/src/Unison/Codebase/BranchUtil.hs b/parser-typechecker/src/Unison/Codebase/BranchUtil.hs index 8a3d1a622..37c714ed7 100644 --- a/parser-typechecker/src/Unison/Codebase/BranchUtil.hs +++ b/parser-typechecker/src/Unison/Codebase/BranchUtil.hs @@ -15,8 +15,6 @@ module Unison.Codebase.BranchUtil makeAddTermName, makeDeleteTermName, makeAnnihilateTermName, - makeDeletePatch, - makeReplacePatch, ) where @@ -24,7 +22,6 @@ import Data.Map qualified as Map import Data.Set qualified as Set import Unison.Codebase.Branch (Branch, Branch0) import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Patch (Patch) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.HashQualified' (HashQualified (HashQualified, NameOnly)) @@ -83,12 +80,6 @@ makeAnnihilateTermName (p, name) = (p, Branch.annihilateTermName name) makeAnnihilateTypeName :: Path.Split -> (Path, Branch0 m -> Branch0 m) makeAnnihilateTypeName (p, name) = (p, Branch.annihilateTypeName name) -makeReplacePatch :: (Applicative m) => Path.Split -> Patch -> (Path, Branch0 m -> Branch0 m) -makeReplacePatch (p, name) patch = (p, Branch.replacePatch name patch) - -makeDeletePatch :: Path.Split -> (Path, Branch0 m -> Branch0 m) -makeDeletePatch (p, name) = (p, Branch.deletePatch name) - makeAddTypeName :: Path.Split -> Reference -> (Path, Branch0 m -> Branch0 m) makeAddTypeName (p, name) r = (p, Branch.addTypeName r name) diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index ddccf48a2..c9f40cf10 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -67,9 +67,6 @@ module Unison.Cli.MonadUtils -- ** Getting patches getPatchAt, - getMaybePatchAt, - expectPatchAt, - assertNoPatchAt, -- * Latest touched Unison file getLatestFile, @@ -514,16 +511,6 @@ getMaybePatchAt path0 = do branch <- getBranch0At path liftIO (Branch.getMaybePatch name branch) --- | Get the patch at a path, or return early if there's no such patch. -expectPatchAt :: Path.Split' -> Cli Patch -expectPatchAt path = - getMaybePatchAt path & onNothingM (Cli.returnEarly (Output.PatchNotFound path)) - --- | Assert that there's no patch at a path, or return early if there is one. -assertNoPatchAt :: Path.Split' -> Cli () -assertNoPatchAt path = do - whenJustM (getMaybePatchAt path) \_ -> Cli.returnEarly (Output.PatchAlreadyExists path) - ------------------------------------------------------------------------------------------------------------------------ -- Latest (typechecked) unison file utils diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 98085b2b2..088062ce2 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -27,7 +27,6 @@ import Text.Megaparsec qualified as Megaparsec import U.Codebase.Branch.Diff qualified as V2Branch.Diff import U.Codebase.Causal qualified as V2Causal import U.Codebase.HashTags (CausalHash (..)) -import U.Codebase.Reference qualified as V2 (Reference) import U.Codebase.Reflog qualified as Reflog import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite @@ -78,7 +77,7 @@ import Unison.Codebase.Editor.HandleInput.ProjectCreate (projectCreate) import Unison.Codebase.Editor.HandleInput.ProjectRename (handleProjectRename) import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch) import Unison.Codebase.Editor.HandleInput.Projects (handleProjects) -import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch, propagatePatch) +import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch) import Unison.Codebase.Editor.HandleInput.Push (handleGist, handlePushRemoteBranch) import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft) import Unison.Codebase.Editor.HandleInput.Run (handleRun) @@ -106,15 +105,8 @@ import Unison.Codebase.Patch qualified as Patch import Unison.Codebase.Path (Path, Path' (..)) import Unison.Codebase.Path qualified as HQSplit' import Unison.Codebase.Path qualified as Path -import Unison.Codebase.Path.Parse qualified as Path import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash qualified as SCH -import Unison.Codebase.SqliteCodebase.Conversions qualified as Conversions -import Unison.Codebase.TermEdit (TermEdit (..)) -import Unison.Codebase.TermEdit qualified as TermEdit -import Unison.Codebase.TermEdit.Typing qualified as TermEdit -import Unison.Codebase.TypeEdit (TypeEdit) -import Unison.Codebase.TypeEdit qualified as TypeEdit import Unison.CommandLine.BranchRelativePath (BranchRelativePath) import Unison.CommandLine.Completion qualified as Completion import Unison.CommandLine.DisplayValues qualified as DisplayValues @@ -132,7 +124,6 @@ import Unison.LabeledDependency qualified as LD import Unison.LabeledDependency qualified as LabeledDependency import Unison.Name (Name) import Unison.Name qualified as Name -import Unison.NameSegment (NameSegment (..)) import Unison.NameSegment qualified as NameSegment import Unison.Names (Names (Names)) import Unison.Names qualified as Names @@ -148,7 +139,7 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.PrettyPrintEnvDecl.Names qualified as PPED import Unison.Project (ProjectAndBranch (..)) import Unison.Project.Util (projectContextFromPath) -import Unison.Reference (Reference, TermReference) +import Unison.Reference (Reference) import Unison.Reference qualified as Reference import Unison.Referent (Referent) import Unison.Referent qualified as Referent @@ -159,7 +150,6 @@ import Unison.Server.CodebaseServer qualified as Server import Unison.Server.Doc.Markdown.Render qualified as Md import Unison.Server.Doc.Markdown.Types qualified as Md import Unison.Server.NameSearch.FromNames qualified as NameSearch -import Unison.Server.QueryResult import Unison.Server.SearchResult (SearchResult) import Unison.Server.SearchResult qualified as SR import Unison.Share.Codeserver qualified as Codeserver @@ -207,60 +197,7 @@ loop e = do Just (_, True) -> (#latestFile . _Just . _2) .= False _ -> loadUnisonFile sourceName text Right input -> - let typeReferences :: [SearchResult] -> [Reference] - typeReferences rs = - [r | SR.Tp (SR.TypeResult _ r _) <- rs] - termReferences :: [SearchResult] -> [Reference] - termReferences rs = - [r | SR.Tm (SR.TermResult _ (Referent.Ref r) _) <- rs] - termResults rs = [r | SR.Tm r <- rs] - typeResults rs = [r | SR.Tp r <- rs] - doRemoveReplacement :: HQ.HashQualified Name -> Maybe PatchPath -> Bool -> Cli () - doRemoveReplacement from patchPath isTerm = do - let patchPath' = fromMaybe Cli.defaultPatchPath patchPath - patch <- Cli.getPatchAt patchPath' - QueryResult misses allHits <- hqNameQuery Names.IncludeSuffixes [from] - let tpRefs = Set.fromList $ typeReferences allHits - tmRefs = Set.fromList $ termReferences allHits - (hits, opHits) = - let tmResults = Set.fromList $ SR.termName <$> termResults allHits - tpResults = Set.fromList $ SR.typeName <$> typeResults allHits - in case isTerm of - True -> (tmResults, tpResults) - False -> (tpResults, tmResults) - go :: Text -> Reference -> Cli () - go description fr = do - let termPatch = over Patch.termEdits (R.deleteDom fr) patch - typePatch = over Patch.typeEdits (R.deleteDom fr) patch - (patchPath'', patchName) <- Cli.resolveSplit' patchPath' - -- Save the modified patch - Cli.stepAtM - description - ( Path.unabsolute patchPath'', - Branch.modifyPatches - patchName - (const (if isTerm then termPatch else typePatch)) - ) - -- Say something - Cli.respond Success - when (Set.null hits) do - Cli.respond (SearchTermsNotFoundDetailed isTerm misses (Set.toList opHits)) - description <- inputDescription input - traverse_ (go description) (if isTerm then tmRefs else tpRefs) - saveAndApplyPatch :: Path -> NameSegment -> Patch -> Cli () - saveAndApplyPatch patchPath'' patchName patch' = do - description <- inputDescription input - Cli.stepAtM - (description <> " (1/2)") - ( patchPath'', - Branch.modifyPatches patchName (const patch') - ) - -- Apply the modified patch to the current path - -- since we might be able to propagate further. - currentPath <- Cli.getCurrentPath - void $ propagatePatch description patch' currentPath - Cli.respond Success - previewResponse sourceName sr uf = do + let previewResponse sourceName sr uf = do names <- Cli.currentNames let namesWithDefinitionsFromFile = UF.addNamesFromTypeCheckedUnisonFile uf names filePPED <- Cli.prettyPrintEnvDeclFromNames namesWithDefinitionsFromFile @@ -463,27 +400,6 @@ loop e = do hasConfirmed <- confirmedCommand input description <- inputDescription input doMoveBranch description hasConfirmed src' dest' - MovePatchI src' dest' -> do - description <- inputDescription input - p <- Cli.expectPatchAt src' - Cli.assertNoPatchAt dest' - src <- Cli.resolveSplit' src' - dest <- Cli.resolveSplit' dest' - Cli.stepManyAt - description - [ BranchUtil.makeDeletePatch (Path.convert src), - BranchUtil.makeReplacePatch (Path.convert dest) p - ] - Cli.respond Success - CopyPatchI src dest' -> do - description <- inputDescription input - p <- Cli.expectPatchAt src - Cli.assertNoPatchAt dest' - dest <- Cli.resolveSplit' dest' - Cli.stepAt - description - (BranchUtil.makeReplacePatch (Path.convert dest) p) - Cli.respond Success SwitchBranchI path' -> do path <- Cli.resolvePath' path' branchExists <- Cli.branchExistsAtPath' path' @@ -727,14 +643,6 @@ loop e = do DeleteTarget'TermOrType doutput hqs -> delete input doutput Cli.getTermsAt Cli.getTypesAt hqs DeleteTarget'Type doutput hqs -> delete input doutput (const (pure Set.empty)) Cli.getTypesAt hqs DeleteTarget'Term doutput hqs -> delete input doutput Cli.getTermsAt (const (pure Set.empty)) hqs - DeleteTarget'Patch src' -> do - _ <- Cli.expectPatchAt src' - description <- inputDescription input - src <- Cli.resolveSplit' src' - Cli.stepAt - description - (BranchUtil.makeDeletePatch (Path.convert src)) - Cli.respond Success DeleteTarget'Namespace insistence Nothing -> do hasConfirmed <- confirmedCommand input if hasConfirmed || insistence == Force @@ -777,15 +685,6 @@ loop e = do traverse_ (displayI outputLoc) namesToDisplay ShowDefinitionI outputLoc showDefinitionScope query -> handleShowDefinition outputLoc showDefinitionScope query EditNamespaceI paths -> handleEditNamespace LatestFileLocation paths - FindPatchI -> do - branch <- Cli.getCurrentBranch0 - let patches = - [ Path.unsafeToName $ Path.snoc p seg - | (p, b) <- Branch.toList0 branch, - (seg, _) <- Map.toList (Branch._edits b) - ] - Cli.respond $ ListOfPatches $ Set.fromList patches - Cli.setNumberedArgs $ fmap (Text.unpack . Name.toText) patches FindShallowI pathArg -> do Cli.Env {codebase} <- ask @@ -818,98 +717,6 @@ loop e = do FindI isVerbose fscope ws -> handleFindI isVerbose fscope ws input StructuredFindI _fscope ws -> handleStructuredFindI ws StructuredFindReplaceI ws -> handleStructuredFindReplaceI ws - ReplaceI from to patchPath -> do - Cli.Env {codebase} <- ask - hqLength <- Cli.runTransaction Codebase.hashLength - - let patchPath' = fromMaybe Cli.defaultPatchPath patchPath - patch <- Cli.getPatchAt patchPath' - QueryResult fromMisses' fromHits <- hqNameQuery Names.IncludeSuffixes [from] - QueryResult toMisses' toHits <- hqNameQuery Names.IncludeSuffixes [to] - let termsFromRefs = termReferences fromHits - termsToRefs = termReferences toHits - typesFromRefs = typeReferences fromHits - typesToRefs = typeReferences toHits - --- Here are all the kinds of misses - --- [X] [X] - --- [Type] [Term] - --- [Term] [Type] - --- [Type] [X] - --- [Term] [X] - --- [X] [Type] - --- [X] [Term] - -- Type hits are term misses - termFromMisses = fromMisses' <> (SR.typeName <$> typeResults fromHits) - termToMisses = toMisses' <> (SR.typeName <$> typeResults toHits) - -- Term hits are type misses - typeFromMisses = fromMisses' <> (SR.termName <$> termResults fromHits) - typeToMisses = toMisses' <> (SR.termName <$> termResults toHits) - - termMisses = termFromMisses <> termToMisses - typeMisses = typeFromMisses <> typeToMisses - - replaceTerms :: Reference -> Reference -> Cli () - replaceTerms fr tr = do - (mft, mtt) <- - Cli.runTransaction do - mft <- Codebase.getTypeOfTerm codebase fr - mtt <- Codebase.getTypeOfTerm codebase tr - pure (mft, mtt) - let termNotFound = - Cli.returnEarly - . TermNotFound' - . SH.shortenTo hqLength - . Reference.toShortHash - ft <- mft & onNothing (termNotFound fr) - tt <- mtt & onNothing (termNotFound tr) - let patch' = - -- The modified patch - over - Patch.termEdits - ( R.insert fr (Replace tr (TermEdit.typing tt ft)) - . R.deleteDom fr - ) - patch - (patchPath'', patchName) <- Cli.resolveSplit' patchPath' - saveAndApplyPatch (Path.convert patchPath'') patchName patch' - - replaceTypes :: Reference -> Reference -> Cli () - replaceTypes fr tr = do - let patch' = - -- The modified patch - over - Patch.typeEdits - (R.insert fr (TypeEdit.Replace tr) . R.deleteDom fr) - patch - (patchPath'', patchName) <- Cli.resolveSplit' patchPath' - saveAndApplyPatch (Path.convert patchPath'') patchName patch' - - ambiguous :: HQ.HashQualified Name -> [TermReference] -> Cli a - ambiguous t rs = - Cli.returnEarly case t of - HQ.HashOnly h -> HashAmbiguous h rs' - (Path.parseHQSplit' . Text.unpack . HQ.toText -> Right n) -> DeleteNameAmbiguous hqLength n rs' Set.empty - _ -> BadName (HQ.toText t) - where - rs' = Set.map Referent.Ref $ Set.fromList rs - - mismatch typeName termName = Cli.respond $ TypeTermMismatch typeName termName - - case (termsFromRefs, termsToRefs, typesFromRefs, typesToRefs) of - ([], [], [], []) -> Cli.respond $ SearchTermsNotFound termMisses - ([_], [], [], [_]) -> mismatch to from - ([], [_], [_], []) -> mismatch from to - ([_], [], _, _) -> Cli.respond $ SearchTermsNotFound termMisses - ([], [_], _, _) -> Cli.respond $ SearchTermsNotFound termMisses - (_, _, [_], []) -> Cli.respond $ SearchTermsNotFound typeMisses - (_, _, [], [_]) -> Cli.respond $ SearchTermsNotFound typeMisses - ([fr], [tr], [], []) -> replaceTerms fr tr - ([], [], [fr], [tr]) -> replaceTypes fr tr - (froms, [_], [], []) -> ambiguous from froms - ([], [], froms, [_]) -> ambiguous from froms - ([_], tos, [], []) -> ambiguous to tos - ([], [], [_], tos) -> ambiguous to tos - (_, _, _, _) -> error "unpossible" LoadI maybePath -> handleLoad maybePath ClearI -> Cli.respond ClearScreen AddI requestedNames -> do @@ -949,12 +756,6 @@ loop e = do branchPath <- Cli.resolvePath' branchPath' doShowTodoOutput patch branchPath TestI testInput -> Tests.handleTest testInput - PropagatePatchI patchPath scopePath' -> do - description <- inputDescription input - patch <- Cli.getPatchAt patchPath - scopePath <- Cli.resolvePath' scopePath' - updated <- propagatePatch description patch scopePath - when (not updated) (Cli.respond $ NothingToPatch patchPath scopePath') ExecuteI main args -> handleRun False main args MakeStandaloneI output main -> doCompile False output main CompileSchemeI output main -> @@ -1015,11 +816,6 @@ loop e = do _ <- Cli.updateAtM description destPath \destb -> liftIO (Branch.merge'' (Codebase.lca codebase) Branch.RegularMerge srcb destb) Cli.respond Success - ListEditsI maybePath -> do - patch <- Cli.getPatchAt (fromMaybe Cli.defaultPatchPath maybePath) - pped <- Cli.currentPrettyPrintEnvDecl - let suffixifiedPPE = PPED.suffixifiedPPE pped - Cli.respondNumbered $ ListEdits patch suffixifiedPPE PullI sourceTarget pullMode -> handlePull sourceTarget pullMode PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput ListDependentsI hq -> handleDependents hq @@ -1160,10 +956,6 @@ loop e = do nameChanges <- V2Branch.Diff.allNameChanges Nothing treeDiff pure (DisplayDebugNameDiff nameChanges) Cli.respond output - DeprecateTermI {} -> Cli.respond NotImplemented - DeprecateTypeI {} -> Cli.respond NotImplemented - RemoveTermReplacementI from patchPath -> doRemoveReplacement from patchPath True - RemoveTypeReplacementI from patchPath -> doRemoveReplacement from patchPath False UpdateBuiltinsI -> Cli.respond NotImplemented QuitI -> Cli.haltRepl GistI input -> handleGist input @@ -1171,9 +963,6 @@ loop e = do VersionI -> do Cli.Env {ucmVersion} <- ask Cli.respond $ PrintVersion ucmVersion - DiffNamespaceToPatchI diffNamespaceToPatchInput -> do - description <- inputDescription input - handleDiffNamespaceToPatch description diffNamespaceToPatchInput ProjectRenameI name -> handleProjectRename name ProjectSwitchI name -> projectSwitch name ProjectCreateI tryDownloadingBase name -> projectCreate tryDownloadingBase name @@ -1244,14 +1033,6 @@ inputDescription input = src <- p' src0 dest <- p' dest0 pure ("move " <> src <> " " <> dest) - MovePatchI src0 dest0 -> do - src <- ps' src0 - dest <- ps' dest0 - pure ("move.patch " <> src <> " " <> dest) - CopyPatchI src0 dest0 -> do - src <- ps' src0 - dest <- ps' dest0 - pure ("copy.patch " <> src <> " " <> dest) DeleteI dtarget -> do case dtarget of DeleteTarget'TermOrType DeleteOutput'NoDiff things0 -> do @@ -1278,20 +1059,8 @@ inputDescription input = DeleteTarget'Namespace Force opath0 -> do opath <- ops opath0 pure ("delete.namespace.force " <> opath) - DeleteTarget'Patch path0 -> do - path <- ps' path0 - pure ("delete.patch " <> path) DeleteTarget'ProjectBranch _ -> wat DeleteTarget'Project _ -> wat - ReplaceI src target p0 -> do - p <- opatch p0 - pure $ - "replace " - <> HQ.toText src - <> " " - <> HQ.toText target - <> " " - <> p AddI _selection -> pure "add" UpdateI p0 _selection -> do p <- @@ -1301,10 +1070,6 @@ inputDescription input = UsePatch p0 -> (" " <>) <$> ps' p0 pure ("update.old" <> p) Update2I -> pure ("update") - PropagatePatchI p0 scope0 -> do - p <- ps' p0 - scope <- p' scope0 - pure ("patch " <> p <> " " <> scope) UndoI {} -> pure "undo" ExecuteI s args -> pure ("execute " <> Text.unwords (s : fmap Text.pack args)) IOTestI hq -> pure ("io.test " <> HQ.toText hq) @@ -1319,17 +1084,6 @@ inputDescription input = pure $ "run.native " <> Text.unwords (nm : fmap Text.pack args) CompileSchemeI fi nm -> pure ("compile.native " <> HQ.toText nm <> " " <> fi) CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name) - RemoveTermReplacementI src p0 -> do - p <- opatch p0 - pure ("delete.term-replacement" <> HQ.toText src <> " " <> p) - RemoveTypeReplacementI src p0 -> do - p <- opatch p0 - pure ("delete.type-replacement" <> HQ.toText src <> " " <> p) - DiffNamespaceToPatchI input -> do - branchId1 <- hp' (input ^. #branchId1) - branchId2 <- hp' (input ^. #branchId2) - patch <- ps' (input ^. #patch) - pure (Text.unwords ["diff.namespace.to-patch", branchId1, branchId2, patch]) ClearI {} -> pure "clear" DocToMarkdownI name -> pure ("debug.doc-to-markdown " <> Name.toText name) -- @@ -1356,14 +1110,11 @@ inputDescription input = DebugFuzzyOptionsI cmd input -> pure . Text.pack $ "debug.fuzzy-completions " <> unwords (cmd : toList input) DebugFormatI -> pure "debug.format" DebugTypecheckedUnisonFileI {} -> wat - DeprecateTermI {} -> wat - DeprecateTypeI {} -> wat DiffNamespaceI {} -> wat DisplayI {} -> wat DocsI {} -> wat DocsToHtmlI {} -> wat FindI {} -> wat - FindPatchI {} -> wat FindShallowI {} -> wat StructuredFindI {} -> wat StructuredFindReplaceI {} -> wat @@ -1372,7 +1123,6 @@ inputDescription input = LibInstallI {} -> wat ListDependenciesI {} -> wat ListDependentsI {} -> wat - ListEditsI {} -> wat LoadI {} -> wat MergeI {} -> wat NamesI {} -> wat @@ -1411,8 +1161,6 @@ inputDescription input = brp = fmap from . ProjectUtils.resolveBranchRelativePath ops :: Maybe Path.Split -> Cli Text ops = maybe (pure ".") ps - opatch :: Maybe Path.Split' -> Cli Text - opatch = ps' . fromMaybe Cli.defaultPatchPath wat = error $ show input ++ " is not expected to alter the branch" hhqs' :: Either SH.ShortHash Path.HQSplit' -> Cli Text hhqs' = \case @@ -1592,73 +1340,6 @@ handleDependents hq = do Cli.setNumberedArgs $ map (Text.unpack . Reference.toText . view _2) (types <> terms) Cli.respond (ListDependents ppe lds (fst <$> types) (fst <$> terms)) -handleDiffNamespaceToPatch :: Text -> DiffNamespaceToPatchInput -> Cli () -handleDiffNamespaceToPatch description input = do - Cli.Env {codebase} <- ask - - absBranchId1 <- Cli.resolveBranchIdToAbsBranchId (input ^. #branchId1) - absBranchId2 <- Cli.resolveBranchIdToAbsBranchId (input ^. #branchId2) - - patch <- do - Cli.runTransactionWithRollback \rollback -> do - branch1 <- Cli.resolveAbsBranchIdV2 rollback absBranchId1 - branch2 <- Cli.resolveAbsBranchIdV2 rollback absBranchId2 - branchDiff <- V2Branch.Diff.diffBranches branch1 branch2 >>= V2Branch.Diff.nameBasedDiff - termEdits <- - (branchDiff ^. #terms) - & Relation.domain - & Map.toList - & traverse \(oldRef, newRefs) -> makeTermEdit codebase oldRef newRefs - pure - Patch - { _termEdits = - termEdits - & catMaybes - & Relation.fromList, - _typeEdits = - (branchDiff ^. #types) - & Relation.domain - & Map.toList - & mapMaybe (\(oldRef, newRefs) -> makeTypeEdit oldRef newRefs) - & Relation.fromList - } - - -- Display the patch that we are about to create. - suffixifiedPPE <- PPED.suffixifiedPPE <$> Cli.currentPrettyPrintEnvDecl - Cli.respondNumbered (ListEdits patch suffixifiedPPE) - - (patchPath, patchName) <- Cli.resolveSplit' (input ^. #patch) - - -- Add the patch to the in-memory root branch and flush it all to SQLite. - -- If there's already a patch at the given path, overwrite it. - Cli.stepAtM - description - (Path.unabsolute patchPath, Branch.modifyPatches patchName (const patch)) - where - -- Given {old reference} and {new references}, create term edit patch entries as follows: - -- - -- * If the {new references} is a singleton set {new reference}, proceed. (Otherwise, the patch we might create - -- would not be a function, which is a bogus/conflicted patch). - -- * Look up {old reference} and {new reference} types in the codebase (which can technically fail, due to - -- non-transactionality of this command, though we don't typically delete anything from SQLite), and create a - -- patch entry that maps {old reference} to {new reference} with the typing relationship. - makeTermEdit :: - Codebase m Symbol Ann -> - V2.Reference -> - Set V2.Reference -> - Sqlite.Transaction (Maybe (Reference, TermEdit)) - makeTermEdit codebase (Conversions.reference2to1 -> oldRef) newRefs = - runMaybeT do - newRef <- Conversions.reference2to1 <$> MaybeT (pure (Set.asSingleton newRefs)) - oldRefType <- MaybeT (Codebase.getTypeOfTerm codebase oldRef) - newRefType <- MaybeT (Codebase.getTypeOfTerm codebase newRef) - pure (oldRef, TermEdit.Replace newRef (TermEdit.typing oldRefType newRefType)) - - -- Same idea as 'makeTermEdit', but simpler, because there's nothing to look up in the database. - makeTypeEdit :: V2.Reference -> Set V2.Reference -> Maybe (Reference, TypeEdit) - makeTypeEdit (Conversions.reference2to1 -> oldRef) newRefs = - Set.asSingleton newRefs <&> \newRef -> (oldRef, TypeEdit.Replace (Conversions.reference2to1 newRef)) - -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: OutputLocation -> ShowDefinitionScope -> NonEmpty (HQ.HashQualified Name) -> Cli () handleShowDefinition outputLoc showDefinitionScope query = do @@ -2205,15 +1886,6 @@ addWatch watchName (Just uf) = do ) _ -> addWatch watchName Nothing -hqNameQuery :: Names.SearchType -> [HQ.HashQualified Name] -> Cli QueryResult -hqNameQuery searchType query = do - Cli.Env {codebase} <- ask - names <- Cli.currentNames - Cli.runTransaction do - hqLength <- Codebase.hashLength - let nameSearch = NameSearch.makeNameSearch hqLength names - Backend.hqNameQuery codebase nameSearch searchType query - looseCodeOrProjectToPath :: Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) -> Path' looseCodeOrProjectToPath = \case Left pth -> pth diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index c82ef2866..4f0e384da 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -1,7 +1,6 @@ module Unison.Codebase.Editor.Input ( Input (..), BranchSourceI (..), - DiffNamespaceToPatchInput (..), GistInput (..), PullSourceTarget (..), PushRemoteBranchInput (..), @@ -142,8 +141,6 @@ data Input MoveTermI Path.HQSplit' Path.Split' | MoveTypeI Path.HQSplit' Path.Split' | MoveBranchI Path.Path' Path.Path' - | MovePatchI Path.Split' Path.Split' - | CopyPatchI Path.Split' Path.Split' | -- delete = unname DeleteI DeleteTarget | -- edits stuff: @@ -155,14 +152,6 @@ data Input | Update2I | PreviewUpdateI (Set Name) | TodoI (Maybe PatchPath) Path' - | PropagatePatchI PatchPath Path' - | ListEditsI (Maybe PatchPath) - | -- -- create and remove update directives - DeprecateTermI PatchPath Path.HQSplit' - | DeprecateTypeI PatchPath Path.HQSplit' - | ReplaceI (HQ.HashQualified Name) (HQ.HashQualified Name) (Maybe PatchPath) - | RemoveTermReplacementI (HQ.HashQualified Name) (Maybe PatchPath) - | RemoveTypeReplacementI (HQ.HashQualified Name) (Maybe PatchPath) | UndoI | -- First `Maybe Int` is cap on number of results, if any -- Second `Maybe Int` is cap on diff elements shown, if any @@ -190,7 +179,6 @@ data Input | -- other FindI Bool FindScope [String] -- FindI isVerbose findScope query | FindShallowI Path' - | FindPatchI | StructuredFindI FindScope (HQ.HashQualified Name) -- sfind findScope query | StructuredFindReplaceI (HQ.HashQualified Name) -- sfind.replace rewriteQuery | -- Show provided definitions. @@ -225,7 +213,6 @@ data Input | GistI GistInput | AuthLoginI | VersionI - | DiffNamespaceToPatchI DiffNamespaceToPatchInput | ProjectCreateI Bool {- try downloading base? -} (Maybe ProjectName) | ProjectRenameI ProjectName | ProjectSwitchI ProjectAndBranchNames @@ -252,16 +239,6 @@ data BranchSourceI BranchSourceI'LooseCodeOrProject LooseCodeOrProject deriving stock (Eq, Show) -data DiffNamespaceToPatchInput = DiffNamespaceToPatchInput - { -- The first/earlier namespace. - branchId1 :: BranchId, - -- The second/later namespace. - branchId2 :: BranchId, - -- Where to store the patch that corresponds to the diff between the namespaces. - patch :: Path.Split' - } - deriving stock (Eq, Generic, Show) - -- | @"push.gist repo"@ pushes the contents of the current namespace to @repo@. data GistInput = GistInput { repo :: WriteGitRepo @@ -332,7 +309,6 @@ data DeleteTarget | DeleteTarget'Term DeleteOutput [Path.HQSplit'] | DeleteTarget'Type DeleteOutput [Path.HQSplit'] | DeleteTarget'Namespace Insistence (Maybe Path.Split) - | DeleteTarget'Patch Path.Split' | DeleteTarget'ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) | DeleteTarget'Project ProjectName deriving stock (Eq, Show) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index da1a1349a..421f39121 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -17,7 +17,6 @@ module Unison.Codebase.Editor.Output where import Data.List.NonEmpty (NonEmpty) -import Data.Set qualified as Set import Data.Set.NonEmpty (NESet) import Data.Time (UTCTime) import Network.URI (URI) @@ -39,7 +38,6 @@ import Unison.Codebase.Editor.SlurpResult (SlurpResult (..)) import Unison.Codebase.Editor.SlurpResult qualified as SR import Unison.Codebase.Editor.TodoOutput qualified as TO import Unison.Codebase.IntegrityCheck (IntegrityResult (..)) -import Unison.Codebase.Patch (Patch) import Unison.Codebase.Path (Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.PushBehavior (PushBehavior) @@ -128,7 +126,6 @@ data NumberedOutput HashLength [(CausalHash, Names.Diff)] HistoryTail -- 'origin point' of this view of history. - | ListEdits Patch PPE.PrettyPrintEnv | ListProjects [Sqlite.Project] | ListBranches ProjectName [(ProjectBranchName, [(URI, ProjectName, ProjectBranchName)])] | AmbiguousSwitch ProjectName (ProjectAndBranch ProjectName ProjectBranchName) @@ -173,7 +170,6 @@ data Output | CreatedNewBranch Path.Absolute | BranchAlreadyExists Path' | FindNoLocalMatches - | PatchAlreadyExists Path.Split' | NoExactTypeMatches | TypeAlreadyExists Path.Split' (Set Reference) | TypeParseError String (Parser.Err Symbol) @@ -192,13 +188,11 @@ data Output | EmptyProjectBranchPush (ProjectAndBranch ProjectName ProjectBranchName) | NameNotFound Path.HQSplit' | NamesNotFound [Name] - | PatchNotFound Path.Split' | TypeNotFound Path.HQSplit' | TermNotFound Path.HQSplit' | MoveNothingFound Path' | TypeNotFound' ShortHash | TermNotFound' ShortHash - | TypeTermMismatch (HQ.HashQualified Name) (HQ.HashQualified Name) | NoLastRunResult | SaveTermNameConflict Name | SearchTermsNotFound [HQ.HashQualified Name] @@ -231,7 +225,6 @@ data Output -- list of all the definitions within this branch | ListOfDefinitions FindScope PPE.PrettyPrintEnv ListDetailed [SearchResult' Symbol Ann] | ListShallow (IO PPE.PrettyPrintEnv) [ShallowListEntry Symbol Ann] - | ListOfPatches (Set Name) | ListStructuredFind [HQ.HashQualified Name] | -- ListStructuredFind patternMatchingUsages termBodyUsages -- show the result of add/update @@ -275,8 +268,6 @@ data Output | ConfiguredRemoteMappingParseError PushPull Path.Absolute Text String | TermMissingType Reference | AboutToPropagatePatch - | -- todo: tell the user to run `todo` on the same patch they just used - NothingToPatch PatchPath Path' | PatchNeedsToBeConflictFree | PatchInvolvesExternalDependents PPE.PrettyPrintEnv (Set Reference) | StartOfCurrentPathHistory @@ -488,7 +479,6 @@ isFailure o = case o of BranchAlreadyExists {} -> True -- we do a global search after finding no local matches, so let's not call this a failure yet FindNoLocalMatches {} -> False - PatchAlreadyExists {} -> True NoExactTypeMatches -> True BranchEmpty {} -> True EmptyLooseCodePush {} -> True @@ -508,13 +498,11 @@ isFailure o = case o of BranchNotFound {} -> True NameNotFound {} -> True NamesNotFound _ -> True - PatchNotFound {} -> True TypeNotFound {} -> True TypeNotFound' {} -> True TermNotFound {} -> True MoveNothingFound {} -> True TermNotFound' {} -> True - TypeTermMismatch {} -> True SearchTermsNotFound ts -> not (null ts) SearchTermsNotFoundDetailed _ misses otherHits -> not (null misses && null otherHits) DeleteBranchConfirmation {} -> False @@ -524,7 +512,6 @@ isFailure o = case o of DeletedEverything -> False ListNames _ _ tys tms -> null tms && null tys ListOfDefinitions _ _ _ ds -> null ds - ListOfPatches s -> Set.null s ListStructuredFind tms -> null tms SlurpOutput _ _ sr -> not $ SR.isOk sr ParseErrors {} -> True @@ -549,7 +536,6 @@ isFailure o = case o of PatchNeedsToBeConflictFree {} -> True PatchInvolvesExternalDependents {} -> True AboutToPropagatePatch {} -> False - NothingToPatch {} -> False StartOfCurrentPathHistory -> True NotImplemented -> True DumpNumberedArgs {} -> False @@ -662,7 +648,6 @@ isNumberedFailure = \case DeletedDespiteDependents {} -> False History {} -> False ListBranches {} -> False - ListEdits {} -> False ListProjects {} -> False ShowDiffAfterCreateAuthor {} -> False ShowDiffAfterDeleteBranch {} -> False diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index b29df8783..661550644 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -19,7 +19,6 @@ module Unison.CommandLine.InputPatterns clear, clone, compileScheme, - copyPatch, createAuthor, debugClearWatchCache, debugDoctor, @@ -39,19 +38,15 @@ module Unison.CommandLine.InputPatterns deleteBranch, deleteNamespace, deleteNamespaceForce, - deletePatch, deleteProject, deleteTerm, - deleteTermReplacement, deleteTermVerbose, deleteType, - deleteTypeReplacement, deleteTypeVerbose, deleteVerbose, dependencies, dependents, diffNamespace, - diffNamespaceToPatch, display, displayTo, docToMarkdown, @@ -65,7 +60,6 @@ module Unison.CommandLine.InputPatterns findGlobal, findIn, findInAll, - findPatch, findShallow, findVerbose, findVerboseAll, @@ -88,7 +82,6 @@ module Unison.CommandLine.InputPatterns moveAll, names, namespaceDependencies, - patch, previewAdd, previewUpdate, printVersion, @@ -106,10 +99,8 @@ module Unison.CommandLine.InputPatterns quit, releaseDraft, renameBranch, - renamePatch, renameTerm, renameType, - replace, reset, resetRoot, runScheme, @@ -129,12 +120,9 @@ module Unison.CommandLine.InputPatterns upgrade, view, viewGlobal, - viewPatch, viewReflog, -- * Misc - deleteTermReplacementCommand, - deleteTypeReplacementCommand, helpFor, makeExample', makeExample, @@ -495,45 +483,6 @@ previewUpdate = ) \ws -> pure $ Input.PreviewUpdateI (Set.fromList $ map (Name.unsafeParseText . Text.pack) ws) -patch :: InputPattern -patch = - InputPattern - "patch" - [] - I.Visible - [("patch", Required, patchArg), ("namespace", Optional, namespaceArg)] - ( P.lines - [ P.wrap $ - makeExample' patch - <> "rewrites any definitions that depend on " - <> "definitions with type-preserving edits to use the updated versions of" - <> "these dependencies.", - "", - P.wrapColumn2 - [ ( makeExample patch ["", "[path]"], - "applies the given patch" - <> "to the given namespace" - ), - ( makeExample patch [""], - "applies the given patch" - <> "to the current namespace" - ) - ] - ] - ) - \case - patchStr : ws -> first P.text do - patch <- Path.parseSplit' patchStr - branch <- case ws of - [pathStr] -> Path.parsePath' pathStr - _ -> pure Path.relativeEmpty' - pure $ Input.PropagatePatchI patch branch - [] -> - Left $ - warn $ - makeExample' patch - <> "takes a patch and an optional namespace." - view :: InputPattern view = InputPattern @@ -852,18 +801,6 @@ findVerboseAll = ) (pure . Input.FindI True (Input.FindLocalAndDeps Path.empty)) -findPatch :: InputPattern -findPatch = - InputPattern - "find.patch" - ["list.patch", "ls.patch"] - I.Visible - [] - ( P.wrapColumn2 - [("`find.patch`", "lists all patches in the current namespace.")] - ) - (pure . const Input.FindPatchI) - renameTerm :: InputPattern renameTerm = InputPattern @@ -989,54 +926,6 @@ deleteType = deleteGen (Just "type") exactDefinitionTypeQueryArg "type" (DeleteT deleteTypeVerbose :: InputPattern deleteTypeVerbose = deleteGen (Just "type.verbose") exactDefinitionTypeQueryArg "type" (DeleteTarget'Type DeleteOutput'Diff) -deleteTermReplacementCommand :: String -deleteTermReplacementCommand = "delete.term-replacement" - -deleteTypeReplacementCommand :: String -deleteTypeReplacementCommand = "delete.type-replacement" - -deleteReplacement :: Bool -> InputPattern -deleteReplacement isTerm = - InputPattern - commandName - [] - I.Visible - [("definition", Required, if isTerm then exactDefinitionTermQueryArg else exactDefinitionTypeQueryArg), ("patch", Optional, patchArg)] - ( P.string $ - commandName - <> " ` removes any edit of the " - <> str - <> " `foo` from the patch `patch`, " - <> "or from the default patch if none is specified. Note that `foo` refers to the " - <> "original name for the " - <> str - <> " - not the one in place after the edit." - ) - ( \case - query : patch -> do - patch <- first P.text . traverse Path.parseSplit' $ listToMaybe patch - q <- parseHashQualifiedName query - pure $ input q patch - _ -> - Left - . P.warnCallout - . P.wrapString - $ commandName - <> " needs arguments. See `help " - <> commandName - <> "`." - ) - where - input = - if isTerm - then Input.RemoveTermReplacementI - else Input.RemoveTypeReplacementI - str = if isTerm then "term" else "type" - commandName = - if isTerm - then deleteTermReplacementCommand - else deleteTypeReplacementCommand - deleteProject :: InputPattern deleteProject = InputPattern @@ -1082,12 +971,6 @@ deleteBranch = branchInclusion = AllBranches } -deleteTermReplacement :: InputPattern -deleteTermReplacement = deleteReplacement True - -deleteTypeReplacement :: InputPattern -deleteTypeReplacement = deleteReplacement False - aliasTerm :: InputPattern aliasTerm = InputPattern @@ -1243,56 +1126,6 @@ deleteNamespaceParser helpText insistence = \case pure $ Input.DeleteI (DeleteTarget'Namespace insistence (Just p)) _ -> Left helpText -deletePatch :: InputPattern -deletePatch = - InputPattern - "delete.patch" - [] - I.Visible - [("patch to delete", Required, patchArg)] - "`delete.patch ` deletes the patch `foo`" - \case - [p] -> first P.text do - p <- Path.parseSplit' p - pure . Input.DeleteI $ DeleteTarget'Patch p - _ -> Left (I.help deletePatch) - -movePatch :: String -> String -> Either (P.Pretty CT.ColorText) Input -movePatch src dest = first P.text do - src <- Path.parseSplit' src - dest <- Path.parseSplit' dest - pure $ Input.MovePatchI src dest - -copyPatch' :: String -> String -> Either (P.Pretty CT.ColorText) Input -copyPatch' src dest = first P.text do - src <- Path.parseSplit' src - dest <- Path.parseSplit' dest - pure $ Input.CopyPatchI src dest - -copyPatch :: InputPattern -copyPatch = - InputPattern - "copy.patch" - [] - I.Visible - [("patch to copy", Required, patchArg), ("copy destination", Required, newNameArg)] - "`copy.patch foo bar` copies the patch `foo` to `bar`." - \case - [src, dest] -> copyPatch' src dest - _ -> Left (I.help copyPatch) - -renamePatch :: InputPattern -renamePatch = - InputPattern - "move.patch" - ["rename.patch"] - I.Visible - [("patch", Required, patchArg), ("new location", Required, newNameArg)] - "`move.patch foo bar` renames the patch `foo` to `bar`." - \case - [src, dest] -> movePatch src dest - _ -> Left (I.help renamePatch) - renameBranch :: InputPattern renameBranch = InputPattern @@ -2012,45 +1845,6 @@ mergeOldPreviewInputPattern = branchInclusion = AllBranches } -replaceEdit :: - ( HQ.HashQualified Name -> - HQ.HashQualified Name -> - Maybe Input.PatchPath -> - Input - ) -> - InputPattern -replaceEdit f = self - where - self = - InputPattern - "replace" - [] - I.Visible - [ ("definition to replace", Required, definitionQueryArg), - ("definition replacement", Required, definitionQueryArg), - ("patch", Optional, patchArg) - ] - ( P.wrapColumn2 - [ ( makeExample self ["", "", ""], - "Replace the term/type in the given patch with the term/type ." - ), - ( makeExample self ["", ""], - "Replace the term/type with in the default patch." - ) - ] - ) - ( \case - source : target : patch -> do - patch <- first P.text <$> traverse Path.parseSplit' $ listToMaybe patch - sourcehq <- parseHashQualifiedName source - targethq <- parseHashQualifiedName target - pure $ f sourcehq targethq patch - _ -> Left $ I.help self - ) - -replace :: InputPattern -replace = replaceEdit Input.ReplaceI - viewReflog :: InputPattern viewReflog = InputPattern @@ -2348,29 +2142,6 @@ quit = [] -> pure Input.QuitI _ -> Left "Use `quit`, `exit`, or to quit." -viewPatch :: InputPattern -viewPatch = - InputPattern - "view.patch" - [] - I.Visible - [("patch", Optional, patchArg)] - ( P.wrapColumn2 - [ ( makeExample' viewPatch, - "Lists all the edits in the default patch." - ), - ( makeExample viewPatch [""], - "Lists all the edits in the given patch." - ) - ] - ) - \case - [] -> Right $ Input.ListEditsI Nothing - [patchStr] -> mapLeft P.text do - patch <- Path.parseSplit' patchStr - Right $ Input.ListEditsI (Just patch) - _ -> Left $ warn "`view.patch` takes a patch and that's it." - names :: Input.IsGlobal -> InputPattern names isGlobal = InputPattern @@ -2865,24 +2636,6 @@ printVersion = _ -> Left (showPatternHelp printVersion) ) -diffNamespaceToPatch :: InputPattern -diffNamespaceToPatch = - InputPattern - { patternName = "diff.namespace.to-patch", - aliases = [], - visibility = I.Visible, - args = [], - help = P.wrap "Create a patch from a namespace diff.", - parse = \case - [branchId1, branchId2, patch] -> - mapLeft P.text do - branchId1 <- Input.parseBranchId branchId1 - branchId2 <- Input.parseBranchId branchId2 - patch <- Path.parseSplit' patch - pure (Input.DiffNamespaceToPatchI Input.DiffNamespaceToPatchInput {branchId1, branchId2, patch}) - _ -> Left (showPatternHelp diffNamespaceToPatch) - } - projectCreate :: InputPattern projectCreate = InputPattern @@ -3174,7 +2927,6 @@ validInputs = clear, clone, compileScheme, - copyPatch, createAuthor, debugClearWatchCache, debugDoctor, @@ -3195,18 +2947,14 @@ validInputs = deleteProject, deleteNamespace, deleteNamespaceForce, - deletePatch, deleteTerm, - deleteTermReplacement, deleteTermVerbose, deleteType, - deleteTypeReplacement, deleteTypeVerbose, deleteVerbose, dependencies, dependents, diffNamespace, - diffNamespaceToPatch, display, displayTo, docToMarkdown, @@ -3220,7 +2968,6 @@ validInputs = findAll, findInAll, findGlobal, - findPatch, findShallow, findVerbose, findVerboseAll, @@ -3245,7 +2992,6 @@ validInputs = names False, -- names names True, -- names.global namespaceDependencies, - patch, previewAdd, previewUpdate, printVersion, @@ -3263,11 +3009,9 @@ validInputs = quit, releaseDraft, renameBranch, - renamePatch, renameTerm, renameType, moveAll, - replace, reset, resetRoot, runScheme, @@ -3285,7 +3029,6 @@ validInputs = upgrade, view, viewGlobal, - viewPatch, viewReflog ] diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index b3d0e4990..a56b7faab 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -6,9 +6,7 @@ module Unison.CommandLine.OutputMessages where import Control.Lens hiding (at) -import Control.Monad.State import Control.Monad.State.Strict qualified as State -import Control.Monad.Writer (Writer, runWriter, tell) import Data.ByteString.Lazy qualified as LazyByteString import Data.Foldable qualified as Foldable import Data.List (stripPrefix) @@ -128,7 +126,6 @@ import Unison.Server.Backend qualified as Backend import Unison.Server.SearchResult' qualified as SR' import Unison.Share.Sync qualified as Share import Unison.Share.Sync.Types (CodeserverTransportError (..)) -import Unison.ShortHash qualified as ShortHash import Unison.Sync.Types qualified as Share import Unison.Syntax.DeclPrinter qualified as DeclPrinter import Unison.Syntax.HashQualified qualified as HQ (toText, unsafeFromVar) @@ -405,7 +402,6 @@ notifyNumbered = \case ], numberedArgsForEndangerments ppeDecl endangerments ) - ListEdits patch ppe -> showListEdits patch ppe ListProjects projects -> ( P.numberedList (map (prettyProjectName . view #name) projects), map (Text.unpack . into @Text . view #name) projects @@ -551,99 +547,6 @@ undoTip = <> IP.makeExample' IP.viewReflog <> "to undo this change." -showListEdits :: Patch -> PPE.PrettyPrintEnv -> (P.Pretty P.ColorText, NumberedArgs) -showListEdits patch ppe = - ( P.sepNonEmpty - "\n\n" - [ if null types - then mempty - else - "Edited Types:" - `P.hang` P.column2 typeOutputs, - if null terms - then mempty - else - "Edited Terms:" - `P.hang` P.column2 termOutputs, - if null types && null terms - then "This patch is empty." - else - tip . P.string $ - "To remove entries from a patch, use " - <> IP.deleteTermReplacementCommand - <> " or " - <> IP.deleteTypeReplacementCommand - <> ", as appropriate." - ], - numberedArgsCol1 <> numberedArgsCol2 - ) - where - typeOutputs, termOutputs :: [(Pretty, Pretty)] - numberedArgsCol1, numberedArgsCol2 :: NumberedArgs - -- We use the output of the first column's count as the first number in the second - -- column's count. Laziness allows this since they're used independently of one another. - (((typeOutputs, termOutputs), (lastNumberInFirstColumn, _)), (numberedArgsCol1, numberedArgsCol2)) = - runWriter . flip runStateT (1, lastNumberInFirstColumn) $ do - typeOutputs <- traverse prettyTypeEdit types - termOutputs <- traverse prettyTermEdit terms - pure (typeOutputs, termOutputs) - types :: [(Reference, TypeEdit.TypeEdit)] - types = R.toList $ Patch._typeEdits patch - terms :: [(Reference, TermEdit.TermEdit)] - terms = R.toList $ Patch._termEdits patch - showNum :: Int -> Pretty - showNum n = P.hiBlack (P.shown n <> ". ") - - prettyTermEdit :: - (Reference.TermReference, TermEdit.TermEdit) -> - StateT (Int, Int) (Writer (NumberedArgs, NumberedArgs)) (Pretty, Pretty) - prettyTermEdit (lhsRef, termEdit) = do - n1 <- gets fst <* modify (first succ) - let lhsTermName = PPE.termName ppe (Referent.Ref lhsRef) - -- We use the shortHash of the lhs rather than its name for numbered args, - -- since its name is likely to be "historical", and won't work if passed to a ucm command. - let lhsHash = Text.unpack . ShortHash.toText . Reference.toShortHash $ lhsRef - case termEdit of - TermEdit.Deprecate -> do - lift $ tell ([lhsHash], []) - pure - ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTermName), - "-> (deprecated)" - ) - TermEdit.Replace rhsRef _typing -> do - n2 <- gets snd <* modify (second succ) - let rhsTermName = PPE.termName ppe (Referent.Ref rhsRef) - lift $ tell ([lhsHash], [Text.unpack (HQ.toText rhsTermName)]) - pure - ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTermName), - "-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTermName) - ) - - prettyTypeEdit :: - (Reference, TypeEdit.TypeEdit) -> - StateT (Int, Int) (Writer (NumberedArgs, NumberedArgs)) (Pretty, Pretty) - prettyTypeEdit (lhsRef, typeEdit) = do - n1 <- gets fst <* modify (first succ) - let lhsTypeName = PPE.typeName ppe lhsRef - -- We use the shortHash of the lhs rather than its name for numbered args, - -- since its name is likely to be "historical", and won't work if passed to a ucm command. - let lhsHash = Text.unpack . ShortHash.toText . Reference.toShortHash $ lhsRef - case typeEdit of - TypeEdit.Deprecate -> do - lift $ tell ([lhsHash], []) - pure - ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTypeName), - "-> (deprecated)" - ) - TypeEdit.Replace rhsRef -> do - n2 <- gets snd <* modify (second succ) - let rhsTypeName = PPE.typeName ppe rhsRef - lift $ tell ([lhsHash], [Text.unpack (HQ.toText rhsTypeName)]) - pure - ( showNum n1 <> (P.syntaxToColor . prettyHashQualified $ lhsTypeName), - "-> " <> showNum n2 <> (P.syntaxToColor . prettyHashQualified $ rhsTypeName) - ) - notifyUser :: FilePath -> Output -> IO Pretty notifyUser dir = \case SaveTermNameConflict name -> @@ -782,13 +685,6 @@ notifyUser dir = \case <> " by someone else. Trying your command again might fix it." ] EvaluationFailure err -> pure err - TypeTermMismatch typeName termName -> - pure $ - P.warnCallout "I was expecting either two types or two terms but was given a type " - <> P.syntaxToColor (prettyHashQualified typeName) - <> " and a term " - <> P.syntaxToColor (prettyHashQualified termName) - <> "." SearchTermsNotFound hqs | null hqs -> pure mempty SearchTermsNotFound hqs -> pure $ @@ -814,8 +710,6 @@ notifyUser dir = \case P.warnCallout typeOrTermMsg <> P.newline <> P.syntaxToColor (P.indent " " (P.lines (prettyHashQualified <$> otherHits))) - PatchNotFound _ -> - pure . P.warnCallout $ "I don't know about that patch." NameNotFound _ -> pure . P.warnCallout $ "I don't know about that name." NamesNotFound hqs -> @@ -833,8 +727,6 @@ notifyUser dir = \case pure . P.warnCallout $ "A term by that name already exists." TypeAlreadyExists _ _ -> pure . P.warnCallout $ "A type by that name already exists." - PatchAlreadyExists _ -> - pure . P.warnCallout $ "A patch by that name already exists." BranchEmpty b -> pure . P.warnCallout . P.wrap $ P.group (prettyWhichBranchEmpty b) <> "is an empty namespace." @@ -1356,17 +1248,6 @@ notifyUser dir = \case "You're missing:" `P.hang` P.lines (fmap (P.text . Reference.toText) new), "I'm missing:" `P.hang` P.lines (fmap (P.text . Reference.toText) old) ] - ListOfPatches patches -> - pure $ - if null patches - then P.lit "nothing to show" - else numberedPatches patches - where - numberedPatches :: Set Name -> Pretty - numberedPatches patches = - (P.column2 . fmap format) ([(1 :: Integer) ..] `zip` (toList patches)) - where - format (i, p) = (P.hiBlack . fromString $ show i <> ".", prettyName p) NoConfiguredRemoteMapping pp p -> do let (localPathExample, sharePathExample) = if Path.isRoot p @@ -1500,12 +1381,6 @@ notifyUser dir = \case "I could't find a type with hash " <> (prettyShortHash sh) AboutToPropagatePatch -> pure "Applying changes from patch..." - NothingToPatch _patchPath dest -> - pure $ - P.callout "😶" . P.wrap $ - "This had no effect. Perhaps the patch has already been applied" - <> "or it doesn't intersect with the definitions in" - <> P.group (prettyPath' dest <> ".") PatchNeedsToBeConflictFree -> pure . P.wrap $ "I tried to auto-apply the patch, but couldn't because it contained" diff --git a/unison-src/transcripts/command-replace.md b/unison-src/transcripts/command-replace.md deleted file mode 100644 index c1d07740a..000000000 --- a/unison-src/transcripts/command-replace.md +++ /dev/null @@ -1,58 +0,0 @@ -# Replace with terms and types - -Let's set up some definitions to start: - -```ucm:hide -.lib> builtins.merge -``` - -```unison -x = 1 -y = 2 - -structural type X = One Nat -structural type Y = Two Nat Nat -``` - -```ucm -.> add -``` - -Test that replace works with terms -```ucm -.> replace x y -.> view x -``` - -Test that replace works with types -```ucm -.> replace X Y -.> find -.> view.patch patch -.> view X -``` - -Try with a type/term mismatch -```ucm:error -.> replace X x -``` -```ucm:error -.> replace y Y -``` - -Try with missing references -```ucm:error -.> replace X NOPE -``` -```ucm:error -.> replace y nope -``` -```ucm:error -.> replace nope X -``` -```ucm:error -.> replace nope y -``` -```ucm:error -.> replace nope nope -``` diff --git a/unison-src/transcripts/command-replace.output.md b/unison-src/transcripts/command-replace.output.md deleted file mode 100644 index 1fb85d502..000000000 --- a/unison-src/transcripts/command-replace.output.md +++ /dev/null @@ -1,146 +0,0 @@ -# Replace with terms and types - -Let's set up some definitions to start: - -```unison -x = 1 -y = 2 - -structural type X = One Nat -structural type Y = Two Nat Nat -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - structural type X - structural type Y - x : Nat - y : Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - structural type X - structural type Y - x : Nat - y : Nat - -``` -Test that replace works with terms -```ucm -.> replace x y - - Done. - -.> view x - - x : Nat - x = 2 - -``` -Test that replace works with types -```ucm -.> replace X Y - - Done. - -.> find - - 1. structural type X - 2. x : Nat - 3. X.One : Nat -> Nat -> X - 4. structural type Y - 5. y : Nat - 6. Y.Two : Nat -> Nat -> X - - -.> view.patch patch - - Edited Types: 1. #68k40ra7l7 -> 3. X - - Edited Terms: 2. #gjmq673r1v -> 4. x - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -.> view X - - structural type X = One Nat Nat - -``` -Try with a type/term mismatch -```ucm -.> replace X x - - ⚠️ - - I was expecting either two types or two terms but was given a type X and a term x. - -``` -```ucm -.> replace y Y - - ⚠️ - - I was expecting either two types or two terms but was given a type Y and a term y. - -``` -Try with missing references -```ucm -.> replace X NOPE - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - NOPE - -``` -```ucm -.> replace y nope - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - nope - -``` -```ucm -.> replace nope X - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - nope - -``` -```ucm -.> replace nope y - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - nope - -``` -```ucm -.> replace nope nope - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - nope - nope - -``` diff --git a/unison-src/transcripts/copy-patch.md b/unison-src/transcripts/copy-patch.md deleted file mode 100644 index 64a1379fa..000000000 --- a/unison-src/transcripts/copy-patch.md +++ /dev/null @@ -1,42 +0,0 @@ -# Test that copying a patch works as expected - -```unison:hide -x = 1 -``` - -```ucm -.> add -``` - -Change the definition of `x` so something goes in our patch: - -```unison:hide -x = 2 -``` - -```ucm -.> update.old foo.patch -``` - -Copy the patch and make sure it's still there. - -```ucm -.> copy.patch foo.patch bar.patch -.> ls foo -.> view.patch foo.patch -.> ls bar -.> view.patch bar.patch -``` - -Now move the patch. - -```ucm -.> move.patch foo.patch qux.patch -``` - -The moved patch should be gone. - -```ucm:error -.> view.patch foo.patch -.> ls foo -``` diff --git a/unison-src/transcripts/copy-patch.output.md b/unison-src/transcripts/copy-patch.output.md deleted file mode 100644 index 881d1b075..000000000 --- a/unison-src/transcripts/copy-patch.output.md +++ /dev/null @@ -1,80 +0,0 @@ -# Test that copying a patch works as expected - -```unison -x = 1 -``` - -```ucm -.> add - - ⍟ I've added these definitions: - - x : ##Nat - -``` -Change the definition of `x` so something goes in our patch: - -```unison -x = 2 -``` - -```ucm -.> update.old foo.patch - - ⍟ I've updated these names to your new definition: - - x : ##Nat - -``` -Copy the patch and make sure it's still there. - -```ucm -.> copy.patch foo.patch bar.patch - - Done. - -.> ls foo - - 1. patch (patch) - -.> view.patch foo.patch - - Edited Terms: 1. #gjmq673r1v -> 2. x - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -.> ls bar - - 1. patch (patch) - -.> view.patch bar.patch - - Edited Terms: 1. #gjmq673r1v -> 2. x - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` -Now move the patch. - -```ucm -.> move.patch foo.patch qux.patch - - Done. - -``` -The moved patch should be gone. - -```ucm -.> view.patch foo.patch - - This patch is empty. - -.> ls foo - - nothing to show - -``` diff --git a/unison-src/transcripts/deleteReplacements.md b/unison-src/transcripts/deleteReplacements.md deleted file mode 100644 index 70ad9e6af..000000000 --- a/unison-src/transcripts/deleteReplacements.md +++ /dev/null @@ -1,94 +0,0 @@ -# Deleting term and type replacements from patches - -```unison -x = 1 -``` - -```ucm -.> add -``` - -```unison -x = 2 -``` - -```ucm -.> update.old -.> view.patch -``` - -```ucm -.> delete.term-replacement 1 -.> view.patch -``` - -```unison -unique[a] type Foo = Foo -``` - -```ucm -.> add -``` - -```unison -unique[b] type Foo = Foo | Bar -``` - -```ucm -.> update.old -.> view.patch -``` - -```ucm -.> delete.type-replacement 1 -.> view.patch -``` - -```unison -bar = 3 -unique[aa] type bar = Foo -``` - -```ucm -.> add -``` - -```unison -unique[bb] type bar = Foo | Bar -``` - -```ucm -.> update.old -.> view.patch -.> delete.type-replacement 1 -.> view.patch -``` - -we get an error when attempting to delete something that is neither a type nor a term -```ucm:error -.> view.patch -.> delete.type-replacement notHere -.> view.patch -``` - -When attempting to delete a type/term that doesn't exist, but a term/type exists -with that name, alert the user. -```unison -baz = 0 -``` - -```ucm:error -.> add baz -.> delete.type-replacement baz -.> view.patch -``` - -```unison -unique type qux = Qux -``` - -```ucm:error -.> add qux -.> delete.term-replacement qux -.> view.patch -``` diff --git a/unison-src/transcripts/deleteReplacements.output.md b/unison-src/transcripts/deleteReplacements.output.md deleted file mode 100644 index 9908542f7..000000000 --- a/unison-src/transcripts/deleteReplacements.output.md +++ /dev/null @@ -1,302 +0,0 @@ -# Deleting term and type replacements from patches - -```unison -x = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - x : ##Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - x : ##Nat - -``` -```unison -x = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - x : ##Nat - -``` -```ucm -.> update.old - - ⍟ I've updated these names to your new definition: - - x : ##Nat - -.> view.patch - - Edited Terms: 1. #gjmq673r1v -> 2. x - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` -```ucm -.> delete.term-replacement 1 - - Done. - -.> view.patch - - This patch is empty. - -``` -```unison -unique[a] type Foo = Foo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type Foo - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type Foo - -``` -```unison -unique[b] type Foo = Foo | Bar -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type Foo - -``` -```ucm -.> update.old - - ⍟ I've updated these names to your new definition: - - type Foo - -.> view.patch - - Edited Types: 1. #ool30cf4ma -> 2. Foo - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` -```ucm -.> delete.type-replacement 1 - - Done. - -.> view.patch - - This patch is empty. - -``` -```unison -bar = 3 -unique[aa] type bar = Foo -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type bar - bar : ##Nat - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - type bar - bar : ##Nat - -``` -```unison -unique[bb] type bar = Foo | Bar -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - type bar - -``` -```ucm -.> update.old - - ⍟ I've updated these names to your new definition: - - type bar - -.> view.patch - - Edited Types: 1. #evhqg163jj -> 2. bar - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -.> delete.type-replacement 1 - - Done. - -.> view.patch - - This patch is empty. - -``` -we get an error when attempting to delete something that is neither a type nor a term -```ucm -.> view.patch - - This patch is empty. - -.> delete.type-replacement notHere - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - notHere - -.> view.patch - - This patch is empty. - -``` -When attempting to delete a type/term that doesn't exist, but a term/type exists -with that name, alert the user. -```unison -baz = 0 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - baz : ##Nat - -``` -```ucm -.> add baz - - ⍟ I've added these definitions: - - baz : ##Nat - -.> delete.type-replacement baz - - ⚠️ - - I was expecting the following names to be types, though I found terms instead. - baz - -.> view.patch - - This patch is empty. - -``` -```unison -unique type qux = Qux -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - type qux - -``` -```ucm -.> add qux - - ⍟ I've added these definitions: - - type qux - -.> delete.term-replacement qux - - ⚠️ - - I was expecting the following names to be terms, though I found types instead. - qux - -.> view.patch - - This patch is empty. - -``` diff --git a/unison-src/transcripts/diff-namespace-to-patch.md b/unison-src/transcripts/diff-namespace-to-patch.md deleted file mode 100644 index 7bed7d82b..000000000 --- a/unison-src/transcripts/diff-namespace-to-patch.md +++ /dev/null @@ -1,43 +0,0 @@ -We can create a patch from the diff between two namespaces. - -```ucm:hide -.> builtins.merge -``` - -```unison:hide -one.a = 1 -one.b = 2 -oneconflicts.b = 20 -one.c = 3 -one.d = 4 -one.e = 4 - -two.a = 100 -two.b = 200 -two.c = 300 -twoconflicts.c = 30 -two.d = 5 -two.e = 6 -``` - -```ucm:hide -.> add -.> merge.old oneconflicts one -.> merge.old twoconflicts two -.> delete.namespace oneconflicts -.> delete.namespace twoconflicts -``` - -```ucm -.> find one. -.> find two. -.> diff.namespace.to-patch one two thepatch -``` - -A summary of the diff: - -* `one.a` -> `two.a` is a normal update. -* Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`. -* Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch. -* Because `one.d` and `one.e` are aliases, they don't end up on the left-hand side of the patch. -* Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g` are not common to both namespaces. diff --git a/unison-src/transcripts/diff-namespace-to-patch.output.md b/unison-src/transcripts/diff-namespace-to-patch.output.md index 09798f8ae..d7d326305 100644 --- a/unison-src/transcripts/diff-namespace-to-patch.output.md +++ b/unison-src/transcripts/diff-namespace-to-patch.output.md @@ -24,7 +24,7 @@ two.e = 6 3. one.b#dcg : Nat 4. one.c : Nat 5. one.d : Nat - + .> find two. @@ -34,24 +34,18 @@ two.e = 6 4. two.c#qpo : Nat 5. two.d : Nat 6. two.e : Nat - + .> diff.namespace.to-patch one two thepatch - Edited Terms: - 1. one.b#cp6ri8mtg0 -> 4. two.b - 2. one.b#dcgdua2lj6 -> 5. two.b - 3. one.a -> 6. two.a - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - ``` -A summary of the diff: -* `one.a` -> `two.a` is a normal update. -* Even though `one.b` is conflicted, both `one.b#hash1` and `one.b#hash2` get mapped to `two.b`. -* Because `two.c` is conflicted, `one.c` doesn't end up on the left-hand side of the patch. -* Because `one.d` and `one.e` are aliases, they don't end up on the left-hand side of the patch. -* Neither `one.f` nor `two.g` end up in the patch because the names `f` and `g are not common to both namespaces. + + +🛑 + +The transcript failed due to an error in the stanza above. The error is: + +⚠️ +I don't know how to diff.namespace.to-patch. Type `help` or `?` +to get help. diff --git a/unison-src/transcripts/diff-namespace.output.md b/unison-src/transcripts/diff-namespace.output.md index 929185b23..2a980bf57 100644 --- a/unison-src/transcripts/diff-namespace.output.md +++ b/unison-src/transcripts/diff-namespace.output.md @@ -299,323 +299,16 @@ unique type Y a b = Y a b .> view.patch ns2.patch - Edited Terms: - 1. ns1.b -> 3. ns2.b - 2. ns1.fromJust' -> 4. ns2.fromJust - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -.> fork ns2 ns3 - - Done. - -.> alias.term ns2.fromJust' ns2.yoohoo - - Done. - -.> delete.term.verbose ns2.fromJust' - - Name changes: - - Original Changes - 1. ns2.fromJust ┐ 2. ns2.fromJust' (removed) - 3. ns2.fromJust' │ - 4. ns2.yoohoo │ - 5. ns3.fromJust │ - 6. ns3.fromJust' ┘ - - Tip: You can use `undo` or `reflog` to undo this change. - -.> diff.namespace ns3 ns2 - - Name changes: - - Original Changes - 1. fromJust ┐ 2. yoohoo (added) - 3. fromJust' ┘ 4. fromJust' (removed) - -``` -```unison -bdependent = "banana" ``` ```ucm -.ns3> update.old - - ⍟ I've updated these names to your new definition: - - bdependent : ##Text - -.> diff.namespace ns2 ns3 - - Updates: - - 1. bdependent : Nat - ↓ - 2. bdependent : Text - - 3. patch patch (added 1 updates) - - Name changes: - - Original Changes - 4. fromJust ┐ 5. fromJust' (added) - 6. yoohoo ┘ 7. yoohoo (removed) - -``` -## Two different auto-propagated changes creating a name conflict -Currently, the auto-propagated name-conflicted definitions are not explicitly -shown, only their also-conflicted dependency is shown. -```unison -a = 333 -b = a + 1 +.ns2> update.old.> diff.namespace ns1 ns2.> alias.term ns2.d ns2.d'.> alias.type ns2.A ns2.A'.> alias.type ns2.X ns2.X'.> diff.namespace ns1 ns2.> alias.type ns1.X ns1.X2.> alias.type ns2.A' ns2.A''.> view.patch ns2.patch.> fork ns2 ns3.> alias.term ns2.fromJust' ns2.yoohoo.> delete.term.verbose ns2.fromJust'.> diff.namespace ns3 ns2 ``` -```ucm - ☝️ The namespace .nsx is empty. -.nsx> add +🛑 - ⍟ I've added these definitions: - - a : ##Nat - b : ##Nat +The transcript failed due to an error in the stanza above. The error is: -.> fork nsx nsy - - Done. - -.> fork nsx nsz - - Done. - -``` -```unison -a = 444 -``` - -```ucm -.nsy> update.old - - ⍟ I've updated these names to your new definition: - - a : ##Nat - -``` -```unison -a = 555 -``` - -```ucm -.nsz> update.old - - ⍟ I've updated these names to your new definition: - - a : ##Nat - -.> merge.old nsy nsw - - Here's what's changed in nsw after the merge: - - Added definitions: - - 1. a : Nat - 2. b : Nat - - 3. patch patch (added 1 updates) - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` -```ucm -.> merge.old nsz nsw - - Here's what's changed in nsw after the merge: - - New name conflicts: - - 1. a#mdl4vqtu00 : Nat - ↓ - 2. ┌ a#mdl4vqtu00 : Nat - 3. └ a#vrs8gtkl2t : Nat - - 4. b#unkqhuu66p : Nat - ↓ - 5. ┌ b#aapqletas7 : Nat - 6. └ b#unkqhuu66p : Nat - - Updates: - - 7. patch patch (added 1 updates) - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - - I tried to auto-apply the patch, but couldn't because it - contained contradictory entries. - -``` -```ucm -.> diff.namespace nsx nsw - - New name conflicts: - - 1. a#uiiiv8a86s : Nat - ↓ - 2. ┌ a#mdl4vqtu00 : Nat - 3. └ a#vrs8gtkl2t : Nat - - 4. b#lhigeb1let : Nat - ↓ - 5. ┌ b#aapqletas7 : Nat - 6. └ b#unkqhuu66p : Nat - - Added definitions: - - 7. patch patch (added 2 updates) - -.nsw> view a b - - a#mdl4vqtu00 : ##Nat - a#mdl4vqtu00 = 444 - - a#vrs8gtkl2t : ##Nat - a#vrs8gtkl2t = 555 - - b#aapqletas7 : ##Nat - b#aapqletas7 = ##Nat.+ a#vrs8gtkl2t 1 - - b#unkqhuu66p : ##Nat - b#unkqhuu66p = ##Nat.+ a#mdl4vqtu00 1 - -``` -## Should be able to diff a namespace hash from history. - -```unison -x = 1 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - x : ##Nat - -``` -```ucm - ☝️ The namespace .hashdiff is empty. - -.hashdiff> add - - ⍟ I've added these definitions: - - x : ##Nat - -``` -```unison -y = 2 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - y : ##Nat - -``` -```ucm -.hashdiff> add - - ⍟ I've added these definitions: - - y : ##Nat - -.hashdiff> history - - Note: The most recent namespace hash is immediately below this - message. - - ⊙ 1. #ru1hnjofdj - - + Adds / updates: - - y - - □ 2. #i52j9fd57b (start of history) - -.hashdiff> diff.namespace 2 1 - - Added definitions: - - 1. y : ##Nat - -``` -## - -Updates: -- 1 to 1 - -New name conflicts: -- updates where RHS has multiple hashes (excluding when RHS=LHS) - - 1. foo#jk19sm5bf8 : Nat - do we want to force a hashqualified? Arya thinks so - ↓ - 2. ┌ foo#0ja1qfpej6 : Nat - 3. └ foo#jk19sm5bf8 : Nat - -Resolved name conflicts: -- updates where LHS had multiple hashes and RHS has one - - 4. ┌ bar#0ja1qfpej6 : Nat - 5. └ bar#jk19sm5bf8 : Nat - ↓ - 6. bar#jk19sm5bf8 : Nat - -## Display issues to fixup - -- [d] Do we want to surface new edit conflicts in patches? -- [t] two different auto-propagated changes creating a name conflict should show - up somewhere besides the auto-propagate count -- [t] Things look screwy when the type signature doesn't fit and has to get broken - up into multiple lines. Maybe just disallow that? -- [d] Delete blank line in between copies / renames entries if all entries are 1 to 1 - see todo in the code -- [x] incorrectly calculated bracket alignment on hashqualified "Name changes" (delete.output.md) -- [x] just handle deletion of isPropagated in propagate function, leave HandleInput alone (assuming this does the trick) -- [x] might want unqualified names to be qualified sometimes: -- [x] if a name is updated to a not-yet-named reference, it's shown as both an update and an add -- [x] similarly, if a conflicted name is resolved by deleting the last name to - a reference, I (arya) suspect it will show up as a Remove -- [d] Maybe group and/or add headings to the types, constructors, terms -- [x] add tagging of propagated updates to test propagated updates output -- [x] missing old names in deletion ppe (delete.output.md) (superseded by \#1143) -- [x] delete.term has some bonkers output -- [x] Make a decision about how we want to show constructors in the diff -- [x] 12.patch patch needs a space -- [x] This looks like garbage -- [x] Extra 2 blank lines at the end of the add section -- [x] Fix alignment issues with buildTable, convert to column3M (to be written) -- [x] adding an alias is showing up as an Add and a Copy; should just show as Copy -- [x] removing one of multiple aliases appears in removes + moves + copies section -- [x] some overlapping cases between Moves and Copies^ -- [x] Maybe don't list the type signature twice for aliases? +⚠️ +I don't know how to view.patch. Type `help` or `?` to get help. diff --git a/unison-src/transcripts/find-patch.md b/unison-src/transcripts/find-patch.md deleted file mode 100644 index a43106cc3..000000000 --- a/unison-src/transcripts/find-patch.md +++ /dev/null @@ -1,27 +0,0 @@ -# find.patch Test - -```ucm:hide -.> builtins.merge -``` - -```unison test.u -hey = "yello" -``` - -```ucm -.> add -``` - -Update - -```unison test.u -hey = "hello" -``` - -Update - -```ucm -.> update.old -.> find.patch -.> view.patch 1 -``` diff --git a/unison-src/transcripts/find-patch.output.md b/unison-src/transcripts/find-patch.output.md deleted file mode 100644 index d08e9f3a9..000000000 --- a/unison-src/transcripts/find-patch.output.md +++ /dev/null @@ -1,77 +0,0 @@ -# find.patch Test - -```unison ---- -title: test.u ---- -hey = "yello" - -``` - - -```ucm - - Loading changes detected in test.u. - - I found and typechecked these definitions in test.u. If you do - an `add` or `update`, here's how your codebase would change: - - ⍟ These new definitions are ok to `add`: - - hey : Text - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - hey : Text - -``` -Update - -```unison ---- -title: test.u ---- -hey = "hello" - -``` - - -```ucm - - Loading changes detected in test.u. - - I found and typechecked these definitions in test.u. If you do - an `add` or `update`, here's how your codebase would change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - hey : Text - -``` -Update - -```ucm -.> update.old - - ⍟ I've updated these names to your new definition: - - hey : Text - -.> find.patch - - 1. patch - -.> view.patch 1 - - Edited Terms: 1. #m0kuh98ou7 -> 2. hey - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` diff --git a/unison-src/transcripts/fix1334.md b/unison-src/transcripts/fix1334.md index 6de756684..68e696748 100644 --- a/unison-src/transcripts/fix1334.md +++ b/unison-src/transcripts/fix1334.md @@ -1,8 +1,6 @@ Previously, the `alias.term` and `alias.type` would fail if the source argument was hash-only, and there was no way to create an alias for a definition that didn't already have a name. Also, the `replace.term` and `replace.type` _only_ worked on hashes, and they had to be _full_ hashes. -With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual, and the arguments to `replace.term` and `replace.type` can be a short hash, a name, or a hash-qualified name. - -Note: `replace.term` and `replace.type` have since been replaced with just `replace`. +With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual. Let's make some hash-only aliases, now that we can. :mad-with-power-emoji: @@ -10,29 +8,3 @@ Let's make some hash-only aliases, now that we can. :mad-with-power-emoji: .> alias.type ##Nat Cat .> alias.term ##Nat.+ please_fix_763.+ ``` - -And some functions that use them: -```unison -f = 3 -g = 4 -h = f + 1 - -> h -``` - -```ucm -.> add -``` - -We used to have to know the full hash for a definition to be able to use the `replace` commands, but now we don't: -```ucm -.> names g -.> replace f g -.> names g -.> view.patch -``` - -The value of `h` should have been updated too: -```unison -> h -``` diff --git a/unison-src/transcripts/fix1334.output.md b/unison-src/transcripts/fix1334.output.md index 7bb95c96d..d397a51a1 100644 --- a/unison-src/transcripts/fix1334.output.md +++ b/unison-src/transcripts/fix1334.output.md @@ -1,8 +1,6 @@ Previously, the `alias.term` and `alias.type` would fail if the source argument was hash-only, and there was no way to create an alias for a definition that didn't already have a name. Also, the `replace.term` and `replace.type` _only_ worked on hashes, and they had to be _full_ hashes. -With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual, and the arguments to `replace.term` and `replace.type` can be a short hash, a name, or a hash-qualified name. - -Note: `replace.term` and `replace.type` have since been replaced with just `replace`. +With this PR, the source of an alias can be a short hash (even of a definition that doesn't currently have a name in the namespace) along with a name or hash-qualified name from the current namespace as usual. Let's make some hash-only aliases, now that we can. :mad-with-power-emoji: @@ -16,96 +14,3 @@ Let's make some hash-only aliases, now that we can. :mad-with-power-emoji: Done. ``` -And some functions that use them: -```unison -f = 3 -g = 4 -h = f + 1 - -> h -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - f : Cat - g : Cat - h : Cat - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 5 | > h - ⧩ - 4 - -``` -```ucm -.> add - - ⍟ I've added these definitions: - - f : Cat - g : Cat - h : Cat - -``` -We used to have to know the full hash for a definition to be able to use the `replace` commands, but now we don't: -```ucm -.> names g - - Term - Hash: #vcfbbslncd - Names: g - - Tip: Use `names.global` to see more results. - -.> replace f g - - Done. - -.> names g - - Term - Hash: #vcfbbslncd - Names: f g - - Tip: Use `names.global` to see more results. - -.> view.patch - - Edited Terms: 1. #f3lgjvjqoo -> 2. f - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` -The value of `h` should have been updated too: -```unison -> h -``` - -```ucm - - Loading changes detected in scratch.u. - - ✅ - - scratch.u changed. - - Now evaluating any watch expressions (lines starting with - `>`)... Ctrl+C cancels. - - 1 | > h - ⧩ - 5 - -``` diff --git a/unison-src/transcripts/resolve.md b/unison-src/transcripts/resolve.md deleted file mode 100644 index 7b359a4f5..000000000 --- a/unison-src/transcripts/resolve.md +++ /dev/null @@ -1,116 +0,0 @@ -# Resolving edit conflicts in `ucm` - -```ucm:hide -.> builtins.merge -``` - -The `ucm` tool tracks edits to hashes in an object called a _patch_. When patches get merged, sometimes those patches will have conflicting edits. The `replace` command helps resolve such conflicts. - -First, let's make a new namespace, `example.resolve` and add the builtins: - -```ucm:hide -.example.resolve> builtins.merge -``` - -Now let's add a term named `a.foo`: - -```unison -a.foo = 42 -``` - -```ucm -.example.resolve> add -``` - -We'll fork the namespace `a` into a new namespace `b`, so we can edit the two concurrently. - -```ucm -.example.resolve> fork a b -``` - -We'll also make a second fork `c` which we'll use as the target for our patch later. - -```ucm -.example.resolve> fork a c -``` - -Now let's make a change to `foo` in the `a` namespace: - -```ucm -.example.resolve> deprecated.cd a -``` - -```unison -foo = 43 -``` - -```ucm -.example.resolve.a> update.old -``` - -And make a different change in the `b` namespace: - -```ucm -.example.resolve> deprecated.cd .example.resolve.b -``` - -```unison -foo = 44 -``` - -```ucm -.example.resolve.b> update.old -``` - -The `a` and `b` namespaces now each contain a patch named `patch`. We can view these: - -```ucm -.example.resolve.b> deprecated.cd .example.resolve -.example.resolve> view.patch a.patch -.example.resolve> view.patch b.patch -``` - -Let's now merge these namespaces into `c`: - -```ucm -.example.resolve> merge.old a c -``` -```ucm:error -.example.resolve> merge.old b c -``` - -The namespace `c` now has an edit conflict, since the term `foo` was edited in two different ways. - -```ucm:error -.example.resolve> deprecated.cd c -.example.resolve.c> todo -``` - -We see that the original hash of `a.foo` got replaced with _two different_ hashes. - -We can resolve this conflict by picking one of the terms as the "winner": - -```ucm -.example.resolve.c> replace 1 2 -``` - -This changes the merged `c.patch` so that only a single edit remains and resolves the conflict. - -```ucm -.example.resolve.c> view.patch -``` - -We still have a remaining _name conflict_ since it just so happened that both of the definitions in the edits were named `foo`. - -```ucm:error -.example.resolve.c> todo -``` - -We can resolve the name conflict by deleting one of the names. - -```ucm -.example.resolve.c> delete.term.verbose 2 -.example.resolve.c> todo -``` - -And that's how you resolve edit conflicts with UCM. diff --git a/unison-src/transcripts/resolve.output.md b/unison-src/transcripts/resolve.output.md deleted file mode 100644 index d4d9d4fe5..000000000 --- a/unison-src/transcripts/resolve.output.md +++ /dev/null @@ -1,265 +0,0 @@ -# Resolving edit conflicts in `ucm` - -The `ucm` tool tracks edits to hashes in an object called a _patch_. When patches get merged, sometimes those patches will have conflicting edits. The `replace` command helps resolve such conflicts. - -First, let's make a new namespace, `example.resolve` and add the builtins: - -Now let's add a term named `a.foo`: - -```unison -a.foo = 42 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These new definitions are ok to `add`: - - a.foo : Nat - -``` -```ucm -.example.resolve> add - - ⍟ I've added these definitions: - - a.foo : Nat - -``` -We'll fork the namespace `a` into a new namespace `b`, so we can edit the two concurrently. - -```ucm -.example.resolve> fork a b - - Done. - -``` -We'll also make a second fork `c` which we'll use as the target for our patch later. - -```ucm -.example.resolve> fork a c - - Done. - -``` -Now let's make a change to `foo` in the `a` namespace: - -```ucm -.example.resolve> deprecated.cd a - -``` -```unison -foo = 43 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : ##Nat - -``` -```ucm -.example.resolve.a> update.old - - ⍟ I've updated these names to your new definition: - - foo : ##Nat - -``` -And make a different change in the `b` namespace: - -```ucm -.example.resolve> deprecated.cd .example.resolve.b - -``` -```unison -foo = 44 -``` - -```ucm - - Loading changes detected in scratch.u. - - I found and typechecked these definitions in scratch.u. If you - do an `add` or `update`, here's how your codebase would - change: - - ⍟ These names already exist. You can `update` them to your - new definition: - - foo : ##Nat - -``` -```ucm -.example.resolve.b> update.old - - ⍟ I've updated these names to your new definition: - - foo : ##Nat - -``` -The `a` and `b` namespaces now each contain a patch named `patch`. We can view these: - -```ucm -.example.resolve.b> deprecated.cd .example.resolve - -.example.resolve> view.patch a.patch - - Edited Terms: 1. c.foo -> 2. a.foo - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -.example.resolve> view.patch b.patch - - Edited Terms: 1. c.foo -> 2. b.foo - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` -Let's now merge these namespaces into `c`: - -```ucm -.example.resolve> merge.old a c - - Here's what's changed in c after the merge: - - Updates: - - 1. foo : Nat - ↓ - 2. foo : Nat - - Added definitions: - - 3. patch patch (added 1 updates) - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - -``` -```ucm -.example.resolve> merge.old b c - - Here's what's changed in c after the merge: - - New name conflicts: - - 1. foo#emomp74i93 : Nat - ↓ - 2. ┌ foo#a84tg4er4k : Nat - 3. └ foo#emomp74i93 : Nat - - Updates: - - 4. patch patch (added 1 updates) - - Tip: You can use `todo` to see if this generated any work to - do in this namespace and `test` to run the tests. Or you - can use `undo` or `reflog` to undo the results of this - merge. - - Applying changes from patch... - - I tried to auto-apply the patch, but couldn't because it - contained contradictory entries. - -``` -The namespace `c` now has an edit conflict, since the term `foo` was edited in two different ways. - -```ucm -.example.resolve> deprecated.cd c - -.example.resolve.c> todo - - ❓ - - These definitions were edited differently in namespaces that - have been merged into this one. You'll have to tell me what to - use as the new definition: - - The term 1. #qkhkl0n238 was replaced with - 2. foo#a84tg4er4k - 3. foo#emomp74i93 - -``` -We see that the original hash of `a.foo` got replaced with _two different_ hashes. - -We can resolve this conflict by picking one of the terms as the "winner": - -```ucm -.example.resolve.c> replace 1 2 - - Done. - -``` -This changes the merged `c.patch` so that only a single edit remains and resolves the conflict. - -```ucm -.example.resolve.c> view.patch - - Edited Terms: 1. #qkhkl0n238 -> 2. foo#a84tg4er4k - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - -``` -We still have a remaining _name conflict_ since it just so happened that both of the definitions in the edits were named `foo`. - -```ucm -.example.resolve.c> todo - - ❓ - - The term foo has conflicting definitions: - 1. foo#a84tg4er4k - 2. foo#emomp74i93 - - Tip: This occurs when merging branches that both independently - introduce the same name. Use `move.term` or `delete.term` - to resolve the conflicts. - -``` -We can resolve the name conflict by deleting one of the names. - -```ucm -.example.resolve.c> delete.term.verbose 2 - - Resolved name conflicts: - - 1. ┌ foo#a84tg4er4k : ##Nat - 2. └ foo#emomp74i93 : ##Nat - ↓ - 3. foo#a84tg4er4k : ##Nat - - Tip: You can use `undo` or `reflog` to undo this change. - -.example.resolve.c> todo - - ✅ - - No conflicts or edits in progress. - -``` -And that's how you resolve edit conflicts with UCM. diff --git a/unison-src/transcripts/tab-completion.output.md b/unison-src/transcripts/tab-completion.output.md index 49ac0684f..34ce96db9 100644 --- a/unison-src/transcripts/tab-completion.output.md +++ b/unison-src/transcripts/tab-completion.output.md @@ -9,20 +9,16 @@ Test that tab completion works as expected. view view.global - view.patch .> debug.tab-complete delete. delete.branch delete.namespace delete.namespace.force - delete.patch delete.project delete.term - delete.term-replacement delete.term.verbose delete.type - delete.type-replacement delete.type.verbose delete.verbose diff --git a/unison-src/transcripts/todo.md b/unison-src/transcripts/todo.md index b1d214af5..39fece2f6 100644 --- a/unison-src/transcripts/todo.md +++ b/unison-src/transcripts/todo.md @@ -103,7 +103,6 @@ oldfoo = 801 ```ucm .lhs> add -.lhs> view.patch patch .lhs> todo ``` diff --git a/unison-src/transcripts/todo.output.md b/unison-src/transcripts/todo.output.md index 8290884f5..b0a9d69c6 100644 --- a/unison-src/transcripts/todo.output.md +++ b/unison-src/transcripts/todo.output.md @@ -205,14 +205,6 @@ oldfoo = 801 oldfoo : Nat -.lhs> view.patch patch - - Edited Terms: 1. oldfoo -> 2. foo - - Tip: To remove entries from a patch, use - delete.term-replacement or delete.type-replacement, as - appropriate. - .lhs> todo ✅ diff --git a/unison-src/transcripts/update-on-conflict.md b/unison-src/transcripts/update-on-conflict.md index e9dfa574e..21b9a656c 100644 --- a/unison-src/transcripts/update-on-conflict.md +++ b/unison-src/transcripts/update-on-conflict.md @@ -17,7 +17,7 @@ Cause a conflict: .merged> merge.old .b ``` -Updating conflicted definitions works fine, and the associated patch contains two entries. +Updating conflicted definitions works fine. ```unison x = 3 @@ -25,5 +25,4 @@ x = 3 ```ucm .merged> update -.merged> view.patch ``` diff --git a/unison-src/transcripts/update-on-conflict.output.md b/unison-src/transcripts/update-on-conflict.output.md index f2888e1fc..6a9afd2e9 100644 --- a/unison-src/transcripts/update-on-conflict.output.md +++ b/unison-src/transcripts/update-on-conflict.output.md @@ -64,7 +64,7 @@ Cause a conflict: Applying changes from patch... ``` -Updating conflicted definitions works fine, and the associated patch contains two entries. +Updating conflicted definitions works fine. ```unison x = 3 @@ -92,8 +92,4 @@ x = 3 Done. -.merged> view.patch - - This patch is empty. - ``` From 1442dc02acdfeee9a00be99104875edb9830ca98 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 24 May 2024 11:08:44 -0400 Subject: [PATCH 61/82] fix up a couple transcripts --- .../diff-namespace-to-patch.output.md | 51 --- unison-src/transcripts/diff-namespace.md | 1 - .../transcripts/diff-namespace.output.md | 309 +++++++++++++++++- 3 files changed, 303 insertions(+), 58 deletions(-) delete mode 100644 unison-src/transcripts/diff-namespace-to-patch.output.md diff --git a/unison-src/transcripts/diff-namespace-to-patch.output.md b/unison-src/transcripts/diff-namespace-to-patch.output.md deleted file mode 100644 index d7d326305..000000000 --- a/unison-src/transcripts/diff-namespace-to-patch.output.md +++ /dev/null @@ -1,51 +0,0 @@ -We can create a patch from the diff between two namespaces. - -```unison -one.a = 1 -one.b = 2 -oneconflicts.b = 20 -one.c = 3 -one.d = 4 -one.e = 4 - -two.a = 100 -two.b = 200 -two.c = 300 -twoconflicts.c = 30 -two.d = 5 -two.e = 6 -``` - -```ucm -.> find one. - - 1. one.a : Nat - 2. one.b#cp6 : Nat - 3. one.b#dcg : Nat - 4. one.c : Nat - 5. one.d : Nat - - -.> find two. - - 1. two.a : Nat - 2. two.b : Nat - 3. two.c#k86 : Nat - 4. two.c#qpo : Nat - 5. two.d : Nat - 6. two.e : Nat - - -.> diff.namespace.to-patch one two thepatch - -``` - - - -🛑 - -The transcript failed due to an error in the stanza above. The error is: - -⚠️ -I don't know how to diff.namespace.to-patch. Type `help` or `?` -to get help. diff --git a/unison-src/transcripts/diff-namespace.md b/unison-src/transcripts/diff-namespace.md index bbbf34046..5e938a79a 100644 --- a/unison-src/transcripts/diff-namespace.md +++ b/unison-src/transcripts/diff-namespace.md @@ -87,7 +87,6 @@ unique type Y a b = Y a b .> diff.namespace ns1 ns2 .> alias.type ns1.X ns1.X2 .> alias.type ns2.A' ns2.A'' -.> view.patch ns2.patch .> fork ns2 ns3 .> alias.term ns2.fromJust' ns2.yoohoo .> delete.term.verbose ns2.fromJust' diff --git a/unison-src/transcripts/diff-namespace.output.md b/unison-src/transcripts/diff-namespace.output.md index 2a980bf57..cacb9d1fc 100644 --- a/unison-src/transcripts/diff-namespace.output.md +++ b/unison-src/transcripts/diff-namespace.output.md @@ -297,18 +297,315 @@ unique type Y a b = Y a b Done. -.> view.patch ns2.patch +.> fork ns2 ns3 + Done. + +.> alias.term ns2.fromJust' ns2.yoohoo + + Done. + +.> delete.term.verbose ns2.fromJust' + + Name changes: + + Original Changes + 1. ns2.fromJust ┐ 2. ns2.fromJust' (removed) + 3. ns2.fromJust' │ + 4. ns2.yoohoo │ + 5. ns3.fromJust │ + 6. ns3.fromJust' ┘ + + Tip: You can use `undo` or `reflog` to undo this change. + +.> diff.namespace ns3 ns2 + + Name changes: + + Original Changes + 1. fromJust ┐ 2. yoohoo (added) + 3. fromJust' ┘ 4. fromJust' (removed) + +``` +```unison +bdependent = "banana" ``` ```ucm -.ns2> update.old.> diff.namespace ns1 ns2.> alias.term ns2.d ns2.d'.> alias.type ns2.A ns2.A'.> alias.type ns2.X ns2.X'.> diff.namespace ns1 ns2.> alias.type ns1.X ns1.X2.> alias.type ns2.A' ns2.A''.> view.patch ns2.patch.> fork ns2 ns3.> alias.term ns2.fromJust' ns2.yoohoo.> delete.term.verbose ns2.fromJust'.> diff.namespace ns3 ns2 +.ns3> update.old + + ⍟ I've updated these names to your new definition: + + bdependent : ##Text + +.> diff.namespace ns2 ns3 + + Updates: + + 1. bdependent : Nat + ↓ + 2. bdependent : Text + + 3. patch patch (added 1 updates) + + Name changes: + + Original Changes + 4. fromJust ┐ 5. fromJust' (added) + 6. yoohoo ┘ 7. yoohoo (removed) + +``` +## Two different auto-propagated changes creating a name conflict +Currently, the auto-propagated name-conflicted definitions are not explicitly +shown, only their also-conflicted dependency is shown. +```unison +a = 333 +b = a + 1 ``` +```ucm + ☝️ The namespace .nsx is empty. -🛑 +.nsx> add -The transcript failed due to an error in the stanza above. The error is: + ⍟ I've added these definitions: + + a : ##Nat + b : ##Nat -⚠️ -I don't know how to view.patch. Type `help` or `?` to get help. +.> fork nsx nsy + + Done. + +.> fork nsx nsz + + Done. + +``` +```unison +a = 444 +``` + +```ucm +.nsy> update.old + + ⍟ I've updated these names to your new definition: + + a : ##Nat + +``` +```unison +a = 555 +``` + +```ucm +.nsz> update.old + + ⍟ I've updated these names to your new definition: + + a : ##Nat + +.> merge.old nsy nsw + + Here's what's changed in nsw after the merge: + + Added definitions: + + 1. a : Nat + 2. b : Nat + + 3. patch patch (added 1 updates) + + Tip: You can use `todo` to see if this generated any work to + do in this namespace and `test` to run the tests. Or you + can use `undo` or `reflog` to undo the results of this + merge. + + Applying changes from patch... + +``` +```ucm +.> merge.old nsz nsw + + Here's what's changed in nsw after the merge: + + New name conflicts: + + 1. a#mdl4vqtu00 : Nat + ↓ + 2. ┌ a#mdl4vqtu00 : Nat + 3. └ a#vrs8gtkl2t : Nat + + 4. b#unkqhuu66p : Nat + ↓ + 5. ┌ b#aapqletas7 : Nat + 6. └ b#unkqhuu66p : Nat + + Updates: + + 7. patch patch (added 1 updates) + + Tip: You can use `todo` to see if this generated any work to + do in this namespace and `test` to run the tests. Or you + can use `undo` or `reflog` to undo the results of this + merge. + + Applying changes from patch... + + I tried to auto-apply the patch, but couldn't because it + contained contradictory entries. + +``` +```ucm +.> diff.namespace nsx nsw + + New name conflicts: + + 1. a#uiiiv8a86s : Nat + ↓ + 2. ┌ a#mdl4vqtu00 : Nat + 3. └ a#vrs8gtkl2t : Nat + + 4. b#lhigeb1let : Nat + ↓ + 5. ┌ b#aapqletas7 : Nat + 6. └ b#unkqhuu66p : Nat + + Added definitions: + + 7. patch patch (added 2 updates) + +.nsw> view a b + + a#mdl4vqtu00 : ##Nat + a#mdl4vqtu00 = 444 + + a#vrs8gtkl2t : ##Nat + a#vrs8gtkl2t = 555 + + b#aapqletas7 : ##Nat + b#aapqletas7 = ##Nat.+ a#vrs8gtkl2t 1 + + b#unkqhuu66p : ##Nat + b#unkqhuu66p = ##Nat.+ a#mdl4vqtu00 1 + +``` +## Should be able to diff a namespace hash from history. + +```unison +x = 1 +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + x : ##Nat + +``` +```ucm + ☝️ The namespace .hashdiff is empty. + +.hashdiff> add + + ⍟ I've added these definitions: + + x : ##Nat + +``` +```unison +y = 2 +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + y : ##Nat + +``` +```ucm +.hashdiff> add + + ⍟ I've added these definitions: + + y : ##Nat + +.hashdiff> history + + Note: The most recent namespace hash is immediately below this + message. + + ⊙ 1. #ru1hnjofdj + + + Adds / updates: + + y + + □ 2. #i52j9fd57b (start of history) + +.hashdiff> diff.namespace 2 1 + + Added definitions: + + 1. y : ##Nat + +``` +## + +Updates: -- 1 to 1 + +New name conflicts: -- updates where RHS has multiple hashes (excluding when RHS=LHS) + + 1. foo#jk19sm5bf8 : Nat - do we want to force a hashqualified? Arya thinks so + ↓ + 2. ┌ foo#0ja1qfpej6 : Nat + 3. └ foo#jk19sm5bf8 : Nat + +Resolved name conflicts: -- updates where LHS had multiple hashes and RHS has one + + 4. ┌ bar#0ja1qfpej6 : Nat + 5. └ bar#jk19sm5bf8 : Nat + ↓ + 6. bar#jk19sm5bf8 : Nat + +## Display issues to fixup + +- [d] Do we want to surface new edit conflicts in patches? +- [t] two different auto-propagated changes creating a name conflict should show + up somewhere besides the auto-propagate count +- [t] Things look screwy when the type signature doesn't fit and has to get broken + up into multiple lines. Maybe just disallow that? +- [d] Delete blank line in between copies / renames entries if all entries are 1 to 1 + see todo in the code +- [x] incorrectly calculated bracket alignment on hashqualified "Name changes" (delete.output.md) +- [x] just handle deletion of isPropagated in propagate function, leave HandleInput alone (assuming this does the trick) +- [x] might want unqualified names to be qualified sometimes: +- [x] if a name is updated to a not-yet-named reference, it's shown as both an update and an add +- [x] similarly, if a conflicted name is resolved by deleting the last name to + a reference, I (arya) suspect it will show up as a Remove +- [d] Maybe group and/or add headings to the types, constructors, terms +- [x] add tagging of propagated updates to test propagated updates output +- [x] missing old names in deletion ppe (delete.output.md) (superseded by \#1143) +- [x] delete.term has some bonkers output +- [x] Make a decision about how we want to show constructors in the diff +- [x] 12.patch patch needs a space +- [x] This looks like garbage +- [x] Extra 2 blank lines at the end of the add section +- [x] Fix alignment issues with buildTable, convert to column3M (to be written) +- [x] adding an alias is showing up as an Add and a Copy; should just show as Copy +- [x] removing one of multiple aliases appears in removes + moves + copies section +- [x] some overlapping cases between Moves and Copies^ +- [x] Maybe don't list the type signature twice for aliases? From babd9b0c69404a8712ca6a54ec7fc520f1efa858 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Wed, 8 May 2024 12:52:56 -0600 Subject: [PATCH 62/82] Repair the Nix flake MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This does the minimum to get `nix flake check` working.; The primary issue is that flakes require flat package sets, and this flake produced nested ones. This flattens the package sets without renaming anything. E.g., `packages.${system}.docker.ucm` is now `packages.${system}.ucm`, and similar for other derivations. The only other change was to correct the attribute name for the UCM docker image’s command. --- flake.nix | 54 +++++++++++++++++++++++++++----------------------- nix/docker.nix | 2 +- 2 files changed, 30 insertions(+), 26 deletions(-) diff --git a/flake.nix b/flake.nix index a9628dc4a..46e3ea3d6 100644 --- a/flake.nix +++ b/flake.nix @@ -94,36 +94,40 @@ assert nixpkgs-packages.unwrapped-stack.version == versions.stack; assert nixpkgs-packages.hpack.version == versions.hpack; { - packages = nixpkgs-packages // { - default = haskell-nix-flake.defaultPackage; - haskell-nix = haskell-nix-flake.packages; - docker = import ./nix/docker.nix { inherit pkgs; haskell-nix = haskell-nix-flake.packages; }; - build-tools = pkgs.symlinkJoin { - name = "build-tools"; - paths = self.devShells."${system}".only-tools-nixpkgs.buildInputs; + packages = + nixpkgs-packages + // haskell-nix-flake.packages + // import ./nix/docker.nix { inherit pkgs; haskell-nix = haskell-nix-flake.packages; } + // { + default = haskell-nix-flake.defaultPackage; + build-tools = pkgs.symlinkJoin { + name = "build-tools"; + paths = self.devShells."${system}".only-tools-nixpkgs.buildInputs; + }; + all = pkgs.symlinkJoin { + name = "all"; + paths = + let + all-other-packages = builtins.attrValues (builtins.removeAttrs self.packages."${system}" [ "all" "build-tools" ]); + devshell-inputs = builtins.concatMap + (devShell: devShell.buildInputs ++ devShell.nativeBuildInputs) + [ + self.devShells."${system}".only-tools-nixpkgs + ]; + in + all-other-packages ++ devshell-inputs; + }; }; - all = pkgs.symlinkJoin { - name = "all"; - paths = - let - all-other-packages = builtins.attrValues (builtins.removeAttrs self.packages."${system}" [ "all" "build-tools" ]); - devshell-inputs = builtins.concatMap - (devShell: devShell.buildInputs ++ devShell.nativeBuildInputs) - [ - self.devShells."${system}".only-tools-nixpkgs - ]; - in - all-other-packages ++ devshell-inputs; - }; - }; apps = haskell-nix-flake.apps // { default = self.apps."${system}"."unison-cli-main:exe:unison"; }; - devShells = nixpkgs-devShells // { - default = self.devShells."${system}".only-tools-nixpkgs; - haskell-nix = haskell-nix-flake.devShells; - }; + devShells = + nixpkgs-devShells + // haskell-nix-flake.devShells + // { + default = self.devShells."${system}".only-tools-nixpkgs; + }; }); } diff --git a/nix/docker.nix b/nix/docker.nix index 4017a792d..bfd4751e4 100644 --- a/nix/docker.nix +++ b/nix/docker.nix @@ -5,6 +5,6 @@ name = "ucm"; tag = "latest"; contents = with pkgs; [ cacert fzf ]; - config.Cmd = [ "${haskell-nix."unison-cli:exe:unison"}/bin/unison" ]; + config.Cmd = [ "${haskell-nix."unison-cli-main:exe:unison"}/bin/unison" ]; }; } From 257337e9151bee1de3b4fce11adeac27875081cd Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Tue, 14 May 2024 00:11:40 -0600 Subject: [PATCH 63/82] Prefix the flattened flake outputs MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This adds some grouping to the outputs, since they can’t be grouped in attribute sets. It also updates the relevant docs with the new names. Here are the renamings: - `packages.haskell-nix.some:cabal:thing`→ `packages.component-some:cabal:thing` - `packages.docker.ucm` → `packages.docker-ucm` - `apps.haskell-nix.some:cabal:thing` → `apps.component-some:cabal:thing`, and - `devShells.haskell-nix.unison-cli` → `devShells.cabal-unison-cli`. --- development.markdown | 16 ++++++++-------- flake.nix | 14 +++++++++----- 2 files changed, 17 insertions(+), 13 deletions(-) diff --git a/development.markdown b/development.markdown index 22e9657c7..962a507c6 100644 --- a/development.markdown +++ b/development.markdown @@ -126,9 +126,9 @@ This is specified with the normal Some examples: ``` -nix build '.#haskell-nix.unison-cli:lib:unison-cli' -nix build '.#haskell-nix.unison-syntax:test:syntax-tests' -nix build '.#haskell-nix.unison-cli:exe:transcripts' +nix build '.#component-unison-cli:lib:unison-cli' +nix build '.#component-unison-syntax:test:syntax-tests' +nix build '.#component-unison-cli:exe:transcripts' ``` ### Development environments @@ -154,7 +154,7 @@ all non-local haskell dependencies (including profiling dependencies) are provided in the nix shell. ``` -nix develop '.#haskell-nix.local' +nix develop '.#cabal-local' ``` #### Get into a development environment for building a specific package @@ -164,17 +164,17 @@ all haskell dependencies of this package are provided by the nix shell (including profiling dependencies). ``` -nix develop '.#haskell-nix.' +nix develop '.#cabal-' ``` for example: ``` -nix develop '.#haskell-nix.unison-cli' +nix develop '.#cabal-unison-cli' ``` or ``` -nix develop '.#haskell-nix.unison-parser-typechecker' +nix develop '.#cabal-unison-parser-typechecker' ``` This is useful if you wanted to profile a package. For example, if you @@ -183,7 +183,7 @@ shells, cd into its directory, then run the program with profiling. ``` -nix develop '.#unison-parser-typechecker' +nix develop '.#cabal-unison-parser-typechecker' cd unison-cli cabal run --enable-profiling unison-cli-main:exe:unison -- +RTS -p ``` diff --git a/flake.nix b/flake.nix index 46e3ea3d6..740109dd1 100644 --- a/flake.nix +++ b/flake.nix @@ -88,6 +88,10 @@ ''; }; }; + + renameAttrs = fn: nixpkgs.lib.mapAttrs' (name: value: { + inherit value; + name = fn name;}); in assert nixpkgs-packages.ormolu.version == versions.ormolu; assert nixpkgs-packages.hls.version == versions.hls; @@ -96,8 +100,8 @@ { packages = nixpkgs-packages - // haskell-nix-flake.packages - // import ./nix/docker.nix { inherit pkgs; haskell-nix = haskell-nix-flake.packages; } + // renameAttrs (name: "component-${name}") haskell-nix-flake.packages + // renameAttrs (name: "docker-${name}") (import ./nix/docker.nix { inherit pkgs; haskell-nix = haskell-nix-flake.packages; }) // { default = haskell-nix-flake.defaultPackage; build-tools = pkgs.symlinkJoin { @@ -119,13 +123,13 @@ }; }; - apps = haskell-nix-flake.apps // { - default = self.apps."${system}"."unison-cli-main:exe:unison"; + apps = renameAttrs (name: "component-${name}") haskell-nix-flake.apps // { + default = self.apps."${system}"."component-unison-cli-main:exe:unison"; }; devShells = nixpkgs-devShells - // haskell-nix-flake.devShells + // renameAttrs (name: "cabal-${name}") haskell-nix-flake.devShells // { default = self.devShells."${system}".only-tools-nixpkgs; }; From f515658504830d51e7ef779867aac4f5bbc771c1 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Thu, 16 May 2024 21:35:46 -0600 Subject: [PATCH 64/82] Ignore the Nix build result symlink --- .gitignore | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/.gitignore b/.gitignore index 8a2be67a4..e02fc7f2b 100644 --- a/.gitignore +++ b/.gitignore @@ -24,5 +24,7 @@ dist-newstyle # Mac developers **/.DS_Store - /libb2.dylib + +# Nix +result From 1b5c93da11736ba1a109f0090e2858f998896c25 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 28 May 2024 09:38:49 -0700 Subject: [PATCH 65/82] remove git push/pull --- lib/unison-prelude/src/Unison/Debug.hs | 13 +- parser-typechecker/src/Unison/Codebase.hs | 22 +- .../src/Unison/Codebase/Editor/Git.hs | 317 -------- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 68 +- .../src/Unison/Codebase/GitError.hs | 37 - .../src/Unison/Codebase/SqliteCodebase.hs | 253 +----- .../Codebase/SqliteCodebase/GitError.hs | 13 - .../src/Unison/Codebase/Type.hs | 36 - .../unison-parser-typechecker.cabal | 5 +- unison-cli/src/Unison/Cli/DownloadUtils.hs | 35 +- unison-cli/src/Unison/Cli/MergeTypes.hs | 3 +- unison-cli/src/Unison/Cli/Pretty.hs | 19 +- .../src/Unison/Cli/UnisonConfigUtils.hs | 14 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 4 +- .../Codebase/Editor/HandleInput/Merge2.hs | 11 +- .../Codebase/Editor/HandleInput/Pull.hs | 12 - .../Codebase/Editor/HandleInput/Push.hs | 98 +-- .../src/Unison/Codebase/Editor/Input.hs | 10 +- .../src/Unison/Codebase/Editor/Output.hs | 5 +- .../src/Unison/Codebase/Editor/UriParser.hs | 288 +------ .../src/Unison/CommandLine/InputPatterns.hs | 82 +- .../src/Unison/CommandLine/OutputMessages.hs | 133 +--- unison-cli/tests/Unison/Test/GitSync.hs | 732 ------------------ unison-cli/unison-cli.cabal | 3 +- 24 files changed, 37 insertions(+), 2176 deletions(-) delete mode 100644 parser-typechecker/src/Unison/Codebase/Editor/Git.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/GitError.hs delete mode 100644 parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs delete mode 100644 unison-cli/tests/Unison/Test/GitSync.hs diff --git a/lib/unison-prelude/src/Unison/Debug.hs b/lib/unison-prelude/src/Unison/Debug.hs index d940c1009..47fdb2ee7 100644 --- a/lib/unison-prelude/src/Unison/Debug.hs +++ b/lib/unison-prelude/src/Unison/Debug.hs @@ -25,7 +25,6 @@ import UnliftIO.Environment (lookupEnv) data DebugFlag = Auth | Codebase - | Git | Integrity | Merge | Migration @@ -59,7 +58,6 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of case Text.toUpper . Text.strip $ w of "AUTH" -> pure Auth "CODEBASE" -> pure Codebase - "GIT" -> pure Git "INTEGRITY" -> pure Integrity "MERGE" -> pure Merge "MIGRATION" -> pure Migration @@ -77,10 +75,6 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of _ -> empty {-# NOINLINE debugFlags #-} -debugGit :: Bool -debugGit = Git `Set.member` debugFlags -{-# NOINLINE debugGit #-} - debugSqlite :: Bool debugSqlite = Sqlite `Set.member` debugFlags {-# NOINLINE debugSqlite #-} @@ -146,11 +140,11 @@ debugPatternCoverageConstraintSolver = PatternCoverageConstraintSolver `Set.memb {-# NOINLINE debugPatternCoverageConstraintSolver #-} -- | Use for trace-style selective debugging. --- E.g. 1 + (debug Git "The second number" 2) +-- E.g. 1 + (debug Sync "The second number" 2) -- -- Or, use in pattern matching to view arguments. -- E.g. --- myFunc (debug Git "argA" -> argA) = ... +-- myFunc (debug Sync "argA" -> argA) = ... debug :: (Show a) => DebugFlag -> String -> a -> a debug flag msg a = if shouldDebug flag @@ -160,7 +154,7 @@ debug flag msg a = -- | Use for selective debug logging in monadic contexts. -- E.g. -- do --- debugM Git "source repo" srcRepo +-- debugM Sync "source repo" srcRepo -- ... debugM :: (Show a, Monad m) => DebugFlag -> String -> a -> m () debugM flag msg a = @@ -187,7 +181,6 @@ shouldDebug :: DebugFlag -> Bool shouldDebug = \case Auth -> debugAuth Codebase -> debugCodebase - Git -> debugGit Integrity -> debugIntegrity Merge -> debugMerge Migration -> debugMigration diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 9817a18b4..107b765c3 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -86,10 +86,6 @@ module Unison.Codebase syncFromDirectory, syncToDirectory, - -- ** Remote sync - viewRemoteBranch, - pushGitBranch, - -- * Codebase path getCodebaseDir, CodebasePath, @@ -124,13 +120,11 @@ import Unison.Codebase.Branch (Branch) import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation)) import Unison.Codebase.CodeLookup qualified as CL -import Unison.Codebase.Editor.Git qualified as Git -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace) import Unison.Codebase.Path import Unison.Codebase.Path qualified as Path import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Operations -import Unison.Codebase.Type (Codebase (..), GitError) +import Unison.Codebase.Type (Codebase (..)) import Unison.CodebasePath (CodebasePath, getCodebaseDir) import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..)) import Unison.DataDeclaration (Decl) @@ -466,20 +460,6 @@ isType c r = case r of Reference.Builtin {} -> pure $ Builtin.isBuiltinType r Reference.DerivedId r -> isJust <$> getTypeDeclaration c r --- * Git stuff - --- | Pull a git branch and view it from the cache, without syncing into the --- local codebase. -viewRemoteBranch :: - (MonadIO m) => - Codebase m v a -> - ReadGitRemoteNamespace -> - Git.GitBranchBehavior -> - (Branch m -> m r) -> - m (Either GitError r) -viewRemoteBranch codebase ns gitBranchBehavior action = - viewRemoteBranch' codebase ns gitBranchBehavior (\(b, _dir) -> action b) - unsafeGetComponentLength :: (HasCallStack) => Hash -> Sqlite.Transaction Reference.CycleSize unsafeGetComponentLength h = Operations.getCycleLen h >>= \case diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs deleted file mode 100644 index 61ec46c38..000000000 --- a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs +++ /dev/null @@ -1,317 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Codebase.Editor.Git - ( gitIn, - gitTextIn, - gitInCaptured, - withRepo, - withIOError, - withStatus, - withIsolatedRepo, - debugGit, - gitDirToPath, - gitVerbosity, - GitBranchBehavior (..), - GitRepo (..), - - -- * Exported for testing - gitCacheDir, - ) -where - -import Control.Exception qualified -import Control.Monad.Except (MonadError, throwError) -import Data.ByteString.Base16 qualified as ByteString -import Data.Char qualified as Char -import Data.Text qualified as Text -import Shellmet (($?), ($^), ($|)) -import System.Exit (ExitCode (ExitSuccess)) -import System.FilePath (()) -import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..)) -import Unison.Codebase.GitError (GitProtocolError) -import Unison.Codebase.GitError qualified as GitError -import Unison.Debug qualified as Debug -import Unison.Prelude -import UnliftIO qualified -import UnliftIO.Directory (XdgDirectory (XdgCache), doesDirectoryExist, findExecutable, getXdgDirectory) -import UnliftIO.IO (hFlush, stdout) -import UnliftIO.Process qualified as UnliftIO - -debugGit :: Bool -debugGit = Debug.shouldDebug Debug.Git - -gitVerbosity :: [Text] -gitVerbosity = - if debugGit - then [] - else ["--quiet"] - --- https://superuser.com/questions/358855/what-characters-are-safe-in-cross-platform-file-names-for-linux-windows-and-os -encodeFileName :: String -> FilePath -encodeFileName s = - let go ('.' : rem) = "$dot$" <> go rem - go ('$' : rem) = "$$" <> go rem - go (c : rem) - | elem @[] c "/\\:*?\"<>|" || not (Char.isPrint c && Char.isAscii c) = - "$x" <> encodeHex [c] <> "$" <> go rem - | otherwise = c : go rem - go [] = [] - encodeHex :: String -> String - encodeHex = - Text.unpack - . Text.toUpper - . ByteString.encodeBase16 - . encodeUtf8 - . Text.pack - in -- 'bare' suffix is to avoid clashes with non-bare repos initialized by earlier versions - -- of ucm. - go s <> "-bare" - -gitCacheDir :: (MonadIO m) => Text -> m FilePath -gitCacheDir url = - getXdgDirectory XdgCache $ - "unisonlanguage" - "gitfiles" - encodeFileName (Text.unpack url) - -withStatus :: (MonadIO m) => String -> m a -> m a -withStatus str ma = do - flushStr str - a <- ma - flushStr (const ' ' <$> str) - pure a - where - flushStr str = do - liftIO . putStr $ " " ++ str ++ "\r" - hFlush stdout - --- | Run an action on an isolated copy of the provided repo. --- The repo is deleted when the action exits or fails. --- A branch or tag to check out from the source repo may be specified. -withIsolatedRepo :: - forall m r. - (MonadUnliftIO m) => - GitRepo -> - Text -> - Maybe Text -> - (GitRepo -> m r) -> - m (Either GitProtocolError r) -withIsolatedRepo srcPath origin mayGitRef action = do - UnliftIO.withSystemTempDirectory "ucm-isolated-repo" $ \tempDir -> do - let tempRepo = Worktree tempDir - copyCommand tempRepo >>= \case - Left gitErr -> pure $ Left (GitError.CopyException (gitDirToPath srcPath) tempDir (show gitErr)) - Right () -> Right <$> action tempRepo - where - copyCommand :: GitRepo -> m (Either IOException ()) - copyCommand dest = UnliftIO.tryIO . liftIO $ do - gitGlobal - ( ["clone", "--origin", "git-cache"] - -- tags work okay here too. - ++ maybe [] (\t -> ["--branch", t]) mayGitRef - ++ [Text.pack . gitDirToPath $ srcPath, Text.pack . gitDirToPath $ dest] - ) - -- If a specific ref wasn't requested, ensure we have all branches and tags from the source. - -- This is fast since it's a local fetch. - when (isNothing mayGitRef) $ do - -- If the source repo is empty, we can't fetch, but there won't be anything to - -- fetch anyways. - unlessM (isEmptyGitRepo srcPath) $ do - gitIn dest $ ["fetch", "--tags", Text.pack . gitDirToPath $ srcPath] ++ gitVerbosity - gitIn dest $ ["remote", "add", "origin", origin] - --- | Define what to do if the repo we're pulling/pushing doesn't have the specified branch. -data GitBranchBehavior - = -- If the desired branch doesn't exist in the repo, - -- create a new branch by the provided name with a fresh codebase - CreateBranchIfMissing - | -- Fail with an error if the branch doesn't exist. - RequireExistingBranch - --- | Clone or fetch an updated copy of the provided repository and check out the expected ref, --- then provide the action with a path to the codebase in that repository. --- Note that the repository provided to the action is temporary, it will be removed when the --- action completes or fails. -withRepo :: - forall m a. - (MonadUnliftIO m) => - ReadGitRepo -> - GitBranchBehavior -> - (GitRepo -> m a) -> - m (Either GitProtocolError a) -withRepo repo@(ReadGitRepo {url = uri, ref = mayGitRef}) branchBehavior action = UnliftIO.try $ do - throwExceptT $ checkForGit - gitCachePath <- gitCacheDir uri - -- Ensure we have the main branch in the cache dir no matter what - _ :: GitRepo <- throwExceptT $ cloneIfMissing repo {ref = Nothing} gitCachePath - let gitCacheRepo = Bare gitCachePath - gitRef <- case mayGitRef of - Nothing -> fromMaybe "main" <$> getDefaultBranch gitCacheRepo - Just gitRef -> pure gitRef - doesRemoteRefExist <- fetchAndUpdateRef gitCacheRepo gitRef - if doesRemoteRefExist - then do - -- A ref by the requested name exists on the remote. - withStatus ("Checking out " ++ Text.unpack gitRef ++ " ...") $ do - -- Check out the ref in a new isolated repo - throwEitherM . withIsolatedRepo gitCacheRepo uri (Just gitRef) $ action - else do - -- No ref by the given name exists on the remote - case branchBehavior of - RequireExistingBranch -> UnliftIO.throwIO (GitError.RemoteRefNotFound uri gitRef) - CreateBranchIfMissing -> - withStatus ("Creating new branch " ++ Text.unpack gitRef ++ " ...") - . throwEitherM - . withIsolatedRepo gitCacheRepo uri Nothing - $ \(workTree) -> do - -- It's possible for the branch to exist in the cache even if it's not in the - -- remote, if for instance the branch was deleted from the remote. - -- In that case we delete the branch from the cache and create a new one. - localRefExists <- doesLocalRefExist gitCacheRepo gitRef - when localRefExists $ do - currentBranch <- gitTextIn workTree ["branch", "--show-current"] - -- In the rare case where we've got the branch already checked out, - -- we need to temporarily switch to a different branch so we can delete and - -- reset the branch to an orphan. - when (currentBranch == gitRef) $ gitIn workTree $ ["branch", "-B", "_unison_temp_branch"] ++ gitVerbosity - gitIn workTree $ ["branch", "-D", gitRef] ++ gitVerbosity - gitIn workTree $ ["checkout", "--orphan", gitRef] ++ gitVerbosity - -- Checking out an orphan branch doesn't actually clear the worktree, do that manually. - _ <- gitInCaptured workTree $ ["rm", "--ignore-unmatch", "-rf", "."] ++ gitVerbosity - action workTree - where - -- Check if a ref exists in the repository at workDir. - doesLocalRefExist :: GitRepo -> Text -> m Bool - doesLocalRefExist workDir ref = liftIO $ do - (gitIn workDir (["show-ref", "--verify", ref] ++ gitVerbosity) $> True) - $? pure False - -- fetch the given ref and update the local repositories ref to match the remote. - -- returns whether or not the ref existed on the remote. - fetchAndUpdateRef :: GitRepo -> Text -> m Bool - fetchAndUpdateRef workDir gitRef = do - (succeeded, _, _) <- - gitInCaptured - workDir - ( [ "fetch", - "--tags", -- if the gitref is a tag, fetch and update that too. - "--force", -- force updating local refs even if not fast-forward - -- update local refs with the same name they have on the remote. - "--refmap", - "*:*", - "--depth", - "1", - uri, -- The repo to fetch from - gitRef -- The specific reference to fetch - ] - ++ gitVerbosity - ) - pure succeeded - --- | Do a `git clone` (for a not-previously-cached repo). -cloneIfMissing :: (MonadIO m, MonadError GitProtocolError m) => ReadGitRepo -> FilePath -> m GitRepo -cloneIfMissing repo@(ReadGitRepo {url = uri}) localPath = do - doesDirectoryExist localPath >>= \case - True -> - whenM (not <$> isGitRepo (Bare localPath)) $ do - throwError (GitError.UnrecognizableCacheDir repo localPath) - False -> do - -- directory doesn't exist, so clone anew - cloneRepo - pure $ Bare localPath - where - cloneRepo = do - withStatus ("Downloading from " ++ Text.unpack uri ++ " ...") $ - ( liftIO $ - gitGlobal - ( ["clone"] - ++ ["--bare"] - ++ ["--depth", "1"] - ++ [uri, Text.pack localPath] - ) - ) - `withIOError` (throwError . GitError.CloneException repo . show) - isGitDir <- liftIO $ isGitRepo (Bare localPath) - unless isGitDir . throwError $ GitError.UnrecognizableCheckoutDir repo localPath - --- | See if `git` is on the system path. -checkForGit :: (MonadIO m) => (MonadError GitProtocolError m) => m () -checkForGit = do - gitPath <- liftIO $ findExecutable "git" - when (isNothing gitPath) $ throwError GitError.NoGit - --- | Returns the name of the default branch of a repository, if one exists. -getDefaultBranch :: (MonadIO m) => GitRepo -> m (Maybe Text) -getDefaultBranch dir = liftIO $ do - (Text.stripPrefix "refs/heads/" <$> gitTextIn dir ["symbolic-ref", "HEAD"]) - $? pure Nothing - --- | Does `git` recognize this directory as being managed by git? -isGitRepo :: (MonadIO m) => GitRepo -> m Bool -isGitRepo dir = - liftIO $ - (True <$ gitIn dir (["rev-parse"] ++ gitVerbosity)) $? pure False - --- | Returns True if the repo is empty, i.e. has no commits at the current branch, --- or if the dir isn't a git repo at all. -isEmptyGitRepo :: (MonadIO m) => GitRepo -> m Bool -isEmptyGitRepo dir = liftIO do - (gitTextIn dir (["rev-parse", "HEAD"] ++ gitVerbosity) $> False) $? pure True - --- | Perform an IO action, passing any IO exception to `handler` -withIOError :: (MonadIO m) => IO a -> (IOException -> m a) -> m a -withIOError action handler = - liftIO (fmap Right action `Control.Exception.catch` (pure . Left)) - >>= either handler pure - --- | A path to a git repository. -data GitRepo - = Bare FilePath - | Worktree FilePath - deriving (Show) - -gitDirToPath :: GitRepo -> FilePath -gitDirToPath = \case - Bare fp -> fp - Worktree fp -> fp - --- | Generate some `git` flags for operating on some arbitary checked out copy -setupGitDir :: GitRepo -> [Text] -setupGitDir dir = - case dir of - Bare localPath -> - ["--git-dir", Text.pack localPath] - Worktree localPath -> - [ "--git-dir", - Text.pack (localPath ".git"), - "--work-tree", - Text.pack localPath - ] - --- | Run a git command in the current work directory. --- Note: this should only be used for commands like 'clone' which don't interact with an --- existing repository. -gitGlobal :: (MonadIO m) => [Text] -> m () -gitGlobal args = do - when debugGit $ traceM (Text.unpack . Text.unwords $ ["$ git"] <> args) - liftIO $ "git" $^ (args ++ gitVerbosity) - --- | Run a git command in the repository at localPath -gitIn :: (MonadIO m) => GitRepo -> [Text] -> m () -gitIn localPath args = do - when debugGit $ traceM (Text.unpack . Text.unwords $ ["$ git"] <> setupGitDir localPath <> args) - liftIO $ "git" $^ (setupGitDir localPath <> args) - --- | like 'gitIn', but silences all output from the command and returns whether the command --- succeeded. -gitInCaptured :: (MonadIO m) => GitRepo -> [Text] -> m (Bool, Text, Text) -gitInCaptured localPath args = do - when debugGit $ traceM (Text.unpack . Text.unwords $ ["$ git"] <> setupGitDir localPath <> args) - (exitCode, stdout, stderr) <- UnliftIO.readProcessWithExitCode "git" (Text.unpack <$> setupGitDir localPath <> args) "" - pure (exitCode == ExitSuccess, Text.pack stdout, Text.pack stderr) - --- | Run a git command in the repository at localPath and capture stdout -gitTextIn :: (MonadIO m) => GitRepo -> [Text] -> m Text -gitTextIn localPath args = do - when debugGit $ traceM (Text.unpack . Text.unwords $ ["$ git"] <> setupGitDir localPath <> args) - liftIO $ "git" $| setupGitDir localPath <> args diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 544b3d5e4..cd2f26815 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -2,22 +2,13 @@ module Unison.Codebase.Editor.RemoteRepo where import Control.Lens (Lens') import Control.Lens qualified as Lens -import Data.Text qualified as Text import Data.Void (absurd) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path -import Unison.Codebase.ShortCausalHash (ShortCausalHash) -import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.NameSegment qualified as NameSegment import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) import Unison.Share.Types -import Unison.Util.Monoid qualified as Monoid - -data ReadRepo - = ReadRepoGit ReadGitRepo - | ReadRepoShare ShareCodeserver - deriving stock (Eq, Ord, Show) data ShareCodeserver = DefaultCodeserver @@ -44,58 +35,21 @@ displayShareCodeserver cs shareUser path = CustomCodeserver cu -> "share(" <> tShow cu <> ")." in shareServer <> shareUserHandleToText shareUser <> maybePrintPath path -data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} - deriving stock (Eq, Ord, Show) - -data WriteRepo - = WriteRepoGit WriteGitRepo - | WriteRepoShare ShareCodeserver - deriving stock (Eq, Ord, Show) - -data WriteGitRepo = WriteGitRepo {url :: Text, branch :: Maybe Text} - deriving stock (Eq, Ord, Show) - -writeToRead :: WriteRepo -> ReadRepo -writeToRead = \case - WriteRepoGit repo -> ReadRepoGit (writeToReadGit repo) - WriteRepoShare repo -> ReadRepoShare repo - -writeToReadGit :: WriteGitRepo -> ReadGitRepo -writeToReadGit = \case - WriteGitRepo {url, branch} -> ReadGitRepo {url = url, ref = branch} - writeNamespaceToRead :: WriteRemoteNamespace Void -> ReadRemoteNamespace void writeNamespaceToRead = \case - WriteRemoteNamespaceGit WriteGitRemoteNamespace {repo, path} -> - ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo = writeToReadGit repo, sch = Nothing, path} WriteRemoteNamespaceShare WriteShareRemoteNamespace {server, repo, path} -> ReadShare'LooseCode ReadShareLooseCode {server, repo, path} WriteRemoteProjectBranch v -> absurd v -printReadGitRepo :: ReadGitRepo -> Text -printReadGitRepo ReadGitRepo {url, ref} = - "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) <> ")" - -printWriteGitRepo :: WriteGitRepo -> Text -printWriteGitRepo WriteGitRepo {url, branch} = "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) <> ")" - -- | print remote namespace printReadRemoteNamespace :: (a -> Text) -> ReadRemoteNamespace a -> Text printReadRemoteNamespace printProject = \case - ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sch, path} -> - printReadGitRepo repo <> maybePrintSCH sch <> maybePrintPath path - where - maybePrintSCH = \case - Nothing -> mempty - Just sch -> "#" <> SCH.toText sch ReadShare'LooseCode ReadShareLooseCode {server, repo, path} -> displayShareCodeserver server repo path ReadShare'ProjectBranch project -> printProject project -- | Render a 'WriteRemoteNamespace' as text. printWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Text printWriteRemoteNamespace = \case - WriteRemoteNamespaceGit (WriteGitRemoteNamespace {repo, path}) -> - printWriteGitRepo repo <> maybePrintPath path WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server, repo, path}) -> displayShareCodeserver server repo path WriteRemoteProjectBranch projectAndBranch -> into @Text projectAndBranch @@ -107,20 +61,12 @@ maybePrintPath path = else "." <> Path.toText path data ReadRemoteNamespace a - = ReadRemoteNamespaceGit !ReadGitRemoteNamespace - | ReadShare'LooseCode !ReadShareLooseCode + = ReadShare'LooseCode !ReadShareLooseCode | -- | A remote project+branch, specified by name (e.g. @unison/base/main). -- Currently assumed to be hosted on Share, though we could include a ShareCodeserver in here, too. ReadShare'ProjectBranch !a deriving stock (Eq, Functor, Show, Generic) -data ReadGitRemoteNamespace = ReadGitRemoteNamespace - { repo :: !ReadGitRepo, - sch :: !(Maybe ShortCausalHash), - path :: !Path - } - deriving stock (Eq, Show) - data ReadShareLooseCode = ReadShareLooseCode { server :: !ShareCodeserver, repo :: !ShareUserHandle, @@ -136,8 +82,7 @@ isPublic ReadShareLooseCode {path} = _ -> False data WriteRemoteNamespace a - = WriteRemoteNamespaceGit !WriteGitRemoteNamespace - | WriteRemoteNamespaceShare !WriteShareRemoteNamespace + = WriteRemoteNamespaceShare !WriteShareRemoteNamespace | WriteRemoteProjectBranch a deriving stock (Eq, Functor, Show) @@ -146,23 +91,14 @@ remotePath_ :: Lens' (WriteRemoteNamespace Void) Path remotePath_ = Lens.lens getter setter where getter = \case - WriteRemoteNamespaceGit (WriteGitRemoteNamespace _ path) -> path WriteRemoteNamespaceShare (WriteShareRemoteNamespace _ _ path) -> path WriteRemoteProjectBranch v -> absurd v setter remote path = case remote of - WriteRemoteNamespaceGit (WriteGitRemoteNamespace repo _) -> - WriteRemoteNamespaceGit $ WriteGitRemoteNamespace repo path WriteRemoteNamespaceShare (WriteShareRemoteNamespace server repo _) -> WriteRemoteNamespaceShare $ WriteShareRemoteNamespace server repo path WriteRemoteProjectBranch v -> absurd v -data WriteGitRemoteNamespace = WriteGitRemoteNamespace - { repo :: !WriteGitRepo, - path :: !Path - } - deriving stock (Eq, Generic, Show) - data WriteShareRemoteNamespace = WriteShareRemoteNamespace { server :: !ShareCodeserver, repo :: !ShareUserHandle, diff --git a/parser-typechecker/src/Unison/Codebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/GitError.hs deleted file mode 100644 index d6d3acc43..000000000 --- a/parser-typechecker/src/Unison/Codebase/GitError.hs +++ /dev/null @@ -1,37 +0,0 @@ -module Unison.Codebase.GitError - ( CodebasePath, - GitProtocolError (..), - GitCodebaseError (..), - ) -where - -import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo, WriteGitRepo) -import Unison.Codebase.Path (Path) -import Unison.Codebase.ShortCausalHash (ShortCausalHash) -import Unison.Prelude - -type CodebasePath = FilePath - -data GitProtocolError - = NoGit - | UnrecognizableCacheDir ReadGitRepo CodebasePath - | UnrecognizableCheckoutDir ReadGitRepo CodebasePath - | -- srcPath destPath error-description - CopyException FilePath FilePath String - | CloneException ReadGitRepo String - | PushException WriteGitRepo String - | PushNoOp WriteGitRepo - | -- url commit Diff of what would change on merge with remote - PushDestinationHasNewStuff WriteGitRepo - | CleanupError SomeException - | -- Thrown when a commit, tag, or branch isn't found in a repo. - -- repo ref - RemoteRefNotFound Text Text - deriving stock (Show) - deriving anyclass (Exception) - -data GitCodebaseError h - = NoRemoteNamespaceWithHash ReadGitRepo ShortCausalHash - | RemoteNamespaceHashAmbiguous ReadGitRepo ShortCausalHash (Set h) - | CouldntFindRemoteBranch ReadGitRepo Path - deriving (Show) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 861c246d3..18f21330e 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -14,17 +14,13 @@ where import Control.Monad.Except qualified as Except import Control.Monad.Extra qualified as Monad -import Data.Char qualified as Char import Data.Either.Extra () import Data.IORef import Data.Map qualified as Map import Data.Set qualified as Set -import Data.Text qualified as Text import Data.Time (getCurrentTime) import System.Console.ANSI qualified as ANSI import System.FileLock (SharedExclusive (Exclusive), withTryFileLock) -import System.FilePath qualified as FilePath -import System.FilePath.Posix qualified as FilePath.Posix import U.Codebase.HashTags (CausalHash, PatchHash (..)) import U.Codebase.Reflog qualified as Reflog import U.Codebase.Sqlite.Operations qualified as Ops @@ -36,15 +32,6 @@ import Unison.Codebase (Codebase, CodebasePath) import Unison.Codebase qualified as Codebase1 import Unison.Codebase.Branch (Branch (..)) import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo) -import Unison.Codebase.Editor.Git qualified as Git -import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRemoteNamespace (..), - ReadGitRepo, - WriteGitRepo (..), - writeToReadGit, - ) -import Unison.Codebase.GitError qualified as GitError import Unison.Codebase.Init (BackupStrategy (..), CodebaseLockOption (..), MigrationStrategy (..), VacuumStrategy (..)) import Unison.Codebase.Init qualified as Codebase import Unison.Codebase.Init.CreateCodebaseError qualified as Codebase1 @@ -54,12 +41,11 @@ import Unison.Codebase.RootBranchCache import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache) import Unison.Codebase.SqliteCodebase.Branch.Dependencies qualified as BD import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv -import Unison.Codebase.SqliteCodebase.GitError qualified as GitError import Unison.Codebase.SqliteCodebase.Migrations qualified as Migrations import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps import Unison.Codebase.SqliteCodebase.Paths import Unison.Codebase.SqliteCodebase.SyncEphemeral qualified as SyncEphemeral -import Unison.Codebase.Type (GitPushBehavior, LocalOrRemote (..)) +import Unison.Codebase.Type (LocalOrRemote (..)) import Unison.Codebase.Type qualified as C import Unison.DataDeclaration (Decl) import Unison.Hash (Hash) @@ -75,9 +61,8 @@ import Unison.Term (Term) import Unison.Type (Type) import Unison.Util.Timing (time) import Unison.WatchKind qualified as UF -import UnliftIO (UnliftIO (..), finally, throwIO, try) +import UnliftIO (UnliftIO (..), finally) import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist) -import UnliftIO.Exception (catch) import UnliftIO.STM debug, debugProcessBranches :: Bool @@ -103,30 +88,6 @@ initWithSetup onCreate = codebasePath = makeCodebaseDirPath } -data CodebaseStatus - = ExistingCodebase - | CreatedCodebase - deriving (Eq) - --- | Open the codebase at the given location, or create it if one doesn't already exist. -withOpenOrCreateCodebase :: - (MonadUnliftIO m) => - Sqlite.Transaction () -> - Codebase.DebugName -> - CodebasePath -> - LocalOrRemote -> - CodebaseLockOption -> - MigrationStrategy -> - ((CodebaseStatus, Codebase m Symbol Ann) -> m r) -> - m (Either Codebase1.OpenCodebaseError r) -withOpenOrCreateCodebase onCreate debugName codebasePath localOrRemote lockOption migrationStrategy action = do - createCodebaseOrError onCreate debugName codebasePath lockOption (action' CreatedCodebase) >>= \case - Left (Codebase1.CreateCodebaseAlreadyExists) -> do - sqliteCodebase debugName codebasePath localOrRemote lockOption migrationStrategy (action' ExistingCodebase) - Right r -> pure (Right r) - where - action' openOrCreate codebase = action (openOrCreate, codebase) - -- | Create a codebase at the given location. createCodebaseOrError :: (MonadUnliftIO m) => @@ -379,8 +340,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action putBranch, syncFromDirectory, syncToDirectory, - viewRemoteBranch', - pushGitBranch = \repo opts action -> withConn \conn -> pushGitBranch conn repo opts action, getWatch, termsOfTypeImpl, termsMentioningTypeImpl, @@ -571,214 +530,6 @@ syncProgress progressStateRef = Sync.Progress (liftIO . need) (liftIO . done) (l where v = const () --- FIXME(mitchell) seems like this should have "git" in its name -viewRemoteBranch' :: - forall m r. - (MonadUnliftIO m) => - ReadGitRemoteNamespace -> - Git.GitBranchBehavior -> - ((Branch m, CodebasePath) -> m r) -> - m (Either C.GitError r) -viewRemoteBranch' ReadGitRemoteNamespace {repo, sch, path} gitBranchBehavior action = UnliftIO.try $ do - -- set up the cache dir - time "Git fetch" $ - throwEitherMWith C.GitProtocolError . withRepo repo gitBranchBehavior $ \remoteRepo -> do - let remotePath = Git.gitDirToPath remoteRepo - -- In modern UCM all new codebases are created in WAL mode, but it's possible old - -- codebases were pushed to git in DELETE mode, so when pulling remote branches we - -- ensure we're in WAL mode just to be safe. - ensureWALMode conn = Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL - -- Tickle the database before calling into `sqliteCodebase`; this covers the case that the database file either - -- doesn't exist at all or isn't a SQLite database file, but does not cover the case that the database file itself - -- is somehow corrupt, or not even a Unison database. - -- - -- FIXME it would probably make more sense to define some proper preconditions on `sqliteCodebase`, and perhaps - -- update its output type, which currently indicates the only way it can fail is with an `UnknownSchemaVersion` - -- error. - (withConnection "codebase exists check" remotePath ensureWALMode) `catch` \exception -> - if Sqlite.isCantOpenException exception - then throwIO (C.GitSqliteCodebaseError (GitError.NoDatabaseFile repo remotePath)) - else throwIO exception - - result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath Remote DoLock (MigrateAfterPrompt Codebase.Backup Codebase.Vacuum) \codebase -> do - -- try to load the requested branch from it - branch <- time "Git fetch (sch)" $ case sch of - -- no sub-branch was specified, so use the root. - Nothing -> time "Get remote root branch" $ Codebase1.getRootBranch codebase - -- load from a specific `ShortCausalHash` - Just sch -> do - branchCompletions <- Codebase1.runTransaction codebase (Codebase1.causalHashesByPrefix sch) - case toList branchCompletions of - [] -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sch - [h] -> - (Codebase1.getBranchForHash codebase h) >>= \case - Just b -> pure b - Nothing -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sch - _ -> throwIO . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sch branchCompletions - case Branch.getAt path branch of - Just b -> action (b, remotePath) - Nothing -> throwIO . C.GitCodebaseError $ GitError.CouldntFindRemoteBranch repo path - case result of - Left err -> throwIO . C.GitSqliteCodebaseError $ C.gitErrorFromOpenCodebaseError remotePath repo err - Right inner -> pure inner - --- | Push a branch to a repo. Optionally attempt to set the branch as the new root, which fails if the branch is not after --- the existing root. -pushGitBranch :: - forall m e. - (MonadUnliftIO m) => - Sqlite.Connection -> - WriteGitRepo -> - GitPushBehavior -> - -- An action which accepts the current root branch on the remote and computes a new branch. - (Branch m -> m (Either e (Branch m))) -> - m (Either C.GitError (Either e (Branch m))) -pushGitBranch srcConn repo behavior action = UnliftIO.try do - -- Pull the latest remote into our git cache - -- Use a local git clone to copy this git repo into a temp-dir - -- Delete the codebase in our temp-dir - -- Use sqlite's VACUUM INTO command to make a copy of the remote codebase into our temp-dir - -- Connect to the copied codebase and sync whatever it is we want to push. - -- sync the branch to the staging codebase using `syncInternal`, which probably needs to be passed in instead of `syncToDirectory` - -- if setting the remote root, - -- do a `before` check on the staging codebase - -- if it passes, proceed (see below) - -- if it fails, throw an exception (which will rollback) and clean up. - -- push from the temp-dir to the remote. - -- Delete the temp-dir. - -- - -- set up the cache dir - throwEitherMWith C.GitProtocolError . withRepo readRepo Git.CreateBranchIfMissing $ \pushStaging -> do - newBranchOrErr <- throwEitherMWith (C.GitSqliteCodebaseError . C.gitErrorFromOpenCodebaseError (Git.gitDirToPath pushStaging) readRepo) - . withOpenOrCreateCodebase (pure ()) "push.dest" (Git.gitDirToPath pushStaging) Remote DoLock (MigrateAfterPrompt Codebase.Backup Codebase.Vacuum) - $ \(codebaseStatus, destCodebase) -> do - currentRootBranch <- - Codebase1.runTransaction destCodebase CodebaseOps.getRootBranchExists >>= \case - False -> pure Branch.empty - True -> C.getRootBranch destCodebase - action currentRootBranch >>= \case - Left e -> pure $ Left e - Right newBranch -> do - C.withConnection destCodebase \destConn -> - doSync codebaseStatus destConn newBranch - pure (Right newBranch) - for_ newBranchOrErr $ push pushStaging repo - pure newBranchOrErr - where - readRepo :: ReadGitRepo - readRepo = writeToReadGit repo - doSync :: CodebaseStatus -> Sqlite.Connection -> Branch m -> m () - doSync codebaseStatus destConn newBranch = do - progressStateRef <- liftIO (newIORef emptySyncProgressState) - Sqlite.runReadOnlyTransaction srcConn \runSrc -> do - Sqlite.runWriteTransaction destConn \runDest -> do - _ <- syncInternal (syncProgress progressStateRef) runSrc runDest newBranch - let overwriteRoot forcePush = do - let newBranchHash = Branch.headHash newBranch - case codebaseStatus of - ExistingCodebase -> do - when (not forcePush) do - -- the call to runDB "handles" the possible DB error by bombing - runDest Ops.loadRootCausalHash >>= \case - Nothing -> pure () - Just oldRootHash -> do - runDest (CodebaseOps.before oldRootHash newBranchHash) >>= \case - False -> throwIO . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo - True -> pure () - CreatedCodebase -> pure () - runDest (setRepoRoot newBranchHash) - case behavior of - C.GitPushBehaviorGist -> pure () - C.GitPushBehaviorFf -> overwriteRoot False - C.GitPushBehaviorForce -> overwriteRoot True - setRepoRoot :: CausalHash -> Sqlite.Transaction () - setRepoRoot h = do - let err = error $ "Called SqliteCodebase.setNamespaceRoot on unknown causal hash " ++ show h - chId <- fromMaybe err <$> Q.loadCausalHashIdByCausalHash h - Q.setNamespaceRoot chId - - -- This function makes sure that the result of git status is valid. - -- Valid lines are any of: - -- - -- ?? .unison/v2/unison.sqlite3 (initial commit to an empty repo) - -- M .unison/v2/unison.sqlite3 (updating an existing repo) - -- D .unison/v2/unison.sqlite3-wal (cleaning up the WAL from before bugfix) - -- D .unison/v2/unison.sqlite3-shm (ditto) - -- - -- Invalid lines are like: - -- - -- ?? .unison/v2/unison.sqlite3-wal - -- - -- Which will only happen if the write-ahead log hasn't been - -- fully folded into the unison.sqlite3 file. - -- - -- Returns `Just (hasDeleteWal, hasDeleteShm)` on success, - -- `Nothing` otherwise. hasDeleteWal means there's the line: - -- D .unison/v2/unison.sqlite3-wal - -- and hasDeleteShm is `True` if there's the line: - -- D .unison/v2/unison.sqlite3-shm - -- - parseStatus :: Text -> Maybe (Bool, Bool) - parseStatus status = - if all okLine statusLines - then Just (hasDeleteWal, hasDeleteShm) - else Nothing - where - -- `git status` always displays paths using posix forward-slashes, - -- so we have to convert our expected path to test. - posixCodebasePath = - FilePath.Posix.joinPath (FilePath.splitDirectories codebasePath) - posixLockfilePath = FilePath.replaceExtension posixCodebasePath "lockfile" - statusLines = Text.unpack <$> Text.lines status - t = dropWhile Char.isSpace - okLine (t -> '?' : '?' : (t -> p)) | p == posixCodebasePath || p == posixLockfilePath = True - okLine (t -> 'M' : (t -> p)) | p == posixCodebasePath = True - okLine line = isWalDelete line || isShmDelete line - isWalDelete (t -> 'D' : (t -> p)) | p == posixCodebasePath ++ "-wal" = True - isWalDelete _ = False - isShmDelete (t -> 'D' : (t -> p)) | p == posixCodebasePath ++ "-wal" = True - isShmDelete _ = False - hasDeleteWal = any isWalDelete statusLines - hasDeleteShm = any isShmDelete statusLines - - -- Commit our changes - push :: forall n. (MonadIO n) => Git.GitRepo -> WriteGitRepo -> Branch m -> n Bool -- withIOError needs IO - push remotePath repo@(WriteGitRepo {url, branch = mayGitBranch}) newRootBranch = time "SqliteCodebase.pushGitRootBranch.push" $ do - -- has anything changed? - -- note: -uall recursively shows status for all files in untracked directories - -- we want this so that we see - -- `?? .unison/v2/unison.sqlite3` and not - -- `?? .unison/` - status <- gitTextIn remotePath ["status", "--short", "-uall"] - if Text.null status - then pure False - else case parseStatus status of - Nothing -> - error $ - "An error occurred during push.\n" - <> "I was expecting only to see " - <> codebasePath - <> " modified, but saw:\n\n" - <> Text.unpack status - <> "\n\n" - <> "Please visit https://github.com/unisonweb/unison/issues/2063\n" - <> "and add any more details about how you encountered this!\n" - Just (hasDeleteWal, hasDeleteShm) -> do - -- Only stage files we're expecting; don't `git add --all .` - -- which could accidentally commit some garbage - gitIn remotePath ["add", Text.pack codebasePath] - when hasDeleteWal $ gitIn remotePath ["rm", Text.pack $ codebasePath <> "-wal"] - when hasDeleteShm $ gitIn remotePath ["rm", Text.pack $ codebasePath <> "-shm"] - gitIn - remotePath - ["commit", "-q", "-m", "Sync branch " <> Text.pack (show $ Branch.headHash newRootBranch)] - -- Push our changes to the repo, silencing all output. - -- Even with quiet, the remote (Github) can still send output through, - -- so we capture stdout and stderr. - (successful, _stdout, stderr) <- gitInCaptured remotePath $ ["push", url] ++ Git.gitVerbosity ++ maybe [] (pure @[]) mayGitBranch - when (not successful) . throwIO $ GitError.PushException repo (Text.unpack stderr) - pure True - -- | Given two codebase roots (e.g. "./mycodebase"), safely copy the codebase -- at the source to the destination. -- Note: this does not copy the .unisonConfig file. diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs deleted file mode 100644 index f60581214..000000000 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs +++ /dev/null @@ -1,13 +0,0 @@ -module Unison.Codebase.SqliteCodebase.GitError where - -import U.Codebase.Sqlite.DbId (SchemaVersion) -import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo) -import Unison.CodebasePath (CodebasePath) - -data GitSqliteCodebaseError - = GitCouldntParseRootBranchHash ReadGitRepo String - | CodebaseFileLockFailed - | NoDatabaseFile ReadGitRepo CodebasePath - | UnrecognizedSchemaVersion ReadGitRepo CodebasePath SchemaVersion - | CodebaseRequiresMigration SchemaVersion SchemaVersion - deriving (Show) diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index d9da1aa2a..0b803dd73 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -4,21 +4,13 @@ module Unison.Codebase.Type ( Codebase (..), CodebasePath, - GitPushBehavior (..), - GitError (..), LocalOrRemote (..), - gitErrorFromOpenCodebaseError, ) where import U.Codebase.HashTags (CausalHash) import U.Codebase.Reference qualified as V2 import Unison.Codebase.Branch (Branch) -import Unison.Codebase.Editor.Git qualified as Git -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo) -import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError) -import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..)) -import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..)) import Unison.CodebasePath (CodebasePath) import Unison.ConstructorType qualified as CT import Unison.DataDeclaration (Decl) @@ -80,9 +72,6 @@ data Codebase m v a = Codebase syncFromDirectory :: CodebasePath -> Branch m -> m (), -- | Copy a branch and all of its dependencies from this codebase into the given codebase. syncToDirectory :: CodebasePath -> Branch m -> m (), - viewRemoteBranch' :: forall r. ReadGitRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r), - -- | Push the given branch to the given repo, and optionally set it as the root branch. - pushGitBranch :: forall e. WriteGitRepo -> GitPushBehavior -> (Branch m -> m (Either e (Branch m))) -> m (Either GitError (Either e (Branch m))), -- | @getWatch k r@ returns watch result @t@ that was previously put by @putWatch k r t@. getWatch :: WK.WatchKind -> Reference.Id -> Sqlite.Transaction (Maybe (Term v a)), -- | Get the set of user-defined terms-or-constructors that have the given type. @@ -106,28 +95,3 @@ data LocalOrRemote = Local | Remote deriving (Show, Eq, Ord) - -data GitPushBehavior - = -- | Don't set root, just sync entities. - GitPushBehaviorGist - | -- | After syncing entities, do a fast-forward check, then set the root. - GitPushBehaviorFf - | -- | After syncing entities, just set the root (force-pushy). - GitPushBehaviorForce - -data GitError - = GitProtocolError GitProtocolError - | GitCodebaseError (GitCodebaseError CausalHash) - | GitSqliteCodebaseError GitSqliteCodebaseError - deriving (Show) - -instance Exception GitError - -gitErrorFromOpenCodebaseError :: CodebasePath -> ReadGitRepo -> OpenCodebaseError -> GitSqliteCodebaseError -gitErrorFromOpenCodebaseError path repo = \case - OpenCodebaseDoesntExist -> NoDatabaseFile repo path - OpenCodebaseUnknownSchemaVersion v -> - UnrecognizedSchemaVersion repo path (fromIntegral v) - OpenCodebaseRequiresMigration fromSv toSv -> - CodebaseRequiresMigration fromSv toSv - OpenCodebaseFileLockFailed -> CodebaseFileLockFailed diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index 0bc924d53..7a9a46709 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack @@ -47,11 +47,9 @@ library Unison.Codebase.CodeLookup Unison.Codebase.CodeLookup.Util Unison.Codebase.Editor.DisplayObject - Unison.Codebase.Editor.Git Unison.Codebase.Editor.RemoteRepo Unison.Codebase.Execute Unison.Codebase.FileCodebase - Unison.Codebase.GitError Unison.Codebase.Init Unison.Codebase.Init.CreateCodebaseError Unison.Codebase.Init.OpenCodebaseError @@ -71,7 +69,6 @@ library Unison.Codebase.SqliteCodebase.Branch.Cache Unison.Codebase.SqliteCodebase.Branch.Dependencies Unison.Codebase.SqliteCodebase.Conversions - Unison.Codebase.SqliteCodebase.GitError Unison.Codebase.SqliteCodebase.Migrations Unison.Codebase.SqliteCodebase.Migrations.Helpers Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12 diff --git a/unison-cli/src/Unison/Cli/DownloadUtils.hs b/unison-cli/src/Unison/Cli/DownloadUtils.hs index 284b1ffb0..cd36949eb 100644 --- a/unison-cli/src/Unison/Cli/DownloadUtils.hs +++ b/unison-cli/src/Unison/Cli/DownloadUtils.hs @@ -4,8 +4,6 @@ module Unison.Cli.DownloadUtils ( downloadProjectBranchFromShare, downloadLooseCodeFromShare, - GitNamespaceHistoryTreatment (..), - downloadLooseCodeFromGitRepo, ) where @@ -18,27 +16,19 @@ import U.Codebase.Sqlite.Queries qualified as Queries import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.Share.Projects qualified as Share -import Unison.Codebase (Codebase) -import Unison.Codebase qualified as Codebase -import Unison.Codebase.Branch qualified as Branch -import Unison.Codebase.Editor.Git qualified as Git import Unison.Codebase.Editor.HandleInput.AuthLogin (ensureAuthenticatedWithCodeserver) import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadShareLooseCode, shareUserHandleToText) +import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode, shareUserHandleToText) import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Path qualified as Path -import Unison.Codebase.Type (GitError) -import Unison.Codebase.Type qualified as Codebase (viewRemoteBranch') import Unison.Core.Project (ProjectAndBranch (..)) import Unison.NameSegment qualified as NameSegment -import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.Share.API.Hash qualified as Share import Unison.Share.Codeserver qualified as Codeserver import Unison.Share.Sync qualified as Share import Unison.Share.Sync.Types qualified as Share import Unison.Share.Types (codeserverBaseURL) -import Unison.Symbol (Symbol) import Unison.Sync.Common qualified as Sync.Common import Unison.Sync.Types qualified as Share @@ -113,26 +103,3 @@ withEntitiesDownloadedProgressCallback action = do <> tShow entitiesDownloaded <> " entities...\n\n" action ((\n -> atomically (modifyTVar' entitiesDownloadedVar (+ n))), readTVarIO entitiesDownloadedVar) - -data GitNamespaceHistoryTreatment - = -- | Don't touch the history - GitNamespaceHistoryTreatment'LetAlone - | -- | Throw away all history at all levels - GitNamespaceHistoryTreatment'DiscardAllHistory - --- | Download loose code that's in a SQLite codebase in a Git repo. -downloadLooseCodeFromGitRepo :: - MonadIO m => - Codebase IO Symbol Ann -> - GitNamespaceHistoryTreatment -> - ReadGitRemoteNamespace -> - m (Either GitError CausalHash) -downloadLooseCodeFromGitRepo codebase historyTreatment namespace = liftIO do - Codebase.viewRemoteBranch' codebase namespace Git.RequireExistingBranch \(branch0, cacheDir) -> do - let branch = - case historyTreatment of - GitNamespaceHistoryTreatment'LetAlone -> branch0 - GitNamespaceHistoryTreatment'DiscardAllHistory -> Branch.discardHistory branch0 - - Codebase.syncFromDirectory codebase cacheDir branch - pure (Branch.headHash branch) diff --git a/unison-cli/src/Unison/Cli/MergeTypes.hs b/unison-cli/src/Unison/Cli/MergeTypes.hs index 42524056d..b44870ad6 100644 --- a/unison-cli/src/Unison/Cli/MergeTypes.hs +++ b/unison-cli/src/Unison/Cli/MergeTypes.hs @@ -7,7 +7,7 @@ module Unison.Cli.MergeTypes ) where -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadShareLooseCode) +import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode) import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) -- | What are we merging in? @@ -15,7 +15,6 @@ data MergeSource = MergeSource'LocalProjectBranch !(ProjectAndBranch ProjectName ProjectBranchName) | MergeSource'RemoteProjectBranch !(ProjectAndBranch ProjectName ProjectBranchName) | MergeSource'RemoteLooseCode !ReadShareLooseCode - | MergeSource'RemoteGitRepo !ReadGitRemoteNamespace type MergeTarget = ProjectAndBranch ProjectName ProjectBranchName diff --git a/unison-cli/src/Unison/Cli/Pretty.hs b/unison-cli/src/Unison/Cli/Pretty.hs index a14937554..75c461056 100644 --- a/unison-cli/src/Unison/Cli/Pretty.hs +++ b/unison-cli/src/Unison/Cli/Pretty.hs @@ -27,7 +27,6 @@ module Unison.Cli.Pretty prettyProjectName, prettyProjectNameSlash, prettyNamespaceKey, - prettyReadGitRepo, prettyReadRemoteNamespace, prettyReadRemoteNamespaceWith, prettyRelative, @@ -46,7 +45,6 @@ module Unison.Cli.Pretty prettyURI, prettyUnisonFile, prettyWhichBranchEmpty, - prettyWriteGitRepo, prettyWriteRemoteNamespace, shareOrigin, unsafePrettyTermResultSigFull', @@ -79,10 +77,8 @@ import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, Missi import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRepo, - ReadRemoteNamespace (..), + ( ReadRemoteNamespace (..), ShareUserHandle (..), - WriteGitRepo, WriteRemoteNamespace (..), WriteShareRemoteNamespace (..), shareUserHandleToText, @@ -239,7 +235,6 @@ prettyMergeSource = \case MergeSource'LocalProjectBranch branch -> prettyProjectAndBranchName branch MergeSource'RemoteProjectBranch branch -> "remote " <> prettyProjectAndBranchName branch MergeSource'RemoteLooseCode info -> prettyReadRemoteNamespace (ReadShare'LooseCode info) - MergeSource'RemoteGitRepo info -> prettyReadRemoteNamespace (ReadRemoteNamespaceGit info) prettyMergeSourceOrTarget :: MergeSourceOrTarget -> Pretty prettyMergeSourceOrTarget = \case @@ -348,18 +343,6 @@ prettyTypeName ppe r = P.syntaxToColor $ prettyHashQualified (PPE.typeName ppe r) -prettyReadGitRepo :: ReadGitRepo -> Pretty -prettyReadGitRepo = \case - RemoteRepo.ReadGitRepo {url} -> P.blue (P.text url) - -prettyWriteGitRepo :: WriteGitRepo -> Pretty -prettyWriteGitRepo RemoteRepo.WriteGitRepo {url} = P.blue (P.text url) - --- prettyWriteRepo :: WriteRepo -> Pretty --- prettyWriteRepo = \case --- RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url} -> P.blue (P.text url) --- RemoteRepo.WriteRepoShare s -> P.blue (P.text (RemoteRepo.printShareRepo s)) - -- | Pretty-print a 'WhichBranchEmpty'. prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty prettyWhichBranchEmpty = \case diff --git a/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs b/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs index f4d2e870e..c062c7b47 100644 --- a/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs +++ b/unison-cli/src/Unison/Cli/UnisonConfigUtils.hs @@ -1,7 +1,6 @@ -- | @.unisonConfig@ file utilities module Unison.Cli.UnisonConfigUtils - ( gitUrlKey, - remoteMappingKey, + ( remoteMappingKey, resolveConfiguredUrl, ) where @@ -33,9 +32,6 @@ configKey k p = NameSegment.toEscapedText (Path.toSeq $ Path.unabsolute p) -gitUrlKey :: Path.Absolute -> Text -gitUrlKey = configKey "GitUrl" - remoteMappingKey :: Path.Absolute -> Text remoteMappingKey = configKey "RemoteMapping" @@ -46,13 +42,7 @@ resolveConfiguredUrl :: PushPull -> Path' -> Cli (WriteRemoteNamespace Void) resolveConfiguredUrl pushPull destPath' = do destPath <- Cli.resolvePath' destPath' whenNothingM (remoteMappingForPath pushPull destPath) do - let gitUrlConfigKey = gitUrlKey destPath - -- Fall back to deprecated GitUrl key - Cli.getConfig gitUrlConfigKey >>= \case - Just url -> - (WriteRemoteNamespaceGit <$> P.parse UriParser.deprecatedWriteGitRemoteNamespace (Text.unpack gitUrlConfigKey) url) & onLeft \err -> - Cli.returnEarly (ConfiguredRemoteMappingParseError pushPull destPath url (show err)) - Nothing -> Cli.returnEarly (NoConfiguredRemoteMapping pushPull destPath) + Cli.returnEarly (NoConfiguredRemoteMapping pushPull destPath) -- | Tries to look up a remote mapping for a given path. -- Will also resolve paths relative to any mapping which is configured for a parent of that diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 088062ce2..ee8c15079 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -78,7 +78,7 @@ import Unison.Codebase.Editor.HandleInput.ProjectRename (handleProjectRename) import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch) import Unison.Codebase.Editor.HandleInput.Projects (handleProjects) import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch) -import Unison.Codebase.Editor.HandleInput.Push (handleGist, handlePushRemoteBranch) +import Unison.Codebase.Editor.HandleInput.Push (handlePushRemoteBranch) import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft) import Unison.Codebase.Editor.HandleInput.Run (handleRun) import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils @@ -958,7 +958,6 @@ loop e = do Cli.respond output UpdateBuiltinsI -> Cli.respond NotImplemented QuitI -> Cli.haltRepl - GistI input -> handleGist input AuthLoginI -> void $ authLogin (Codeserver.resolveCodeserver RemoteRepo.DefaultCodeserver) VersionI -> do Cli.Env {ucmVersion} <- ask @@ -1118,7 +1117,6 @@ inputDescription input = FindShallowI {} -> wat StructuredFindI {} -> wat StructuredFindReplaceI {} -> wat - GistI {} -> wat HistoryI {} -> wat LibInstallI {} -> wat ListDependenciesI {} -> wat diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index d6685f105..b17ded709 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -43,7 +43,7 @@ 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 (..), MergeSourceOrTarget (..), MergeSourceAndTarget (..)) +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 @@ -61,7 +61,7 @@ import Unison.Codebase.Editor.HandleInput.Update2 typecheckedUnisonFileToBranchAdds, ) import Unison.Codebase.Editor.Output qualified as Output -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadShareLooseCode (..)) +import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode (..)) import Unison.Codebase.Path (Path) import Unison.Codebase.Path qualified as Path import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache) @@ -220,7 +220,7 @@ doMerge info = do let aliceBranchNames = ProjectAndBranch info.alice.project.name info.alice.projectBranch.name let mergeSource = MergeSourceOrTarget'Source info.bob.source let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames - let mergeSourceAndTarget = MergeSourceAndTarget { alice = aliceBranchNames, bob = info.bob.source } + let mergeSourceAndTarget = MergeSourceAndTarget {alice = aliceBranchNames, bob = info.bob.source} Cli.Env {codebase} <- ask @@ -407,10 +407,6 @@ doMerge info = do case Path.toName info.path of Nothing -> "" Just name -> Name.toText name - MergeSource'RemoteGitRepo info -> - case Path.toName info.path of - Nothing -> "" - Just name -> Name.toText name } renderedConflicts renderedDependents @@ -854,7 +850,6 @@ findTemporaryBranchName projectId mergeSourceAndTarget = do MergeSource'LocalProjectBranch (ProjectAndBranch _project branch) -> mangleBranchName branch MergeSource'RemoteProjectBranch (ProjectAndBranch _project branch) -> "remote-" <> mangleBranchName branch MergeSource'RemoteLooseCode info -> manglePath info.path - MergeSource'RemoteGitRepo info -> manglePath info.path mangleBranchName :: ProjectBranchName -> Text.Builder mangleBranchName name = case classifyProjectBranchName name of diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 3bf286d99..d10a2bc39 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -57,17 +57,7 @@ handlePull unresolvedSourceAndTarget pullMode = do (source, target) <- resolveSourceAndTarget includeSquashed unresolvedSourceAndTarget remoteCausalHash <- do - Cli.Env {codebase} <- ask case source of - ReadRemoteNamespaceGit repo -> do - downloadLooseCodeFromGitRepo - codebase - ( case pullMode of - Input.PullWithHistory -> GitNamespaceHistoryTreatment'LetAlone - Input.PullWithoutHistory -> GitNamespaceHistoryTreatment'DiscardAllHistory - ) - repo - & onLeftM (Cli.returnEarly . Output.GitError) ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError) ReadShare'ProjectBranch remoteBranch -> downloadProjectBranchFromShare @@ -136,7 +126,6 @@ handlePull unresolvedSourceAndTarget pullMode = do ReadShare'ProjectBranch remoteBranch -> MergeSource'RemoteProjectBranch (ProjectAndBranch remoteBranch.projectName remoteBranch.branchName) ReadShare'LooseCode info -> MergeSource'RemoteLooseCode info - ReadRemoteNamespaceGit info -> MergeSource'RemoteGitRepo info }, lca = LcaMergeInfo @@ -209,7 +198,6 @@ resolveExplicitSource :: ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease) -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch) resolveExplicitSource includeSquashed = \case - ReadRemoteNamespaceGit namespace -> pure (ReadRemoteNamespaceGit namespace) ReadShare'LooseCode namespace -> pure (ReadShare'LooseCode namespace) ReadShare'ProjectBranch (This remoteProjectName) -> do remoteProject <- ProjectUtils.expectRemoteProjectByName remoteProjectName diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs index 3c68d0ebf..c5e5d1007 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs @@ -1,13 +1,11 @@ -- | @push@ input handler module Unison.Codebase.Editor.HandleInput.Push - ( handleGist, - handlePushRemoteBranch, + ( handlePushRemoteBranch, ) where import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO) import Control.Lens (over, view, (.~), (^.), _1, _2) -import Control.Monad.Reader (ask) import Data.Set.NonEmpty qualified as Set.NonEmpty import Data.Text as Text import Data.These (These (..)) @@ -26,13 +24,9 @@ import Unison.Cli.MonadUtils qualified as Cli import Unison.Cli.ProjectUtils qualified as ProjectUtils import Unison.Cli.Share.Projects qualified as Share import Unison.Cli.UnisonConfigUtils qualified as UnisonConfigUtils -import Unison.Codebase qualified as Codebase -import Unison.Codebase.Branch (Branch (..)) -import Unison.Codebase.Branch qualified as Branch import Unison.Codebase.Editor.HandleInput.AuthLogin qualified as AuthLogin import Unison.Codebase.Editor.Input - ( GistInput (..), - PushRemoteBranchInput (..), + ( PushRemoteBranchInput (..), PushSource (..), PushSourceTarget (..), ) @@ -40,20 +34,13 @@ import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.Editor.Output.PushPull (PushPull (Push)) import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRemoteNamespace (..), - ReadRemoteNamespace (..), - WriteGitRemoteNamespace (..), - WriteRemoteNamespace (..), + ( WriteRemoteNamespace (..), WriteShareRemoteNamespace (..), - writeToReadGit, ) import Unison.Codebase.Path qualified as Path import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.PushBehavior qualified as PushBehavior -import Unison.Codebase.ShortCausalHash qualified as SCH -import Unison.Codebase.Type (GitPushBehavior (..)) import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName)) -import Unison.Hash qualified as Hash import Unison.Hash32 (Hash32) import Unison.Hash32 qualified as Hash32 import Unison.NameSegment (NameSegment (..)) @@ -76,25 +63,6 @@ import Unison.Sqlite qualified as Sqlite import Unison.Sync.Types qualified as Share import Witch (unsafeFrom) --- | Handle a @gist@ command. -handleGist :: GistInput -> Cli () -handleGist (GistInput repo) = do - Cli.Env {codebase} <- ask - sourceBranch <- Cli.getCurrentBranch - result <- - Cli.ioE (Codebase.pushGitBranch codebase repo GitPushBehaviorGist (\_remoteRoot -> pure (Right sourceBranch))) \err -> - Cli.returnEarly (Output.GitError err) - _branch <- result & onLeft Cli.returnEarly - schLength <- Cli.runTransaction Codebase.branchHashLength - Cli.respond $ - GistCreated $ - ReadRemoteNamespaceGit - ReadGitRemoteNamespace - { repo = writeToReadGit repo, - sch = Just (SCH.fromHash schLength (Branch.headHash sourceBranch)), - path = Path.empty - } - -- | Handle a @push@ command. handlePushRemoteBranch :: PushRemoteBranchInput -> Cli () handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do @@ -105,7 +73,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do Nothing -> do localPath <- Cli.getCurrentPath UnisonConfigUtils.resolveConfiguredUrl Push Path.currentPath >>= \case - WriteRemoteNamespaceGit namespace -> pushLooseCodeToGitLooseCode localPath namespace pushBehavior WriteRemoteNamespaceShare namespace -> pushLooseCodeToShareLooseCode localPath namespace pushBehavior WriteRemoteProjectBranch v -> absurd v Just (localProjectAndBranch, _restPath) -> @@ -113,10 +80,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do force localProjectAndBranch Nothing - -- push to .some.path (git) - PushSourceTarget1 (WriteRemoteNamespaceGit namespace) -> do - localPath <- Cli.getCurrentPath - pushLooseCodeToGitLooseCode localPath namespace pushBehavior -- push to .some.path (share) PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do localPath <- Cli.getCurrentPath @@ -130,10 +93,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch Just (localProjectAndBranch, _restPath) -> pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0) - -- push .some.path to .some.path (git) - PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceGit namespace) -> do - localPath <- Cli.resolvePath' localPath0 - pushLooseCodeToGitLooseCode localPath namespace pushBehavior -- push .some.path to .some.path (share) PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do localPath <- Cli.resolvePath' localPath0 @@ -143,13 +102,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do localPath <- Cli.resolvePath' localPath0 remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0 pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch - -- push @some/project to .some.path (git) - PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceGit namespace) -> do - ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0 - pushLooseCodeToGitLooseCode - (ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId))) - namespace - pushBehavior -- push @some/project to .some.path (share) PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceShare namespace) -> do ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0 @@ -168,49 +120,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do PushBehavior.RequireEmpty -> False PushBehavior.RequireNonEmpty -> False --- Push a local namespace ("loose code") to a Git-hosted remote namespace ("loose code"). -pushLooseCodeToGitLooseCode :: Path.Absolute -> WriteGitRemoteNamespace -> PushBehavior -> Cli () -pushLooseCodeToGitLooseCode localPath gitRemotePath pushBehavior = do - sourceBranch <- Cli.getBranchAt localPath - let withRemoteRoot :: Branch IO -> Either Output (Branch IO) - withRemoteRoot remoteRoot = do - let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if - -- this rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` - -- already. - f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing - case Branch.modifyAtM (gitRemotePath ^. #path) f remoteRoot of - Nothing -> Left (RefusedToPush pushBehavior (WriteRemoteNamespaceGit gitRemotePath)) - Just newRemoteRoot -> Right newRemoteRoot - let behavior = - case pushBehavior of - PushBehavior.ForcePush -> GitPushBehaviorForce - PushBehavior.RequireEmpty -> GitPushBehaviorFf - PushBehavior.RequireNonEmpty -> GitPushBehaviorFf - Cli.Env {codebase} <- ask - let push = - Codebase.pushGitBranch - codebase - (gitRemotePath ^. #repo) - behavior - (\remoteRoot -> pure (withRemoteRoot remoteRoot)) - result <- - liftIO push & onLeftM \err -> - Cli.returnEarly (Output.GitError err) - _branch <- result & onLeft Cli.returnEarly - Cli.respond Success - where - -- Per `pushBehavior`, we are either: - -- - -- (1) force-pushing, in which case the remote branch state doesn't matter - -- (2) updating an empty branch, which fails if the branch isn't empty (`push.create`) - -- (3) updating a non-empty branch, which fails if the branch is empty (`push`) - shouldPushTo :: PushBehavior -> Branch m -> Bool - shouldPushTo pushBehavior remoteBranch = - case pushBehavior of - PushBehavior.ForcePush -> True - PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch) - PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) - -- Push a local namespace ("loose code") to a Share-hosted remote namespace ("loose code"). pushLooseCodeToShareLooseCode :: Path.Absolute -> WriteShareRemoteNamespace -> PushBehavior -> Cli () pushLooseCodeToShareLooseCode _ _ _ = do @@ -656,7 +565,6 @@ makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do Cli.respond (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames) Cli.returnEarly (ViewOnShare (Right (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName))) - when (not force) do whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do Cli.returnEarly (RemoteProjectBranchHeadMismatch Share.hardCodedUri remoteProjectAndBranchNames) diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 4f0e384da..56acd83e9 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -1,7 +1,6 @@ module Unison.Codebase.Editor.Input ( Input (..), BranchSourceI (..), - GistInput (..), PullSourceTarget (..), PushRemoteBranchInput (..), PushSourceTarget (..), @@ -32,7 +31,7 @@ import Data.List.NonEmpty (NonEmpty) import Data.Text qualified as Text import Data.These (These) import Unison.Codebase.Branch.Merge qualified as Branch -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace) import Unison.Codebase.Path (Path, Path') import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path @@ -210,7 +209,6 @@ data Input | UiI Path' | DocToMarkdownI Name | DocsToHtmlI Path' FilePath - | GistI GistInput | AuthLoginI | VersionI | ProjectCreateI Bool {- try downloading base? -} (Maybe ProjectName) @@ -239,12 +237,6 @@ data BranchSourceI BranchSourceI'LooseCodeOrProject LooseCodeOrProject deriving stock (Eq, Show) --- | @"push.gist repo"@ pushes the contents of the current namespace to @repo@. -data GistInput = GistInput - { repo :: WriteGitRepo - } - deriving stock (Eq, Show) - -- | Pull source and target: either neither is specified, or only a source, or both. data PullSourceTarget = PullSourceTarget0 diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 421f39121..1f2cb3864 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -27,7 +27,7 @@ import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import Unison.Auth.Types (CredentialFailure) -import Unison.Cli.MergeTypes (MergeSourceOrTarget, MergeSourceAndTarget) +import Unison.Cli.MergeTypes (MergeSourceAndTarget, MergeSourceOrTarget) import Unison.Cli.Share.Projects.Types qualified as Share import Unison.Codebase.Editor.Input import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) @@ -44,7 +44,6 @@ import Unison.Codebase.PushBehavior (PushBehavior) import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH -import Unison.Codebase.Type (GitError) import Unison.CommandLine.InputPattern qualified as Input import Unison.DataDeclaration qualified as DD import Unison.DataDeclaration.ConstructorId (ConstructorId) @@ -261,7 +260,6 @@ data Output -- todo: eventually replace these sets with [SearchResult' v Ann] -- and a nicer render. BustedBuiltins (Set Reference) (Set Reference) - | GitError GitError | ShareError ShareError | ViewOnShare (Either WriteShareRemoteNamespace (URI, ProjectName, ProjectBranchName)) | NoConfiguredRemoteMapping PushPull Path.Absolute @@ -529,7 +527,6 @@ isFailure o = case o of TestIncrementalOutputEnd {} -> False TestResults _ _ _ _ _ fails -> not (null fails) CantUndo {} -> True - GitError {} -> True BustedBuiltins {} -> True NoConfiguredRemoteMapping {} -> True ConfiguredRemoteMappingParseError {} -> True diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 5ae4bf1ca..707042285 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -1,36 +1,26 @@ module Unison.Codebase.Editor.UriParser ( readRemoteNamespaceParser, - writeGitRepo, - deprecatedWriteGitRemoteNamespace, writeRemoteNamespace, writeRemoteNamespaceWith, parseReadShareLooseCode, ) where -import Data.Char (isAlphaNum, isDigit, isSpace) -import Data.Sequence as Seq +import Data.Char (isAlphaNum) import Data.Text qualified as Text import Data.These (These) import Data.Void import Text.Megaparsec qualified as P import Text.Megaparsec.Char qualified as C -import U.Util.Base32Hex qualified as Base32Hex import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRemoteNamespace (..), - ReadGitRepo (..), - ReadRemoteNamespace (..), + ( ReadRemoteNamespace (..), ReadShareLooseCode (..), ShareCodeserver (DefaultCodeserver), ShareUserHandle (..), - WriteGitRemoteNamespace (..), - WriteGitRepo (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..), ) -import Unison.Codebase.Path (Path (..)) import Unison.Codebase.Path qualified as Path -import Unison.Codebase.ShortCausalHash (ShortCausalHash (..)) import Unison.NameSegment (NameSegment (..)) import Unison.Prelude import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser) @@ -41,28 +31,9 @@ import Unison.Util.Pretty.MegaParsec qualified as P type P = P.Parsec Void Text.Text --- Here are the git protocols that we know how to parse --- Local Protocol - --- $ git clone /srv/git/project.git - --- $ git clone /srv/git/project.git[:treeish][:[#hash][.path]] --- File Protocol - --- $ git clone file:///srv/git/project.git[:treeish][:[#hash][.path]] --- Smart / Dumb HTTP protocol - --- $ git clone https://example.com/gitproject.git[:treeish][:[#hash][.path]] --- SSH Protocol - --- $ git clone ssh://[user@]server/project.git[:treeish][:[#hash][.path]] - --- $ git clone [user@]server:project.git[:treeish][:[#hash][.path]] - readRemoteNamespaceParser :: ProjectBranchSpecifier branch -> P (ReadRemoteNamespace (These ProjectName branch)) readRemoteNamespaceParser specifier = - ReadRemoteNamespaceGit <$> readGitRemoteNamespace - <|> ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier + ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier <|> ReadShare'LooseCode <$> readShareLooseCode projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths :: @@ -81,9 +52,7 @@ parseReadShareLooseCode label input = in first printError (P.parse readShareLooseCode label (Text.pack input)) -- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4" --- >>> P.parseMaybe writeRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3" -- Just (WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})) --- Just (WriteRemoteNamespaceGit (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "git@github.com:unisonweb/base", branch = Just "v3"}, path = _releases.M3})) writeRemoteNamespace :: P (WriteRemoteNamespace (These ProjectName ProjectBranchName)) writeRemoteNamespace = writeRemoteNamespaceWith @@ -91,8 +60,7 @@ writeRemoteNamespace = writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a) writeRemoteNamespaceWith projectBranchParser = - WriteRemoteNamespaceGit <$> writeGitRemoteNamespace - <|> WriteRemoteProjectBranch <$> projectBranchParser + WriteRemoteProjectBranch <$> projectBranchParser <|> WriteRemoteNamespaceShare <$> writeShareRemoteNamespace -- >>> P.parseMaybe writeShareRemoteNamespace "unisonweb.base._releases.M4" @@ -130,252 +98,15 @@ shareUserHandle :: P ShareUserHandle shareUserHandle = do ShareUserHandle . Text.pack <$> P.some (P.satisfy \c -> isAlphaNum c || c == '-' || c == '_') --- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf" --- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf." --- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)" --- >>> P.parseMaybe readGitRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3" --- >>> P.parseMaybe readGitRemoteNamespace "git( user@server:project.git:branch )#asdf.foo.bar" --- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = }) --- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = }) --- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Nothing, path = }) --- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "git@github.com:unisonweb/base", ref = Just "v3"}, sch = Nothing, path = _releases.M3}) --- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = foo.bar}) -readGitRemoteNamespace :: P ReadGitRemoteNamespace -readGitRemoteNamespace = P.label "generic git repo" $ do - C.string "git(" - protocol <- parseGitProtocol - treeish <- P.optional gitTreeishSuffix - let repo = ReadGitRepo {url = printProtocol protocol, ref = treeish} - C.string ")" - nshashPath <- P.optional namespaceHashPath - pure case nshashPath of - Nothing -> ReadGitRemoteNamespace {repo, sch = Nothing, path = Path.empty} - Just (sch, path) -> ReadGitRemoteNamespace {repo, sch, path} - --- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git)" --- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git:branch)" --- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Nothing}) --- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"}) --- --- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git)" --- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git:branch)" --- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing}) --- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"}) --- --- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git)" --- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git:base)" --- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing}) --- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"}) --- --- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git)" --- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git:branch)" --- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git)" --- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git:branch)" --- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing}) --- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"}) --- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Nothing}) --- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"}) --- --- >>> P.parseMaybe writeGitRepo "git(server:project)" --- >>> P.parseMaybe writeGitRepo "git(user@server:project.git:branch)" --- Just (WriteGitRepo {url = "server:project", branch = Nothing}) --- Just (WriteGitRepo {url = "user@server:project.git", branch = Just "branch"}) -writeGitRepo :: P WriteGitRepo -writeGitRepo = P.label "repo root for writing" $ do - C.string "git(" - uri <- parseGitProtocol - treeish <- P.optional gitTreeishSuffix - C.string ")" - pure WriteGitRepo {url = printProtocol uri, branch = treeish} - --- | A parser for the deprecated format of git URLs, which may still exist in old GitURL --- unisonConfigs. --- --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "/srv/git/project.git:.namespace" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "/srv/git/project.git:branch:.namespace" --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "/srv/git/project.git", branch = Nothing}, path = namespace}) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"}, path = namespace}) --- --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "file:///srv/git/project.git" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "file:///srv/git/project.git:branch" --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing}, path = }) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"}, path = }) --- --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "https://example.com/gitproject.git" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "https://example.com/gitproject.git:base" --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing}, path = }) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"}, path = }) --- --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://user@server/project.git" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://user@server/project.git:branch" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://server/project.git" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://server/project.git:branch" --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing}, path = }) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"}, path = }) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://server/project.git", branch = Nothing}, path = }) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"}, path = }) --- --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "server:project" --- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "user@server:project.git:branch" --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "server:project", branch = Nothing}, path = }) --- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "user@server:project.git", branch = Just "branch"}, path = }) -deprecatedWriteGitRemoteNamespace :: P WriteGitRemoteNamespace -deprecatedWriteGitRemoteNamespace = P.label "generic write repo" $ do - repo <- deprecatedWriteGitRepo - path <- P.optional (C.char ':' *> absolutePath) - pure WriteGitRemoteNamespace {repo, path = fromMaybe Path.empty path} - where - deprecatedWriteGitRepo :: P WriteGitRepo - deprecatedWriteGitRepo = do - P.label "repo root for writing" $ do - uri <- parseGitProtocol - treeish <- P.optional deprecatedTreeishSuffix - pure WriteGitRepo {url = printProtocol uri, branch = treeish} - deprecatedTreeishSuffix :: P Text - deprecatedTreeishSuffix = P.label "git treeish" . P.try $ do - void $ C.char ':' - notdothash <- P.noneOf @[] ".#:" - rest <- P.takeWhileP (Just "not colon") (/= ':') - pure $ Text.cons notdothash rest - --- git(myrepo@git.com).foo.bar -writeGitRemoteNamespace :: P WriteGitRemoteNamespace -writeGitRemoteNamespace = P.label "generic write repo" $ do - repo <- writeGitRepo - path <- P.optional absolutePath - pure WriteGitRemoteNamespace {repo, path = fromMaybe Path.empty path} - -data GitProtocol - = HttpsProtocol (Maybe User) HostInfo UrlPath - | SshProtocol (Maybe User) HostInfo UrlPath - | ScpProtocol (Maybe User) Host UrlPath - | FileProtocol UrlPath - | LocalProtocol UrlPath - deriving (Eq, Ord, Show) - -printProtocol :: GitProtocol -> Text --- printProtocol x | traceShow x False = undefined -printProtocol x = case x of - HttpsProtocol muser hostInfo path -> - "https://" - <> printUser muser - <> printHostInfo hostInfo - <> path - SshProtocol muser hostInfo path -> - "ssh://" - <> printUser muser - <> printHostInfo hostInfo - <> path - ScpProtocol muser host path -> printUser muser <> host <> ":" <> path - FileProtocol path -> "file://" <> path - LocalProtocol path -> path - where - printUser = maybe mempty (\(User u) -> u <> "@") - printHostInfo :: HostInfo -> Text - printHostInfo (HostInfo hostname mport) = - hostname <> maybe mempty (Text.cons ':') mport - data Scheme = Ssh | Https deriving (Eq, Ord, Show) data User = User Text deriving (Eq, Ord, Show) -type UrlPath = Text - data HostInfo = HostInfo Text (Maybe Text) deriving (Eq, Ord, Show) -type Host = Text -- no port - --- doesn't yet handle basic authentication like https://user:pass@server.com --- (does anyone even want that?) --- or handle ipv6 addresses (https://en.wikipedia.org/wiki/IPv6#Addressing) -parseGitProtocol :: P GitProtocol -parseGitProtocol = - P.label "parseGitProtocol" $ - fileRepo <|> httpsRepo <|> sshRepo <|> scpRepo <|> localRepo - where - localRepo, fileRepo, httpsRepo, sshRepo, scpRepo :: P GitProtocol - parsePath = - P.takeWhile1P - (Just "repo path character") - (\c -> not (isSpace c || c == ':' || c == ')')) - localRepo = LocalProtocol <$> parsePath - fileRepo = P.label "fileRepo" $ do - void $ C.string "file://" - FileProtocol <$> parsePath - httpsRepo = P.label "httpsRepo" $ do - void $ C.string "https://" - HttpsProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath - sshRepo = P.label "sshRepo" $ do - void $ C.string "ssh://" - SshProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath - scpRepo = - P.label "scpRepo" . P.try $ - ScpProtocol <$> P.optional userInfo <*> parseHost <* C.string ":" <*> parsePath - userInfo :: P User - userInfo = P.label "userInfo" . P.try $ do - username <- P.takeWhile1P (Just "username character") (/= '@') - void $ C.char '@' - pure $ User username - parseHostInfo :: P HostInfo - parseHostInfo = - P.label "parseHostInfo" $ - HostInfo - <$> parseHost - <*> ( P.optional $ do - void $ C.char ':' - P.takeWhile1P (Just "digits") isDigit - ) - - parseHost = P.label "parseHost" $ hostname <|> ipv4 -- <|> ipv6 - where - hostname = - P.takeWhile1P - (Just "hostname character") - (\c -> isAlphaNum c || c == '.' || c == '-') - ipv4 = P.label "ipv4 address" $ do - o1 <- decOctet - void $ C.char '.' - o2 <- decOctet - void $ C.char '.' - o3 <- decOctet - void $ C.char '.' - o4 <- decOctet - pure $ Text.pack $ o1 <> "." <> o2 <> "." <> o3 <> "." <> o4 - decOctet = P.count' 1 3 C.digitChar - --- >>> P.parseMaybe namespaceHashPath "#nshashabc.path.foo.bar" --- Just (Just #nshashabc,path.foo.bar) --- --- >>> P.parseMaybe namespaceHashPath ".path.foo.bar" --- Just (Nothing,path.foo.bar) --- --- >>> P.parseMaybe namespaceHashPath "#nshashabc" --- Just (Just #nshashabc,) --- --- >>> P.parseMaybe namespaceHashPath "#nshashabc." --- Just (Just #nshashabc,) --- --- >>> P.parseMaybe namespaceHashPath "." --- Just (Nothing,) -namespaceHashPath :: P (Maybe ShortCausalHash, Path) -namespaceHashPath = do - sch <- P.optional shortCausalHash - p <- P.optional absolutePath - pure (sch, fromMaybe Path.empty p) - --- >>> P.parseMaybe absolutePath "." --- Just --- --- >>> P.parseMaybe absolutePath ".path.foo.bar" --- Just path.foo.bar -absolutePath :: P Path -absolutePath = do - void $ C.char '.' - Path . Seq.fromList <$> P.sepBy nameSegment (C.char '.') - nameSegment :: P NameSegment nameSegment = NameSegment.unsafeParseText . Text.pack @@ -383,14 +114,3 @@ nameSegment = <$> P.satisfy Unison.Syntax.Lexer.wordyIdStartChar <*> P.many (P.satisfy Unison.Syntax.Lexer.wordyIdChar) ) - -gitTreeishSuffix :: P Text -gitTreeishSuffix = P.label "git treeish" . P.try $ do - void $ C.char ':' - P.takeWhile1P (Just "not close paren") (/= ')') - -shortCausalHash :: P ShortCausalHash -shortCausalHash = P.label "short causal hash" $ do - void $ C.char '#' - ShortCausalHash - <$> P.takeWhile1P (Just "base32hex chars") (`elem` Base32Hex.validChars) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 661550644..6335e2808 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -64,7 +64,6 @@ module Unison.CommandLine.InputPatterns findVerbose, findVerboseAll, forkLocal, - gist, help, helpTopics, history, @@ -163,8 +162,7 @@ import Unison.Codebase.Branch.Merge qualified as Branch import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input) import Unison.Codebase.Editor.Input qualified as Input import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push)) -import Unison.Codebase.Editor.Output.PushPull qualified as PushPull -import Unison.Codebase.Editor.RemoteRepo (WriteGitRepo, WriteRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (WriteRemoteNamespace) import Unison.Codebase.Editor.SlurpResult qualified as SR import Unison.Codebase.Editor.UriParser (readRemoteNamespaceParser) import Unison.Codebase.Editor.UriParser qualified as UriParser @@ -200,6 +198,7 @@ import Unison.Syntax.Name qualified as Name (parseText, unsafeParseText) import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr, segmentP) import Unison.Util.ColorText qualified as CT import Unison.Util.Monoid (intercalateMap) +import Unison.Util.Monoid qualified as Monoid import Unison.Util.Pretty qualified as P import Unison.Util.Pretty.MegaParsec (prettyPrintParseError) @@ -2576,34 +2575,6 @@ createAuthor = _ -> Left $ showPatternHelp createAuthor ) -gist :: InputPattern -gist = - InputPattern - "push.gist" - ["gist"] - I.Visible - [("repository", Required, gitUrlArg)] - ( P.lines - [ "Publish the current namespace.", - "", - P.wrapColumn2 - [ ( "`gist git(git@github.com:user/repo)`", - "publishes the contents of the current namespace into the specified git repo." - ) - ], - "", - P.indentN 2 . P.wrap $ - "Note: Gists are not yet supported on Unison Share, though you can just do a normal" - <> "`push.create` of the current namespace to your Unison Share codebase wherever you like!" - ] - ) - ( \case - [repoString] -> do - repo <- parseWriteGitRepo "gist git repo" repoString - pure (Input.GistI (Input.GistInput repo)) - _ -> Left (showPatternHelp gist) - ) - authLogin :: InputPattern authLogin = InputPattern @@ -2974,7 +2945,6 @@ validInputs = sfind, sfindReplace, forkLocal, - gist, help, helpTopics, history, @@ -3166,39 +3136,12 @@ filePathArg = fzfResolver = Nothing } --- Arya: I could imagine completions coming from previous pulls -gitUrlArg :: ArgumentType -gitUrlArg = - ArgumentType - { typeName = "git-url", - suggestions = - let complete s = pure [Completion s s False] - in \input _ _ _ -> case input of - "gh" -> complete "git(https://github.com/" - "gl" -> complete "git(https://gitlab.com/" - "bb" -> complete "git(https://bitbucket.com/" - "ghs" -> complete "git(git@github.com:" - "gls" -> complete "git(git@gitlab.com:" - "bbs" -> complete "git(git@bitbucket.com:" - _ -> pure [], - fzfResolver = Nothing - } - -- | Refers to a namespace on some remote code host. remoteNamespaceArg :: ArgumentType remoteNamespaceArg = ArgumentType { typeName = "remote-namespace", - suggestions = - let complete s = pure [Completion s s False] - in \input _cb http _p -> case input of - "gh" -> complete "git(https://github.com/" - "gl" -> complete "git(https://gitlab.com/" - "bb" -> complete "git(https://bitbucket.com/" - "ghs" -> complete "git(git@github.com:" - "gls" -> complete "git(git@gitlab.com:" - "bbs" -> complete "git(git@bitbucket.com:" - _ -> sharePathCompletion http input, + suggestions = \input _cb http _p -> sharePathCompletion http input, fzfResolver = Nothing } @@ -3655,27 +3598,18 @@ parseHashQualifiedName s = Right $ HQ.parseText (Text.pack s) -parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitRepo -parseWriteGitRepo label input = do - first - (fromString . show) -- turn any parsing errors into a Pretty. - (Megaparsec.parse (UriParser.writeGitRepo <* Megaparsec.eof) label (Text.pack input)) - explainRemote :: PushPull -> P.Pretty CT.ColorText explainRemote pushPull = P.group $ P.lines - [ P.wrap $ "where `remote` is a hosted codebase, such as:", + [ P.wrap $ "where `remote` is a project or project branch, such as:", P.indentN 2 . P.column2 $ - [ ("Unison Share", P.backticked "user.public.some.remote.path"), - ("Git + root", P.backticked $ "git(" <> gitRepo <> "user/repo)"), - ("Git + path", P.backticked $ "git(" <> gitRepo <> "user/repo).some.remote.path"), - ("Git + branch", P.backticked $ "git(" <> gitRepo <> "user/repo:some-branch)"), - ("Git + branch + path", P.backticked $ "git(" <> gitRepo <> "user/repo:some-branch).some.remote.path") + [ ("Project (defaults to the /main branch)", P.backticked "@unison/base"), + ("Project Branch", P.backticked "@unison/base/feature"), + ("Contributor Branch", P.backticked "@unison/base/@johnsmith/feature") ] + <> Monoid.whenM (pushPull == Pull) [("Project Release", P.backticked "@unison/base/releases/1.0.0")] ] - where - gitRepo = PushPull.fold @(P.Pretty P.ColorText) "git@github.com:" "https://github.com/" pushPull megaparse :: Megaparsec.Parsec Void Text a -> Text -> Either (P.Pretty P.ColorText) a megaparse parser input = diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index a56b7faab..6f0070da1 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -35,7 +35,6 @@ import U.Codebase.Branch (NamespaceStats (..)) import U.Codebase.Branch.Diff (NameChanges (..)) import U.Codebase.HashTags (CausalHash (..)) import U.Codebase.Reference qualified as Reference -import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import Unison.ABT qualified as ABT @@ -63,7 +62,6 @@ import Unison.Codebase.Editor.RemoteRepo (ShareUserHandle (..), WriteRemoteNames import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult import Unison.Codebase.Editor.TodoOutput qualified as TO -import Unison.Codebase.GitError import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors) import Unison.Codebase.Patch (Patch (..)) import Unison.Codebase.Patch qualified as Patch @@ -73,9 +71,7 @@ import Unison.Codebase.Runtime qualified as Runtime import Unison.Codebase.ShortCausalHash (ShortCausalHash) import Unison.Codebase.ShortCausalHash qualified as SCH import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv -import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..)) import Unison.Codebase.TermEdit qualified as TermEdit -import Unison.Codebase.Type (GitError (GitCodebaseError, GitProtocolError, GitSqliteCodebaseError)) import Unison.Codebase.TypeEdit qualified as TypeEdit import Unison.CommandLine (bigproblem, note, tip) import Unison.CommandLine.FZFResolvers qualified as FZFResolvers @@ -1092,133 +1088,6 @@ notifyUser dir = \case pure . P.wrap $ "I loaded " <> P.text sourceName <> " and didn't find anything." else pure mempty - GitError e -> pure $ case e of - GitSqliteCodebaseError e -> case e of - CodebaseFileLockFailed -> - P.wrap $ - "It looks to me like another ucm process is using this codebase. Only one ucm process can use a codebase at a time." - NoDatabaseFile repo localPath -> - P.wrap $ - "I didn't find a codebase in the repository at" - <> prettyReadGitRepo repo - <> "in the cache directory at" - <> P.backticked' (P.string localPath) "." - CodebaseRequiresMigration (SchemaVersion fromSv) (SchemaVersion toSv) -> do - P.wrap $ - "The specified codebase codebase is on version " - <> P.shown fromSv - <> " but needs to be on version " - <> P.shown toSv - UnrecognizedSchemaVersion repo localPath (SchemaVersion v) -> - P.wrap $ - "I don't know how to interpret schema version " - <> P.shown v - <> "in the repository at" - <> prettyReadGitRepo repo - <> "in the cache directory at" - <> P.backticked' (P.string localPath) "." - GitCouldntParseRootBranchHash repo s -> - P.wrap $ - "I couldn't parse the string" - <> P.red (P.string s) - <> "into a namespace hash, when opening the repository at" - <> P.group (prettyReadGitRepo repo <> ".") - GitProtocolError e -> case e of - NoGit -> - P.wrap $ - "I couldn't find git. Make sure it's installed and on your path." - CleanupError e -> - P.wrap $ - "I encountered an exception while trying to clean up a git cache directory:" - <> P.group (P.shown e) - CloneException repo msg -> - P.wrap $ - "I couldn't clone the repository at" - <> prettyReadGitRepo repo - <> ";" - <> "the error was:" - <> (P.indentNAfterNewline 2 . P.group . P.string) msg - CopyException srcRepoPath destPath msg -> - P.wrap $ - "I couldn't copy the repository at" - <> P.string srcRepoPath - <> "into" - <> P.string destPath - <> ";" - <> "the error was:" - <> (P.indentNAfterNewline 2 . P.group . P.string) msg - PushNoOp repo -> - P.wrap $ - "The repository at" <> prettyWriteGitRepo repo <> "is already up-to-date." - PushException repo msg -> - P.wrap $ - "I couldn't push to the repository at" - <> prettyWriteGitRepo repo - <> ";" - <> "the error was:" - <> (P.indentNAfterNewline 2 . P.group . P.string) msg - RemoteRefNotFound repo ref -> - P.wrap $ - "I couldn't find the ref " <> P.green (P.text ref) <> " in the repository at " <> P.blue (P.text repo) <> ";" - UnrecognizableCacheDir uri localPath -> - P.wrap $ - "A cache directory for" - <> P.backticked (P.text $ RemoteRepo.printReadGitRepo uri) - <> "already exists at" - <> P.backticked' (P.string localPath) "," - <> "but it doesn't seem to" - <> "be a git repository, so I'm not sure what to do next. Delete it?" - UnrecognizableCheckoutDir uri localPath -> - P.wrap $ - "I tried to clone" - <> P.backticked (P.text $ RemoteRepo.printReadGitRepo uri) - <> "into a cache directory at" - <> P.backticked' (P.string localPath) "," - <> "but I can't recognize the" - <> "result as a git repository, so I'm not sure what to do next." - PushDestinationHasNewStuff repo -> - P.callout "⏸" . P.lines $ - [ P.wrap $ - "The repository at" - <> prettyWriteGitRepo repo - <> "has some changes I don't know about.", - "", - P.wrap $ "Try" <> pull <> "to merge these changes locally, then" <> push <> "again." - ] - where - push = P.group . P.backticked . IP.patternName $ IP.push - pull = P.group . P.backticked . IP.patternName $ IP.pull - GitCodebaseError e -> case e of - CouldntFindRemoteBranch repo path -> - P.wrap $ - "I couldn't find the remote branch at" - <> P.shown path - <> "in the repository at" - <> prettyReadGitRepo repo - NoRemoteNamespaceWithHash repo sch -> - P.wrap $ - "The repository at" - <> prettyReadGitRepo repo - <> "doesn't contain a namespace with the hash prefix" - <> (P.blue . P.text . SCH.toText) sch - RemoteNamespaceHashAmbiguous repo sch hashes -> - P.lines - [ P.wrap $ - "The namespace hash" - <> prettySCH sch - <> "at" - <> prettyReadGitRepo repo - <> "is ambiguous." - <> "Did you mean one of these hashes?", - "", - P.indentN 2 $ - P.lines - ( prettySCH . SCH.fromHash ((Text.length . SCH.toText) sch * 2) - <$> Set.toList hashes - ), - "", - P.wrap "Try again with a few more hash characters to disambiguate." - ] BustedBuiltins (Set.toList -> new) (Set.toList -> old) -> -- todo: this could be prettier! Have a nice list like `find` gives, but -- that requires querying the codebase to determine term types. Probably @@ -1267,7 +1136,7 @@ notifyUser dir = \case "Type `help " <> PushPull.fold "push" "pull" pp <> "` for more information." ] - -- | ConfiguredGitUrlParseError PushPull Path' Text String + -- | ConfiguredRemoteMappingParseError PushPull Path' Text String ConfiguredRemoteMappingParseError pp p url err -> pure . P.fatalCallout . P.lines $ [ P.wrap $ diff --git a/unison-cli/tests/Unison/Test/GitSync.hs b/unison-cli/tests/Unison/Test/GitSync.hs deleted file mode 100644 index a4a719a7b..000000000 --- a/unison-cli/tests/Unison/Test/GitSync.hs +++ /dev/null @@ -1,732 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ViewPatterns #-} - -module Unison.Test.GitSync where - -import Data.Maybe (fromJust) -import Data.String.Here.Interpolated (i) -import Data.Text qualified as Text -import EasyTest -import Shellmet () -import System.Directory (removePathForcibly) -import System.FilePath (()) -import System.IO.Temp qualified as Temp -import Unison.Codebase (Codebase) -import Unison.Codebase qualified as Codebase -import Unison.Parser.Ann (Ann) -import Unison.Prelude -import Unison.Symbol (Symbol) -import Unison.Test.Ucm (CodebaseFormat, Transcript) -import Unison.Test.Ucm qualified as Ucm -import Unison.WatchKind (pattern TestWatch) - -transcriptOutputFile :: String -> FilePath -transcriptOutputFile name = - (".." "unison-src" "transcripts" ("GitSync22." ++ name ++ ".output.md")) - --- keep it off for CI, since the random temp dirs it generates show up in the --- output, which causes the test output to change, and the "no change" check --- to fail -writeTranscriptOutput :: Bool -writeTranscriptOutput = False - -test :: Test () -test = - scope "gitsync22" . tests $ - fastForwardPush - : nonFastForwardPush - : destroyedRemote - : flip - map - [(Ucm.CodebaseFormat2, "sc")] - \(fmt, name) -> - scope name $ - tests - [ pushPullTest - "pull-over-deleted-namespace" - fmt - ( \repo -> - [i| - ```unison:hide - x = 1 - ``` - ```ucm:hide - .> add - .> push.create git(${repo}) - ``` - |] - ) - ( \repo -> - [i| - ```unison:hide - child.y = 2 - ``` - - Should be able to pull a branch from the repo over top of our deleted local branch. - ```ucm - .> add - .> delete.namespace child - .> pull git(${repo}) child - ``` - |] - ), - pushPullTest - "pull.without-history" - fmt - ( \repo -> - [i| - ```unison:hide - child.x = 1 - ``` - - ```ucm:hide - .> add - ``` - - ```unison:hide - child.y = 2 - ``` - - ```ucm:hide - .> add - ``` - - ```unison:hide - child.x = 3 - ``` - - ```ucm:hide - .> update - .> push.create git(${repo}) - ``` - |] - ) - ( \repo -> - [i| - Should be able to pull the branch from the remote without its history. - Note that this only tests that the pull succeeds, since (at time of writing) we don't - track/test transcript output for these tests in the unison repo. - ```ucm - .> pull.without-history git(${repo}):.child .child - .> history .child - ``` - |] - ), - pushPullTest - "push-over-deleted-namespace" - fmt - ( \repo -> - [i| - ```unison:hide - child.x = 1 - y = 2 - ``` - ```ucm:hide - .> add - .> delete.namespace child - .> push.create git(${repo}) - ``` - |] - ) - ( \repo -> - [i| - ```unison:hide - child.z = 3 - ``` - - Should be able to push a branch over top of a deleted remote branch. - ```ucm - .> add - .> push.create git(${repo}).child child - ``` - |] - ), - pushPullTest - "typeAlias" - fmt - ( \repo -> - [i| - ```ucm - .> alias.type ##Nat builtin.Nat - .> history - .> history builtin - .> push.create git(${repo}) - ``` - |] - ) - ( \repo -> - [i| - ```ucm - .> pull git(${repo}) - ``` - ```unison - x : Nat - x = 3 - ``` - |] - ), - pushPullTest - "topLevelTerm" - fmt - ( \repo -> - [i| - ```unison:hide - y = 3 - ``` - ```ucm - .> add - .> history - .> push.create git(${repo}) - ``` - |] - ) - ( \repo -> - [i| - ```ucm - .> pull git(${repo}) - .> find - ``` - ```unison - > y - ``` - |] - ), - pushPullTest - "subNamespace" - fmt - ( \repo -> - [i| - ```ucm - .> alias.type ##Nat builtin.Nat - ``` - ```unison - unique type a.b.C = C Nat - a.b.d = 4 - ``` - ```ucm - .> add - .> push.create git(${repo}) - ``` - |] - ) - ( \repo -> - [i| - ```ucm - .> pull.silent git(${repo}) - .> find - ``` - ```unison - > a.b.C.C a.b.d - ``` - |] - ), - pushPullTest - "accessPatch" - fmt - ( \repo -> - [i| - ```ucm - .> alias.type ##Nat builtin.Nat - ``` - ```unison:hide - unique type A = A Nat - foo = A.A 3 - ``` - ```ucm - .> debug.file - .> add - ``` - ```unison:hide - unique type A = A Nat Nat - foo = A.A 3 3 - ``` - ```ucm - .> debug.file - .> update - ``` - ```ucm - .> view.patch patch - .> push.create git(${repo}) - ``` - |] - ) - ( \repo -> - [i| - ```ucm - .> pull.silent git(${repo}) - .> view.patch patch - ``` - |] - ), - pushPullTest - "history" - fmt - ( \repo -> - [i| - ```unison - foo = 3 - ``` - ```ucm - .> add - ``` - ```unison - foo = 4 - ``` - ```ucm - .> update - .> history - .> push.create git(${repo}) - ``` - |] - ) - ( \repo -> - [i| - ```ucm - .> pull git(${repo}) - .> history - .> reset-root #l43v9nr16v - .> history - ``` - |] -- Not sure why this hash is here. - -- Is it to test `reset-root`? - -- Or to notice a change in hashing? - -- Or to test that two distinct points of history were pulled? - -- It would be great to not need the explicit hash here, - -- since it does change periodically. - -- Though, I guess that should also be rare, so maybe this is fine. - ), - pushPullTest - "one-term" - fmt - -- simplest-author - ( \repo -> - [i| - ```unison - c = 3 - ``` - ```ucm - .> debug.file - .myLib> add - .myLib> push.create git(${repo}) - ``` - |] - ) - -- simplest-user - ( \repo -> - [i| - ```ucm - .yourLib> pull git(${repo}) - ``` - ```unison - > c - ``` - |] - ), - pushPullTest - "one-type" - fmt - -- simplest-author - ( \repo -> - [i| - ```unison - structural type Foo = Foo - ``` - ```ucm - .myLib> debug.file - .myLib> add - .myLib> push.create git(${repo}) - ``` - |] - ) - -- simplest-user - ( \repo -> - [i| - ```ucm - .yourLib> pull git(${repo}) - ``` - ```unison - > Foo.Foo - ``` - |] - ), - pushPullTest - "patching" - fmt - ( \repo -> - [i| - ```ucm - .myLib> alias.term ##Nat.+ + - ``` - ```unison - improveNat x = x + 3 - ``` - ```ucm - .myLib> add - .myLib> ls - .myLib> move.namespace .myLib .workaround1552.myLib.v1 - .workaround1552.myLib> ls - .workaround1552.myLib> fork v1 v2 - .workaround1552.myLib.v2> - ``` - ```unison - improveNat x = x + 100 - ``` - ```ucm - .workaround1552.myLib.v2> update - .workaround1552.myLib> push.create git(${repo}) - ``` - |] - ) - ( \repo -> - [i| - ```ucm - .myApp> pull git(${repo}).v1 external.yourLib - .myApp> alias.term ##Nat.* * - ```` - ```unison - greatApp = improveNat 5 * improveNat 6 - > greatApp - ``` - ```ucm - .myApp> add - .myApp> pull git(${repo}).v2 external.yourLib - ``` - ```unison - > greatApp - ``` - ```ucm - .myApp> patch external.yourLib.patch - ``` - ```unison - > greatApp - ``` - |] - ), - -- TODO: remove the alias.type .defns.A A line once patch syncing is fixed - pushPullTest - "lightweightPatch" - fmt - ( \repo -> - [i| - ```ucm - .> builtins.merge - ``` - ```unison - structural type A = A Nat - structural type B = B Int - x = 3 - y = 4 - ``` - ```ucm - .defns> add - .patches> replace .defns.A .defns.B - .patches> alias.type .defns.A A - .patches> replace .defns.x .defns.y - .patches> push.create git(${repo}) - ``` - |] - ) - ( \repo -> - [i| - ```ucm - .> builtins.merge - .> pull git(${repo}) patches - .> view.patch patches.patch - ``` - |] - ), - watchPushPullTest - "test-watches" - fmt - ( \repo -> - [i| - ```ucm - .> builtins.merge - ``` - ```unison - test> pass = [Ok "Passed"] - ``` - ```ucm - .> add - .> push.create git(${repo}) - ``` - |] - ) - ( \repo -> - [i| - ```ucm - .> pull git(${repo}) - ``` - |] - ) - ( \cb -> do - Codebase.runTransaction cb do - void . fmap (fromJust . sequence) $ - traverse (Codebase.getWatch cb TestWatch) - =<< Codebase.watches TestWatch - ), - gistTest fmt, - pushPullBranchesTests fmt, - pushPullTest - "fix2068_a_" - fmt - -- this triggers - {- - gitsync22.sc.fix2068(a) EXCEPTION!!!: Called SqliteCodebase.setNamespaceRoot on unknown causal hash CausalHash (fromBase32Hex "codddvgt1ep57qpdkhe2j4pe1ehlpi5iitcrludtb8ves1aaqjl453onvfphqg83vukl7bbrj49itceqfob2b3alf47u4vves5s7pog") - CallStack (from HasCallStack): - error, called at src/Unison/Codebase/SqliteCodebase.hs:1072:17 in unison-parser-typechecker-0.0.0-6U6boimwb8GAC5qrhLfs8h:Unison.Codebase.SqliteCodebase - -} - ( \repo -> - [i| - ```ucm - .> alias.type ##Nat builtin.Nat2 - .> alias.type ##Int builtin.Int2 - .> push.create git(${repo}).foo.bar - ``` - |] - ) - ( \repo -> - [i| - ```ucm - .> pull git(${repo}) pulled - .> view pulled.foo.bar.builtin.Nat2 - .> view pulled.foo.bar.builtin.Int2 - ``` - |] - ), - pushPullTest - "fix2068_b_" - fmt - -- this triggers - {- - - gitsync22.sc.fix2068(b) EXCEPTION!!!: I couldn't find the hash ndn6fa85ggqtbgffqhd4d3bca2d08pgp3im36oa8k6p257aid90ovjq75htmh7lmg7akaqneva80ml1o21iscjmp9n1uc3lmqgg9rgg that I just synced to the cached copy of /private/var/folders/6m/p3szds2j67d8vwmxr51yrf5c0000gn/T/git-simple-1047398c149d3d5c/repo.git in "/Users/pchiusano/.cache/unisonlanguage/gitfiles/$x2F$private$x2F$var$x2F$folders$x2F$6m$x2F$p3szds2j67d8vwmxr51yrf5c0000gn$x2F$T$x2F$git-simple-1047398c149d3d5c$x2F$repo$dot$git". - CallStack (from HasCallStack): - error, called at src/Unison/Codebase/SqliteCodebase.hs:1046:13 in unison-parser-typechecker-0.0.0-6U6boimwb8GAC5qrhLfs8h:Unison.Codebase.SqliteCodebase - -} - ( \repo -> - [i| - ```ucm - .> alias.type ##Nat builtin.Nat2 - .> alias.type ##Int builtin.Int2 - .> push.create git(${repo}) - .> push.create git(${repo}).foo.bar - ``` - |] - ) - ( \repo -> - [i| - ```ucm - .> pull git(${repo}) pulled - .> view pulled.foo.bar.builtin.Nat2 - .> view pulled.foo.bar.builtin.Int2 - ``` - |] - ) - ] - -pushPullTest :: String -> CodebaseFormat -> (FilePath -> Transcript) -> (FilePath -> Transcript) -> Test () -pushPullTest name fmt authorScript userScript = scope name do - io do - repo <- initGitRepo - author <- Ucm.initCodebase fmt - authorOutput <- Ucm.runTranscript author (authorScript repo) - user <- Ucm.initCodebase fmt - userOutput <- Ucm.runTranscript user (userScript repo) - - when writeTranscriptOutput $ - writeUtf8 - (transcriptOutputFile name) - (Text.pack $ authorOutput <> "\n-------\n" <> userOutput) - - -- if we haven't crashed, clean up! - removePathForcibly repo - Ucm.deleteCodebase author - Ucm.deleteCodebase user - ok - -watchPushPullTest :: String -> CodebaseFormat -> (FilePath -> Transcript) -> (FilePath -> Transcript) -> (Codebase IO Symbol Ann -> IO ()) -> Test () -watchPushPullTest name fmt authorScript userScript codebaseCheck = scope name do - io do - repo <- initGitRepo - author <- Ucm.initCodebase fmt - authorOutput <- Ucm.runTranscript author (authorScript repo) - user <- Ucm.initCodebase fmt - userOutput <- Ucm.runTranscript user (userScript repo) - Ucm.lowLevel user codebaseCheck - - when writeTranscriptOutput $ - writeUtf8 - (transcriptOutputFile name) - (Text.pack $ authorOutput <> "\n-------\n" <> userOutput) - - -- if we haven't crashed, clean up! - removePathForcibly repo - Ucm.deleteCodebase author - Ucm.deleteCodebase user - ok - -gistTest :: CodebaseFormat -> Test () -gistTest fmt = - pushPullTest "gist" fmt authorScript userScript - where - authorScript repo = - [i| - ```unison:hide - y = 3 - ``` - ```ucm - .> add - .> gist git(${repo}) - ``` - |] - userScript repo = - [i| - ```ucm - .> pull git(${repo})#td09c6jlks - .> find - ``` - ```unison - > y - ``` - |] - -pushPullBranchesTests :: CodebaseFormat -> Test () -pushPullBranchesTests fmt = scope "branches" $ do - simplePushPull - multiplePushPull - emptyBranchFailure - where - simplePushPull = - let authorScript repo = - [i| - ```unison:hide - y = 3 - ``` - ```ucm - .> add - .> push.create git(${repo}:mybranch).path - ``` - |] - userScript repo = - [i| - ```ucm - .> pull git(${repo}:mybranch) .dest - .> view .dest.path.y - ``` - |] - in pushPullTest "simple" fmt authorScript userScript - emptyBranchFailure = - let authorScript _repo = "" - userScript repo = - [i| - ```ucm:error - .> pull git(${repo}:mybranch) .dest - ``` - |] - in pushPullTest "empty" fmt authorScript userScript - multiplePushPull = - let authorScript repo = - [i| - ```unison:hide - ns1.x = 10 - ns2.y = 20 - ``` - ```ucm - .> add - .> push.create git(${repo}:mybranch).ns1 .ns1 - .> push.create git(${repo}:mybranch).ns2 .ns2 - ``` - ```unison - ns1.x = 11 - ns1.new = 12 - ``` - ```ucm - .> update - .> push git(${repo}:mybranch).ns1 .ns1 - ``` - |] - userScript repo = - [i| - ```ucm - .> pull git(${repo}:mybranch).ns1 .ns1 - .> pull git(${repo}:mybranch).ns2 .ns2 - .> view .ns1.x - .> view .ns1.new - .> view .ns2.y - ``` - |] - in pushPullTest "multiple" fmt authorScript userScript - -fastForwardPush :: Test () -fastForwardPush = scope "fastforward-push" do - io do - repo <- initGitRepo - author <- Ucm.initCodebase Ucm.CodebaseFormat2 - void $ - Ucm.runTranscript - author - [i| - ```ucm - .lib> alias.type ##Nat Nat - .lib> push.create git(${repo}) - .lib> alias.type ##Int Int - .lib> push git(${repo}) - ``` - |] - ok - -nonFastForwardPush :: Test () -nonFastForwardPush = scope "non-fastforward-push" do - io do - repo <- initGitRepo - author <- Ucm.initCodebase Ucm.CodebaseFormat2 - void $ - Ucm.runTranscript - author - [i| - ```ucm:error - .lib> alias.type ##Nat Nat - .lib> push git(${repo}) - .lib2> alias.type ##Int Int - .lib2> push git(${repo}) - ``` - |] - ok - -destroyedRemote :: Test () -destroyedRemote = scope "destroyed-remote" do - io do - repo <- initGitRepo - codebase <- Ucm.initCodebase Ucm.CodebaseFormat2 - void $ - Ucm.runTranscript - codebase - [i| - ```ucm - .lib> alias.type ##Nat Nat - .lib> push.create git(${repo}) - ``` - |] - reinitRepo repo - void $ - Ucm.runTranscript - codebase - [i| - ```ucm - .lib> push.create git(${repo}) - ``` - |] - ok - where - reinitRepo repoStr@(Text.pack -> repo) = do - removePathForcibly repoStr - "git" ["init", "--bare", repo] - -initGitRepo :: IO FilePath -initGitRepo = do - tmp <- Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory ("git-simple") - let repo = tmp "repo.git" - "git" ["init", "--bare", Text.pack repo] - pure repo diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index b70ec4680..d1ea32baa 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack @@ -427,7 +427,6 @@ test-suite cli-tests other-modules: Unison.Test.ClearCache Unison.Test.Cli.Monad - Unison.Test.GitSync Unison.Test.LSP Unison.Test.Ucm Unison.Test.UriParser From 1f90eb365e06e1f7c3aa48c9161a04fe8e0febfd Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 28 May 2024 10:10:51 -0700 Subject: [PATCH 66/82] Clean up tests and transcripts --- unison-cli/tests/Main.hs | 2 -- unison-cli/tests/Unison/Test/UriParser.hs | 44 +++-------------------- 2 files changed, 4 insertions(+), 42 deletions(-) diff --git a/unison-cli/tests/Main.hs b/unison-cli/tests/Main.hs index b94d9407f..c0aa02275 100644 --- a/unison-cli/tests/Main.hs +++ b/unison-cli/tests/Main.hs @@ -6,7 +6,6 @@ import System.IO import System.IO.CodePage (withCP65001) import Unison.Test.ClearCache qualified as ClearCache import Unison.Test.Cli.Monad qualified as Cli.Monad -import Unison.Test.GitSync qualified as GitSync import Unison.Test.LSP qualified as LSP import Unison.Test.UriParser qualified as UriParser @@ -16,7 +15,6 @@ test = [ LSP.test, ClearCache.test, Cli.Monad.test, - GitSync.test, UriParser.test ] diff --git a/unison-cli/tests/Unison/Test/UriParser.hs b/unison-cli/tests/Unison/Test/UriParser.hs index ba71a26ba..e1eaacabf 100644 --- a/unison-cli/tests/Unison/Test/UriParser.hs +++ b/unison-cli/tests/Unison/Test/UriParser.hs @@ -6,7 +6,7 @@ import Data.These (These (..)) import Data.Void (Void) import EasyTest import Text.Megaparsec qualified as P -import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..), ReadRemoteNamespace (..), ShareCodeserver (..), ShareUserHandle (..), WriteGitRemoteNamespace (..), WriteGitRepo (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..), pattern ReadGitRemoteNamespace, pattern ReadShareLooseCode) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), ShareCodeserver (..), ShareUserHandle (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..), pattern ReadShareLooseCode) import Unison.Codebase.Editor.UriParser qualified as UriParser import Unison.Codebase.Path qualified as Path import Unison.Codebase.ShortCausalHash (ShortCausalHash (..)) @@ -23,22 +23,7 @@ test = [ ("unisonweb.base._releases.M4", looseR "unisonweb" ["base", "_releases", "M4"]), ("project", branchR (This "project")), ("/branch", branchR (That "branch")), - ("project/branch", branchR (These "project" "branch")), - ("git(/srv/git/project.git)", gitR "/srv/git/project.git" Nothing Nothing []), - ("git(/srv/git/project.git:abc)#def.hij.klm", gitR "/srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), - ("git(srv/git/project.git)", gitR "srv/git/project.git" Nothing Nothing []), - ("git(srv/git/project.git:abc)#def.hij.klm", gitR "srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), - ("git(file:///srv/git/project.git)", gitR "file:///srv/git/project.git" Nothing Nothing []), - ("git(file:///srv/git/project.git:abc)#def.hij.klm", gitR "file:///srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), - ("git(file://srv/git/project.git)", gitR "file://srv/git/project.git" Nothing Nothing []), - ("git(file://srv/git/project.git:abc)#def.hij.klm", gitR "file://srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), - ("git(https://example.com/git/project.git)", gitR "https://example.com/git/project.git" Nothing Nothing []), - ("git(https://user@example.com/git/project.git:abc)#def.hij.klm", gitR "https://user@example.com/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]), - ("git(ssh://git@8.8.8.8:222/user/project.git)", gitR "ssh://git@8.8.8.8:222/user/project.git" Nothing Nothing []), - ("git(ssh://git@github.com/user/project.git:abc)#def.hij.klm", gitR "ssh://git@github.com/user/project.git" (Just "abc") (sch "def") ["hij", "klm"]), - ("git(git@github.com:user/project.git)", gitR "git@github.com:user/project.git" Nothing Nothing []), - ("git(github.com:user/project.git)", gitR "github.com:user/project.git" Nothing Nothing []), - ("git(git@github.com:user/project.git:abc)#def.hij.klm", gitR "git@github.com:user/project.git" (Just "abc") (sch "def") ["hij", "klm"]) + ("project/branch", branchR (These "project" "branch")) ] [".unisonweb.base"], parserTests @@ -47,33 +32,12 @@ test = [ ("unisonweb.base._releases.M4", looseW "unisonweb" ["base", "_releases", "M4"]), ("project", branchW (This "project")), ("/branch", branchW (That "branch")), - ("project/branch", branchW (These "project" "branch")), - ("git(/srv/git/project.git)", gitW "/srv/git/project.git" Nothing []), - ("git(srv/git/project.git)", gitW "srv/git/project.git" Nothing []), - ("git(file:///srv/git/project.git)", gitW "file:///srv/git/project.git" Nothing []), - ("git(file://srv/git/project.git)", gitW "file://srv/git/project.git" Nothing []), - ("git(https://example.com/git/project.git)", gitW "https://example.com/git/project.git" Nothing []), - ("git(ssh://git@8.8.8.8:222/user/project.git)", gitW "ssh://git@8.8.8.8:222/user/project.git" Nothing []), - ("git(git@github.com:user/project.git)", gitW "git@github.com:user/project.git" Nothing []), - ("git(github.com:user/project.git)", gitW "github.com:user/project.git" Nothing []) + ("project/branch", branchW (These "project" "branch")) ] - [ ".unisonweb.base", - "git(/srv/git/project.git:abc)#def.hij.klm", - "git(srv/git/project.git:abc)#def.hij.klm", - "git(file:///srv/git/project.git:abc)#def.hij.klm", - "git(file://srv/git/project.git:abc)#def.hij.klm", - "git(https://user@example.com/git/project.git:abc)#def.hij.klm", - "git(ssh://git@github.com/user/project.git:abc)#def.hij.klm", - "git(git@github.com:user/project.git:abc)#def.hij.klm" + [ ".unisonweb.base" ] ] -gitR :: Text -> Maybe Text -> Maybe ShortCausalHash -> [NameSegment] -> ReadRemoteNamespace void -gitR url ref sch path = ReadRemoteNamespaceGit (ReadGitRemoteNamespace (ReadGitRepo url ref) sch (Path.fromList path)) - -gitW :: Text -> Maybe Text -> [NameSegment] -> WriteRemoteNamespace void -gitW url branch path = WriteRemoteNamespaceGit (WriteGitRemoteNamespace (WriteGitRepo url branch) (Path.fromList path)) - looseR :: Text -> [NameSegment] -> ReadRemoteNamespace void looseR user path = ReadShare'LooseCode (ReadShareLooseCode DefaultCodeserver (ShareUserHandle user) (Path.fromList path)) From 647072d2c7250952932b28aa5a421327267093dd Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Tue, 28 May 2024 14:34:05 -0600 Subject: [PATCH 67/82] Allow structured args in more find commands --- .../src/Unison/CommandLine/InputPatterns.hs | 21 ++++--------------- 1 file changed, 4 insertions(+), 17 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index b674b8c4a..8a01919f4 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1244,17 +1244,8 @@ findIn' cmd mkfscope = I.Visible [("namespace", Required, namespaceArg), ("query", ZeroPlus, exactDefinitionArg)] findHelp - $ \case - p : args -> - Input.FindI False . mkfscope - <$> first P.text (handlePathArg p) - -- __FIXME__: This changes things a bit. Previously, `find` and - -- friends would just expand the numbered args and search - -- for them like any other string, but now it recognizes - -- that you’re trying to look up something you already - -- have, and refuses to. Is that the right thing to do? We - -- _could_ still serialize in this case. - <*> traverse (unsupportedStructuredArgument "text") args + \case + p : args -> Input.FindI False . mkfscope <$> handlePathArg p <*> pure (unifyArgument <$> args) _ -> Left findHelp findHelp :: P.Pretty CT.ColorText @@ -1332,9 +1323,7 @@ findVerbose = ( "`find.verbose` searches for definitions like `find`, but includes hashes " <> "and aliases in the results." ) - ( fmap (Input.FindI True $ Input.FindLocal Path.empty) - . traverse (unsupportedStructuredArgument "text") - ) + (pure . Input.FindI True (Input.FindLocal Path.empty) . fmap unifyArgument) findVerboseAll :: InputPattern findVerboseAll = @@ -1346,9 +1335,7 @@ findVerboseAll = ( "`find.all.verbose` searches for definitions like `find.all`, but includes hashes " <> "and aliases in the results." ) - ( fmap (Input.FindI True $ Input.FindLocalAndDeps Path.empty) - . traverse (unsupportedStructuredArgument "text") - ) + (pure . Input.FindI True (Input.FindLocalAndDeps Path.empty) . fmap unifyArgument) renameTerm :: InputPattern renameTerm = From c6f1f2c2a8625c4d34d6a43e85bf691c574bedaa Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Tue, 28 May 2024 14:37:26 -0600 Subject: [PATCH 68/82] =?UTF-8?q?Don=E2=80=99t=20allow=20`ProjectBranch`?= =?UTF-8?q?=20as=20project=20arg?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 8a01919f4..8fa5afb76 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -369,8 +369,6 @@ handleProjectArg = ) ( \case SA.Project project -> pure project - -- __FIXME__: Do we want to treat a project branch as a project? - SA.ProjectBranch (ProjectAndBranch (Just project) _) -> pure project otherArgType -> Left $ wrongStructuredArgument "a path" otherArgType ) From a9c29d01c5f05203f5e0e55e1b253a4e5890bb7e Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Tue, 28 May 2024 14:35:31 -0600 Subject: [PATCH 69/82] Have handlers fail with `Pretty`, not `Text` MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This also generally improves formatting: - follows the longer line convention in Unison and - removes unnecessary `( … )` and `$` before `LambdaCase` args. --- .../src/Unison/CommandLine/InputPatterns.hs | 915 +++++++----------- 1 file changed, 331 insertions(+), 584 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 8fa5afb76..7f7524dd2 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -233,24 +233,15 @@ formatStructuredArgument = \case SA.HashQualified hqName -> HQ.toText hqName SA.Project projectName -> into @Text projectName SA.ProjectBranch (ProjectAndBranch mproj branch) -> - maybe - (Text.cons '/' . into @Text) - (\project -> into @Text . ProjectAndBranch project) - mproj - branch - SA.Ref reference -> - -- also: ShortHash.toText . Reference.toShortHash - Reference.toText reference - SA.Namespace causalHash -> - -- also: ("#" <>) . Hash.toBase32HexText . unCausalHash - ("#" <>) . SCH.toText $ SCH.fromHash schLength causalHash - SA.NameWithBranchPrefix absBranchId name -> - prefixBranchId absBranchId name - SA.HashQualifiedWithBranchPrefix absBranchId hq'Name -> - HQ'.toTextWith (prefixBranchId absBranchId) hq'Name + maybe (Text.cons '/' . into @Text) (\project -> into @Text . ProjectAndBranch project) mproj branch + -- also: ShortHash.toText . Reference.toShortHash + SA.Ref reference -> Reference.toText reference + -- also: ("#" <>) . Hash.toBase32HexText . unCausalHash + SA.Namespace causalHash -> ("#" <>) . SCH.toText $ SCH.fromHash schLength causalHash + SA.NameWithBranchPrefix absBranchId name -> prefixBranchId absBranchId name + SA.HashQualifiedWithBranchPrefix absBranchId hq'Name -> HQ'.toTextWith (prefixBranchId absBranchId) hq'Name SA.ShallowListEntry path entry -> entryToHQText path entry - SA.SearchResult searchRoot searchResult -> - HQ.toText $ searchResultToHQ searchRoot searchResult + SA.SearchResult searchRoot searchResult -> HQ.toText $ searchResultToHQ searchRoot searchResult where -- E.g. -- prefixBranchId "#abcdef" "base.List.map" -> "#abcdef:.base.List.map" @@ -261,8 +252,8 @@ formatStructuredArgument = \case Right pathPrefix -> Name.toText (Name.makeAbsolute . Path.prefixName pathPrefix $ name) entryToHQText :: Path' -> ShallowListEntry v Ann -> Text - entryToHQText pathArg e = - fixup $ case e of + entryToHQText pathArg = + fixup . \case ShallowTypeEntry te -> Backend.typeEntryDisplayName te ShallowTermEntry te -> Backend.termEntryDisplayName te ShallowBranchEntry ns _ _ -> NameSegment.toEscapedText ns @@ -303,26 +294,17 @@ searchResultToHQ oprefix = \case addPrefix :: Name -> Name addPrefix = maybe id Path.prefixName2 oprefix -unsupportedStructuredArgument :: - Text -> I.Argument -> Either (P.Pretty CT.ColorText) String +unsupportedStructuredArgument :: Text -> I.Argument -> Either (P.Pretty CT.ColorText) String unsupportedStructuredArgument expected = - either - pure - (const . Left . P.text $ "can’t use a numbered argument for " <> expected) + either pure (const . Left . P.text $ "can’t use a numbered argument for " <> expected) expectedButActually :: Text -> Text -> Text -> Text expectedButActually expected actualValue actualType = - "Expected " - <> expected - <> ", but the numbered arg resulted in " - <> actualValue - <> ", which is " - <> actualType - <> "." + "Expected " <> expected <> ", but the numbered arg resulted in " <> actualValue <> ", which is " <> actualType <> "." -wrongStructuredArgument :: Text -> StructuredArgument -> Text +wrongStructuredArgument :: Text -> StructuredArgument -> P.Pretty CT.ColorText wrongStructuredArgument expected actual = - expectedButActually + P.text $ expectedButActually expected (formatStructuredArgument actual) case actual of @@ -358,194 +340,151 @@ makeExampleEOS p args = helpFor :: InputPattern -> P.Pretty CT.ColorText helpFor = I.help -handleProjectArg :: I.Argument -> Either Text ProjectName +handleProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) ProjectName handleProjectArg = either ( \name -> - first - (const $ "“" <> Text.pack name <> "” is an invalid project name") - . tryInto @ProjectName - $ Text.pack name - ) - ( \case - SA.Project project -> pure project - otherArgType -> Left $ wrongStructuredArgument "a path" otherArgType + first (const . P.text $ "“" <> Text.pack name <> "” is an invalid project name") . tryInto @ProjectName $ + Text.pack name ) + \case + SA.Project project -> pure project + otherArgType -> Left $ wrongStructuredArgument "a project" otherArgType -handleLooseCodeOrProjectArg :: - I.Argument -> Either Text Input.LooseCodeOrProject +handleLooseCodeOrProjectArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.LooseCodeOrProject handleLooseCodeOrProjectArg = either - ( maybe (Left "invalid path or project branch") pure - . parseLooseCodeOrProject - ) - ( \case - SA.AbsolutePath path -> pure . This $ Path.absoluteToPath' path - SA.ProjectBranch pb -> pure $ That pb - otherArgType -> - Left $ wrongStructuredArgument "a path or project branch" otherArgType - ) + (maybe (Left $ P.text "invalid path or project branch") pure . parseLooseCodeOrProject) + \case + SA.AbsolutePath path -> pure . This $ Path.absoluteToPath' path + SA.ProjectBranch pb -> pure $ That pb + otherArgType -> Left $ wrongStructuredArgument "a path or project branch" otherArgType handleMaybeProjectBranchArg :: - I.Argument -> - Either (P.Pretty CT.ColorText) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) + I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) handleMaybeProjectBranchArg = either (megaparse branchWithOptionalProjectParser . Text.pack) - ( \case - SA.ProjectBranch pb -> pure pb - otherArgType -> Left . P.text $ wrongStructuredArgument "a branch" otherArgType - ) + \case + SA.ProjectBranch pb -> pure pb + otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType handleProjectMaybeBranchArg :: - I.Argument -> - Either Text (ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) + I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch ProjectName (Maybe ProjectBranchNameOrLatestRelease)) handleProjectMaybeBranchArg = either - (first (const "The argument wasn’t a project") . tryInto . Text.pack) - ( \case - SA.Project proj -> pure $ ProjectAndBranch proj Nothing - SA.ProjectBranch (ProjectAndBranch (Just proj) branch) -> - pure . ProjectAndBranch proj . pure $ ProjectBranchNameOrLatestRelease'Name branch - otherArgType -> Left $ wrongStructuredArgument "a project" otherArgType - ) + (first (const $ P.text "The argument wasn’t a project") . tryInto . Text.pack) + \case + SA.Project proj -> pure $ ProjectAndBranch proj Nothing + SA.ProjectBranch (ProjectAndBranch (Just proj) branch) -> + pure . ProjectAndBranch proj . pure $ ProjectBranchNameOrLatestRelease'Name branch + otherArgType -> Left $ wrongStructuredArgument "a project" otherArgType -handleHashQualifiedNameArg :: - I.Argument -> Either (P.Pretty CT.ColorText) (HQ.HashQualified Name) +handleHashQualifiedNameArg :: I.Argument -> Either (P.Pretty CT.ColorText) (HQ.HashQualified Name) handleHashQualifiedNameArg = either parseHashQualifiedName - ( \case - SA.Name name -> pure $ HQ.NameOnly name - SA.NameWithBranchPrefix (Left _) name -> pure $ HQ.NameOnly name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . HQ.NameOnly . Name.makeAbsolute $ Path.prefixName prefix name - SA.Ref ref -> pure . HQ.HashOnly $ Reference.toShortHash ref - SA.HashQualified hqname -> pure hqname - SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toHQ hqname - SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> - pure . HQ'.toHQ $ Name.makeAbsolute . Path.prefixName prefix <$> hqname - SA.SearchResult mpath result -> pure $ searchResultToHQ mpath result - otherArgType -> - Left . P.text $ wrongStructuredArgument "a hash-qualified name" otherArgType - ) + \case + SA.Name name -> pure $ HQ.NameOnly name + SA.NameWithBranchPrefix mprefix name -> + pure . HQ.NameOnly $ foldr (\prefix -> Name.makeAbsolute . Path.prefixName prefix) name mprefix + SA.Ref ref -> pure . HQ.HashOnly $ Reference.toShortHash ref + SA.HashQualified hqname -> pure hqname + SA.HashQualifiedWithBranchPrefix mprefix hqname -> + pure . HQ'.toHQ $ foldr (\prefix -> fmap $ Name.makeAbsolute . Path.prefixName prefix) hqname mprefix + SA.SearchResult mpath result -> pure $ searchResultToHQ mpath result + otherArgType -> Left $ wrongStructuredArgument "a hash-qualified name" otherArgType -handlePathArg :: I.Argument -> Either Text Path.Path +handlePathArg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Path handlePathArg = either - Path.parsePath + (first P.text . Path.parsePath) \case SA.Name name -> pure $ Path.fromName name - SA.NameWithBranchPrefix (Left _) name -> pure $ Path.fromName name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . Path.fromName $ Path.prefixName prefix name - otherArgType -> - Left $ wrongStructuredArgument "a relative path" otherArgType + SA.NameWithBranchPrefix mprefix name -> pure . Path.fromName $ foldr Path.prefixName name mprefix + otherArgType -> Left $ wrongStructuredArgument "a relative path" otherArgType -handlePath'Arg :: I.Argument -> Either Text Path.Path' +handlePath'Arg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Path' handlePath'Arg = either - Path.parsePath' - ( \case - SA.AbsolutePath path -> pure $ Path.absoluteToPath' path - SA.Name name -> pure $ Path.fromName' name - SA.NameWithBranchPrefix (Left _) name -> pure $ Path.fromName' name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name - otherArgType -> Left $ wrongStructuredArgument "a namespace" otherArgType - ) + (first P.text . Path.parsePath') + \case + SA.AbsolutePath path -> pure $ Path.absoluteToPath' path + SA.Name name -> pure $ Path.fromName' name + SA.NameWithBranchPrefix mprefix name -> + pure . Path.fromName' $ foldr (\prefix -> Name.makeAbsolute . Path.prefixName prefix) name mprefix + otherArgType -> Left $ wrongStructuredArgument "a namespace" otherArgType -handleNewName :: I.Argument -> Either Text Path.Split' +handleNewName :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Split' handleNewName = either - Path.parseSplit' + (first P.text . Path.parseSplit') (const . Left $ "can’t use a numbered argument for a new name") -handleNewPath :: I.Argument -> Either Text Path.Path' +handleNewPath :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Path' handleNewPath = either - Path.parsePath' + (first P.text . Path.parsePath') (const . Left $ "can’t use a numbered argument for a new namespace") -- | When only a relative name is allowed. -handleSplitArg :: I.Argument -> Either Text Path.Split +handleSplitArg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Split handleSplitArg = either - Path.parseSplit - ( \case - SA.Name name | Name.isRelative name -> pure $ Path.splitFromName name - SA.NameWithBranchPrefix (Left _) name - | Name.isRelative name -> - pure $ Path.splitFromName name - SA.NameWithBranchPrefix (Right prefix) name - | Name.isRelative name -> - pure . Path.splitFromName . Name.makeAbsolute $ - Path.prefixName prefix name - otherNumArg -> - Left $ wrongStructuredArgument "a relative name" otherNumArg - ) + (first P.text . Path.parseSplit) + \case + SA.Name name | Name.isRelative name -> pure $ Path.splitFromName name + SA.NameWithBranchPrefix (Left _) name | Name.isRelative name -> pure $ Path.splitFromName name + SA.NameWithBranchPrefix (Right prefix) name + | Name.isRelative name -> pure . Path.splitFromName . Name.makeAbsolute $ Path.prefixName prefix name + otherNumArg -> Left $ wrongStructuredArgument "a relative name" otherNumArg -handleSplit'Arg :: I.Argument -> Either Text Path.Split' +handleSplit'Arg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.Split' handleSplit'Arg = either - Path.parseSplit' - ( \case - SA.Name name -> pure $ Path.splitFromName' name - SA.NameWithBranchPrefix (Left _) name -> pure $ Path.splitFromName' name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . Path.splitFromName' . Name.makeAbsolute $ Path.prefixName prefix name - otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg - ) + (first P.text . Path.parseSplit') + \case + SA.Name name -> pure $ Path.splitFromName' name + SA.NameWithBranchPrefix (Left _) name -> pure $ Path.splitFromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . Path.splitFromName' . Name.makeAbsolute $ Path.prefixName prefix name + otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg -handleProjectBranchNameArg :: I.Argument -> Either Text ProjectBranchName +handleProjectBranchNameArg :: I.Argument -> Either (P.Pretty CT.ColorText) ProjectBranchName handleProjectBranchNameArg = either - (first (const "Wanted a branch name, but it wasn’t") . tryInto . Text.pack) - ( \case - SA.ProjectBranch (ProjectAndBranch _ branch) -> pure branch - otherNumArg -> Left $ wrongStructuredArgument "a branch name" otherNumArg - ) + (first (const $ P.text "Wanted a branch name, but it wasn’t") . tryInto . Text.pack) + \case + SA.ProjectBranch (ProjectAndBranch _ branch) -> pure branch + otherNumArg -> Left $ wrongStructuredArgument "a branch name" otherNumArg -handleBranchIdArg :: I.Argument -> Either Text Input.BranchId +handleBranchIdArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.BranchId handleBranchIdArg = either - Input.parseBranchId - ( \case - SA.AbsolutePath path -> pure . pure $ Path.absoluteToPath' path - SA.Name name -> pure . pure $ Path.fromName' name - SA.NameWithBranchPrefix mprefix name -> - pure . pure . Path.fromName' $ - either (const name) (Name.makeAbsolute . flip Path.prefixName name) mprefix - SA.Namespace hash -> pure . Left $ SCH.fromHash schLength hash - otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg - ) + (first P.text . Input.parseBranchId) + \case + SA.AbsolutePath path -> pure . pure $ Path.absoluteToPath' path + SA.Name name -> pure . pure $ Path.fromName' name + SA.NameWithBranchPrefix mprefix name -> + pure . pure . Path.fromName' $ either (const name) (Name.makeAbsolute . flip Path.prefixName name) mprefix + SA.Namespace hash -> pure . Left $ SCH.fromHash schLength hash + otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg handleBranchIdOrProjectArg :: I.Argument -> - Either - Text - ( These - Input.BranchId - (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - ) + Either (P.Pretty CT.ColorText) (These Input.BranchId (ProjectAndBranch (Maybe ProjectName) ProjectBranchName)) handleBranchIdOrProjectArg = either - ( maybe (Left "Expected a branch or project, but it’s not") pure - . branchIdOrProject - ) - ( \case - SA.Namespace hash -> pure . This . Left $ SCH.fromHash schLength hash - SA.AbsolutePath path -> - pure . This . pure $ Path.absoluteToPath' path - SA.Name name -> pure . This . pure $ Path.fromName' name - SA.NameWithBranchPrefix (Left _) name -> - pure . This . pure $ Path.fromName' name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . This . pure . Path.fromName' . Name.makeAbsolute $ - Path.prefixName prefix name - SA.ProjectBranch pb -> pure $ pure pb - otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType - ) + (maybe (Left $ P.text "Expected a branch or project, but it’s not") pure . branchIdOrProject) + \case + SA.Namespace hash -> pure . This . Left $ SCH.fromHash schLength hash + SA.AbsolutePath path -> pure . This . pure $ Path.absoluteToPath' path + SA.Name name -> pure . This . pure $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . This . pure $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . This . pure . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.ProjectBranch pb -> pure $ pure pb + otherArgType -> Left $ wrongStructuredArgument "a branch" otherArgType where branchIdOrProject :: String -> @@ -565,57 +504,44 @@ handleBranchIdOrProjectArg = (Right bid, Left _) -> Just (This bid) (Right bid, Right pr) -> Just (These bid pr) -handleBranchId2Arg :: - I.Argument -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath) +handleBranchId2Arg :: I.Argument -> Either (P.Pretty P.ColorText) (Either ShortCausalHash BranchRelativePath) handleBranchId2Arg = either Input.parseBranchId2 - ( \case - SA.Namespace hash -> pure . Left $ SCH.fromHash schLength hash - SA.AbsolutePath path -> - pure . pure . LoosePath $ Path.absoluteToPath' path - SA.Name name -> pure . pure . LoosePath $ Path.fromName' name - SA.NameWithBranchPrefix (Left _) name -> - pure . pure . LoosePath $ Path.fromName' name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . pure . LoosePath . Path.fromName' . Name.makeAbsolute $ - Path.prefixName prefix name - SA.ProjectBranch (ProjectAndBranch mproject branch) -> - pure . pure . BranchRelative . This $ - maybe (Left branch) (pure . (,branch)) mproject - otherNumArg -> - Left . P.text $ wrongStructuredArgument "a branch id" otherNumArg - ) + \case + SA.Namespace hash -> pure . Left $ SCH.fromHash schLength hash + SA.AbsolutePath path -> pure . pure . LoosePath $ Path.absoluteToPath' path + SA.Name name -> pure . pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . pure . LoosePath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.ProjectBranch (ProjectAndBranch mproject branch) -> + pure . pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject + otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg -handleBranchRelativePathArg :: - I.Argument -> Either (P.Pretty P.ColorText) BranchRelativePath +handleBranchRelativePathArg :: I.Argument -> Either (P.Pretty P.ColorText) BranchRelativePath handleBranchRelativePathArg = either parseBranchRelativePath - ( \case - SA.AbsolutePath path -> pure . LoosePath $ Path.absoluteToPath' path - SA.Name name -> pure . LoosePath $ Path.fromName' name - SA.NameWithBranchPrefix (Left _) name -> - pure . LoosePath $ Path.fromName' name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . LoosePath . Path.fromName' . Name.makeAbsolute $ - Path.prefixName prefix name - SA.ProjectBranch (ProjectAndBranch mproject branch) -> - pure . BranchRelative . This $ - maybe (Left branch) (pure . (,branch)) mproject - otherNumArg -> - Left . P.text $ wrongStructuredArgument "a branch id" otherNumArg - ) + \case + SA.AbsolutePath path -> pure . LoosePath $ Path.absoluteToPath' path + SA.Name name -> pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . LoosePath $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . LoosePath . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.ProjectBranch (ProjectAndBranch mproject branch) -> + pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject + otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg -hqNameToSplit' :: HQ.HashQualified Name -> Either Text Path.HQSplit' +hqNameToSplit' :: HQ.HashQualified Name -> Either (P.Pretty CT.ColorText) Path.HQSplit' hqNameToSplit' = \case - HQ.HashOnly _ -> Left "Only have a hash" + HQ.HashOnly _ -> Left $ P.text "Only have a hash" HQ.NameOnly name -> pure . fmap HQ'.NameOnly $ Path.splitFromName' name HQ.HashQualified name hash -> pure . fmap (`HQ'.HashQualified` hash) $ Path.splitFromName' name -hqNameToSplit :: HQ.HashQualified Name -> Either Text Path.HQSplit +hqNameToSplit :: HQ.HashQualified Name -> Either (P.Pretty CT.ColorText) Path.HQSplit hqNameToSplit = \case - HQ.HashOnly _ -> Left "Only have a hash" + HQ.HashOnly _ -> Left $ P.text "Only have a hash" HQ.NameOnly name -> pure . fmap HQ'.NameOnly $ Path.splitFromName name HQ.HashQualified name hash -> pure . fmap (`HQ'.HashQualified` hash) $ Path.splitFromName name @@ -629,85 +555,75 @@ hq'NameToSplit = \case HQ'.NameOnly name -> HQ'.NameOnly <$> Path.splitFromName name HQ'.HashQualified name hash -> flip HQ'.HashQualified hash <$> Path.splitFromName name -handleHashQualifiedSplit'Arg :: I.Argument -> Either Text Path.HQSplit' +handleHashQualifiedSplit'Arg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.HQSplit' handleHashQualifiedSplit'Arg = either - Path.parseHQSplit' - ( \case - SA.HashQualified name -> hqNameToSplit' name - SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit' hqname - SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> - pure . hq'NameToSplit' $ Name.makeAbsolute . Path.prefixName prefix <$> hqname - SA.SearchResult mpath result -> hqNameToSplit' $ searchResultToHQ mpath result - otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg - ) + (first P.text . Path.parseHQSplit') + \case + SA.HashQualified name -> hqNameToSplit' name + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit' hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . hq'NameToSplit' $ Name.makeAbsolute . Path.prefixName prefix <$> hqname + SA.SearchResult mpath result -> hqNameToSplit' $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg -handleHashQualifiedSplitArg :: I.Argument -> Either Text Path.HQSplit +handleHashQualifiedSplitArg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.HQSplit handleHashQualifiedSplitArg = either - Path.parseHQSplit - ( \case - SA.HashQualified name -> hqNameToSplit name - SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit hqname - SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> - pure . hq'NameToSplit $ Name.makeAbsolute . Path.prefixName prefix <$> hqname - SA.SearchResult mpath result -> hqNameToSplit $ searchResultToHQ mpath result - otherNumArg -> Left $ wrongStructuredArgument "a relative name" otherNumArg - ) + (first P.text . Path.parseHQSplit) + \case + SA.HashQualified name -> hqNameToSplit name + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . hq'NameToSplit $ Name.makeAbsolute . Path.prefixName prefix <$> hqname + SA.SearchResult mpath result -> hqNameToSplit $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a relative name" otherNumArg -handleShortCausalHashArg :: I.Argument -> Either Text ShortCausalHash +handleShortCausalHashArg :: I.Argument -> Either (P.Pretty CT.ColorText) ShortCausalHash handleShortCausalHashArg = either - (first Text.pack . Input.parseShortCausalHash) - ( \case - SA.Namespace hash -> pure $ SCH.fromHash schLength hash - otherNumArg -> Left $ wrongStructuredArgument "a causal hash" otherNumArg - ) + (first (P.text . Text.pack) . Input.parseShortCausalHash) + \case + SA.Namespace hash -> pure $ SCH.fromHash schLength hash + otherNumArg -> Left $ wrongStructuredArgument "a causal hash" otherNumArg handleShortHashOrHQSplit'Arg :: - I.Argument -> Either Text (Either ShortHash Path.HQSplit') + I.Argument -> Either (P.Pretty CT.ColorText) (Either ShortHash Path.HQSplit') handleShortHashOrHQSplit'Arg = either - Path.parseShortHashOrHQSplit' - ( \case - SA.Ref ref -> pure $ Left $ Reference.toShortHash ref - SA.HashQualified name -> pure <$> hqNameToSplit' name - SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure . pure $ hq'NameToSplit' hqname - SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> - pure . pure $ hq'NameToSplit' (Name.makeAbsolute . Path.prefixName prefix <$> hqname) - SA.SearchResult mpath result -> - fmap pure . hqNameToSplit' $ searchResultToHQ mpath result - otherNumArg -> Left $ wrongStructuredArgument "a hash or name" otherNumArg - ) + (first P.text . Path.parseShortHashOrHQSplit') + \case + SA.Ref ref -> pure $ Left $ Reference.toShortHash ref + SA.HashQualified name -> pure <$> hqNameToSplit' name + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure . pure $ hq'NameToSplit' hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . pure $ hq'NameToSplit' (Name.makeAbsolute . Path.prefixName prefix <$> hqname) + SA.SearchResult mpath result -> fmap pure . hqNameToSplit' $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a hash or name" otherNumArg -handleRelativeNameSegmentArg :: I.Argument -> Either Text NameSegment +handleRelativeNameSegmentArg :: I.Argument -> Either (P.Pretty CT.ColorText) NameSegment handleRelativeNameSegmentArg arg = do name <- handleNameArg arg let (segment NE.:| tail) = Name.reverseSegments name if Name.isRelative name && null tail then pure segment - else Left "Wanted a single relative name segment, but it wasn’t." + else Left $ P.text "Wanted a single relative name segment, but it wasn’t." -handleNameArg :: I.Argument -> Either Text Name +handleNameArg :: I.Argument -> Either (P.Pretty CT.ColorText) Name handleNameArg = either - (Name.parseTextEither . Text.pack) - ( \case - SA.Name name -> pure name - SA.NameWithBranchPrefix (Left _) name -> pure name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . Name.makeAbsolute $ Path.prefixName prefix name - SA.HashQualified hqname -> - maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname - SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toName hqname - SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> - pure . Name.makeAbsolute . Path.prefixName prefix $ HQ'.toName hqname - SA.SearchResult mpath result -> - maybe (Left "can’t find a name from the numbered arg") pure - . HQ.toName - $ searchResultToHQ mpath result - otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg - ) + (first P.text . Name.parseTextEither . Text.pack) + \case + SA.Name name -> pure name + SA.NameWithBranchPrefix (Left _) name -> pure name + SA.NameWithBranchPrefix (Right prefix) name -> pure . Name.makeAbsolute $ Path.prefixName prefix name + SA.HashQualified hqname -> maybe (Left "can’t find a name from the numbered arg") pure $ HQ.toName hqname + SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ HQ'.toName hqname + SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> + pure . Name.makeAbsolute . Path.prefixName prefix $ HQ'.toName hqname + SA.SearchResult mpath result -> + maybe (Left "can’t find a name from the numbered arg") pure . HQ.toName $ searchResultToHQ mpath result + otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg handlePullSourceArg :: I.Argument -> @@ -717,68 +633,45 @@ handlePullSourceArg :: handlePullSourceArg = either (megaparse (readRemoteNamespaceParser ProjectBranchSpecifier'NameOrLatestRelease) . Text.pack) - ( \case - SA.Project project -> - pure . RemoteRepo.ReadShare'ProjectBranch $ This project - SA.ProjectBranch (ProjectAndBranch project branch) -> - pure . RemoteRepo.ReadShare'ProjectBranch . maybe That These project $ - ProjectBranchNameOrLatestRelease'Name branch - otherNumArg -> - Left . P.text $ wrongStructuredArgument "a source to pull from" otherNumArg - ) + \case + SA.Project project -> pure . RemoteRepo.ReadShare'ProjectBranch $ This project + SA.ProjectBranch (ProjectAndBranch project branch) -> + pure . RemoteRepo.ReadShare'ProjectBranch . maybe That These project $ + ProjectBranchNameOrLatestRelease'Name branch + otherNumArg -> Left $ wrongStructuredArgument "a source to pull from" otherNumArg handlePushTargetArg :: - I.Argument -> - Either Text (WriteRemoteNamespace (These ProjectName ProjectBranchName)) + I.Argument -> Either (P.Pretty CT.ColorText) (WriteRemoteNamespace (These ProjectName ProjectBranchName)) handlePushTargetArg = either - ( maybe (Left "Wanted a source to push from, but this ain’t it.") pure - . parsePushTarget - ) - ( fmap RemoteRepo.WriteRemoteProjectBranch - . \case - SA.Project project -> pure $ This project - SA.ProjectBranch (ProjectAndBranch project branch) -> - pure $ maybe That These project branch - otherNumArg -> - Left $ wrongStructuredArgument "a source to push from" otherNumArg - ) + (maybe (Left "Wanted a source to push from, but this ain’t it.") pure . parsePushTarget) + $ fmap RemoteRepo.WriteRemoteProjectBranch . \case + SA.Project project -> pure $ This project + SA.ProjectBranch (ProjectAndBranch project branch) -> pure $ maybe That These project branch + otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg -handlePushSourceArg :: I.Argument -> Either Text Input.PushSource +handlePushSourceArg :: I.Argument -> Either (P.Pretty CT.ColorText) Input.PushSource handlePushSourceArg = either - ( maybe (Left "Wanted a source to push from, but this ain’t it.") pure - . parsePushSource - ) - ( \case - SA.AbsolutePath path -> pure . Input.PathySource $ Path.absoluteToPath' path - SA.Name name -> pure . Input.PathySource $ Path.fromName' name - SA.NameWithBranchPrefix (Left _) name -> - pure . Input.PathySource $ Path.fromName' name - SA.NameWithBranchPrefix (Right prefix) name -> - pure . Input.PathySource . Path.fromName' . Name.makeAbsolute $ - Path.prefixName prefix name - SA.Project project -> pure . Input.ProjySource $ This project - SA.ProjectBranch (ProjectAndBranch project branch) -> - pure . Input.ProjySource . maybe That These project $ branch - otherNumArg -> - Left $ wrongStructuredArgument "a source to push from" otherNumArg - ) + (maybe (Left $ P.text "Wanted a source to push from, but this ain’t it.") pure . parsePushSource) + \case + SA.AbsolutePath path -> pure . Input.PathySource $ Path.absoluteToPath' path + SA.Name name -> pure . Input.PathySource $ Path.fromName' name + SA.NameWithBranchPrefix (Left _) name -> pure . Input.PathySource $ Path.fromName' name + SA.NameWithBranchPrefix (Right prefix) name -> + pure . Input.PathySource . Path.fromName' . Name.makeAbsolute $ Path.prefixName prefix name + SA.Project project -> pure . Input.ProjySource $ This project + SA.ProjectBranch (ProjectAndBranch project branch) -> pure . Input.ProjySource $ maybe That These project branch + otherNumArg -> Left $ wrongStructuredArgument "a source to push from" otherNumArg -handleProjectAndBranchNamesArg :: I.Argument -> Either Text ProjectAndBranchNames +handleProjectAndBranchNamesArg :: I.Argument -> Either (P.Pretty CT.ColorText) ProjectAndBranchNames handleProjectAndBranchNamesArg = either - ( first (const "The argument wasn’t a project or branch") - . tryInto @ProjectAndBranchNames - . Text.pack - ) - ( fmap ProjectAndBranchNames'Unambiguous . \case - SA.Project project -> pure $ This project - SA.ProjectBranch (ProjectAndBranch mproj branch) -> - pure $ maybe That These mproj branch - otherNumArg -> - Left $ wrongStructuredArgument "a project or branch" otherNumArg - ) + (first (const $ P.text "The argument wasn’t a project or branch") . tryInto @ProjectAndBranchNames . Text.pack) + $ fmap ProjectAndBranchNames'Unambiguous . \case + SA.Project project -> pure $ This project + SA.ProjectBranch (ProjectAndBranch mproj branch) -> pure $ maybe That These mproj branch + otherNumArg -> Left $ wrongStructuredArgument "a project or branch" otherNumArg mergeBuiltins :: InputPattern mergeBuiltins = @@ -788,9 +681,9 @@ mergeBuiltins = I.Hidden [("namespace", Optional, namespaceArg)] "Adds the builtins (excluding `io` and misc) to the specified namespace. Defaults to `builtin.`" - $ \case + \case [] -> pure . Input.MergeBuiltinsI $ Nothing - [p] -> bimap P.text (Input.MergeBuiltinsI . Just) $ handlePathArg p + [p] -> Input.MergeBuiltinsI . Just <$> handlePathArg p _ -> Left (I.help mergeBuiltins) mergeIOBuiltins :: InputPattern @@ -803,7 +696,7 @@ mergeIOBuiltins = "Adds all the builtins, including `io` and misc., to the specified namespace. Defaults to `builtin.`" \case [] -> pure . Input.MergeIOBuiltinsI $ Nothing - [p] -> bimap P.text (Input.MergeIOBuiltinsI . Just) $ handlePathArg p + [p] -> Input.MergeIOBuiltinsI . Just <$> handlePathArg p _ -> Left (I.help mergeBuiltins) updateBuiltins :: InputPattern @@ -839,16 +732,15 @@ todo = ) ] ) - ( \case - patchStr : ws -> first (warn . P.text) $ do - patch <- handleSplit'Arg patchStr - branch <- case ws of - [] -> pure Path.relativeEmpty' - [pathStr] -> handlePath'Arg pathStr - _ -> Left "`todo` just takes a patch and one optional namespace" - Right $ Input.TodoI (Just patch) branch - [] -> Right $ Input.TodoI Nothing Path.relativeEmpty' - ) + \case + patchStr : ws -> first warn $ do + patch <- handleSplit'Arg patchStr + branch <- case ws of + [] -> pure Path.relativeEmpty' + [pathStr] -> handlePath'Arg pathStr + _ -> Left "`todo` just takes a patch and one optional namespace" + Right $ Input.TodoI (Just patch) branch + [] -> Right $ Input.TodoI Nothing Path.relativeEmpty' load :: InputPattern load = @@ -866,13 +758,10 @@ load = ) ] ) - ( \case - [] -> pure $ Input.LoadI Nothing - [file] -> - Input.LoadI . Just - <$> unsupportedStructuredArgument "a file name" file - _ -> Left (I.help load) - ) + \case + [] -> pure $ Input.LoadI Nothing + [file] -> Input.LoadI . Just <$> unsupportedStructuredArgument "a file name" file + _ -> Left (I.help load) clear :: InputPattern clear = @@ -887,10 +776,9 @@ clear = ) ] ) - ( \case - [] -> pure Input.ClearI - _ -> Left (I.help clear) - ) + \case + [] -> pure Input.ClearI + _ -> Left (I.help clear) add :: InputPattern add = @@ -902,7 +790,7 @@ add = ( "`add` adds to the codebase all the definitions from the most recently " <> "typechecked file." ) - $ bimap P.text (Input.AddI . Set.fromList) . traverse handleNameArg + $ fmap (Input.AddI . Set.fromList) . traverse handleNameArg previewAdd :: InputPattern previewAdd = @@ -916,7 +804,7 @@ previewAdd = <> "results. Use `load` to reparse & typecheck the file if the context " <> "has changed." ) - $ bimap P.text (Input.PreviewAddI . Set.fromList) . traverse handleNameArg + $ fmap (Input.PreviewAddI . Set.fromList) . traverse handleNameArg update :: InputPattern update = @@ -962,8 +850,7 @@ updateOldNoPatch = ) ] ) - $ bimap P.text (Input.UpdateI Input.NoPatch . Set.fromList) - . traverse handleNameArg + $ fmap (Input.UpdateI Input.NoPatch . Set.fromList) . traverse handleNameArg updateOld :: InputPattern updateOld = @@ -998,10 +885,8 @@ updateOld = ] ) \case - patchStr : ws -> first P.text do - patch <- handleSplit'Arg patchStr - Input.UpdateI (Input.UsePatch patch) . Set.fromList - <$> traverse handleNameArg ws + patchStr : ws -> + Input.UpdateI . Input.UsePatch <$> handleSplit'Arg patchStr <*> fmap Set.fromList (traverse handleNameArg ws) [] -> Right $ Input.UpdateI Input.DefaultPatch mempty previewUpdate :: InputPattern @@ -1016,8 +901,7 @@ previewUpdate = <> "typechecking results. Use `load` to reparse & typecheck the file if " <> "the context has changed." ) - $ bimap P.text (Input.PreviewUpdateI . Set.fromList) - . traverse handleNameArg + $ fmap (Input.PreviewUpdateI . Set.fromList) . traverse handleNameArg view :: InputPattern view = @@ -1077,11 +961,7 @@ display = "`display` without arguments invokes a search to select a definition to display, which requires that `fzf` can be found within your PATH." ] ) - $ maybe - (Left $ I.help display) - ( fmap (Input.DisplayI Input.ConsoleLocation) - . traverse handleHashQualifiedNameArg - ) + $ maybe (Left $ I.help display) (fmap (Input.DisplayI Input.ConsoleLocation) . traverse handleHashQualifiedNameArg) . NE.nonEmpty displayTo :: InputPattern @@ -1119,10 +999,7 @@ docs = "`docs` without arguments invokes a search to select which definition to view documentation for, which requires that `fzf` can be found within your PATH." ] ) - $ maybe - (Left $ I.help docs) - (bimap P.text Input.DocsI . traverse handleHashQualifiedSplit'Arg) - . NE.nonEmpty + $ maybe (Left $ I.help docs) (fmap Input.DocsI . traverse handleHashQualifiedSplit'Arg) . NE.nonEmpty api :: InputPattern api = @@ -1144,7 +1021,7 @@ ui = help = P.wrap "`ui` opens the Local UI in the default browser.", parse = \case [] -> pure $ Input.UiI Path.relativeEmpty' - [path] -> bimap P.text Input.UiI $ handlePath'Arg path + [path] -> Input.UiI <$> handlePath'Arg path _ -> Left (I.help ui) } @@ -1307,7 +1184,7 @@ findShallow = ) ( fmap Input.FindShallowI . \case [] -> pure Path.relativeEmpty' - [path] -> first P.text $ handlePath'Arg path + [path] -> handlePath'Arg path _ -> Left (I.help findShallow) ) @@ -1345,17 +1222,9 @@ renameTerm = ("new location", Required, newNameArg) ] "`move.term foo bar` renames `foo` to `bar`." - ( \case - [oldName, newName] -> - first P.text $ - Input.MoveTermI - <$> handleHashQualifiedSplit'Arg oldName - <*> handleNewName newName - _ -> - Left . P.warnCallout $ - P.wrap - "`rename.term` takes two arguments, like `rename.term oldname newname`." - ) + \case + [oldName, newName] -> Input.MoveTermI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName + _ -> Left . P.warnCallout $ P.wrap "`rename.term` takes two arguments, like `rename.term oldname newname`." moveAll :: InputPattern moveAll = @@ -1367,17 +1236,9 @@ moveAll = ("new location", Required, newNameArg) ] "`move foo bar` renames the term, type, and namespace foo to bar." - ( \case - [oldName, newName] -> - first P.text $ - Input.MoveAllI - <$> handlePath'Arg oldName - <*> handleNewPath newName - _ -> - Left . P.warnCallout $ - P.wrap - "`move` takes two arguments, like `move oldname newname`." - ) + \case + [oldName, newName] -> Input.MoveAllI <$> handlePath'Arg oldName <*> handleNewPath newName + _ -> Left . P.warnCallout $ P.wrap "`move` takes two arguments, like `move oldname newname`." renameType :: InputPattern renameType = @@ -1389,17 +1250,10 @@ renameType = ("new location", Required, newNameArg) ] "`move.type foo bar` renames `foo` to `bar`." - ( \case - [oldName, newName] -> - first P.text $ - Input.MoveTypeI - <$> handleHashQualifiedSplit'Arg oldName - <*> handleNewName newName - _ -> - Left . P.warnCallout $ - P.wrap - "`rename.type` takes two arguments, like `rename.type oldname newname`." - ) + \case + [oldName, newName] -> Input.MoveTypeI <$> handleHashQualifiedSplit'Arg oldName <*> handleNewName newName + _ -> + Left . P.warnCallout $ P.wrap "`rename.type` takes two arguments, like `rename.type oldname newname`." deleteGen :: Maybe String -> ArgumentType -> String -> ([Path.HQSplit'] -> DeleteTarget) -> InputPattern deleteGen suffix queryCompletionArg target mkTarget = @@ -1438,12 +1292,9 @@ deleteGen suffix queryCompletionArg target mkTarget = I.Visible [("definition to delete", OnePlus, queryCompletionArg)] info - ( \case - [] -> Left . P.warnCallout $ P.wrap warn - queries -> - bimap P.text (Input.DeleteI . mkTarget) $ - traverse handleHashQualifiedSplit'Arg queries - ) + \case + [] -> Left . P.warnCallout $ P.wrap warn + queries -> Input.DeleteI . mkTarget <$> traverse handleHashQualifiedSplit'Arg queries delete :: InputPattern delete = deleteGen Nothing exactDefinitionTypeOrTermQueryArg "term or type" (DeleteTarget'TermOrType DeleteOutput'NoDiff) @@ -1475,9 +1326,7 @@ deleteProject = [ ("`delete.project foo`", "deletes the local project `foo`") ], parse = \case - [name] -> - bimap P.text (Input.DeleteI . DeleteTarget'Project) $ - handleProjectArg name + [name] -> Input.DeleteI . DeleteTarget'Project <$> handleProjectArg name _ -> Left (showPatternHelp deleteProject) } @@ -1494,9 +1343,7 @@ deleteBranch = ("`delete.branch /bar`", "deletes the branch `bar` in the current project") ], parse = \case - [name] -> - Input.DeleteI . DeleteTarget'ProjectBranch - <$> handleMaybeProjectBranchArg name + [name] -> Input.DeleteI . DeleteTarget'ProjectBranch <$> handleMaybeProjectBranchArg name _ -> Left (showPatternHelp deleteBranch) } where @@ -1516,15 +1363,8 @@ aliasTerm = [("term to alias", Required, exactDefinitionTermQueryArg), ("alias name", Required, newNameArg)] "`alias.term foo bar` introduces `bar` with the same definition as `foo`." $ \case - [oldName, newName] -> - first P.text $ - Input.AliasTermI - <$> handleShortHashOrHQSplit'Arg oldName - <*> handleSplit'Arg newName - _ -> - Left . warn $ - P.wrap - "`alias.term` takes two arguments, like `alias.term oldname newname`." + [oldName, newName] -> Input.AliasTermI <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + _ -> Left . warn $ P.wrap "`alias.term` takes two arguments, like `alias.term oldname newname`." aliasType :: InputPattern aliasType = @@ -1534,16 +1374,9 @@ aliasType = I.Visible [("type to alias", Required, exactDefinitionTypeQueryArg), ("alias name", Required, newNameArg)] "`alias.type Foo Bar` introduces `Bar` with the same definition as `Foo`." - $ \case - [oldName, newName] -> - first P.text $ - Input.AliasTypeI - <$> handleShortHashOrHQSplit'Arg oldName - <*> handleSplit'Arg newName - _ -> - Left . warn $ - P.wrap - "`alias.type` takes two arguments, like `alias.type oldname newname`." + \case + [oldName, newName] -> Input.AliasTypeI <$> handleShortHashOrHQSplit'Arg oldName <*> handleSplit'Arg newName + _ -> Left . warn $ P.wrap "`alias.type` takes two arguments, like `alias.type oldname newname`." aliasMany :: InputPattern aliasMany = @@ -1561,12 +1394,9 @@ aliasMany = <> "creates aliases `.quux.foo.foo` and `.quux.bar.bar`." ] ) - $ \case + \case srcs@(_ : _) Cons.:> dest -> - first P.text $ - Input.AliasManyI - <$> traverse handleHashQualifiedSplitArg srcs - <*> handlePath'Arg dest + Input.AliasManyI <$> traverse handleHashQualifiedSplitArg srcs <*> handlePath'Arg dest _ -> Left (I.help aliasMany) up :: InputPattern @@ -1577,10 +1407,9 @@ up = I.Hidden [] (P.wrapColumn2 [(makeExample up [], "move current path up one level (deprecated)")]) - ( \case - [] -> Right Input.UpI - _ -> Left (I.help up) - ) + \case + [] -> Right Input.UpI + _ -> Left (I.help up) cd :: InputPattern cd = @@ -1608,9 +1437,9 @@ cd = ] ] ) - $ \case + \case [Left ".."] -> Right Input.UpI - [p] -> bimap P.text Input.SwitchBranchI $ handlePath'Arg p + [p] -> Input.SwitchBranchI <$> handlePath'Arg p _ -> Left (I.help cd) back :: InputPattern @@ -1654,13 +1483,8 @@ deleteNamespaceForce = deleteNamespaceParser :: P.Pretty CT.ColorText -> Input.Insistence -> I.Arguments -> Either (P.Pretty CT.ColorText) Input deleteNamespaceParser helpText insistence = \case - [Left "."] -> - first fromString - . pure - $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) - [p] -> - bimap P.text (Input.DeleteI . DeleteTarget'Namespace insistence . pure) $ - handleSplitArg p + [Left "."] -> first fromString . pure $ Input.DeleteI (DeleteTarget'Namespace insistence Nothing) + [p] -> Input.DeleteI . DeleteTarget'Namespace insistence . pure <$> handleSplitArg p _ -> Left helpText renameBranch :: InputPattern @@ -1671,10 +1495,8 @@ renameBranch = I.Visible [("namespace to move", Required, namespaceArg), ("new location", Required, newNameArg)] "`move.namespace foo bar` renames the path `foo` to `bar`." - $ \case - [src, dest] -> - first P.text $ - Input.MoveBranchI <$> handlePath'Arg src <*> handlePath'Arg dest + \case + [src, dest] -> Input.MoveBranchI <$> handlePath'Arg src <*> handlePath'Arg dest _ -> Left (I.help renameBranch) history :: InputPattern @@ -1693,10 +1515,8 @@ history = ) ] ) - $ \case - [src] -> - bimap P.text (Input.HistoryI (Just 10) (Just 10)) $ - handleBranchIdArg src + \case + [src] -> Input.HistoryI (Just 10) (Just 10) <$> handleBranchIdArg src [] -> pure $ Input.HistoryI (Just 10) (Just 10) (Right Path.currentPath) _ -> Left (I.help history) @@ -1721,11 +1541,8 @@ forkLocal = ) ] ) - $ \case - [src, dest] -> - Input.ForkLocalBranchI - <$> handleBranchId2Arg src - <*> handleBranchRelativePathArg dest + \case + [src, dest] -> Input.ForkLocalBranchI <$> handleBranchId2Arg src <*> handleBranchRelativePathArg dest _ -> Left (I.help forkLocal) libInstallInputPattern :: InputPattern @@ -1755,7 +1572,7 @@ libInstallInputPattern = ] ], parse = \case - [arg] -> bimap P.text Input.LibInstallI $ handleProjectMaybeBranchArg arg + [arg] -> Input.LibInstallI <$> handleProjectMaybeBranchArg arg _ -> Left (I.help libInstallInputPattern) } @@ -1775,17 +1592,10 @@ reset = ("`reset #pvfd222s8n /topic`", "reset the branch `topic` of the current project to the causal `#pvfd222s8n`.") ] ) - ( \case - [arg0] -> - Input.ResetI - <$> first P.text (handleBranchIdOrProjectArg arg0) - <*> pure Nothing - [arg0, arg1] -> - Input.ResetI - <$> first P.text (handleBranchIdOrProjectArg arg0) - <*> bimap P.text pure (handleLooseCodeOrProjectArg arg1) - _ -> Left $ I.help reset - ) + \case + [arg0] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> pure Nothing + [arg0, arg1] -> Input.ResetI <$> handleBranchIdOrProjectArg arg0 <*> fmap pure (handleLooseCodeOrProjectArg arg1) + _ -> Left $ I.help reset where config = ProjectBranchSuggestionsConfig @@ -1816,7 +1626,7 @@ resetRoot = ] ) $ \case - [src] -> bimap P.text Input.ResetRootI $ handleBranchIdArg src + [src] -> Input.ResetRootI <$> handleBranchIdArg src _ -> Left (I.help resetRoot) pull :: InputPattern @@ -1949,7 +1759,7 @@ debugFuzzyOptions = P.wrap $ "or `debug.fuzzy-options merge - _`" ] ) - $ \case + \case (cmd : args) -> Input.DebugFuzzyOptionsI <$> unsupportedStructuredArgument "a command" cmd @@ -2014,13 +1824,9 @@ push = ) . \case [] -> pure Input.PushSourceTarget0 - [targetStr] -> - bimap P.text Input.PushSourceTarget1 $ handlePushTargetArg targetStr + [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr [targetStr, sourceStr] -> - first P.text $ - Input.PushSourceTarget2 - <$> handlePushSourceArg sourceStr - <*> handlePushTargetArg targetStr + Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr _ -> Left (I.help push) where suggestionsConfig = @@ -2069,13 +1875,9 @@ pushCreate = ) . \case [] -> pure Input.PushSourceTarget0 - [targetStr] -> - bimap P.text Input.PushSourceTarget1 $ handlePushTargetArg targetStr + [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr [targetStr, sourceStr] -> - first P.text $ - Input.PushSourceTarget2 - <$> handlePushSourceArg sourceStr - <*> handlePushTargetArg targetStr + Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr _ -> Left (I.help pushForce) where suggestionsConfig = @@ -2103,13 +1905,9 @@ pushForce = ) . \case [] -> pure Input.PushSourceTarget0 - [targetStr] -> - bimap P.text Input.PushSourceTarget1 $ handlePushTargetArg targetStr + [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr [targetStr, sourceStr] -> - first P.text $ - Input.PushSourceTarget2 - <$> handlePushSourceArg sourceStr - <*> handlePushTargetArg targetStr + Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr _ -> Left (I.help pushForce) where suggestionsConfig = @@ -2147,13 +1945,9 @@ pushExhaustive = ) . \case [] -> pure Input.PushSourceTarget0 - [targetStr] -> - bimap P.text Input.PushSourceTarget1 $ handlePushTargetArg targetStr + [targetStr] -> Input.PushSourceTarget1 <$> handlePushTargetArg targetStr [targetStr, sourceStr] -> - first P.text $ - Input.PushSourceTarget2 - <$> handlePushSourceArg sourceStr - <*> handlePushTargetArg targetStr + Input.PushSourceTarget2 <$> handlePushSourceArg sourceStr <*> handlePushTargetArg targetStr _ -> Left (I.help pushExhaustive) where suggestionsConfig = @@ -2182,11 +1976,10 @@ mergeOldSquashInputPattern = <> "additional history entry.", parse = \case [src, dest] -> - first P.text $ - Input.MergeLocalBranchI - <$> handleLooseCodeOrProjectArg src - <*> handleLooseCodeOrProjectArg dest - <*> pure Branch.SquashMerge + Input.MergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> handleLooseCodeOrProjectArg dest + <*> pure Branch.SquashMerge _ -> Left $ I.help mergeOldSquashInputPattern } where @@ -2229,17 +2022,15 @@ mergeOldInputPattern = ) ( \case [src] -> - first P.text $ - Input.MergeLocalBranchI - <$> handleLooseCodeOrProjectArg src - <*> pure (This Path.relativeEmpty') - <*> pure Branch.RegularMerge + Input.MergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> pure (This Path.relativeEmpty') + <*> pure Branch.RegularMerge [src, dest] -> - first P.text $ - Input.MergeLocalBranchI - <$> handleLooseCodeOrProjectArg src - <*> handleLooseCodeOrProjectArg dest - <*> pure Branch.RegularMerge + Input.MergeLocalBranchI + <$> handleLooseCodeOrProjectArg src + <*> handleLooseCodeOrProjectArg dest + <*> pure Branch.RegularMerge _ -> Left $ I.help mergeOldInputPattern ) where @@ -2303,16 +2094,8 @@ diffNamespace = ] ) ( \case - [before, after] -> - first P.text $ - Input.DiffNamespaceI - <$> handleBranchIdArg before - <*> handleBranchIdArg after - [before] -> - first P.text $ - Input.DiffNamespaceI - <$> handleBranchIdArg before - <*> pure (pure Path.currentPath) + [before, after] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> handleBranchIdArg after + [before] -> Input.DiffNamespaceI <$> handleBranchIdArg before <*> pure (pure Path.currentPath) _ -> Left $ I.help diffNamespace ) where @@ -2340,16 +2123,9 @@ mergeOldPreviewInputPattern = ] ) ( \case - [src] -> - first P.text $ - Input.PreviewMergeLocalBranchI - <$> handleLooseCodeOrProjectArg src - <*> pure (This Path.relativeEmpty') + [src] -> Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> pure (This Path.relativeEmpty') [src, dest] -> - first P.text $ - Input.PreviewMergeLocalBranchI - <$> handleLooseCodeOrProjectArg src - <*> handleLooseCodeOrProjectArg dest + Input.PreviewMergeLocalBranchI <$> handleLooseCodeOrProjectArg src <*> handleLooseCodeOrProjectArg dest _ -> Left $ I.help mergeOldPreviewInputPattern ) where @@ -2409,7 +2185,7 @@ editNamespace = [ "`edit.namespace` will load all terms and types contained within the current namespace into your scratch file. This includes definitions in namespaces, but excludes libraries.", "`edit.namespace ns1 ns2 ...` loads the terms and types contained within the provided namespaces." ], - parse = bimap P.text Input.EditNamespaceI . traverse handlePathArg + parse = fmap Input.EditNamespaceI . traverse handlePathArg } topicNameArg :: ArgumentType @@ -2705,8 +2481,7 @@ namespaceDependencies = [("namespace", Optional, namespaceArg)] "List the external dependencies of the specified namespace." $ \case - [p] -> - bimap P.text (Input.NamespaceDependenciesI . pure) $ handlePath'Arg p + [p] -> Input.NamespaceDependenciesI . pure <$> handlePath'Arg p [] -> pure (Input.NamespaceDependenciesI Nothing) _ -> Left (I.help namespaceDependencies) @@ -2831,15 +2606,9 @@ debugNameDiff = visibility = I.Hidden, args = [("before namespace", Required, namespaceArg), ("after namespace", Required, namespaceArg)], help = P.wrap "List all name changes between two causal hashes. Does not detect patch changes.", - parse = - ( \case - [from, to] -> - first P.text $ - Input.DebugNameDiffI - <$> handleShortCausalHashArg from - <*> handleShortCausalHashArg to - _ -> Left (I.help debugNameDiff) - ) + parse = \case + [from, to] -> Input.DebugNameDiffI <$> handleShortCausalHashArg from <*> handleShortCausalHashArg to + _ -> Left (I.help debugNameDiff) } test :: InputPattern @@ -2867,7 +2636,7 @@ test = ) . \case [] -> pure Path.empty - [pathString] -> first P.text $ handlePathArg pathString + [pathString] -> handlePathArg pathString _ -> Left $ I.help test } @@ -2904,10 +2673,10 @@ docsToHtml = ) ] ) - $ \case + \case [namespacePath, destinationFilePath] -> Input.DocsToHtmlI - <$> first P.text (handlePath'Arg namespacePath) + <$> handlePath'Arg namespacePath <*> unsupportedStructuredArgument "a file name" destinationFilePath _ -> Left $ showPatternHelp docsToHtml @@ -2924,9 +2693,8 @@ docToMarkdown = ) ] ) - $ \case - [docNameText] -> - bimap P.text Input.DocToMarkdownI $ handleNameArg docNameText + \case + [docNameText] -> Input.DocToMarkdownI <$> handleNameArg docNameText _ -> Left $ showPatternHelp docToMarkdown execute :: InputPattern @@ -2962,7 +2730,7 @@ saveExecuteResult = <> "as `name`." ) $ \case - [w] -> first P.text $ Input.SaveExecuteResultI <$> handleNameArg w + [w] -> Input.SaveExecuteResultI <$> handleNameArg w _ -> Left $ showPatternHelp saveExecuteResult ioTest :: InputPattern @@ -3085,10 +2853,8 @@ createAuthor = \case symbolStr : authorStr@(_ : _) -> Input.CreateAuthorI - <$> first P.text (handleRelativeNameSegmentArg symbolStr) - <*> fmap - (parseAuthorName . unwords) - (traverse (unsupportedStructuredArgument "text") authorStr) + <$> handleRelativeNameSegmentArg symbolStr + <*> fmap (parseAuthorName . unwords) (traverse (unsupportedStructuredArgument "text") authorStr) _ -> Left $ showPatternHelp createAuthor where -- let's have a real parser in not too long @@ -3172,10 +2938,8 @@ projectCreate = ("`project.create foo`", "creates a project named `foo`") ], parse = \case - [] -> Right (Input.ProjectCreateI True Nothing) - [name] -> - bimap P.text (Input.ProjectCreateI True . pure) $ - handleProjectArg name + [] -> pure $ Input.ProjectCreateI True Nothing + [name] -> Input.ProjectCreateI True . pure <$> handleProjectArg name _ -> Left $ showPatternHelp projectCreate } @@ -3192,10 +2956,8 @@ projectCreateEmptyInputPattern = ("`project.create-empty foo`", "creates an empty project named `foo`") ], parse = \case - [] -> Right (Input.ProjectCreateI False Nothing) - [name] -> - bimap P.text (Input.ProjectCreateI False . pure) $ - handleProjectArg name + [] -> pure $ Input.ProjectCreateI False Nothing + [name] -> Input.ProjectCreateI False . pure <$> handleProjectArg name _ -> Left $ showPatternHelp projectCreateEmptyInputPattern } @@ -3211,8 +2973,7 @@ projectRenameInputPattern = [ ("`project.rename foo`", "renames the current project to `foo`") ], parse = \case - [nameString] -> - bimap P.text Input.ProjectRenameI $ handleProjectArg nameString + [nameString] -> Input.ProjectRenameI <$> handleProjectArg nameString _ -> Left (showPatternHelp projectRenameInputPattern) } @@ -3231,9 +2992,7 @@ projectSwitch = ("`switch /bar`", "switches to the branch `bar` in the current project") ], parse = \case - [name] -> - bimap P.text Input.ProjectSwitchI $ - handleProjectAndBranchNamesArg name + [name] -> Input.ProjectSwitchI <$> handleProjectAndBranchNamesArg name _ -> Left (showPatternHelp projectSwitch) } where @@ -3269,8 +3028,7 @@ branchesInputPattern = ], parse = \case [] -> Right (Input.BranchesI Nothing) - [nameString] -> - bimap P.text (Input.BranchesI . pure) $ handleProjectArg nameString + [nameString] -> Input.BranchesI . pure <$> handleProjectArg nameString _ -> Left (showPatternHelp branchesInputPattern) } @@ -3293,11 +3051,9 @@ branchInputPattern = parse = \case [source0, name] -> Input.BranchI . Input.BranchSourceI'LooseCodeOrProject - <$> first P.text (handleLooseCodeOrProjectArg source0) + <$> handleLooseCodeOrProjectArg source0 <*> handleMaybeProjectBranchArg name - [name] -> - Input.BranchI Input.BranchSourceI'CurrentContext - <$> handleMaybeProjectBranchArg name + [name] -> Input.BranchI Input.BranchSourceI'CurrentContext <$> handleMaybeProjectBranchArg name _ -> Left $ showPatternHelp branchInputPattern } where @@ -3340,8 +3096,7 @@ branchRenameInputPattern = P.wrapColumn2 [("`branch.rename foo`", "renames the current branch to `foo`")], parse = \case - [name] -> - bimap P.text Input.BranchRenameI $ handleProjectBranchNameArg name + [name] -> Input.BranchRenameI <$> handleProjectBranchNameArg name _ -> Left (showPatternHelp branchRenameInputPattern) } @@ -3375,16 +3130,11 @@ clone = ) ], parse = \case - [remoteNames] -> do - first P.text $ - Input.CloneI - <$> handleProjectAndBranchNamesArg remoteNames - <*> pure Nothing + [remoteNames] -> Input.CloneI <$> handleProjectAndBranchNamesArg remoteNames <*> pure Nothing [remoteNames, localNames] -> - first P.text $ - Input.CloneI - <$> handleProjectAndBranchNamesArg remoteNames - <*> fmap pure (handleProjectAndBranchNamesArg localNames) + Input.CloneI + <$> handleProjectAndBranchNamesArg remoteNames + <*> fmap pure (handleProjectAndBranchNamesArg localNames) _ -> Left $ showPatternHelp clone } @@ -3417,10 +3167,7 @@ upgrade = "`upgrade old new` upgrades library dependency `lib.old` to `lib.new`, and, if successful, deletes `lib.old`.", parse = \case [oldString, newString] -> - first P.text $ - Input.UpgradeI - <$> handleRelativeNameSegmentArg oldString - <*> handleRelativeNameSegmentArg newString + Input.UpgradeI <$> handleRelativeNameSegmentArg oldString <*> handleRelativeNameSegmentArg newString _ -> Left $ I.help upgrade } From f8474ff457f2d3a28bba854376e3b16b819e5168 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Tue, 28 May 2024 16:54:33 -0600 Subject: [PATCH 70/82] Handle `SCH` carefully in `StructuredArgument`s When `StructuredArgument`s are used as an input, preserve the entire hash. When printed, take the length as an optional argument (and show the full hash when unavailable). --- .../src/Unison/Codebase/ShortCausalHash.hs | 9 +++++++ .../src/Unison/Codebase/Editor/HandleInput.hs | 3 ++- .../src/Unison/Codebase/Editor/Output.hs | 4 ++-- .../src/Unison/CommandLine/InputPatterns.hs | 24 +++++++------------ .../src/Unison/CommandLine/OutputMessages.hs | 3 ++- 5 files changed, 24 insertions(+), 19 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs b/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs index 753351933..7e8b40e75 100644 --- a/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs +++ b/parser-typechecker/src/Unison/Codebase/ShortCausalHash.hs @@ -2,6 +2,7 @@ module Unison.Codebase.ShortCausalHash ( toString, toHash, fromHash, + fromFullHash, fromText, ShortCausalHash (..), ) @@ -27,6 +28,14 @@ fromHash :: (Coercible h Hash.Hash) => Int -> h -> ShortCausalHash fromHash len = ShortCausalHash . Text.take len . Hash.toBase32HexText . coerce +-- | This allows a full hash to be preserved as a `ShortCausalHash`. +-- +-- `ShortCausalHash` is used for input when we expect a user to enter a hash on the command line, so they aren’t +-- required to enter the full hash. However, these inputs may also come from an internal source, and in such cases, +-- there is no reason to truncate the hash. +fromFullHash :: (Coercible h Hash.Hash) => h -> ShortCausalHash +fromFullHash = ShortCausalHash . Hash.toBase32HexText . coerce + -- abc -> SCH abc -- #abc -> SCH abc fromText :: Text -> Maybe ShortCausalHash diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 9f934f574..26eb5723f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -812,8 +812,9 @@ loop e = do ListDependenciesI hq -> handleDependencies hq NamespaceDependenciesI path -> handleNamespaceDependencies path DebugNumberedArgsI -> do + schLength <- Cli.runTransaction Codebase.branchHashLength numArgs <- use #numberedArgs - Cli.respond (DumpNumberedArgs numArgs) + Cli.respond (DumpNumberedArgs schLength numArgs) DebugTypecheckedUnisonFileI -> do hqLength <- Cli.runTransaction Codebase.hashLength uf <- Cli.expectLatestTypecheckedFile diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 4aa79eed3..ca67d3e4b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -27,7 +27,7 @@ import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Project qualified as Sqlite import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import Unison.Auth.Types (CredentialFailure) -import Unison.Cli.MergeTypes (MergeSourceOrTarget, MergeSourceAndTarget) +import Unison.Cli.MergeTypes (MergeSourceAndTarget, MergeSourceOrTarget) import Unison.Cli.Share.Projects.Types qualified as Share import Unison.Codebase.Editor.Input import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput) @@ -302,7 +302,7 @@ data Output | ListDependencies PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms | -- | List dependents of a type or term. ListDependents PPE.PrettyPrintEnv (Set LabeledDependency) [HQ.HashQualified Name] [HQ.HashQualified Name] -- types, terms - | DumpNumberedArgs NumberedArgs + | DumpNumberedArgs HashLength NumberedArgs | DumpBitBooster CausalHash (Map CausalHash [CausalHash]) | DumpUnisonFileHashes Int [(Name, Reference.Id)] [(Name, Reference.Id)] [(Name, Reference.Id)] | BadName Text diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 7f7524dd2..dac337904 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -220,14 +220,8 @@ import Unison.Util.Monoid (intercalateMap) import Unison.Util.Pretty qualified as P import Unison.Util.Pretty.MegaParsec (prettyPrintParseError) --- | --- --- __FIXME__: Don’t hardcode this -schLength :: Int -schLength = 10 - -formatStructuredArgument :: StructuredArgument -> Text -formatStructuredArgument = \case +formatStructuredArgument :: Maybe Int -> StructuredArgument -> Text +formatStructuredArgument schLength = \case SA.AbsolutePath path -> into @Text $ show path SA.Name name -> Name.toText name SA.HashQualified hqName -> HQ.toText hqName @@ -237,7 +231,7 @@ formatStructuredArgument = \case -- also: ShortHash.toText . Reference.toShortHash SA.Ref reference -> Reference.toText reference -- also: ("#" <>) . Hash.toBase32HexText . unCausalHash - SA.Namespace causalHash -> ("#" <>) . SCH.toText $ SCH.fromHash schLength causalHash + SA.Namespace causalHash -> ("#" <>) . SCH.toText $ maybe SCH.fromFullHash SCH.fromHash schLength causalHash SA.NameWithBranchPrefix absBranchId name -> prefixBranchId absBranchId name SA.HashQualifiedWithBranchPrefix absBranchId hq'Name -> HQ'.toTextWith (prefixBranchId absBranchId) hq'Name SA.ShallowListEntry path entry -> entryToHQText path entry @@ -270,7 +264,7 @@ formatStructuredArgument = \case -- command /should/ accept a structured argument of some type, but currently -- wants a `String`. unifyArgument :: I.Argument -> String -unifyArgument = either id (Text.unpack . formatStructuredArgument) +unifyArgument = either id (Text.unpack . formatStructuredArgument Nothing) showPatternHelp :: InputPattern -> P.Pretty CT.ColorText showPatternHelp i = @@ -306,7 +300,7 @@ wrongStructuredArgument :: Text -> StructuredArgument -> P.Pretty CT.ColorText wrongStructuredArgument expected actual = P.text $ expectedButActually expected - (formatStructuredArgument actual) + (formatStructuredArgument Nothing actual) case actual of SA.Ref _ -> "a reference" SA.Name _ -> "a name" @@ -467,7 +461,7 @@ handleBranchIdArg = SA.Name name -> pure . pure $ Path.fromName' name SA.NameWithBranchPrefix mprefix name -> pure . pure . Path.fromName' $ either (const name) (Name.makeAbsolute . flip Path.prefixName name) mprefix - SA.Namespace hash -> pure . Left $ SCH.fromHash schLength hash + SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg handleBranchIdOrProjectArg :: @@ -477,7 +471,7 @@ handleBranchIdOrProjectArg = either (maybe (Left $ P.text "Expected a branch or project, but it’s not") pure . branchIdOrProject) \case - SA.Namespace hash -> pure . This . Left $ SCH.fromHash schLength hash + SA.Namespace hash -> pure . This . Left $ SCH.fromFullHash hash SA.AbsolutePath path -> pure . This . pure $ Path.absoluteToPath' path SA.Name name -> pure . This . pure $ Path.fromName' name SA.NameWithBranchPrefix (Left _) name -> pure . This . pure $ Path.fromName' name @@ -509,7 +503,7 @@ handleBranchId2Arg = either Input.parseBranchId2 \case - SA.Namespace hash -> pure . Left $ SCH.fromHash schLength hash + SA.Namespace hash -> pure . Left $ SCH.fromFullHash hash SA.AbsolutePath path -> pure . pure . LoosePath $ Path.absoluteToPath' path SA.Name name -> pure . pure . LoosePath $ Path.fromName' name SA.NameWithBranchPrefix (Left _) name -> pure . pure . LoosePath $ Path.fromName' name @@ -584,7 +578,7 @@ handleShortCausalHashArg = either (first (P.text . Text.pack) . Input.parseShortCausalHash) \case - SA.Namespace hash -> pure $ SCH.fromHash schLength hash + SA.Namespace hash -> pure $ SCH.fromFullHash hash otherNumArg -> Left $ wrongStructuredArgument "a causal hash" otherNumArg handleShortHashOrHQSplit'Arg :: diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 43e6c9fbb..0054183d4 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1545,7 +1545,8 @@ notifyUser dir = \case prettyNamespaceKey dest <> "is already up-to-date with" <> P.group (prettyNamespaceKey src <> ".") - DumpNumberedArgs args -> pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument) args + DumpNumberedArgs schLength args -> + pure . P.numberedList $ fmap (P.text . IP.formatStructuredArgument (pure schLength)) args NoConflictsOrEdits -> pure (P.okCallout "No conflicts or edits in progress.") HelpMessage pat -> pure $ IP.showPatternHelp pat From efcff6e076dc67e949281b1b5dee92b268d23b04 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Tue, 28 May 2024 17:17:22 -0600 Subject: [PATCH 71/82] Add an EditorConfig config MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit https://editorconfig.org/ This provides limited editor-agnostic style information. The only one I care about here is `max_line_length`, since Ormolu doesn’t manage that. It sets up my editor so that comments wrap at the expected place, and gives me a hint when expressions should be split. The other values just seem like reasonable ones, but they can also be removed (and/or customized for particular file types). --- .editorconfig | 11 +++++++++++ 1 file changed, 11 insertions(+) create mode 100644 .editorconfig diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 000000000..24503cfc2 --- /dev/null +++ b/.editorconfig @@ -0,0 +1,11 @@ +# Multi-editor style config: https://EditorConfig.org + +root = true + +[*] +charset = utf-8 +end_of_line = lf +indent_style = space +insert_final_newline = true +max_line_length = 120 +trim_trailing_whitespace = true From 50334f262f9628fd8a6b120d5979654778d00362 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Tue, 28 May 2024 16:44:01 -0400 Subject: [PATCH 72/82] make "lenient" decl coherency check that can't fail --- lib/unison-prelude/src/Unison/Util/Map.hs | 6 + .../src/Unison/Merge/DeclCoherencyCheck.hs | 151 +++++++++++++----- .../src/Unison/Merge/DeclNameLookup.hs | 5 + 3 files changed, 121 insertions(+), 41 deletions(-) diff --git a/lib/unison-prelude/src/Unison/Util/Map.hs b/lib/unison-prelude/src/Unison/Util/Map.hs index 3f46ad42a..be67d730b 100644 --- a/lib/unison-prelude/src/Unison/Util/Map.hs +++ b/lib/unison-prelude/src/Unison/Util/Map.hs @@ -5,6 +5,7 @@ module Unison.Util.Map bitraverse, bitraversed, deleteLookup, + deleteLookupJust, elemsSet, foldM, foldMapM, @@ -106,6 +107,11 @@ deleteLookup :: (Ord k) => k -> Map k v -> (Maybe v, Map k v) deleteLookup = Map.alterF (,Nothing) +-- | Like 'deleteLookup', but asserts the value is in the map prior to deletion. +deleteLookupJust :: (HasCallStack, Ord k) => k -> Map k v -> (v, Map k v) +deleteLookupJust = + Map.alterF (maybe (error (reportBug "E525283" "deleteLookupJust: element not found")) (,Nothing)) + -- | Like 'Map.elems', but return the values as a set. elemsSet :: Ord v => Map k v -> Set v elemsSet = diff --git a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs index b763d4e55..a54812904 100644 --- a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs +++ b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs @@ -82,10 +82,11 @@ module Unison.Merge.DeclCoherencyCheck ( IncoherentDeclReason (..), checkDeclCoherency, + lenientCheckDeclCoherency, ) where -import Control.Lens (view, (%=), (.=)) +import Control.Lens (over, view, (%=), (.=), _2) import Control.Monad.Except (ExceptT) import Control.Monad.Except qualified as Except import Control.Monad.State.Strict (StateT) @@ -108,9 +109,8 @@ import Unison.NameSegment (NameSegment) import Unison.Prelude import Unison.Referent (Referent) import Unison.Referent qualified as Referent -import Unison.Sqlite (Transaction) import Unison.Util.Defns (Defns (..), DefnsF) -import Unison.Util.Map qualified as Map (deleteLookup, upsertF) +import Unison.Util.Map qualified as Map (deleteLookup, deleteLookupJust, upsertF) import Unison.Util.Nametree (Nametree (..)) data IncoherentDeclReason @@ -129,9 +129,11 @@ data IncoherentDeclReason | IncoherentDeclReason'StrayConstructor !Name checkDeclCoherency :: - (TypeReferenceId -> Transaction Int) -> + forall m. + Monad m => + (TypeReferenceId -> m Int) -> Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> - Transaction (Either IncoherentDeclReason DeclNameLookup) + m (Either IncoherentDeclReason DeclNameLookup) checkDeclCoherency loadDeclNumConstructors = Except.runExceptT . fmap (view #declNameLookup) @@ -140,10 +142,10 @@ checkDeclCoherency loadDeclNumConstructors = where go :: [NameSegment] -> - (Nametree (Defns (Map NameSegment Referent) (Map NameSegment TypeReference))) -> - StateT DeclCoherencyCheckState (ExceptT IncoherentDeclReason Transaction) () - go prefix (Nametree Defns {terms, types} children) = do - for_ (Map.toList terms) \case + (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> + StateT DeclCoherencyCheckState (ExceptT IncoherentDeclReason m) () + go prefix (Nametree defns children) = do + for_ (Map.toList defns.terms) \case (_, Referent.Ref _) -> pure () (_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure () (name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do @@ -152,35 +154,35 @@ checkDeclCoherency loadDeclNumConstructors = #expectedConstructors .= expectedConstructors1 where f :: - Maybe (Name, IntMap MaybeConstructorName) -> - Either IncoherentDeclReason (Name, IntMap MaybeConstructorName) + Maybe (Name, IntMap (Maybe Name)) -> + Either IncoherentDeclReason (Name, IntMap (Maybe Name)) f = \case Nothing -> Left (IncoherentDeclReason'StrayConstructor (fullName name)) Just (typeName, expected) -> (typeName,) <$> IntMap.alterF g (fromIntegral @Word64 @Int conId) expected where - g :: Maybe MaybeConstructorName -> Either IncoherentDeclReason (Maybe MaybeConstructorName) + g :: Maybe (Maybe Name) -> Either IncoherentDeclReason (Maybe (Maybe Name)) g = \case Nothing -> error "didnt put expected constructor id" - Just NoConstructorNameYet -> Right (Just (YesConstructorName (fullName name))) - Just (YesConstructorName firstName) -> + Just Nothing -> Right (Just (Just (fullName name))) + Just (Just firstName) -> Left (IncoherentDeclReason'ConstructorAlias firstName (fullName name)) childrenWeWentInto <- - forMaybe (Map.toList types) \case + forMaybe (Map.toList defns.types) \case (_, ReferenceBuiltin _) -> pure Nothing (name, ReferenceDerived typeRef) -> do DeclCoherencyCheckState {expectedConstructors} <- State.get whatHappened <- do let recordNewDecl :: - Maybe (Name, IntMap MaybeConstructorName) -> - Compose (ExceptT IncoherentDeclReason Transaction) WhatHappened (Name, IntMap MaybeConstructorName) + Maybe (Name, IntMap (Maybe Name)) -> + Compose (ExceptT IncoherentDeclReason m) WhatHappened (Name, IntMap (Maybe Name)) recordNewDecl = Compose . \case Just (shorterTypeName, _) -> Except.throwError (IncoherentDeclReason'NestedDeclAlias shorterTypeName typeName) Nothing -> lift (loadDeclNumConstructors typeRef) <&> \case 0 -> UninhabitedDecl - n -> InhabitedDecl (typeName, IntMap.fromAscList [(i, NoConstructorNameYet) | i <- [0 .. n - 1]]) + n -> InhabitedDecl (typeName, IntMap.fromAscList [(i, Nothing) | i <- [0 .. n - 1]]) lift (getCompose (Map.upsertF recordNewDecl typeRef expectedConstructors)) case whatHappened of UninhabitedDecl -> do @@ -197,18 +199,92 @@ checkDeclCoherency loadDeclNumConstructors = let (fromJust -> (_typeName, maybeConstructorNames), expectedConstructors1) = Map.deleteLookup typeRef expectedConstructors constructorNames <- - unMaybeConstructorNames maybeConstructorNames & onNothing do + sequence (IntMap.elems maybeConstructorNames) & onNothing do Except.throwError (IncoherentDeclReason'MissingConstructorName typeName) #expectedConstructors .= expectedConstructors1 - #declNameLookup %= \declNameLookup -> - DeclNameLookup - { constructorToDecl = - List.foldl' - (\acc constructorName -> Map.insert constructorName typeName acc) - declNameLookup.constructorToDecl - constructorNames, - declToConstructors = Map.insert typeName constructorNames declNameLookup.declToConstructors - } + #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 = fullName name + + let childrenWeHaventGoneInto = children `Map.withoutKeys` Set.fromList childrenWeWentInto + for_ (Map.toList childrenWeHaventGoneInto) \(name, child) -> go (name : prefix) child + where + fullName name = + Name.fromReverseSegments (name :| prefix) + +lenientCheckDeclCoherency :: + forall m. + Monad m => + (TypeReferenceId -> m Int) -> + Nametree (DefnsF (Map NameSegment) Referent TypeReference) -> + m (Map Name [Maybe Name]) +lenientCheckDeclCoherency loadDeclNumConstructors = + fmap (view #declToConstructors) + . (`State.execStateT` LenientDeclCoherencyCheckState Map.empty Map.empty) + . go [] + where + go :: + [NameSegment] -> + (Nametree (DefnsF (Map NameSegment) Referent TypeReference)) -> + StateT LenientDeclCoherencyCheckState m () + go prefix (Nametree defns children) = do + for_ (Map.toList defns.terms) \case + (_, Referent.Ref _) -> pure () + (_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure () + (name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do + #expectedConstructors %= Map.adjust (Map.map f) typeRef + where + f :: IntMap (Maybe Name) -> IntMap (Maybe Name) + f = + IntMap.adjust g (fromIntegral @Word64 @Int conId) + where + g :: Maybe Name -> Maybe Name + g = \case + Nothing -> Just (fullName name) + -- Ignore constructor alias, just keep first name we found + Just firstName -> Just firstName + + childrenWeWentInto <- + forMaybe (Map.toList defns.types) \case + (_, ReferenceBuiltin _) -> pure Nothing + (name, ReferenceDerived typeRef) -> do + whatHappened <- do + let recordNewDecl :: m (WhatHappened (Map Name (IntMap (Maybe Name)))) + recordNewDecl = + loadDeclNumConstructors typeRef <&> \case + 0 -> UninhabitedDecl + n -> InhabitedDecl (Map.singleton typeName (IntMap.fromAscList [(i, Nothing) | i <- [0 .. n - 1]])) + state <- State.get + lift (getCompose (Map.upsertF (\_ -> Compose recordNewDecl) typeRef state.expectedConstructors)) + case whatHappened of + UninhabitedDecl -> do + #declToConstructors %= Map.insert typeName [] + pure Nothing + InhabitedDecl expectedConstructors1 -> do + let child = Map.findWithDefault (Nametree (Defns Map.empty Map.empty) Map.empty) name children + #expectedConstructors .= expectedConstructors1 + go (name : prefix) child + state <- State.get + let (maybeConstructorNames, expectedConstructors) = + Map.alterF f typeRef state.expectedConstructors + where + f :: + Maybe (Map Name (IntMap (Maybe Name))) -> + (IntMap (Maybe Name), Maybe (Map Name (IntMap (Maybe Name)))) + f = + -- fromJust is safe here because we upserted `typeRef` key above + -- deleteLookupJust is safe here because we upserted `typeName` key above + fromJust + >>> Map.deleteLookupJust typeName + >>> over _2 \m -> if Map.null m then Nothing else Just m + #expectedConstructors .= expectedConstructors + #declToConstructors %= Map.insert typeName (IntMap.elems maybeConstructorNames) pure (Just name) where typeName = fullName name @@ -220,23 +296,16 @@ checkDeclCoherency loadDeclNumConstructors = Name.fromReverseSegments (name :| prefix) data DeclCoherencyCheckState = DeclCoherencyCheckState - { expectedConstructors :: !(Map TypeReferenceId (Name, IntMap MaybeConstructorName)), + { expectedConstructors :: !(Map TypeReferenceId (Name, IntMap (Maybe Name))), declNameLookup :: !DeclNameLookup } deriving stock (Generic) -data MaybeConstructorName - = NoConstructorNameYet - | YesConstructorName !Name - -unMaybeConstructorNames :: IntMap MaybeConstructorName -> Maybe [Name] -unMaybeConstructorNames = - traverse f . IntMap.elems - where - f :: MaybeConstructorName -> Maybe Name - f = \case - NoConstructorNameYet -> Nothing - YesConstructorName name -> Just name +data LenientDeclCoherencyCheckState = LenientDeclCoherencyCheckState + { expectedConstructors :: !(Map TypeReferenceId (Map Name (IntMap (Maybe Name)))), + declToConstructors :: !(Map Name [Maybe Name]) + } + deriving stock (Generic) data WhatHappened a = UninhabitedDecl diff --git a/unison-merge/src/Unison/Merge/DeclNameLookup.hs b/unison-merge/src/Unison/Merge/DeclNameLookup.hs index c3e663172..9fa85b99d 100644 --- a/unison-merge/src/Unison/Merge/DeclNameLookup.hs +++ b/unison-merge/src/Unison/Merge/DeclNameLookup.hs @@ -12,8 +12,13 @@ import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) import Unison.DataDeclaration (Decl) import Unison.DataDeclaration qualified as DataDeclaration import Unison.Name (Name) +import Unison.NameSegment (NameSegment) import Unison.Prelude +import Unison.Reference (TypeReference) +import Unison.Referent (Referent) import Unison.Syntax.Name qualified as Name +import Unison.Util.Defns (Defns (..), DefnsF) +import Unison.Util.Nametree (Nametree (..)) import Unison.Var (Var) -- | A lookup from decl-to-constructor name and vice-versa. From 52283ed3f7ded8cae8aa45cb08fd6128e36331fb Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 29 May 2024 10:38:13 -0400 Subject: [PATCH 73/82] minor cleanup --- .../src/Unison/Merge/DeclCoherencyCheck.hs | 82 ++++++++++++------- 1 file changed, 51 insertions(+), 31 deletions(-) diff --git a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs index a54812904..82cff729f 100644 --- a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs +++ b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs @@ -102,6 +102,7 @@ import Data.Maybe (fromJust) import Data.Set qualified as Set import U.Codebase.Reference (Reference' (..), TypeReference, TypeReferenceId) import Unison.ConstructorReference (GConstructorReference (..)) +import Unison.DataDeclaration.ConstructorId (ConstructorId) import Unison.Merge.DeclNameLookup (DeclNameLookup (..)) import Unison.Name (Name) import Unison.Name qualified as Name @@ -154,18 +155,16 @@ checkDeclCoherency loadDeclNumConstructors = #expectedConstructors .= expectedConstructors1 where f :: - Maybe (Name, IntMap (Maybe Name)) -> - Either IncoherentDeclReason (Name, IntMap (Maybe Name)) + Maybe (Name, ConstructorNames) -> + Either IncoherentDeclReason (Name, ConstructorNames) f = \case - Nothing -> Left (IncoherentDeclReason'StrayConstructor (fullName name)) - Just (typeName, expected) -> (typeName,) <$> IntMap.alterF g (fromIntegral @Word64 @Int conId) expected - where - g :: Maybe (Maybe Name) -> Either IncoherentDeclReason (Maybe (Maybe Name)) - g = \case - Nothing -> error "didnt put expected constructor id" - Just Nothing -> Right (Just (Just (fullName name))) - Just (Just firstName) -> - Left (IncoherentDeclReason'ConstructorAlias firstName (fullName name)) + Nothing -> Left (IncoherentDeclReason'StrayConstructor name1) + Just (typeName, expected) -> + case recordConstructorName conId name1 expected of + Left existingName -> Left (IncoherentDeclReason'ConstructorAlias existingName name1) + Right expected1 -> Right (typeName, expected1) + where + name1 = fullName name childrenWeWentInto <- forMaybe (Map.toList defns.types) \case @@ -174,15 +173,15 @@ checkDeclCoherency loadDeclNumConstructors = DeclCoherencyCheckState {expectedConstructors} <- State.get whatHappened <- do let recordNewDecl :: - Maybe (Name, IntMap (Maybe Name)) -> - Compose (ExceptT IncoherentDeclReason m) WhatHappened (Name, IntMap (Maybe Name)) + Maybe (Name, ConstructorNames) -> + Compose (ExceptT IncoherentDeclReason m) WhatHappened (Name, ConstructorNames) recordNewDecl = Compose . \case Just (shorterTypeName, _) -> Except.throwError (IncoherentDeclReason'NestedDeclAlias shorterTypeName typeName) Nothing -> lift (loadDeclNumConstructors typeRef) <&> \case 0 -> UninhabitedDecl - n -> InhabitedDecl (typeName, IntMap.fromAscList [(i, Nothing) | i <- [0 .. n - 1]]) + n -> InhabitedDecl (typeName, emptyConstructorNames n) lift (getCompose (Map.upsertF recordNewDecl typeRef expectedConstructors)) case whatHappened of UninhabitedDecl -> do @@ -238,28 +237,18 @@ lenientCheckDeclCoherency loadDeclNumConstructors = (_, Referent.Ref _) -> pure () (_, Referent.Con (ConstructorReference (ReferenceBuiltin _) _) _) -> pure () (name, Referent.Con (ConstructorReference (ReferenceDerived typeRef) conId) _) -> do - #expectedConstructors %= Map.adjust (Map.map f) typeRef - where - f :: IntMap (Maybe Name) -> IntMap (Maybe Name) - f = - IntMap.adjust g (fromIntegral @Word64 @Int conId) - where - g :: Maybe Name -> Maybe Name - g = \case - Nothing -> Just (fullName name) - -- Ignore constructor alias, just keep first name we found - Just firstName -> Just firstName + #expectedConstructors %= Map.adjust (Map.map (lenientRecordConstructorName conId (fullName name))) typeRef childrenWeWentInto <- forMaybe (Map.toList defns.types) \case (_, ReferenceBuiltin _) -> pure Nothing (name, ReferenceDerived typeRef) -> do whatHappened <- do - let recordNewDecl :: m (WhatHappened (Map Name (IntMap (Maybe Name)))) + let recordNewDecl :: m (WhatHappened (Map Name ConstructorNames)) recordNewDecl = loadDeclNumConstructors typeRef <&> \case 0 -> UninhabitedDecl - n -> InhabitedDecl (Map.singleton typeName (IntMap.fromAscList [(i, Nothing) | i <- [0 .. n - 1]])) + n -> InhabitedDecl (Map.singleton typeName (emptyConstructorNames n)) state <- State.get lift (getCompose (Map.upsertF (\_ -> Compose recordNewDecl) typeRef state.expectedConstructors)) case whatHappened of @@ -275,8 +264,8 @@ lenientCheckDeclCoherency loadDeclNumConstructors = Map.alterF f typeRef state.expectedConstructors where f :: - Maybe (Map Name (IntMap (Maybe Name))) -> - (IntMap (Maybe Name), Maybe (Map Name (IntMap (Maybe Name)))) + Maybe (Map Name ConstructorNames) -> + (ConstructorNames, Maybe (Map Name ConstructorNames)) f = -- fromJust is safe here because we upserted `typeRef` key above -- deleteLookupJust is safe here because we upserted `typeName` key above @@ -296,17 +285,48 @@ lenientCheckDeclCoherency loadDeclNumConstructors = Name.fromReverseSegments (name :| prefix) data DeclCoherencyCheckState = DeclCoherencyCheckState - { expectedConstructors :: !(Map TypeReferenceId (Name, IntMap (Maybe Name))), + { expectedConstructors :: !(Map TypeReferenceId (Name, ConstructorNames)), declNameLookup :: !DeclNameLookup } deriving stock (Generic) data LenientDeclCoherencyCheckState = LenientDeclCoherencyCheckState - { expectedConstructors :: !(Map TypeReferenceId (Map Name (IntMap (Maybe Name)))), + { expectedConstructors :: !(Map TypeReferenceId (Map Name ConstructorNames)), declToConstructors :: !(Map Name [Maybe Name]) } deriving stock (Generic) +-- A partial mapping from constructor id to name; a collection of constructor names starts out with the correct number +-- of keys (per the number of data constructors) all mapped to Nothing. Then, as names are discovered by walking a +-- name tree, Nothings become Justs. +type ConstructorNames = + IntMap (Maybe Name) + +-- Make an empty set of constructor names given the number of constructors. +emptyConstructorNames :: Int -> ConstructorNames +emptyConstructorNames numConstructors = + IntMap.fromAscList [(i, Nothing) | i <- [0 .. numConstructors - 1]] + +recordConstructorName :: HasCallStack => ConstructorId -> Name -> ConstructorNames -> Either Name ConstructorNames +recordConstructorName conId conName = + IntMap.alterF f (fromIntegral @Word64 @Int conId) + where + f :: Maybe (Maybe Name) -> Either Name (Maybe (Maybe Name)) + f = \case + Nothing -> error (reportBug "E397219" ("recordConstructorName: didn't expect constructor id " ++ show conId)) + Just Nothing -> Right (Just (Just conName)) + Just (Just existingName) -> Left existingName + +lenientRecordConstructorName :: ConstructorId -> Name -> ConstructorNames -> ConstructorNames +lenientRecordConstructorName conId conName = + IntMap.adjust f (fromIntegral @Word64 @Int conId) + where + f :: Maybe Name -> Maybe Name + f = \case + Nothing -> Just conName + -- Ignore constructor alias, just keep first name we found + Just existingName -> Just existingName + data WhatHappened a = UninhabitedDecl | InhabitedDecl !a From 32cde2cd35976029e4c548edcd08becbd48c6601 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 29 May 2024 12:41:59 -0400 Subject: [PATCH 74/82] relax merge preconditions on lca --- .../Codebase/Editor/HandleInput/Merge2.hs | 50 +++---- .../src/Unison/Codebase/Editor/Output.hs | 8 +- .../src/Unison/CommandLine/OutputMessages.hs | 24 ++-- unison-core/src/Unison/DataDeclaration.hs | 17 ++- .../src/Unison/Merge/DeclCoherencyCheck.hs | 6 + .../src/Unison/Merge/DeclNameLookup.hs | 30 ---- unison-merge/src/Unison/Merge/Diff.hs | 58 ++++++-- unison-merge/src/Unison/Merge/Synhash.hs | 50 +++---- unison-src/transcripts/merge.md | 67 +++++++++ unison-src/transcripts/merge.output.md | 136 ++++++++++++++++++ 10 files changed, 327 insertions(+), 119 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index d6685f105..d492d4650 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -43,7 +43,7 @@ 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 (..), MergeSourceOrTarget (..), MergeSourceAndTarget (..)) +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 @@ -76,7 +76,7 @@ import Unison.HashQualified qualified as HQ import Unison.HashQualified' qualified as HQ' import Unison.Merge.CombineDiffs (CombinedDiffOp (..), combineDiffs) import Unison.Merge.Database (MergeDatabase (..), makeMergeDatabase, referent2to1) -import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason (..), checkDeclCoherency) +import Unison.Merge.DeclCoherencyCheck (IncoherentDeclReason (..), checkDeclCoherency, lenientCheckDeclCoherency) import Unison.Merge.DeclNameLookup (DeclNameLookup (..), expectConstructorNames) import Unison.Merge.Diff qualified as Merge import Unison.Merge.DiffOp (DiffOp (..)) @@ -220,7 +220,7 @@ doMerge info = do let aliceBranchNames = ProjectAndBranch info.alice.project.name info.alice.projectBranch.name let mergeSource = MergeSourceOrTarget'Source info.bob.source let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames - let mergeSourceAndTarget = MergeSourceAndTarget { alice = aliceBranchNames, bob = info.bob.source } + let mergeSourceAndTarget = MergeSourceAndTarget {alice = aliceBranchNames, bob = info.bob.source} Cli.Env {codebase} <- ask @@ -267,19 +267,17 @@ doMerge info = do Cli.returnEarly (Output.MergeDefnsInLib who) -- Load Alice/Bob/LCA definitions and decl name lookups - (defns3, declNameLookups3) <- do + (defns3, declNameLookups, lcaDeclToConstructors) <- do + let emptyNametree = Nametree {value = Defns Map.empty Map.empty, children = Map.empty} + let loadDefns branch = + Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName -> + Cli.returnEarly case conflictedName of + ConflictedName'Term name refs -> Output.MergeConflictedTermName name refs + ConflictedName'Type name refs -> Output.MergeConflictedTypeName name refs let load = \case - Nothing -> - pure - ( Nametree {value = Defns Map.empty Map.empty, children = Map.empty}, - DeclNameLookup Map.empty Map.empty - ) + Nothing -> pure (emptyNametree, DeclNameLookup Map.empty Map.empty) Just (who, branch) -> do - defns <- - Cli.runTransaction (loadNamespaceDefinitions (referent2to1 db) branch) & onLeftM \conflictedName -> - Cli.returnEarly case conflictedName of - ConflictedName'Term name refs -> Output.MergeConflictedTermName name refs - ConflictedName'Type name refs -> Output.MergeConflictedTypeName name refs + defns <- loadDefns branch declNameLookup <- Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err -> Cli.returnEarly case err of @@ -291,23 +289,23 @@ doMerge info = do IncoherentDeclReason'StrayConstructor name -> Output.MergeStrayConstructor who name pure (defns, declNameLookup) - (aliceDefns0, aliceDeclNameLookup) <- load (Just (Just mergeTarget, branches.alice)) - (bobDefns0, bobDeclNameLookup) <- load (Just (Just mergeSource, branches.bob)) - (lcaDefns0, lcaDeclNameLookup) <- load ((Nothing,) <$> branches.lca) + (aliceDefns0, aliceDeclNameLookup) <- load (Just (mergeTarget, branches.alice)) + (bobDefns0, bobDeclNameLookup) <- load (Just (mergeSource, branches.bob)) + lcaDefns0 <- maybe (pure emptyNametree) loadDefns branches.lca + lcaDeclToConstructors <- Cli.runTransaction (lenientCheckDeclCoherency db.loadDeclNumConstructors lcaDefns0) let flatten defns = Defns (flattenNametree (view #terms) defns) (flattenNametree (view #types) defns) let defns3 = flatten <$> ThreeWay {alice = aliceDefns0, bob = bobDefns0, lca = lcaDefns0} - let declNameLookups3 = ThreeWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup, lca = lcaDeclNameLookup} + let declNameLookups = TwoWay {alice = aliceDeclNameLookup, bob = bobDeclNameLookup} - pure (defns3, declNameLookups3) + pure (defns3, declNameLookups, lcaDeclToConstructors) let defns = ThreeWay.forgetLca defns3 - let declNameLookups = ThreeWay.forgetLca declNameLookups3 - liftIO (debugFunctions.debugDefns defns3 declNameLookups3) + liftIO (debugFunctions.debugDefns defns3 declNameLookups lcaDeclToConstructors) -- Diff LCA->Alice and LCA->Bob - diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups3 defns3) + diffs <- Cli.runTransaction (Merge.nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns3) liftIO (debugFunctions.debugDiffs diffs) @@ -1032,7 +1030,8 @@ data DebugFunctions = DebugFunctions { debugCausals :: TwoOrThreeWay (V2.CausalBranch Transaction) -> IO (), debugDefns :: ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> - ThreeWay DeclNameLookup -> + TwoWay DeclNameLookup -> + Map Name [Maybe Name] -> IO (), debugDiffs :: TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference) -> IO (), debugCombinedDiff :: DefnsF2 (Map Name) CombinedDiffOp Referent TypeReference -> IO (), @@ -1073,9 +1072,10 @@ realDebugCausals causals = do realDebugDefns :: ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> - ThreeWay DeclNameLookup -> + TwoWay DeclNameLookup -> + Map Name [Maybe Name] -> IO () -realDebugDefns defns declNameLookups = do +realDebugDefns defns declNameLookups _lcaDeclNameLookup = do Text.putStrLn (Text.bold "\n=== Alice definitions ===") debugDefns1 (bimap BiMultimap.range BiMultimap.range defns.alice) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 421f39121..dd333effd 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -395,11 +395,11 @@ data Output | MergeConflictedTermName !Name !(NESet Referent) | MergeConflictedTypeName !Name !(NESet TypeReference) | MergeConflictInvolvingBuiltin !Name - | MergeConstructorAlias !(Maybe MergeSourceOrTarget) !Name !Name + | MergeConstructorAlias !MergeSourceOrTarget !Name !Name | MergeDefnsInLib !MergeSourceOrTarget - | MergeMissingConstructorName !(Maybe MergeSourceOrTarget) !Name - | MergeNestedDeclAlias !(Maybe MergeSourceOrTarget) !Name !Name - | MergeStrayConstructor !(Maybe MergeSourceOrTarget) !Name + | MergeMissingConstructorName !MergeSourceOrTarget !Name + | MergeNestedDeclAlias !MergeSourceOrTarget !Name !Name + | MergeStrayConstructor !MergeSourceOrTarget !Name | InstalledLibdep !(ProjectAndBranch ProjectName ProjectBranchName) !NameSegment data UpdateOrUpgrade = UOUUpdate | UOUUpgrade diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index a56b7faab..e75b8b65e 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1488,12 +1488,10 @@ notifyUser dir = \case "There's a merge conflict on" <> P.group (prettyName name <> ",") <> "but it's a builtin on one or both branches. We can't yet handle merge conflicts on builtins." - MergeConstructorAlias maybeAliceOrBob name1 name2 -> + MergeConstructorAlias aliceOrBob name1 name2 -> pure . P.wrap $ "On" - <> case maybeAliceOrBob of - Nothing -> "the LCA," - Just aliceOrBob -> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") <> prettyName name1 <> "and" <> prettyName name2 @@ -1504,32 +1502,26 @@ notifyUser dir = \case <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") <> "there's a type or term directly in the `lib` namespace, but I expected only library dependencies to be in there." <> "Please remove it before merging." - MergeMissingConstructorName maybeAliceOrBob name -> + MergeMissingConstructorName aliceOrBob name -> pure . P.wrap $ "On" - <> case maybeAliceOrBob of - Nothing -> "the LCA," - Just aliceOrBob -> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") <> "the type" <> prettyName name <> "is missing a name for one of its constructors. Please add one before merging." - MergeNestedDeclAlias maybeAliceOrBob shorterName longerName -> + MergeNestedDeclAlias aliceOrBob shorterName longerName -> pure . P.wrap $ "On" - <> case maybeAliceOrBob of - Nothing -> "the LCA," - Just aliceOrBob -> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") <> "the type" <> prettyName longerName <> "is an alias of" <> P.group (prettyName shorterName <> ".") <> "Type aliases cannot be nested. Please make them disjoint before merging." - MergeStrayConstructor maybeAliceOrBob name -> + MergeStrayConstructor aliceOrBob name -> pure . P.wrap $ "On" - <> case maybeAliceOrBob of - Nothing -> "the LCA," - Just aliceOrBob -> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") <> "the constructor" <> prettyName name <> "is not in a subnamespace of a name of its type." diff --git a/unison-core/src/Unison/DataDeclaration.hs b/unison-core/src/Unison/DataDeclaration.hs index 9467880ca..e06f71512 100644 --- a/unison-core/src/Unison/DataDeclaration.hs +++ b/unison-core/src/Unison/DataDeclaration.hs @@ -33,10 +33,11 @@ module Unison.DataDeclaration constructors_, asDataDecl_, declAsDataDecl_, + setConstructorNames, ) where -import Control.Lens (Iso', Lens', imap, iso, lens, over, _3) +import Control.Lens (Iso', Lens', imap, iso, lens, over, set, _2, _3) import Control.Monad.State (evalState) import Data.Map qualified as Map import Data.Set qualified as Set @@ -164,6 +165,20 @@ constructorVars dd = fst <$> constructors dd constructorNames :: (Var v) => DataDeclaration v a -> [Text] constructorNames dd = Var.name <$> constructorVars dd +-- | Overwrite the constructor names with the given list, given in canonical order, which is assumed to be of the +-- correct length. +-- +-- Presumably this is called because the decl was loaded from the database outside of the context of a namespace, +-- since it's not stored with names there, so we had plugged in dummy names like "Constructor1", "Constructor2", ... +-- +-- Then, at some point, we discover the constructors' names in a namespace, and now we'd like to combine the two +-- together to get a Decl structure in memory with good/correct names for constructors. +setConstructorNames :: [v] -> Decl v a -> Decl v a +setConstructorNames constructorNames = + over + (declAsDataDecl_ . constructors_) + (zipWith (set _2) constructorNames) + -- This function is unsound, since the `rid` and the `decl` have to match. -- It should probably be hashed directly from the Decl, once we have a -- reliable way of doing that. —AI diff --git a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs index 82cff729f..b62b9f44d 100644 --- a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs +++ b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs @@ -217,6 +217,12 @@ checkDeclCoherency loadDeclNumConstructors = fullName name = Name.fromReverseSegments (name :| prefix) +-- | A lenient variant of 'checkDeclCoherency' - so lenient it can't even fail! It returns a mapping from decl name to +-- constructor names, where constructor names can be missing. +-- +-- This function exists merely to extract a best-effort decl-name-to-constructor-name mapping for the LCA of a merge. +-- We require Alice and Bob to have coherent decls, but their LCA is out of the user's control and may have incoherent +-- decls, and whether or not it does, we still need to compute *some* syntactic hash for its decls. lenientCheckDeclCoherency :: forall m. Monad m => diff --git a/unison-merge/src/Unison/Merge/DeclNameLookup.hs b/unison-merge/src/Unison/Merge/DeclNameLookup.hs index 9fa85b99d..08611a944 100644 --- a/unison-merge/src/Unison/Merge/DeclNameLookup.hs +++ b/unison-merge/src/Unison/Merge/DeclNameLookup.hs @@ -2,24 +2,13 @@ module Unison.Merge.DeclNameLookup ( DeclNameLookup (..), expectDeclName, expectConstructorNames, - setConstructorNames, ) where -import Control.Lens (over) import Data.Map.Strict qualified as Map import Data.Semigroup.Generic (GenericSemigroupMonoid (..)) -import Unison.DataDeclaration (Decl) -import Unison.DataDeclaration qualified as DataDeclaration import Unison.Name (Name) -import Unison.NameSegment (NameSegment) import Unison.Prelude -import Unison.Reference (TypeReference) -import Unison.Referent (Referent) -import Unison.Syntax.Name qualified as Name -import Unison.Util.Defns (Defns (..), DefnsF) -import Unison.Util.Nametree (Nametree (..)) -import Unison.Var (Var) -- | A lookup from decl-to-constructor name and vice-versa. -- @@ -62,22 +51,3 @@ expectConstructorNames DeclNameLookup {declToConstructors} x = case Map.lookup x declToConstructors of Nothing -> error (reportBug "E077058" ("Expected decl name key " <> show x <> " in decl name lookup")) Just y -> y - --- | Set the constructor names of a data declaration. --- --- Presumably this is used because the decl was loaded from the database outside of the context of a namespace, because --- it's not stored with names there, so we plugged in dummy names like "Constructor1", "Constructor2", ... --- --- Then, at some point, a `DeclNameLookup` was constructed for the corresponding namespace, and now we'd like to --- combine the two together to get a Decl structure in memory with good/correct names for constructors. -setConstructorNames :: forall a v. Var v => DeclNameLookup -> Name -> Decl v a -> Decl v a -setConstructorNames declNameLookup name = - case Map.lookup name declNameLookup.declToConstructors of - Nothing -> id - Just constructorNames -> - over - (DataDeclaration.declAsDataDecl_ . DataDeclaration.constructors_) - ( zipWith - (\realConName (ann, _junkConName, typ) -> (ann, Name.toVar realConName, typ)) - constructorNames - ) diff --git a/unison-merge/src/Unison/Merge/Diff.hs b/unison-merge/src/Unison/Merge/Diff.hs index f361c77b2..754b36be7 100644 --- a/unison-merge/src/Unison/Merge/Diff.hs +++ b/unison-merge/src/Unison/Merge/Diff.hs @@ -9,23 +9,30 @@ import Data.Semialign (alignWith) import Data.Set qualified as Set import Data.These (These (..)) import U.Codebase.Reference (TypeReference) -import Unison.Hash (Hash) +import Unison.DataDeclaration (Decl) +import Unison.DataDeclaration qualified as DataDeclaration +import Unison.Hash (Hash (Hash)) import Unison.HashQualified' qualified as HQ' import Unison.Merge.Database (MergeDatabase (..)) import Unison.Merge.DeclNameLookup (DeclNameLookup) import Unison.Merge.DeclNameLookup qualified as DeclNameLookup import Unison.Merge.DiffOp (DiffOp (..)) -import Unison.Merge.Synhash qualified as Synhash +import Unison.Merge.Synhash import Unison.Merge.Synhashed (Synhashed (..)) import Unison.Merge.ThreeWay (ThreeWay (..)) +import Unison.Merge.ThreeWay qualified as ThreeWay import Unison.Merge.TwoWay (TwoWay (..)) import Unison.Merge.Updated (Updated (..)) import Unison.Name (Name) +import Unison.Parser.Ann (Ann) import Unison.Prelude hiding (catMaybes) import Unison.PrettyPrintEnv (PrettyPrintEnv (..)) import Unison.PrettyPrintEnv qualified as Ppe +import Unison.Reference (Reference' (..), TypeReferenceId) import Unison.Referent (Referent) import Unison.Sqlite (Transaction) +import Unison.Symbol (Symbol) +import Unison.Syntax.Name qualified as Name import Unison.Util.BiMultimap (BiMultimap) import Unison.Util.BiMultimap qualified as BiMultimap import Unison.Util.Defns (Defns (..), DefnsF2, DefnsF3, zipDefnsWith) @@ -40,12 +47,29 @@ import Unison.Util.Defns (Defns (..), DefnsF2, DefnsF3, zipDefnsWith) -- branches. If the hash of a name did not change, it will not appear in the map. nameBasedNamespaceDiff :: MergeDatabase -> - ThreeWay DeclNameLookup -> + TwoWay DeclNameLookup -> + Map Name [Maybe Name] -> ThreeWay (Defns (BiMultimap Referent Name) (BiMultimap TypeReference Name)) -> Transaction (TwoWay (DefnsF3 (Map Name) DiffOp Synhashed Referent TypeReference)) -nameBasedNamespaceDiff db declNameLookups defns = do - diffs <- sequence (synhashDefns <$> declNameLookups <*> defns) - pure (diffNamespaceDefns diffs.lca <$> TwoWay {alice = diffs.alice, bob = diffs.bob}) +nameBasedNamespaceDiff db declNameLookups lcaDeclToConstructors defns = do + lcaHashes <- + synhashDefnsWith + hashTerm + ( \name -> \case + ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin) + ReferenceDerived ref -> + case sequence (lcaDeclToConstructors Map.! name) of + -- If we don't have a name for every constructor, that's okay, just use a dummy syntactic hash here. + -- This is safe; Alice/Bob can't have such a decl (it violates a merge precondition), so there's no risk + -- that we accidentally get an equal hash and classify a real update as unchanged. + Nothing -> pure (Hash mempty) + Just names -> do + decl <- loadDeclWithGoodConstructorNames names ref + pure (synhashDerivedDecl ppe name decl) + ) + defns.lca + hashes <- sequence (synhashDefns <$> declNameLookups <*> ThreeWay.forgetLca defns) + pure (diffNamespaceDefns lcaHashes <$> hashes) where synhashDefns :: DeclNameLookup -> @@ -55,16 +79,20 @@ nameBasedNamespaceDiff db declNameLookups defns = do -- FIXME: use cache so we only synhash each thing once synhashDefnsWith hashTerm hashType where - hashTerm :: Referent -> Transaction Hash - hashTerm = - Synhash.hashTerm db.loadV1Term ppe - hashType :: Name -> TypeReference -> Transaction Hash - hashType name = - Synhash.hashDecl - (fmap (DeclNameLookup.setConstructorNames declNameLookup name) . db.loadV1Decl) - ppe - name + hashType name = \case + ReferenceBuiltin builtin -> pure (synhashBuiltinDecl builtin) + ReferenceDerived ref -> do + decl <- loadDeclWithGoodConstructorNames (DeclNameLookup.expectConstructorNames declNameLookup name) ref + pure (synhashDerivedDecl ppe name decl) + + loadDeclWithGoodConstructorNames :: [Name] -> TypeReferenceId -> Transaction (Decl Symbol Ann) + loadDeclWithGoodConstructorNames names = + fmap (DataDeclaration.setConstructorNames (map Name.toVar names)) . db.loadV1Decl + + hashTerm :: Referent -> Transaction Hash + hashTerm = + synhashTerm db.loadV1Term ppe ppe :: PrettyPrintEnv ppe = diff --git a/unison-merge/src/Unison/Merge/Synhash.hs b/unison-merge/src/Unison/Merge/Synhash.hs index 56c69d459..29559690b 100644 --- a/unison-merge/src/Unison/Merge/Synhash.hs +++ b/unison-merge/src/Unison/Merge/Synhash.hs @@ -24,9 +24,10 @@ -- "foo" would have the same syntactic hash. This indicates (to our merge algorithm) that this was an auto-propagated -- update. module Unison.Merge.Synhash - ( hashType, - hashTerm, - hashDecl, + ( synhashType, + synhashTerm, + synhashBuiltinDecl, + synhashDerivedDecl, ) where @@ -72,8 +73,8 @@ isDeclTag, isTermTag :: H.Token Hash isDeclTag = H.Tag 0 isTermTag = H.Tag 1 -hashBuiltinDecl :: Text -> Hash -hashBuiltinDecl name = +synhashBuiltinDecl :: Text -> Hash +synhashBuiltinDecl name = H.accumulate [isBuiltinTag, isDeclTag, H.Text name] hashBuiltinTerm :: Text -> Hash @@ -104,23 +105,6 @@ hashConstructorNameToken declName conName = ) in H.Text (Name.toText strippedConName) --- | Syntactically hash a decl, using reference names rather than hashes. Two decls will have the same syntactic hash if --- they they are the same sort of decl (both are data decls or both are effect decls), the unique type guid is the same, --- the constructors appear in the same order and have the same names, and the constructors' types have the same --- syntactic hashes. -hashDecl :: - (Monad m, Var v) => - (TypeReferenceId -> m (Decl v a)) -> - PrettyPrintEnv -> - Name -> - TypeReference -> - m Hash -hashDecl loadDecl ppe name = \case - ReferenceBuiltin builtin -> pure (hashBuiltinDecl builtin) - ReferenceDerived ref -> do - decl <- loadDecl ref - pure (hashDerivedDecl ppe name decl) - hashDerivedTerm :: Var v => PrettyPrintEnv -> Term v a -> Hash hashDerivedTerm ppe t = H.accumulate $ isNotBuiltinTag : hashTermTokens ppe t @@ -148,8 +132,12 @@ hashDeclTokens :: Var v => PrettyPrintEnv -> Name -> Decl v a -> [Token] hashDeclTokens ppe name decl = hashConstructorType (DD.constructorType decl) : hashDataDeclTokens ppe name (DD.asDataDecl decl) -hashDerivedDecl :: Var v => PrettyPrintEnv -> Name -> Decl v a -> Hash -hashDerivedDecl ppe name decl = +-- | Syntactically hash a decl, using reference names rather than hashes. Two decls will have the same syntactic hash if +-- they they are the same sort of decl (both are data decls or both are effect decls), the unique type guid is the same, +-- the constructors appear in the same order and have the same names, and the constructors' types have the same +-- syntactic hashes. +synhashDerivedDecl :: Var v => PrettyPrintEnv -> Name -> Decl v a -> Hash +synhashDerivedDecl ppe name decl = H.accumulate $ isNotBuiltinTag : hashDeclTokens ppe name decl hashHQNameToken :: HashQualified Name -> Token @@ -218,8 +206,14 @@ hashReferentTokens ppe referent = -- | Syntactically hash a term, using reference names rather than hashes. -- Two terms will have the same syntactic hash if they would -- print the the same way under the given pretty-print env. -hashTerm :: forall m v a. (Monad m, Var v) => (TypeReferenceId -> m (Term v a)) -> PrettyPrintEnv -> V1.Referent -> m Hash -hashTerm loadTerm ppe = \case +synhashTerm :: + forall m v a. + (Monad m, Var v) => + (TypeReferenceId -> m (Term v a)) -> + PrettyPrintEnv -> + V1.Referent -> + m Hash +synhashTerm loadTerm ppe = \case V1.Referent.Con ref CT.Data -> pure (hashDerivedTerm ppe (Term.constructor @v () ref)) V1.Referent.Con ref CT.Effect -> pure (hashDerivedTerm ppe (Term.request @v () ref)) V1.Referent.Ref (ReferenceBuiltin builtin) -> pure (hashBuiltinTerm builtin) @@ -269,8 +263,8 @@ hashTermFTokens ppe = \case -- | Syntactically hash a type, using reference names rather than hashes. -- Two types will have the same syntactic hash if they would -- print the the same way under the given pretty-print env. -hashType :: Var v => PrettyPrintEnv -> Type v a -> Hash -hashType ppe t = +synhashType :: Var v => PrettyPrintEnv -> Type v a -> Hash +synhashType ppe t = H.accumulate $ hashTypeTokens ppe t hashTypeTokens :: forall v a. Var v => PrettyPrintEnv -> Type v a -> [Token] diff --git a/unison-src/transcripts/merge.md b/unison-src/transcripts/merge.md index d74605f1c..e6475de63 100644 --- a/unison-src/transcripts/merge.md +++ b/unison-src/transcripts/merge.md @@ -1300,3 +1300,70 @@ project/alice> merge /bob ```ucm:hide .> project.delete project ``` + +## LCA precondition violations + +The LCA is not subject to most precondition violations, which is good, because the user can't easily manipulate it! + +Here's an example. We'll delete a constructor name from the LCA and still be able to merge Alice and Bob's stuff +together. + +```ucm:hide +.> project.create-empty project +project/main> builtins.mergeio +``` + +LCA: + +```unison +structural type Foo = Bar Nat | Baz Nat Nat +``` + +```ucm +project/main> add +project/main> delete.term Foo.Baz +``` + +Alice's branch: + +```ucm +project/main> branch alice +project/alice> delete.type Foo +project/alice> delete.term Foo.Bar +``` + +```unison +alice : Nat +alice = 100 +``` + +```ucm +project/alice> add +``` + +Bob's branch: + +```ucm +project/main> branch bob +project/bob> delete.type Foo +project/bob> delete.term Foo.Bar +``` + +```unison +bob : Nat +bob = 101 +``` + +```ucm +project/bob> add +``` + +Now we merge: + +```ucm +project/alice> merge /bob +``` + +```ucm:hide +.> project.delete project +``` diff --git a/unison-src/transcripts/merge.output.md b/unison-src/transcripts/merge.output.md index 6b50339ee..ba3ab0d03 100644 --- a/unison-src/transcripts/merge.output.md +++ b/unison-src/transcripts/merge.output.md @@ -1144,3 +1144,139 @@ project/alice> merge /bob there. Please remove it before merging. ``` +## LCA precondition violations + +The LCA is not subject to most precondition violations, which is good, because the user can't easily manipulate it! + +Here's an example. We'll delete a constructor name from the LCA and still be able to merge Alice and Bob's stuff +together. + +LCA: + +```unison +structural type Foo = Bar Nat | Baz Nat Nat +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + structural type Foo + +``` +```ucm +project/main> add + + ⍟ I've added these definitions: + + structural type Foo + +project/main> delete.term Foo.Baz + + Done. + +``` +Alice's branch: + +```ucm +project/main> branch alice + + Done. I've created the alice branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /alice`. + +project/alice> delete.type Foo + + Done. + +project/alice> delete.term Foo.Bar + + Done. + +``` +```unison +alice : Nat +alice = 100 +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + alice : Nat + +``` +```ucm +project/alice> add + + ⍟ I've added these definitions: + + alice : Nat + +``` +Bob's branch: + +```ucm +project/main> branch bob + + Done. I've created the bob branch based off of main. + + Tip: To merge your work back into the main branch, first + `switch /main` then `merge /bob`. + +project/bob> delete.type Foo + + Done. + +project/bob> delete.term Foo.Bar + + Done. + +``` +```unison +bob : Nat +bob = 101 +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + bob : Nat + +``` +```ucm +project/bob> add + + ⍟ I've added these definitions: + + bob : Nat + +``` +Now we merge: + +```ucm +project/alice> merge /bob + + I merged project/bob into project/alice. + +``` From 7d7047967a127ec9888105058850559d57afb0bc Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Fri, 24 May 2024 22:20:53 -0600 Subject: [PATCH 75/82] Add a transcript to replicate #3939 --- unison-src/transcripts-using-base/fix3939.md | 12 ++++ .../transcripts-using-base/fix3939.output.md | 56 +++++++++++++++++++ 2 files changed, 68 insertions(+) create mode 100644 unison-src/transcripts-using-base/fix3939.md create mode 100644 unison-src/transcripts-using-base/fix3939.output.md diff --git a/unison-src/transcripts-using-base/fix3939.md b/unison-src/transcripts-using-base/fix3939.md new file mode 100644 index 000000000..7ec695e6c --- /dev/null +++ b/unison-src/transcripts-using-base/fix3939.md @@ -0,0 +1,12 @@ +```unison +{{ +A simple doc. +}} +meh = 9 +``` + +```ucm +.> add +.> find meh +.> docs 1 +``` diff --git a/unison-src/transcripts-using-base/fix3939.output.md b/unison-src/transcripts-using-base/fix3939.output.md new file mode 100644 index 000000000..dd9cfe4a9 --- /dev/null +++ b/unison-src/transcripts-using-base/fix3939.output.md @@ -0,0 +1,56 @@ +```unison +{{ +A simple doc. +}} +meh = 9 +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + meh : Nat + meh.doc : Doc2 + +``` +```ucm +.> add + + ⍟ I've added these definitions: + + meh : Nat + meh.doc : Doc2 + +.> find meh + + 1. meh : Nat + 2. meh.doc : Doc2 + + +.> docs 1 + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + meh.doc#3n6of1k7qmgib9jda9ov1obetubfmladketn40gqifp4pfdea8it6ofa920l1topi2pd32vlsbfu3q41fkbt8coa38akg9eetto09j8 + +``` + + + +🛑 + +The transcript failed due to an error in the stanza above. The error is: + + + ⚠️ + + The following names were not found in the codebase. Check your spelling. + meh.doc#3n6of1k7qmgib9jda9ov1obetubfmladketn40gqifp4pfdea8it6ofa920l1topi2pd32vlsbfu3q41fkbt8coa38akg9eetto09j8 + From b985bb1728dd2bb5b22ba2cbef04e64bf77a1ebc Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Fri, 24 May 2024 23:07:47 -0600 Subject: [PATCH 76/82] Change `docs` command to expect `Name` Previously, when given a numbered arg, from some commands (e.g., `find`), it would fail to find the docs because the hash associated with the definition was applied to the `doc`, which then would be incorrect. This now discards hashes up-front, so it can add the `doc` suffix to the name. Fixes #3939. --- .../src/Unison/Codebase/Editor/HandleInput.hs | 10 ++-------- unison-cli/src/Unison/Codebase/Editor/Input.hs | 2 +- .../src/Unison/CommandLine/InputPatterns.hs | 2 +- .../transcripts-using-base/fix3939.output.md | 18 +----------------- 4 files changed, 5 insertions(+), 27 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f5f06bde1..71185d49c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1758,7 +1758,7 @@ displayI outputLoc hq = do let ns = UF.addNamesFromTypeCheckedUnisonFile unisonFile names doDisplay outputLoc ns tm -docsI :: Path.HQSplit' -> Cli () +docsI :: Name -> Cli () docsI src = do findInScratchfileByName where @@ -1766,14 +1766,8 @@ docsI src = do (fileByName) First check the file for `foo.doc`, and if found do `display foo.doc` (codebaseByName) Lastly check for `foo.doc` in the codebase and if found do `display foo.doc` -} - hq :: HQ.HashQualified Name - hq = - let hq' :: HQ'.HashQualified Name - hq' = Path.unsafeToName' <$> Name.convert src - in Name.convert hq' - dotDoc :: HQ.HashQualified Name - dotDoc = hq <&> \n -> Name.joinDot n (Name.fromSegment "doc") + dotDoc = Name.convert . Name.joinDot src $ Name.fromSegment "doc" findInScratchfileByName :: Cli () findInScratchfileByName = do diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 56acd83e9..b24401330 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -174,7 +174,7 @@ data Input | -- Display provided definitions. DisplayI OutputLocation (NonEmpty (HQ.HashQualified Name)) | -- Display docs for provided terms. - DocsI (NonEmpty Path.HQSplit') + DocsI (NonEmpty Name) | -- other FindI Bool FindScope [String] -- FindI isVerbose findScope query | FindShallowI Path' diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 9a5d0a364..0fa6e436d 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -992,7 +992,7 @@ docs = "`docs` without arguments invokes a search to select which definition to view documentation for, which requires that `fzf` can be found within your PATH." ] ) - $ maybe (Left $ I.help docs) (fmap Input.DocsI . traverse handleHashQualifiedSplit'Arg) . NE.nonEmpty + $ maybe (Left $ I.help docs) (fmap Input.DocsI . traverse handleNameArg) . NE.nonEmpty api :: InputPattern api = diff --git a/unison-src/transcripts-using-base/fix3939.output.md b/unison-src/transcripts-using-base/fix3939.output.md index dd9cfe4a9..99197263c 100644 --- a/unison-src/transcripts-using-base/fix3939.output.md +++ b/unison-src/transcripts-using-base/fix3939.output.md @@ -35,22 +35,6 @@ meh = 9 .> docs 1 - ⚠️ - - The following names were not found in the codebase. Check your spelling. - meh.doc#3n6of1k7qmgib9jda9ov1obetubfmladketn40gqifp4pfdea8it6ofa920l1topi2pd32vlsbfu3q41fkbt8coa38akg9eetto09j8 + A simple doc. ``` - - - -🛑 - -The transcript failed due to an error in the stanza above. The error is: - - - ⚠️ - - The following names were not found in the codebase. Check your spelling. - meh.doc#3n6of1k7qmgib9jda9ov1obetubfmladketn40gqifp4pfdea8it6ofa920l1topi2pd32vlsbfu3q41fkbt8coa38akg9eetto09j8 - From 8b46f810845a14a063ec3f2db9873191d8d282b1 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Wed, 29 May 2024 09:46:49 -0600 Subject: [PATCH 77/82] Replicate failure from #4898 --- unison-src/transcripts/fix4898.md | 17 +++++++ unison-src/transcripts/fix4898.output.md | 58 ++++++++++++++++++++++++ 2 files changed, 75 insertions(+) create mode 100644 unison-src/transcripts/fix4898.md create mode 100644 unison-src/transcripts/fix4898.output.md diff --git a/unison-src/transcripts/fix4898.md b/unison-src/transcripts/fix4898.md new file mode 100644 index 000000000..9bc68041b --- /dev/null +++ b/unison-src/transcripts/fix4898.md @@ -0,0 +1,17 @@ +```ucm +.> builtins.merge +``` + +```unison +double : Int -> Int +double x = x + x + +redouble : Int -> Int +redouble x = double x + double x +``` + +```ucm +.> add +.> dependents double +.> delete.term 1 +``` diff --git a/unison-src/transcripts/fix4898.output.md b/unison-src/transcripts/fix4898.output.md new file mode 100644 index 000000000..e52dc6553 --- /dev/null +++ b/unison-src/transcripts/fix4898.output.md @@ -0,0 +1,58 @@ +```ucm +.> builtins.merge + + Done. + +``` +```unison +double : Int -> Int +double x = x + x + +redouble : Int -> Int +redouble x = double x + double x +``` + +```ucm + + Loading changes detected in scratch.u. + + I found and typechecked these definitions in scratch.u. If you + do an `add` or `update`, here's how your codebase would + change: + + ⍟ These new definitions are ok to `add`: + + double : Int -> Int + redouble : Int -> Int + +``` +```ucm +.> add + + ⍟ I've added these definitions: + + double : Int -> Int + redouble : Int -> Int + +.> dependents double + + Dependents of: double + + Terms: + + 1. redouble + + Tip: Try `view 1` to see the source of any numbered item in + the above list. + +.> delete.term 1 + +``` + + + +🛑 + +The transcript failed due to an error in the stanza above. The error is: + +Expected a name, but the numbered arg resulted in #1gupumeruksjs4sb5mg8jcb891dmbufmqrfblfss1sevbl62fr7oud24mpo03jm2qlbdt6ntordsmfj1jovhfsp3mij461odaahfh2g, which is a reference. From 78816fdc3a3d2c328de3cf842345fb0329e11ef4 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Wed, 29 May 2024 10:31:04 -0600 Subject: [PATCH 78/82] Remove `Reference` from `StructuredArgument` MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Almost everywhere we produce a `Reference` for numbered args, we also have a `HashQualified Name` handy, which is much more consumable by commands. The only case we don’t have an `HQ` is in the `todo` command output, so that now explicitly builds a `HQ.HashOnly`. This also fixes an issue with `StructuredArgument` handling where `alias.term` and `alias.type` wouldn’t make an alias to a `HQ.HashOnly` `StructuredArgument`. Fixes #4898. --- .../src/Unison/Codebase/Editor/HandleInput.hs | 23 +++++----- .../Editor/HandleInput/FindAndReplace.hs | 13 +++--- .../Codebase/Editor/StructuredArgument.hs | 2 - .../src/Unison/CommandLine/InputPatterns.hs | 43 ++++++++++--------- unison-cli/tests/Unison/Test/Cli/Monad.hs | 8 ++-- unison-src/transcripts/fix4898.output.md | 10 +---- 6 files changed, 47 insertions(+), 52 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f5f06bde1..f787ab22d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1285,12 +1285,10 @@ handleDependencies hq = do let types = [(PPE.typeName suffixifiedPPE r, r) | LabeledDependency.TypeReference r <- toList dependencies] let terms = [(PPE.termName suffixifiedPPE r, r) | LabeledDependency.TermReferent r <- toList dependencies] pure (types, terms) - let types = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ fst <$> results) - let terms = nubOrdOn snd . Name.sortByText (HQ.toText . fst) $ (join $ snd <$> results) - Cli.setNumberedArgs $ - map (SA.Ref . snd) types - <> map (SA.Ref . Referent.toReference . snd) terms - Cli.respond $ ListDependencies suffixifiedPPE lds (fst <$> types) (fst <$> terms) + let types = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst) . join $ fst <$> results + let terms = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst) . join $ snd <$> results + Cli.setNumberedArgs . map SA.HashQualified $ types <> terms + Cli.respond $ ListDependencies suffixifiedPPE lds types terms handleDependents :: HQ.HashQualified Name -> Cli () handleDependents hq = do @@ -1307,7 +1305,7 @@ handleDependents hq = do results <- for (toList lds) \ld -> do -- The full set of dependent references, any number of which may not have names in the current namespace. dependents <- - let tp r = Codebase.dependents Queries.ExcludeOwnComponent r + let tp = Codebase.dependents Queries.ExcludeOwnComponent tm = \case Referent.Ref r -> Codebase.dependents Queries.ExcludeOwnComponent r Referent.Con (ConstructorReference r _cid) _ct -> @@ -1323,11 +1321,11 @@ handleDependents hq = do Just shortName <- pure $ PPE.terms ppe (Referent.Ref r) <|> PPE.types ppe r pure (isTerm, HQ'.toHQ shortName, r) pure results - let sort = nubOrdOn snd . Name.sortByText (HQ.toText . fst) + let sort = fmap fst . nubOrdOn snd . Name.sortByText (HQ.toText . fst) let types = sort [(n, r) | (False, n, r) <- join results] let terms = sort [(n, r) | (True, n, r) <- join results] - Cli.setNumberedArgs . map (SA.Ref . view _2) $ types <> terms - Cli.respond (ListDependents ppe lds (fst <$> types) (fst <$> terms)) + Cli.setNumberedArgs . map SA.HashQualified $ types <> terms + Cli.respond (ListDependents ppe lds types terms) -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: OutputLocation -> ShowDefinitionScope -> NonEmpty (HQ.HashQualified Name) -> Cli () @@ -1439,8 +1437,9 @@ doShowTodoOutput patch scopePath = do if TO.noConflicts todo && TO.noEdits todo then Cli.respond NoConflictsOrEdits else do - Cli.setNumberedArgs - (SA.Ref . view _2 <$> fst (TO.todoFrontierDependents todo)) + Cli.setNumberedArgs $ + SA.HashQualified . HQ.HashOnly . Reference.toShortHash . view _2 + <$> fst (TO.todoFrontierDependents todo) pped <- Cli.currentPrettyPrintEnvDecl Cli.respondNumbered $ TodoOutput pped todo diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs index f96ae85b2..45fb100a4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/FindAndReplace.hs @@ -82,15 +82,14 @@ handleStructuredFindI rule = do Referent.Ref _ <- pure r Just shortName <- [PPE.terms (PPED.suffixifiedPPE ppe) r] pure (HQ'.toHQ shortName, r) - let ok t@(_, Referent.Ref (Reference.DerivedId r)) = do + let ok (hq, Referent.Ref (Reference.DerivedId r)) = do oe <- Cli.runTransaction (Codebase.getTerm codebase r) - pure $ (t, maybe False (\e -> any ($ e) rules) oe) - ok t = pure (t, False) + pure $ (hq, maybe False (\e -> any ($ e) rules) oe) + ok (hq, _) = pure (hq, False) results0 <- traverse ok results - let results = Alphabetical.sortAlphabeticallyOn fst [(hq, r) | ((hq, r), True) <- results0] - let toNumArgs = SA.Ref . Referent.toReference . view _2 - Cli.setNumberedArgs $ map toNumArgs results - Cli.respond (ListStructuredFind (fst <$> results)) + let results = Alphabetical.sortAlphabetically [hq | (hq, True) <- results0] + Cli.setNumberedArgs $ map SA.HashQualified results + Cli.respond (ListStructuredFind results) lookupRewrite :: (HQ.HashQualified Name -> Output) -> diff --git a/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs b/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs index 935d6ccd2..eda42c610 100644 --- a/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs +++ b/unison-cli/src/Unison/Codebase/Editor/StructuredArgument.hs @@ -10,7 +10,6 @@ import Unison.HashQualified' qualified as HQ' import Unison.Name (Name) import Unison.Parser.Ann (Ann) import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName) -import Unison.Reference (Reference) import Unison.Server.Backend (ShallowListEntry) import Unison.Server.SearchResult (SearchResult) import Unison.Symbol (Symbol) @@ -22,7 +21,6 @@ data StructuredArgument | HashQualified (HQ.HashQualified Name) | Project ProjectName | ProjectBranch (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) - | Ref Reference | Namespace CausalHash | NameWithBranchPrefix AbsBranchId Name | HashQualifiedWithBranchPrefix AbsBranchId (HQ'.HashQualified Name) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 9a5d0a364..777105dfb 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -203,7 +203,6 @@ import Unison.Project branchWithOptionalProjectParser, ) import Unison.Project.Util (ProjectContext (..), projectContextFromPath) -import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.Server.Backend (ShallowListEntry (..)) import Unison.Server.Backend qualified as Backend @@ -227,8 +226,6 @@ formatStructuredArgument schLength = \case SA.Project projectName -> into @Text projectName SA.ProjectBranch (ProjectAndBranch mproj branch) -> maybe (Text.cons '/' . into @Text) (\project -> into @Text . ProjectAndBranch project) mproj branch - -- also: ShortHash.toText . Reference.toShortHash - SA.Ref reference -> Reference.toText reference -- also: ("#" <>) . Hash.toBase32HexText . unCausalHash SA.Namespace causalHash -> ("#" <>) . SCH.toText $ maybe SCH.fromFullHash SCH.fromHash schLength causalHash SA.NameWithBranchPrefix absBranchId name -> prefixBranchId absBranchId name @@ -291,17 +288,23 @@ unsupportedStructuredArgument :: Text -> I.Argument -> Either (P.Pretty CT.Color unsupportedStructuredArgument expected = either pure (const . Left . P.text $ "can’t use a numbered argument for " <> expected) -expectedButActually :: Text -> Text -> Text -> Text +expectedButActually :: Text -> StructuredArgument -> Text -> P.Pretty CT.ColorText expectedButActually expected actualValue actualType = - "Expected " <> expected <> ", but the numbered arg resulted in " <> actualValue <> ", which is " <> actualType <> "." + P.text $ + "Expected " + <> expected + <> ", but the numbered arg resulted in " + <> formatStructuredArgument Nothing actualValue + <> ", which is " + <> actualType + <> "." wrongStructuredArgument :: Text -> StructuredArgument -> P.Pretty CT.ColorText wrongStructuredArgument expected actual = - P.text $ expectedButActually + expectedButActually expected - (formatStructuredArgument Nothing actual) + actual case actual of - SA.Ref _ -> "a reference" SA.Name _ -> "a name" SA.AbsolutePath _ -> "an absolute path" SA.Namespace _ -> "a namespace" @@ -381,7 +384,6 @@ handleHashQualifiedNameArg = SA.Name name -> pure $ HQ.NameOnly name SA.NameWithBranchPrefix mprefix name -> pure . HQ.NameOnly $ foldr (\prefix -> Name.makeAbsolute . Path.prefixName prefix) name mprefix - SA.Ref ref -> pure . HQ.HashOnly $ Reference.toShortHash ref SA.HashQualified hqname -> pure hqname SA.HashQualifiedWithBranchPrefix mprefix hqname -> pure . HQ'.toHQ $ foldr (\prefix -> fmap $ Name.makeAbsolute . Path.prefixName prefix) hqname mprefix @@ -526,15 +528,15 @@ handleBranchRelativePathArg = pure . BranchRelative . This $ maybe (Left branch) (pure . (,branch)) mproject otherNumArg -> Left $ wrongStructuredArgument "a branch id" otherNumArg -hqNameToSplit' :: HQ.HashQualified Name -> Either (P.Pretty CT.ColorText) Path.HQSplit' +hqNameToSplit' :: HQ.HashQualified Name -> Either ShortHash Path.HQSplit' hqNameToSplit' = \case - HQ.HashOnly _ -> Left $ P.text "Only have a hash" + HQ.HashOnly hash -> Left hash HQ.NameOnly name -> pure . fmap HQ'.NameOnly $ Path.splitFromName' name HQ.HashQualified name hash -> pure . fmap (`HQ'.HashQualified` hash) $ Path.splitFromName' name -hqNameToSplit :: HQ.HashQualified Name -> Either (P.Pretty CT.ColorText) Path.HQSplit +hqNameToSplit :: HQ.HashQualified Name -> Either ShortHash Path.HQSplit hqNameToSplit = \case - HQ.HashOnly _ -> Left $ P.text "Only have a hash" + HQ.HashOnly hash -> Left hash HQ.NameOnly name -> pure . fmap HQ'.NameOnly $ Path.splitFromName name HQ.HashQualified name hash -> pure . fmap (`HQ'.HashQualified` hash) $ Path.splitFromName name @@ -553,11 +555,12 @@ handleHashQualifiedSplit'Arg = either (first P.text . Path.parseHQSplit') \case - SA.HashQualified name -> hqNameToSplit' name + hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit' name SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit' hqname SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> pure . hq'NameToSplit' $ Name.makeAbsolute . Path.prefixName prefix <$> hqname - SA.SearchResult mpath result -> hqNameToSplit' $ searchResultToHQ mpath result + sr@(SA.SearchResult mpath result) -> + first (const $ expectedButActually "a name" sr "a hash") . hqNameToSplit' $ searchResultToHQ mpath result otherNumArg -> Left $ wrongStructuredArgument "a name" otherNumArg handleHashQualifiedSplitArg :: I.Argument -> Either (P.Pretty CT.ColorText) Path.HQSplit @@ -565,11 +568,12 @@ handleHashQualifiedSplitArg = either (first P.text . Path.parseHQSplit) \case - SA.HashQualified name -> hqNameToSplit name + hq@(SA.HashQualified name) -> first (const $ expectedButActually "a name" hq "a hash") $ hqNameToSplit name SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure $ hq'NameToSplit hqname SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> pure . hq'NameToSplit $ Name.makeAbsolute . Path.prefixName prefix <$> hqname - SA.SearchResult mpath result -> hqNameToSplit $ searchResultToHQ mpath result + sr@(SA.SearchResult mpath result) -> + first (const $ expectedButActually "a name" sr "a hash") . hqNameToSplit $ searchResultToHQ mpath result otherNumArg -> Left $ wrongStructuredArgument "a relative name" otherNumArg handleShortCausalHashArg :: I.Argument -> Either (P.Pretty CT.ColorText) ShortCausalHash @@ -586,12 +590,11 @@ handleShortHashOrHQSplit'Arg = either (first P.text . Path.parseShortHashOrHQSplit') \case - SA.Ref ref -> pure $ Left $ Reference.toShortHash ref - SA.HashQualified name -> pure <$> hqNameToSplit' name + SA.HashQualified name -> pure $ hqNameToSplit' name SA.HashQualifiedWithBranchPrefix (Left _) hqname -> pure . pure $ hq'NameToSplit' hqname SA.HashQualifiedWithBranchPrefix (Right prefix) hqname -> pure . pure $ hq'NameToSplit' (Name.makeAbsolute . Path.prefixName prefix <$> hqname) - SA.SearchResult mpath result -> fmap pure . hqNameToSplit' $ searchResultToHQ mpath result + SA.SearchResult mpath result -> pure . hqNameToSplit' $ searchResultToHQ mpath result otherNumArg -> Left $ wrongStructuredArgument "a hash or name" otherNumArg handleRelativeNameSegmentArg :: I.Argument -> Either (P.Pretty CT.ColorText) NameSegment diff --git a/unison-cli/tests/Unison/Test/Cli/Monad.hs b/unison-cli/tests/Unison/Test/Cli/Monad.hs index 0edb1dc3d..712b6c083 100644 --- a/unison-cli/tests/Unison/Test/Cli/Monad.hs +++ b/unison-cli/tests/Unison/Test/Cli/Monad.hs @@ -7,7 +7,7 @@ import Control.Lens import EasyTest import Unison.Cli.Monad qualified as Cli import Unison.Codebase.Editor.StructuredArgument qualified as SA -import Unison.Reference qualified as Reference +import Unison.Syntax.Name qualified as Name test :: Test () test = @@ -18,13 +18,15 @@ test = Cli.runCli dummyEnv dummyLoopState do Cli.label \goto -> do Cli.label \_ -> do - Cli.setNumberedArgs [SA.Ref $ Reference.ReferenceBuiltin "foo"] + Cli.setNumberedArgs [SA.Name $ Name.unsafeParseText "foo"] goto (1 :: Int) pure 2 -- test that 'goto' short-circuits, as expected expectEqual' (Cli.Success 1) r -- test that calling 'goto' doesn't lose state changes made along the way - expectEqual' [SA.Ref $ Reference.ReferenceBuiltin "foo"] (state ^. #numberedArgs) + expectEqual' + [SA.Name $ Name.unsafeParseText "foo"] + (state ^. #numberedArgs) ok ] diff --git a/unison-src/transcripts/fix4898.output.md b/unison-src/transcripts/fix4898.output.md index e52dc6553..dceafc4cb 100644 --- a/unison-src/transcripts/fix4898.output.md +++ b/unison-src/transcripts/fix4898.output.md @@ -47,12 +47,6 @@ redouble x = double x + double x .> delete.term 1 + Done. + ``` - - - -🛑 - -The transcript failed due to an error in the stanza above. The error is: - -Expected a name, but the numbered arg resulted in #1gupumeruksjs4sb5mg8jcb891dmbufmqrfblfss1sevbl62fr7oud24mpo03jm2qlbdt6ntordsmfj1jovhfsp3mij461odaahfh2g, which is a reference. From 06c4b695f63d89ac6c832010dd5c0a6d29c56e69 Mon Sep 17 00:00:00 2001 From: Greg Pfeil Date: Wed, 22 May 2024 23:51:13 -0600 Subject: [PATCH 79/82] Type the `main` arg to `execute` This avoids throwing away the type information from `NumberedArgs` and just generally gets text handling out of the domain logic. --- .../src/Unison/Codebase/Execute.hs | 11 ++--- .../src/Unison/Codebase/MainTerm.hs | 43 ++++++++----------- unison-cli/src/ArgParse.hs | 24 +++++++---- .../src/Unison/Codebase/Editor/HandleInput.hs | 4 +- .../Unison/Codebase/Editor/HandleInput/Run.hs | 12 +++--- .../Editor/HandleInput/TermResolution.hs | 6 +-- .../Codebase/Editor/HandleInput/Tests.hs | 8 ++-- .../src/Unison/Codebase/Editor/Input.hs | 4 +- .../src/Unison/Codebase/Editor/Output.hs | 4 +- .../src/Unison/CommandLine/InputPatterns.hs | 10 +++-- .../src/Unison/CommandLine/OutputMessages.hs | 8 ++-- 11 files changed, 69 insertions(+), 65 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Execute.hs b/parser-typechecker/src/Unison/Codebase/Execute.hs index 4d8a5317a..e7f1ef076 100644 --- a/parser-typechecker/src/Unison/Codebase/Execute.hs +++ b/parser-typechecker/src/Unison/Codebase/Execute.hs @@ -14,17 +14,19 @@ import Unison.Codebase.MainTerm (getMainTerm) import Unison.Codebase.MainTerm qualified as MainTerm import Unison.Codebase.Runtime (Runtime) import Unison.Codebase.Runtime qualified as Runtime +import Unison.HashQualified qualified as HQ +import Unison.Name (Name) import Unison.Names qualified as Names import Unison.Parser.Ann (Ann) -import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.Symbol (Symbol) +import Unison.Syntax.HashQualified qualified as HQ (toText) import Unison.Util.Pretty qualified as P execute :: Codebase.Codebase IO Symbol Ann -> Runtime Symbol -> - Text -> + HQ.HashQualified Name -> IO (Either Runtime.Error ()) execute codebase runtime mainName = (`finally` Runtime.terminate runtime) . runExceptT $ do @@ -34,9 +36,8 @@ execute codebase runtime mainName = let mainType = Runtime.mainType runtime mt <- liftIO $ Codebase.runTransaction codebase $ getMainTerm loadTypeOfTerm parseNames mainName mainType case mt of - MainTerm.NotAFunctionName s -> throwError ("Not a function name: " <> P.text s) - MainTerm.NotFound s -> throwError ("Not found: " <> P.text s) - MainTerm.BadType s _ -> throwError (P.text s <> " is not of type '{IO} ()") + MainTerm.NotFound s -> throwError ("Not found: " <> P.text (HQ.toText s)) + MainTerm.BadType s _ -> throwError (P.text (HQ.toText s) <> " is not of type '{IO} ()") MainTerm.Success _ tm _ -> do let codeLookup = Codebase.toCodeLookup codebase ppe = PPE.empty diff --git a/parser-typechecker/src/Unison/Codebase/MainTerm.hs b/parser-typechecker/src/Unison/Codebase/MainTerm.hs index 159030aa7..9f99ae559 100644 --- a/parser-typechecker/src/Unison/Codebase/MainTerm.hs +++ b/parser-typechecker/src/Unison/Codebase/MainTerm.hs @@ -16,7 +16,6 @@ import Unison.Parser.Ann qualified as Parser.Ann import Unison.Prelude import Unison.Reference (Reference) import Unison.Referent qualified as Referent -import Unison.Syntax.HashQualified qualified as HQ (parseText) import Unison.Term (Term) import Unison.Term qualified as Term import Unison.Type (Type) @@ -26,37 +25,33 @@ import Unison.Var (Var) import Unison.Var qualified as Var data MainTerm v - = NotAFunctionName Text - | NotFound Text - | BadType Text (Maybe (Type v Ann)) + = NotFound (HQ.HashQualified Name) + | BadType (HQ.HashQualified Name) (Maybe (Type v Ann)) | Success (HQ.HashQualified Name) (Term v Ann) (Type v Ann) getMainTerm :: (Monad m, Var v) => (Reference -> m (Maybe (Type v Ann))) -> Names.Names -> - Text -> + HQ.HashQualified Name -> Type.Type v Ann -> m (MainTerm v) -getMainTerm loadTypeOfTerm parseNames mainName mainType = - case HQ.parseText mainName of - Nothing -> pure (NotAFunctionName mainName) - Just hq -> do - let refs = Names.lookupHQTerm Names.IncludeSuffixes hq parseNames - let a = Parser.Ann.External - case toList refs of - [] -> pure (NotFound mainName) - [Referent.Ref ref] -> do - typ <- loadTypeOfTerm ref - case typ of - Just typ -> - if Typechecker.fitsScheme typ mainType - then do - let tm = DD.forceTerm a a (Term.ref a ref) - return (Success hq tm typ) - else pure (BadType mainName $ Just typ) - _ -> pure (BadType mainName Nothing) - _ -> pure (error "multiple matching refs") -- TODO: make a real exception +getMainTerm loadTypeOfTerm parseNames mainName mainType = do + let refs = Names.lookupHQTerm Names.IncludeSuffixes mainName parseNames + let a = Parser.Ann.External + case toList refs of + [] -> pure (NotFound mainName) + [Referent.Ref ref] -> do + typ <- loadTypeOfTerm ref + case typ of + Just typ -> + if Typechecker.fitsScheme typ mainType + then do + let tm = DD.forceTerm a a (Term.ref a ref) + return (Success mainName tm typ) + else pure (BadType mainName $ Just typ) + _ -> pure (BadType mainName Nothing) + _ -> pure (error "multiple matching refs") -- TODO: make a real exception -- forall x. '{ io2.IO, Exception } x builtinMain :: (Var v) => a -> Type.Type v a diff --git a/unison-cli/src/ArgParse.hs b/unison-cli/src/ArgParse.hs index 84f2ae538..5e7032942 100644 --- a/unison-cli/src/ArgParse.hs +++ b/unison-cli/src/ArgParse.hs @@ -17,6 +17,7 @@ import Options.Applicative ParserPrefs, ReadM, action, + argument, auto, columns, command, @@ -32,6 +33,7 @@ import Options.Applicative info, infoOption, long, + maybeReader, metavar, option, parserFailure, @@ -53,21 +55,21 @@ import System.Environment (lookupEnv) import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path import Unison.CommandLine.Types (ShouldWatchFiles (..)) +import Unison.HashQualified (HashQualified) import Unison.LSP (LspFormattingConfig (..)) +import Unison.Name (Name) import Unison.Prelude import Unison.PrettyTerminal qualified as PT import Unison.Server.CodebaseServer (CodebaseServerOpts (..)) import Unison.Server.CodebaseServer qualified as Server +import Unison.Syntax.HashQualified qualified as HQ import Unison.Util.Pretty (Width (..)) --- The name of a symbol to execute. -type SymbolName = Text - -- | Valid ways to provide source code to the run command data RunSource - = RunFromPipe SymbolName - | RunFromSymbol SymbolName - | RunFromFile FilePath SymbolName + = RunFromPipe (HashQualified Name) + | RunFromSymbol (HashQualified Name) + | RunFromFile FilePath (HashQualified Name) | RunCompiled FilePath deriving (Show, Eq) @@ -368,22 +370,26 @@ versionParser = pure PrintVersion runArgumentParser :: Parser [String] runArgumentParser = many (strArgument (metavar "RUN-ARGS")) +runHQParser :: Parser (HashQualified Name) +runHQParser = + argument (maybeReader (HQ.parseText . Text.pack)) (metavar "SYMBOL") + runSymbolParser :: Parser Command runSymbolParser = - Run . RunFromSymbol <$> strArgument (metavar "SYMBOL") <*> runArgumentParser + Run . RunFromSymbol <$> runHQParser <*> runArgumentParser runFileParser :: Parser Command runFileParser = Run <$> ( RunFromFile <$> fileArgument "path/to/file" - <*> strArgument (metavar "SYMBOL") + <*> runHQParser ) <*> runArgumentParser runPipeParser :: Parser Command runPipeParser = - Run . RunFromPipe <$> strArgument (metavar "SYMBOL") <*> runArgumentParser + Run . RunFromPipe <$> runHQParser <*> runArgumentParser runCompiledParser :: Parser Command runCompiledParser = diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f5f06bde1..187019a67 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1061,7 +1061,7 @@ inputDescription input = pure ("update.old" <> p) Update2I -> pure ("update") UndoI {} -> pure "undo" - ExecuteI s args -> pure ("execute " <> Text.unwords (s : fmap Text.pack args)) + ExecuteI s args -> pure ("execute " <> Text.unwords (HQ.toText s : fmap Text.pack args)) IOTestI hq -> pure ("io.test " <> HQ.toText hq) IOTestAllI -> pure "io.test.all" UpdateBuiltinsI -> pure "builtins.update" @@ -1071,7 +1071,7 @@ inputDescription input = MergeIOBuiltinsI (Just path) -> ("builtins.mergeio " <>) <$> p path MakeStandaloneI out nm -> pure ("compile " <> Text.pack out <> " " <> HQ.toText nm) ExecuteSchemeI nm args -> - pure $ "run.native " <> Text.unwords (nm : fmap Text.pack args) + pure $ "run.native " <> Text.unwords (HQ.toText nm : fmap Text.pack args) CompileSchemeI fi nm -> pure ("compile.native " <> HQ.toText nm <> " " <> fi) CreateAuthorI id name -> pure ("create.author " <> NameSegment.toEscapedText id <> " " <> name) ClearI {} -> pure "clear" diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs index 5bbc11907..d2c6ed7aa 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Run.hs @@ -20,6 +20,8 @@ import Unison.Codebase.Editor.Output qualified as Output import Unison.Codebase.MainTerm qualified as MainTerm import Unison.Codebase.Runtime qualified as Runtime import Unison.Hash qualified as Hash +import Unison.HashQualified qualified as HQ +import Unison.Name (Name) import Unison.Parser.Ann (Ann (External)) import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE @@ -40,7 +42,7 @@ import Unison.UnisonFile qualified as UF import Unison.UnisonFile.Names qualified as UF import Unison.Var qualified as Var -handleRun :: Bool -> Text -> [String] -> Cli () +handleRun :: Bool -> HQ.HashQualified Name -> [String] -> Cli () handleRun native main args = do (unisonFile, mainResType) <- do (sym, term, typ, otyp) <- getTerm main @@ -75,7 +77,7 @@ data GetTermResult -- | Look up runnable term with the given name in the codebase or -- latest typechecked unison file. Return its symbol, term, type, and -- the type of the evaluated term. -getTerm :: Text -> Cli (Symbol, Term Symbol Ann, Type Symbol Ann, Type Symbol Ann) +getTerm :: HQ.HashQualified Name -> Cli (Symbol, Term Symbol Ann, Type Symbol Ann, Type Symbol Ann) getTerm main = getTerm' main >>= \case NoTermWithThatName -> do @@ -90,7 +92,7 @@ getTerm main = Cli.returnEarly $ Output.BadMainFunction "run" main ty suffixifiedPPE [mainType] GetTermSuccess x -> pure x -getTerm' :: Text -> Cli GetTermResult +getTerm' :: HQ.HashQualified Name -> Cli GetTermResult getTerm' mainName = let getFromCodebase = do Cli.Env {codebase, runtime} <- ask @@ -99,7 +101,6 @@ getTerm' mainName = mainToFile =<< MainTerm.getMainTerm loadTypeOfTerm names mainName (Runtime.mainType runtime) where - mainToFile (MainTerm.NotAFunctionName _) = pure NoTermWithThatName mainToFile (MainTerm.NotFound _) = pure NoTermWithThatName mainToFile (MainTerm.BadType _ ty) = pure $ maybe NoTermWithThatName TermHasBadType ty mainToFile (MainTerm.Success hq tm typ) = @@ -108,7 +109,8 @@ getTerm' mainName = pure (GetTermSuccess (v, tm, typ, otyp)) getFromFile uf = do let components = join $ UF.topLevelComponents uf - let mainComponent = filter ((\v -> Var.name v == mainName) . view _1) components + -- __TODO__: We shouldn’t need to serialize mainName` for this check + let mainComponent = filter ((\v -> Var.name v == HQ.toText mainName) . view _1) components case mainComponent of [(v, _, tm, ty)] -> checkType ty \otyp -> diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs index 7e12e623e..bb6dddabd 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/TermResolution.hs @@ -31,7 +31,6 @@ import Unison.PrettyPrintEnvDecl qualified as PPED import Unison.Reference (Reference) import Unison.Referent (Referent, pattern Con, pattern Ref) import Unison.Symbol (Symbol) -import Unison.Syntax.HashQualified qualified as HQ (toText) import Unison.Type (Type) import Unison.Typechecker qualified as Typechecker @@ -118,9 +117,8 @@ resolveMainRef main = do pped <- Cli.prettyPrintEnvDeclFromNames names let suffixifiedPPE = PPED.suffixifiedPPE pped let mainType = Runtime.mainType runtime - smain = HQ.toText main lookupTermRefWithType codebase main >>= \case [(rf, ty)] | Typechecker.fitsScheme ty mainType -> pure (rf, suffixifiedPPE) - | otherwise -> Cli.returnEarly (BadMainFunction "main" smain ty suffixifiedPPE [mainType]) - _ -> Cli.returnEarly (NoMainFunction smain suffixifiedPPE [mainType]) + | otherwise -> Cli.returnEarly (BadMainFunction "main" main ty suffixifiedPPE [mainType]) + _ -> Cli.returnEarly (NoMainFunction main suffixifiedPPE [mainType]) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs index 901a0b3e2..3eb365800 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Tests.hs @@ -28,6 +28,8 @@ import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils import Unison.Codebase.Editor.Input (TestInput (..)) import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.Output qualified as Output +import Unison.Codebase.Path (Path) +import Unison.Codebase.Path qualified as Path import Unison.Codebase.Runtime qualified as Runtime import Unison.ConstructorReference (GConstructorReference (..)) import Unison.HashQualified qualified as HQ @@ -38,6 +40,7 @@ import Unison.Parser.Ann (Ann) import Unison.Prelude import Unison.PrettyPrintEnv qualified as PPE import Unison.PrettyPrintEnvDecl qualified as PPED +import Unison.Reference (TermReferenceId) import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent import Unison.ShortHash qualified as SH @@ -53,9 +56,6 @@ import Unison.Util.Monoid (foldMapM) import Unison.Util.Relation qualified as R import Unison.Util.Set qualified as Set import Unison.WatchKind qualified as WK -import Unison.Codebase.Path (Path) -import Unison.Reference (TermReferenceId) -import qualified Unison.Codebase.Path as Path -- | Handle a @test@ command. -- Run pure tests in the current subnamespace. @@ -137,7 +137,7 @@ handleIOTest main = do (fails, oks) <- refs & foldMapM \(ref, typ) -> do when (not $ isIOTest typ) do - Cli.returnEarly (BadMainFunction "io.test" (HQ.toText main) typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime)) + Cli.returnEarly (BadMainFunction "io.test" main typ suffixifiedPPE (Foldable.toList $ Runtime.ioTestTypes runtime)) runIOTest suffixifiedPPE ref Cli.respond $ TestResults Output.NewlyComputed suffixifiedPPE True True oks fails diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 56acd83e9..e4cb7a3dd 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -156,7 +156,7 @@ data Input -- Second `Maybe Int` is cap on diff elements shown, if any HistoryI (Maybe Int) (Maybe Int) BranchId | -- execute an IO thunk with args - ExecuteI Text [String] + ExecuteI (HQ.HashQualified Name) [String] | -- save the result of a previous Execute SaveExecuteResultI Name | -- execute an IO [Result] @@ -166,7 +166,7 @@ data Input | -- make a standalone binary file MakeStandaloneI String (HQ.HashQualified Name) | -- execute an IO thunk using scheme - ExecuteSchemeI Text [String] + ExecuteSchemeI (HQ.HashQualified Name) [String] | -- compile to a scheme file CompileSchemeI Text (HQ.HashQualified Name) | TestI TestInput diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 3efdb8a71..24f3ae044 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -157,13 +157,13 @@ data Output | InvalidSourceName String | SourceLoadFailed String | -- No main function, the [Type v Ann] are the allowed types - NoMainFunction Text PPE.PrettyPrintEnv [Type Symbol Ann] + NoMainFunction (HQ.HashQualified Name) PPE.PrettyPrintEnv [Type Symbol Ann] | -- | Function found, but has improper type -- Note: the constructor name is misleading here; we weren't necessarily looking for a "main". BadMainFunction Text -- ^ what we were trying to do (e.g. "run", "io.test") - Text + (HQ.HashQualified Name) -- ^ name of function (Type Symbol Ann) -- ^ bad type of function diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 9a5d0a364..6559301f8 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -2708,8 +2708,9 @@ execute = ) $ \case main : args -> - Input.ExecuteI (Text.pack $ unifyArgument main) - <$> traverse (unsupportedStructuredArgument "a command-line argument") args + Input.ExecuteI + <$> handleHashQualifiedNameArg main + <*> traverse (unsupportedStructuredArgument "a command-line argument") args _ -> Left $ showPatternHelp execute saveExecuteResult :: InputPattern @@ -2799,8 +2800,9 @@ runScheme = ) $ \case main : args -> - Input.ExecuteSchemeI (Text.pack $ unifyArgument main) - <$> traverse (unsupportedStructuredArgument "a command-line argument") args + Input.ExecuteSchemeI + <$> handleHashQualifiedNameArg main + <*> traverse (unsupportedStructuredArgument "a command-line argument") args _ -> Left $ showPatternHelp runScheme compileScheme :: InputPattern diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 6b142389b..515557858 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -739,21 +739,21 @@ notifyUser dir = \case P.lines [ P.wrap $ "I looked for a function" - <> P.backticked (P.text main) + <> P.backticked (P.text $ HQ.toText main) <> "in the most recently typechecked file and codebase but couldn't find one. It has to have the type:", "", - P.indentN 2 $ P.lines [P.text main <> " : " <> TypePrinter.pretty ppe t | t <- ts] + P.indentN 2 $ P.lines [P.text (HQ.toText main) <> " : " <> TypePrinter.pretty ppe t | t <- ts] ] BadMainFunction what main ty ppe ts -> pure . P.callout "😶" $ P.lines [ P.string "I found this function:", "", - P.indentN 2 $ P.text main <> " : " <> TypePrinter.pretty ppe ty, + P.indentN 2 $ P.text (HQ.toText main) <> " : " <> TypePrinter.pretty ppe ty, "", P.wrap $ P.string "but in order for me to" <> P.backticked (P.text what) <> "it needs to be a subtype of:", "", - P.indentN 2 $ P.lines [P.text main <> " : " <> TypePrinter.pretty ppe t | t <- ts] + P.indentN 2 $ P.lines [P.text (HQ.toText main) <> " : " <> TypePrinter.pretty ppe t | t <- ts] ] NoUnisonFile -> do dir' <- canonicalizePath dir From 2c8904a3112c6f2159c89e6d580442815c523691 Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Fri, 31 May 2024 11:35:03 -0400 Subject: [PATCH 80/82] make `auth.login` visible --- unison-cli/src/Unison/CommandLine/InputPatterns.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 68ef17b17..5069db901 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -2867,7 +2867,7 @@ authLogin = InputPattern "auth.login" [] - I.Hidden + I.Visible [] ( P.lines [ P.wrap "Obtain an authentication session with Unison Share.", From f2bc1bde2246d93d4b1f6633c2f594d2d1df6b51 Mon Sep 17 00:00:00 2001 From: Arya Irani <538571+aryairani@users.noreply.github.com> Date: Fri, 31 May 2024 11:59:21 -0400 Subject: [PATCH 81/82] Update .mergify.yml --- .mergify.yml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/.mergify.yml b/.mergify.yml index 06be4d2a6..5b7829eff 100644 --- a/.mergify.yml +++ b/.mergify.yml @@ -11,9 +11,12 @@ pull_request_rules: - check-success=run interpreter tests (macOS-12) # - check-success=run interpreter tests (windows-2019) - check-success=generate jit source - - check-success=build jit binary (ubuntu-20.04) - - check-success=build jit binary (macOS-12) - - check-success=build jit binary (windows-2019) + - check-success=build jit binary / build jit binary (ubuntu-20.04) + - check-success=build jit binary / build jit binary (macOS-12) + - check-success=build jit binary / build jit binary (windows-2019) + - check-success=test jit / test jit (ubuntu-20.04) + - check-success=test jit / test jit (macOS-12) + # - check-success=test jit / test jit (windows-2019) - label=ready-to-merge - "#approved-reviews-by>=1" actions: From 899be60f5a87186394a91d45c9ac75a5bbd9cc21 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 31 May 2024 14:34:47 -0400 Subject: [PATCH 82/82] improve merge precondition violation output messages --- .../Codebase/Editor/HandleInput/Merge2.hs | 4 +- .../src/Unison/Codebase/Editor/Output.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 151 +++++++++++++----- .../src/Unison/Merge/DeclCoherencyCheck.hs | 4 +- unison-src/transcripts/merge.output.md | 74 +++++++-- 5 files changed, 176 insertions(+), 59 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs index 5c8a7b014..7e87a1cbc 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Merge2.hs @@ -281,8 +281,8 @@ doMerge info = do declNameLookup <- Cli.runTransaction (checkDeclCoherency db.loadDeclNumConstructors defns) & onLeftM \err -> Cli.returnEarly case err of - IncoherentDeclReason'ConstructorAlias name1 name2 -> - Output.MergeConstructorAlias who name1 name2 + 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 diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 24f3ae044..45d252a0d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -399,7 +399,7 @@ data Output | MergeConflictedTermName !Name !(NESet Referent) | MergeConflictedTypeName !Name !(NESet TypeReference) | MergeConflictInvolvingBuiltin !Name - | MergeConstructorAlias !MergeSourceOrTarget !Name !Name + | MergeConstructorAlias !MergeSourceOrTarget !Name !Name !Name | MergeDefnsInLib !MergeSourceOrTarget | MergeMissingConstructorName !MergeSourceOrTarget !Name | MergeNestedDeclAlias !MergeSourceOrTarget !Name !Name diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 515557858..66824fccd 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1344,13 +1344,43 @@ notifyUser dir = \case <> "was already up-to-date with" <> P.group (prettyMergeSource aliceAndBob.bob <> ".") MergeConflictedAliases aliceOrBob name1 name2 -> - pure . P.wrap $ - "On" - <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") - <> prettyName name1 - <> "and" - <> prettyName name2 - <> "are not aliases, but they used to be." + pure $ + P.wrap "Sorry, I wasn't able to perform the merge:" + <> P.newline + <> P.newline + <> P.wrap + ( "On the merge ancestor," + <> prettyName name1 + <> "and" + <> prettyName name2 + <> "were aliases for the same definition, but on" + <> prettyMergeSourceOrTarget aliceOrBob + <> "the names have different definitions currently. I'd need just a single new definition to use in their" + <> "dependents when I merge." + ) + <> P.newline + <> P.newline + <> P.wrap ("Please fix up" <> prettyMergeSourceOrTarget aliceOrBob <> "to resolve this. For example,") + <> P.newline + <> P.newline + <> P.indentN + 2 + ( P.bulleted + [ P.wrap + ( IP.makeExample' IP.update + <> "the definitions to be the same again, so that there's nothing for me to decide." + ), + P.wrap + ( IP.makeExample' IP.moveAll + <> "or" + <> IP.makeExample' IP.delete + <> "all but one of the definitions; I'll use the remaining name when propagating updates." + ) + ] + ) + <> 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." @@ -1358,31 +1388,66 @@ notifyUser dir = \case pure . P.wrap $ "The type name" <> prettyName name <> "is ambiguous. Please resolve the ambiguity before merging." MergeConflictInvolvingBuiltin name -> - pure . P.wrap $ - "There's a merge conflict on" - <> P.group (prettyName name <> ",") - <> "but it's a builtin on one or both branches. We can't yet handle merge conflicts on builtins." - MergeConstructorAlias aliceOrBob name1 name2 -> - pure . P.wrap $ - "On" - <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") - <> prettyName name1 - <> "and" - <> prettyName name2 - <> "are aliases. Every type declaration must have exactly one name for each constructor." + pure . P.lines $ + [ P.wrap "Sorry, I wasn't able to perform the merge:", + "", + P.wrap + ( "There's a merge conflict on" + <> P.group (prettyName name <> ",") + <> "but it's a builtin on one or both branches. I can't yet handle merge conflicts involving builtins." + ), + "", + P.wrap + ( "Please eliminate this conflict by updating one branch or the other, making" + <> prettyName name + <> "the same on both branches, or making neither of them a builtin, and then try the merge again." + ) + ] + 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." + ] MergeDefnsInLib aliceOrBob -> - pure . P.wrap $ - "On" - <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") - <> "there's a type or term directly in the `lib` namespace, but I expected only library dependencies to be in there." - <> "Please remove it before merging." + pure . P.lines $ + [ P.wrap "Sorry, I wasn't able to perform the merge:", + "", + P.wrap $ + "On" + <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") + <> "there's a type or term at the top level of the `lib` namespace, where I only expect to find" + <> "subnamespaces representing library dependencies.", + "", + P.wrap "Please move or remove it and then try merging again." + ] MergeMissingConstructorName aliceOrBob name -> - pure . P.wrap $ - "On" - <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") - <> "the type" - <> prettyName name - <> "is missing a name for one of its constructors. Please add one before merging." + 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 ["", prettyName name <> "."] + <> "to give names to each unnamed constructor, and then try the merge again." + ] MergeNestedDeclAlias aliceOrBob shorterName longerName -> pure . P.wrap $ "On" @@ -1391,15 +1456,25 @@ notifyUser dir = \case <> prettyName longerName <> "is an alias of" <> P.group (prettyName shorterName <> ".") - <> "Type aliases cannot be nested. Please make them disjoint before merging." + <> "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." MergeStrayConstructor aliceOrBob name -> - pure . P.wrap $ - "On" - <> P.group (prettyMergeSourceOrTarget aliceOrBob <> ",") - <> "the constructor" - <> prettyName name - <> "is not in a subnamespace of a name of its type." - <> "Please either delete it or rename it before merging." + 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 $ diff --git a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs index b62b9f44d..b2780772d 100644 --- a/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs +++ b/unison-merge/src/Unison/Merge/DeclCoherencyCheck.hs @@ -120,7 +120,7 @@ data IncoherentDeclReason -- Foo#Foo -- Foo.Bar#Foo#0 -- Foo.Some.Other.Name.For.Bar#Foo#0 - IncoherentDeclReason'ConstructorAlias !Name !Name + IncoherentDeclReason'ConstructorAlias !Name !Name !Name -- type, first constructor, second constructor | IncoherentDeclReason'MissingConstructorName !Name | -- | A second naming of a decl was discovered underneath its name, e.g. -- @@ -161,7 +161,7 @@ checkDeclCoherency loadDeclNumConstructors = Nothing -> Left (IncoherentDeclReason'StrayConstructor name1) Just (typeName, expected) -> case recordConstructorName conId name1 expected of - Left existingName -> Left (IncoherentDeclReason'ConstructorAlias existingName name1) + Left existingName -> Left (IncoherentDeclReason'ConstructorAlias typeName existingName name1) Right expected1 -> Right (typeName, expected1) where name1 = fullName name diff --git a/unison-src/transcripts/merge.output.md b/unison-src/transcripts/merge.output.md index ba3ab0d03..90412693d 100644 --- a/unison-src/transcripts/merge.output.md +++ b/unison-src/transcripts/merge.output.md @@ -964,8 +964,21 @@ baz = "baz" ```ucm project/alice> merge /bob - On project/alice, bar and foo are not aliases, but they used - to be. + Sorry, I wasn't able to perform the merge: + + On the merge ancestor, bar and foo were aliases for the same + definition, but on project/alice the names have different + definitions currently. I'd need just a single new definition + to use in their dependents when I merge. + + Please fix up project/alice to resolve this. For example, + + * `update` the definitions to be the same again, so that + there's nothing for me to decide. + * `move` or `delete` all but one of the definitions; I'll + use the remaining name when propagating updates. + + and then try merging again. ``` ### Conflict involving builtin @@ -990,9 +1003,15 @@ unique type MyNat = MyNat Nat ```ucm project/alice> merge /bob + Sorry, I wasn't able to perform the merge: + There's a merge conflict on MyNat, but it's a builtin on one - or both branches. We can't yet handle merge conflicts on + or both branches. I can't yet handle merge conflicts involving builtins. + + Please eliminate this conflict by updating one branch or the + other, making MyNat the same on both branches, or making + neither of them a builtin, and then try the merge again. ``` ### Constructor alias @@ -1019,9 +1038,16 @@ bob = 100 ```ucm project/alice> merge /bob - On project/alice, Foo.Bar and Foo.some.other.Alias are - aliases. Every type declaration must have exactly one name for - each constructor. + Sorry, I wasn't able to perform the merge: + + On project/alice, the type Foo has a constructor with multiple + names, and I can't perform a merge in this situation: + + * Foo.Bar + * Foo.some.other.Alias + + Please delete all but one name for each constructor, and then + try merging again. ``` ### Missing constructor name @@ -1048,8 +1074,14 @@ bob = 100 ```ucm project/alice> merge /bob - On project/alice, the type Foo is missing a name for one of - its constructors. Please add one before merging. + Sorry, I wasn't able to perform the merge: + + On project/alice, the type Foo has some constructors with + missing names, and I can't perform a merge in this situation. + + You can use `view Foo` and + `alias.term Foo.` to give names to + each unnamed constructor, and then try the merge again. ``` ### Nested decl alias @@ -1081,9 +1113,10 @@ bob = 100 ```ucm project/alice> merge /bob - On project/alice, the type A.inner.X is an alias of A. Type - aliases cannot be nested. Please make them disjoint before - merging. + On project/alice, the type A.inner.X is an alias of A. 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. ``` ### Stray constructor alias @@ -1115,9 +1148,14 @@ project/bob> add ```ucm project/alice> merge bob + Sorry, I wasn't able to perform the merge, because I need all + constructor names to be nested somewhere beneath the + corresponding type name. + On project/alice, the constructor AliasOutsideFooNamespace is - not in a subnamespace of a name of its type. Please either - delete it or rename it before merging. + 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 merge again. ``` ### Term or type in `lib` @@ -1139,9 +1177,13 @@ bob = 100 ```ucm project/alice> merge /bob - On project/alice, there's a type or term directly in the `lib` - namespace, but I expected only library dependencies to be in - there. Please remove it before merging. + Sorry, I wasn't able to perform the merge: + + On project/alice, there's a type or term at the top level of + the `lib` namespace, where I only expect to find subnamespaces + representing library dependencies. + + Please move or remove it and then try merging again. ``` ## LCA precondition violations