First stab at getting default metadata from config

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

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

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
                 <> " = <some-git-url>' 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."