Fix spurious crash

2024-09-24 00:39:58 +03:00 · 2021-02-08 13:12:52 -05:00 · 2021-02-08 13:12:52 -05:00 · b14a1efd31
commit b14a1efd31
parent 05816fa3ff
8 changed files with 146 additions and 81 deletions
--- a/parser-typechecker/src/Unison/Codebase/Editor/Command.hs
+++ b/parser-typechecker/src/Unison/Codebase/Editor/Command.hs
@ -14,6 +14,11 @@ module Unison.Codebase.Editor.Command (

 import Unison.Prelude

+-- TODO: Don't import backend, but move dependencies to own modules
+import           Unison.Server.Backend          ( DefinitionResults
+                                                , ShallowListEntry
+                                                , BackendError
+                                                )
 import           Data.Configurator.Types        ( Configured )

 import           Unison.Codebase.Editor.Output
@ -42,8 +47,14 @@ import           Unison.ShortHash               ( ShortHash )
 import           Unison.Type                    ( Type )
 import           Unison.Codebase.ShortBranchHash
                                                ( ShortBranchHash )
-import Unison.Codebase (Codebase)
 import Unison.Codebase.Editor.AuthorInfo (AuthorInfo)
+import Unison.Codebase.Path (Path)
+import qualified Unison.Codebase.Path as Path
+import qualified Unison.HashQualified as HQ
+import Unison.Name (Name)
+import Unison.Server.QueryResult (QueryResult)
+import qualified Unison.Server.SearchResult as SR
+import qualified Unison.Server.SearchResult' as SR'

 type AmbientAbilities v = [Type v Ann]
 type SourceName = Text
@ -62,9 +73,24 @@ data Command m i v a where
  -- Escape hatch.
  Eval :: m a -> Command m i v a

-  -- Escape hatch. Temporarily here while we replace this file with calls
-  -- into Server.Backend.
-  WithCodebase :: (Codebase m v Ann -> a) -> Command m i v a
+  HQNameQuery
+    :: Maybe Path
+    -> Branch m
+    -> [HQ.HashQualified Name]
+    -> Command m i v QueryResult
+
+  LoadSearchResults
+    :: [SR.SearchResult] -> Command m i v [SR'.SearchResult' v Ann]
+
+  GetDefinitionsBySuffixes
+    :: Maybe Path
+    -> Branch m
+    -> [HQ.HashQualified Name]
+    -> Command m i v (Either BackendError (DefinitionResults v))
+
+  FindShallow
+    :: Path.Absolute
+    -> Command m i v (Either BackendError [ShallowListEntry v Ann])

  ConfigLookup :: Configured a => Text -> Command m i v (Maybe a)

@ -201,7 +227,6 @@ data Command m i v a where
 commandName :: Command m i v a -> String
 commandName = \case
  Eval{}                      -> "Eval"
-  WithCodebase{}              -> "WithCodebase"
  ConfigLookup{}              -> "ConfigLookup"
  Input                       -> "Input"
  Notify{}                    -> "Notify"
@ -243,4 +268,7 @@ commandName = \case
  CreateAuthorInfo{}          -> "CreateAuthorInfo"
  RuntimeMain                 -> "RuntimeMain"
  RuntimeTest                 -> "RuntimeTest"
-
+  HQNameQuery{}               -> "HQNameQuery"
+  LoadSearchResults{}         -> "LoadSearchResults"
+  GetDefinitionsBySuffixes{}  -> "GetDefinitionsBySuffixes"
+  FindShallow{}               -> "FindShallow"
--- a/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs
+++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs
@ -163,7 +163,12 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour
    AppendToReflog reason old new -> Codebase.appendReflog codebase reason old new
    LoadReflog -> Codebase.getReflog codebase
    CreateAuthorInfo t -> AuthorInfo.createAuthorInfo Parser.External t
-    WithCodebase k -> pure (k codebase)
+    HQNameQuery mayPath branch query ->
+      Backend.hqNameQuery mayPath branch codebase query
+    LoadSearchResults srs -> Backend.loadSearchResults codebase srs
+    GetDefinitionsBySuffixes mayPath branch query ->
+      runExceptT $ Backend.definitionsBySuffixes mayPath branch codebase query
+    FindShallow path -> runExceptT $ Backend.findShallow codebase path

  eval1 :: PPE.PrettyPrintEnv -> Term v Ann -> _
  eval1 ppe tm = do
--- a/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs
+++ b/parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs
@ -21,9 +21,10 @@ where

 import           Unison.Prelude

-import Unison.Server.Types (QueryResult (..))
+-- TODO: Don't import backend
 import qualified Unison.Server.Backend as Backend
-import Unison.Server.Backend (ShallowListEntry(..), Backend)
+import Unison.Server.QueryResult
+import Unison.Server.Backend (ShallowListEntry(..))
 import qualified Unison.Codebase.MainTerm as MainTerm
 import Unison.Codebase.Editor.Command
 import Unison.Codebase.Editor.Input
@ -196,9 +197,7 @@ loop = do
  sbhLength   <- eval BranchHashLength
  let
      currentPath'' = Path.unabsolute currentPath'
-      hqNameQuery q =
-        join . eval $ WithCodebase (\c ->
-          _liftToAction $ Backend.hqNameQuery (Just currentPath'') root' c q)
+      hqNameQuery q = eval $ HQNameQuery (Just currentPath'') root' q
      sbh = SBH.fromHash sbhLength
      root0 = Branch.head root'
      currentBranch0 = Branch.head currentBranch'
@ -494,8 +493,7 @@ loop = do
        viewRemoteBranch ns = ExceptT . eval $ ViewRemoteBranch ns
        syncRemoteRootBranch repo b mode =
          ExceptT . eval $ SyncRemoteRootBranch repo b mode
-        loadSearchResults sr = join . eval . WithCodebase $ \c ->
-          _liftToAction $ Backend.loadSearchResults c sr
+        loadSearchResults = eval . LoadSearchResults
        handleFailedDelete failed failedDependents = do
          failed           <- loadSearchResults $ SR.fromNames failed
          failedDependents <- loadSearchResults $ SR.fromNames failedDependents
@ -1101,7 +1099,7 @@ loop = do
      DeleteTermI hq -> delete getHQ'Terms       (const Set.empty) hq

      DisplayI outputLoc hq -> do
-        let parseNames0 = (`Names3.Names` mempty) $ basicPrettyPrintNames0
+        let parseNames0 = (`Names3.Names` mempty) basicPrettyPrintNames0
            -- use suffixed names for resolving the argument to display
            parseNames = Names3.suffixify parseNames0
            results = Names3.lookupHQTerm hq parseNames
@ -1113,26 +1111,27 @@ loop = do
        else doDisplay outputLoc parseNames0 (Set.findMin results)

      ShowDefinitionI outputLoc query -> do
-        Backend.DefinitionResults terms types misses <-
-          join . eval . WithCodebase $ \c -> handleBackend $
-            Backend.definitionsBySuffixes (Just currentPath'') root' c query
-        let loc = case outputLoc of
-              ConsoleLocation    -> Nothing
-              FileLocation path  -> Just path
-              LatestFileLocation -> fmap fst latestFile' <|> Just "scratch.u"
-            printNames =
-              Backend.getCurrentNames currentPath'' root'
-            ppe = PPE.fromNamesDecl hqLength printNames
-        unless (null types && null terms) $
-          eval . Notify $
-            DisplayDefinitions loc ppe types terms
-        unless (null misses) $
-          eval . Notify $ SearchTermsNotFound misses
-        -- We set latestFile to be programmatically generated, if we
-        -- are viewing these definitions to a file - this will skip the
-        -- next update for that file (which will happen immediately)
-        latestFile .= ((, True) <$> loc)
-
+        res <- eval $ GetDefinitionsBySuffixes (Just currentPath'') root' query
+        case res of
+          Left e -> handleBackendError e
+          Right (Backend.DefinitionResults terms types misses) -> do
+            let loc = case outputLoc of
+                  ConsoleLocation    -> Nothing
+                  FileLocation path  -> Just path
+                  LatestFileLocation ->
+                    fmap fst latestFile' <|> Just "scratch.u"
+                printNames =
+                  Backend.getCurrentNames currentPath'' root'
+                ppe = PPE.fromNamesDecl hqLength printNames
+            unless (null types && null terms) $
+              eval . Notify $
+                DisplayDefinitions loc ppe types terms
+            unless (null misses) $
+              eval . Notify $ SearchTermsNotFound misses
+            -- We set latestFile to be programmatically generated, if we
+            -- are viewing these definitions to a file - this will skip the
+            -- next update for that file (which will happen immediately)
+            latestFile .= ((, True) <$> loc)
      FindPatchI -> do
        let patches =
              [ Path.toName $ Path.snoc p seg
@ -1143,26 +1142,31 @@ loop = do

      FindShallowI pathArg -> do
        let pathArgAbs = resolveToAbsolute pathArg
-            ppe = Backend.basicSuffixifiedNames sbhLength root' (Path.fromPath' pathArg)
-        findOp <- eval $ WithCodebase (`Backend.findShallow` pathArgAbs)
-        entries <- handleBackend findOp
-        -- caching the result as an absolute path, for easier jumping around
-        numberedArgs .= fmap entryToHQString entries
-        respond $ ListShallow ppe entries
-        where
-          entryToHQString :: ShallowListEntry v Ann -> String
-          entryToHQString e =
-            fixup $ case e of
-              ShallowTypeEntry _ hq   -> HQ'.toString hq
-              ShallowTermEntry _ hq _ -> HQ'.toString hq
-              ShallowBranchEntry ns _ -> NameSegment.toString ns
-              ShallowPatchEntry ns    -> NameSegment.toString ns
-           where
-            fixup s = case pathArgStr of
-                       "" -> s
-                       p | last p == '.' -> p ++ s
-                       p -> p ++ "." ++ s
-            pathArgStr = show pathArg
+            ppe = Backend.basicSuffixifiedNames
+                           sbhLength
+                           root'
+                           (Path.fromPath' pathArg)
+        res <- eval $ FindShallow pathArgAbs
+        case res of
+          Left e -> handleBackendError e
+          Right entries -> do
+            -- caching the result as an absolute path, for easier jumping around
+            numberedArgs .= fmap entryToHQString entries
+            respond $ ListShallow ppe entries
+            where
+              entryToHQString :: ShallowListEntry v Ann -> String
+              entryToHQString e =
+                fixup $ case e of
+                  ShallowTypeEntry _ hq   -> HQ'.toString hq
+                  ShallowTermEntry _ hq _ -> HQ'.toString hq
+                  ShallowBranchEntry ns _ -> NameSegment.toString ns
+                  ShallowPatchEntry ns    -> NameSegment.toString ns
+               where
+                fixup s = case pathArgStr of
+                           "" -> s
+                           p | last p == '.' -> p ++ s
+                           p -> p ++ "." ++ s
+                pathArgStr = show pathArg

      SearchByNameI isVerbose _showAll ws -> do
        let prettyPrintNames0 = basicPrettyPrintNames0
@ -2057,26 +2061,17 @@ searchBranchScored names0 score queries =
        Just score -> Set.singleton (Just score, result)
        Nothing -> mempty

-handleBackend :: Backend m a -> Action m i v a
-handleBackend b = _liftToAction (runExceptT b) >>= \case
-  Left e -> case e of
-    Backend.NoSuchNamespace path -> do
-      respond . BranchNotFound $ Path.absoluteToPath' path
-      fail mempty
-    Backend.BadRootBranch e -> do
-      respond $ BadRootBranch e
-      fail mempty
-    Backend.NoBranchForHash h -> do
-      sbhLength <- eval BranchHashLength
-      respond . NoBranchWithHash $ SBH.fromHash sbhLength h
-      fail mempty
-    Backend.CouldntExpandBranchHash sbh -> do
-      respond $ NoBranchWithHash sbh
-      fail mempty
-    Backend.AmbiguousBranchHash h hashes -> do
-      respond $ BranchHashAmbiguous h hashes
-      fail mempty
-  Right a -> pure a
+handleBackendError :: Backend.BackendError -> Action m i v ()
+handleBackendError = \case
+  Backend.NoSuchNamespace path ->
+    respond . BranchNotFound $ Path.absoluteToPath' path
+  Backend.BadRootBranch   e -> respond $ BadRootBranch e
+  Backend.NoBranchForHash h -> do
+    sbhLength <- eval BranchHashLength
+    respond . NoBranchWithHash $ SBH.fromHash sbhLength h
+  Backend.CouldntExpandBranchHash sbh -> respond $ NoBranchWithHash sbh
+  Backend.AmbiguousBranchHash h hashes ->
+    respond $ BranchHashAmbiguous h hashes

 respond :: Output v -> Action m i v ()
 respond output = eval $ Notify output
--- a/parser-typechecker/src/Unison/Server/Backend.hs
+++ b/parser-typechecker/src/Unison/Server/Backend.hs
@ -52,6 +52,7 @@ import qualified Unison.Util.Relation as R
 import qualified Unison.Util.Star3 as Star3
 import Unison.Var (Var)
 import Unison.Server.Types
+import Unison.Server.QueryResult
 import Unison.Util.SyntaxText (SyntaxText)
 import Unison.Util.List (uniqueBy)
 import Unison.ShortHash
@ -357,6 +358,7 @@ hqNameQuerySuffixify
  -> m QueryResult
 hqNameQuerySuffixify = hqNameQuery' True

+-- TODO: Move this to its own module
 data DefinitionResults v =
  DefinitionResults
    { termResults :: Map Reference (DisplayObject (Term v Ann))
--- a/parser-typechecker/src/Unison/Server/QueryResult.hs
+++ b/parser-typechecker/src/Unison/Server/QueryResult.hs
@ -0,0 +1,11 @@
+module Unison.Server.QueryResult where
+
+import qualified Unison.HashQualified          as HQ
+import           Unison.Name                    ( Name )
+import qualified Unison.Server.SearchResult as SR
+
+data QueryResult = QueryResult
+  { misses :: [HQ.HashQualified Name]
+  , hits :: [SR.SearchResult]
+  }
+
--- a/parser-typechecker/src/Unison/Server/Types.hs
+++ b/parser-typechecker/src/Unison/Server/Types.hs
@ -32,7 +32,6 @@ import Unison.Var (Var)
 import qualified Unison.PrettyPrintEnv as PPE
 import Unison.Type (Type)
 import qualified Unison.TypePrinter as TypePrinter
-import qualified Unison.Server.SearchResult as SR
 import Unison.Codebase.Editor.DisplayObject (DisplayObject)

 type HashQualifiedName = Text
@ -96,11 +95,6 @@ data DefinitionDisplayResults =
    , missingDefinitions :: [HQ.HashQualified Name]
    } deriving (Eq, Show, Generic)

-data QueryResult = QueryResult
-  { misses :: [HQ.HashQualified Name]
-  , hits :: [SR.SearchResult]
-  }
-
 formatType
  :: Var v => PPE.PrettyPrintEnv -> Width -> Type v a -> SyntaxText' ShortHash
 formatType ppe w =
--- a/parser-typechecker/unison-parser-typechecker.cabal
+++ b/parser-typechecker/unison-parser-typechecker.cabal
@ -143,6 +143,7 @@ library
    Unison.Server.Endpoints.GetDefinitions 
    Unison.Server.Endpoints.ListNamespace
    Unison.Server.Errors
+    Unison.Server.QueryResult
    Unison.Server.SearchResult
    Unison.Server.SearchResult'
    Unison.Server.Types
--- a/unison-src/transcripts/emptyCodebase.output.md
+++ b/unison-src/transcripts/emptyCodebase.output.md
@ -12,3 +12,32 @@ BEHOLD!!!
  ⚠️
  
  The namespace . doesn't exist.
+
+```
+Technically, the definitions all exist, but they have no names. `builtins.merge` brings them into existence, under the current namespace:
+
+```ucm
+  ☝️  The namespace .foo is empty.
+
+.foo> builtins.merge
+
+  Done.
+
+.foo> ls
+
+  1. builtin/ (328 definitions)
+
+```
+And for a limited time, you can get even more builtin goodies:
+
+```ucm
+.foo> builtins.mergeio
+
+  Done.
+
+.foo> ls
+
+  1. builtin/ (491 definitions)
+
+```
+More typically, you'd start out by pulling `base.