From 26c5a98ff9f4fcd4e91ef53f85c9ce89ad9f0f1f Mon Sep 17 00:00:00 2001 From: Runar Bjarnason Date: Tue, 31 Mar 2020 17:00:58 -0400 Subject: [PATCH] First stab at getting default metadata from config --- .../src/Unison/Codebase/Editor/HandleInput.hs | 132 ++++++++++-------- .../src/Unison/Codebase/Editor/Output.hs | 2 + .../src/Unison/CommandLine/OutputMessages.hs | 21 ++- 3 files changed, 91 insertions(+), 64 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs index 1f4fae0e1..6a0f4f215 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs @@ -32,6 +32,7 @@ import qualified Unison.Codebase.Editor.SlurpResult as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent(..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC import Unison.Codebase.Editor.RemoteRepo (RemoteRepo, printNamespace, RemoteNamespace) +import qualified Unison.CommandLine.InputPatterns as InputPatterns import Control.Lens import Control.Lens.TH ( makeLenses ) @@ -468,45 +469,50 @@ loop = do stepManyAtM = Unison.Codebase.Editor.HandleInput.stepManyAtM inputDescription updateAtM = Unison.Codebase.Editor.HandleInput.updateAtM inputDescription manageLinks :: [(Path', NameSegment.HQSegment)] - -> HQ.HashQualified + -> [HQ.HashQualified] -> (forall r. Ord r => (r, Reference, Reference) -> Branch.Star r NameSegment -> Branch.Star r NameSegment) -> MaybeT (StateT (LoopState m v) (F m (Either Event Input) v)) () - manageLinks srcs mdValue2 op = do - let !srcle = toList . getHQ'Terms =<< srcs - !srclt = toList . getHQ'Types =<< srcs - mdValuel <- toList <$> getHQTerms mdValue2 - names0 <- basicPrettyPrintNames0 - ppe <- PPE.suffixifiedPPE <$> prettyPrintEnvDecl (Names names0 mempty) - case (srcle, srclt, mdValuel) of - (srcle, srclt, [r@(Referent.Ref mdValue)]) -> do - mdType <- eval $ LoadTypeOfTerm mdValue - case mdType of - Nothing -> respond $ MetadataMissingType ppe r - Just ty -> do - let steps = - second (const . step $ Type.toReference ty) - . first (Path.unabsolute . resolveToAbsolute) <$> srcs - let get = Branch.head <$> use root - before <- get - stepManyAt steps - after <- get - (ppe, outputDiff) <- diffHelper before after - respondNumbered $ ShowDiffNamespace - Path.absoluteEmpty Path.absoluteEmpty ppe outputDiff - where - step mdType b0 = let - tmUpdates terms = foldl' go terms srcle - where - go terms src = op (src, mdType, mdValue) terms - tyUpdates types = foldl' go types srclt - where - go types src = op (src, mdType, mdValue) types - in over Branch.terms tmUpdates . over Branch.types tyUpdates $ b0 - (_srcle, _srclt, mdValues) -> - respond $ MetadataAmbiguous ppe mdValues + manageLinks srcs mdValues op = do + mdValuels <- fmap toList <$> traverse getHQTerms mdValues + traverse_ go mdValuels + where + go mdl = do + let !srcle = toList . getHQ'Terms =<< srcs + !srclt = toList . getHQ'Types =<< srcs + names0 <- basicPrettyPrintNames0 + ppe <- PPE.suffixifiedPPE <$> prettyPrintEnvDecl (Names names0 mempty) + case mdl of + [r@(Referent.Ref mdValue)] -> do + mdType <- eval $ LoadTypeOfTerm mdValue + case mdType of + Nothing -> respond $ MetadataMissingType ppe r + Just ty -> do + let steps = + second (const . step $ Type.toReference ty) + . first (Path.unabsolute . resolveToAbsolute) + <$> srcs + let get = Branch.head <$> use root + before <- get + stepManyAt steps + after <- get + (ppe, outputDiff) <- diffHelper before after + if OBranchDiff.isEmpty outputDiff + then success + else respondNumbered $ ShowDiffNamespace Path.absoluteEmpty + Path.absoluteEmpty + ppe + outputDiff + where + step mdType b0 = + let tmUpdates terms = foldl' go terms srcle + where go terms src = op (src, mdType, mdValue) terms + tyUpdates types = foldl' go types srclt + where go types src = op (src, mdType, mdValue) types + in over Branch.terms tmUpdates . over Branch.types tyUpdates $ b0 + mdValues -> respond $ MetadataAmbiguous ppe mdValues delete :: (Path.HQSplit' -> Set Referent) -- compute matching terms -> (Path.HQSplit' -> Set Reference) -- compute matching types @@ -943,10 +949,10 @@ loop = do -- in (terms, types) LinkI mdValue srcs -> - manageLinks srcs mdValue Metadata.insert + manageLinks srcs [mdValue] Metadata.insert UnlinkI mdValue srcs -> - manageLinks srcs mdValue Metadata.delete + manageLinks srcs [mdValue] Metadata.delete -- > links List.map (.Docs .English) -- > links List.map -- give me all the @@ -1315,15 +1321,35 @@ loop = do . applySelection hqs uf . toSlurpResult currentPath' uf <$> slurpResultNames0 + let adds = Slurp.adds sr when (Slurp.isNonempty sr) $ do stepAt ( Path.unabsolute currentPath' - , doSlurpAdds (Slurp.adds sr) uf) + , doSlurpAdds adds uf) eval . AddDefsToCodebase . filterBySlurpResult sr $ uf ppe <- prettyPrintEnvDecl =<< makeShadowedPrintNamesFromLabeled (UF.termSignatureExternalLabeledDependencies uf) (UF.typecheckedToNames0 uf) respond $ SlurpOutput input (PPE.suffixifiedPPE ppe) sr + let + addedVs = Set.toList $ SC.types adds <> SC.terms adds + parseResult = (Path.parseHQSplit' . Var.nameStr) <$> addedVs + (errs, addedNames) = partitionEithers parseResult + case errs of + e : _ -> + error $ "I couldn't parse a name I just added to the codebase! " <> e + _ -> do + dm <- resolveDefaultMetadata currentPath' + case dm of + Nothing -> pure () + Just dm' -> do + let hqs = traverse InputPatterns.parseHashQualifiedName dm' + case hqs of + Left e -> respond $ + ConfiguredMetadataParseError + (Path.absoluteToPath' currentPath') (show dm') e + Right defaultMeta -> + manageLinks addedNames defaultMeta Metadata.insert PreviewAddI hqs -> case (latestFile', uf) of (Just (sourceName, _), Just uf) -> do @@ -1587,6 +1613,15 @@ loop = do notImplemented = eval $ Notify NotImplemented success = respond Success + resolveDefaultMetadata :: Path.Absolute -> Action' m v (Maybe [String]) + resolveDefaultMetadata path = + (eval . ConfigLookup) $ configKey "DefaultMetadata" path + + configKey k p = + Text.intercalate "." . toList $ k :<| fmap + NameSegment.toText + (Path.toSeq $ Path.unabsolute p) + -- Takes a maybe (namespace address triple); returns it as-is if `Just`; -- otherwise, tries to load a value from .unisonConfig, and complains -- if needed. @@ -1614,30 +1649,11 @@ loop = do Nothing -> pure . Left $ NoConfiguredGitUrl pushPull destPath' - gitUrlKey p = Text.intercalate "." . toList $ "GitUrl" :<| fmap - NameSegment.toText - (Path.toSeq $ Path.unabsolute p) + gitUrlKey = configKey "GitUrl" + case e of Right input -> lastInput .= Just input _ -> pure () - -- where - {- - doMerge branchName b = do - updated <- eval $ SyncBranch branchName b - -- updated is False if `branchName` doesn't exist. - -- Not sure why you were updating a nonexistent branch, but under the - -- assumption that it just got deleted somehow, I guess, we'll write - -- it to disk now. - unless updated $ do - written <- eval $ NewBranch b branchName - unless written (disappearingBranchBomb branchName) - disappearingBranchBomb branchName = - error - $ "The branch named " - <> Text.unpack branchName - <> " disappeared from storage. " - <> "I tried to put it back, but couldn't. Everybody panic!" - -} doDisplay :: Var v => OutputLocation -> Names -> Referent -> Action' m v () doDisplay outputLoc names r = do diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs index 09de64d9e..d73be80b1 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Output.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Output.hs @@ -168,6 +168,7 @@ data Output v -- and a nicer render. | BustedBuiltins (Set Reference) (Set Reference) | GitError Input GitError + | ConfiguredMetadataParseError Path' String (P.Pretty P.ColorText) | NoConfiguredGitUrl PushPull Path' | ConfiguredGitUrlParseError PushPull Path' Text String | ConfiguredGitUrlIncludesShortBranchHash PushPull RemoteRepo ShortBranchHash Path @@ -299,6 +300,7 @@ isFailure o = case o of ListEdits{} -> False GitError{} -> True BustedBuiltins{} -> True + ConfiguredMetadataParseError{} -> True NoConfiguredGitUrl{} -> True ConfiguredGitUrlParseError{} -> True ConfiguredGitUrlIncludesShortBranchHash{} -> True diff --git a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs index c2fa9fc7f..fd726a23e 100644 --- a/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs +++ b/parser-typechecker/src/Unison/CommandLine/OutputMessages.hs @@ -737,27 +737,36 @@ notifyUser dir o = case o of (P.column2 . fmap format) ([(1::Integer)..] `zip` (toList patches)) where format (i, p) = (P.hiBlack . fromString $ show i <> ".", prettyName p) + ConfiguredMetadataParseError p md err -> + pure . P.fatalCallout . P.lines $ + [ P.wrap $ "I couldn't understand the default metadata that's set for " + <> prettyPath' p <> " in .unisonConfig." + , P.wrap $ "The value I found was" + <> (P.backticked . P.blue . P.string) md + <> "but I encountered the following error when trying to parse it:" + , "" + , err + ] NoConfiguredGitUrl pp p -> pure . P.fatalCallout . P.wrap $ "I don't know where to " <> pushPull "push to!" "pull from!" pp <> (if Path.isRoot' p then "" - else "Add a line like `GitUrl." <> prettyPath' p + else "Add a line like `GitUrl." <> P.shown p <> " = ' to .unisonConfig. " ) <> "Type `help " <> pushPull "push" "pull" pp <> "` for more information." -- | ConfiguredGitUrlParseError PushPull Path' Text String - ConfiguredGitUrlParseError pp p url error -> + ConfiguredGitUrlParseError pp p url err -> pure . P.fatalCallout . P.lines $ - [ P.wrap $ "I couldn't understand the url set in .unisonConfig for" - <> prettyPath' p <> "." - , "" + [ P.wrap $ "I couldn't understand the GitUrl that's set for" + <> prettyPath' p <> "in .unisonConfig" , P.wrap $ "The value I found was" <> (P.backticked . P.blue . P.text) url <> "but I encountered the following error when trying to parse it:" , "" - , P.string error + , P.string err , "" , P.wrap $ "Type" <> P.backticked ("help " <> pushPull "push" "pull" pp) <> "for more information."